This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Deparse state variables.
[perl5.git] / ext / threads / threads.xs
CommitLineData
68795e93
NIS
1#define PERL_NO_GET_CONTEXT
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
0f1612a7
JH
5#ifdef HAS_PPPORT_H
6# define NEED_newRV_noinc
7# define NEED_sv_2pv_nolen
8# include "ppport.h"
9# include "threads.h"
10#endif
68795e93 11
73e09c8f
JH
12#ifdef USE_ITHREADS
13
68795e93 14#ifdef WIN32
fc04eb16 15# include <windows.h>
514612b7
JH
16 /* Supposed to be in Winbase.h */
17# ifndef STACK_SIZE_PARAM_IS_A_RESERVATION
18# define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000
19# endif
fc04eb16 20# include <win32thread.h>
68795e93 21#else
fc04eb16 22# ifdef OS2
5c728af0 23typedef perl_os_thread pthread_t;
fc04eb16
JH
24# else
25# include <pthread.h>
26# endif
27# include <thread.h>
28# define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
29# ifdef OLD_PTHREADS_API
30# define PERL_THREAD_DETACH(t) pthread_detach(&(t))
31# else
32# define PERL_THREAD_DETACH(t) pthread_detach((t))
33# endif
467f3f08 34#endif
d305c2c9
JH
35#if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM)
36# include <sys/param.h>
37#endif
68795e93 38
62375a60 39/* Values for 'state' member */
fc04eb16
JH
40#define PERL_ITHR_JOINABLE 0
41#define PERL_ITHR_DETACHED 1
42#define PERL_ITHR_JOINED 2
43#define PERL_ITHR_FINISHED 4
44
45typedef struct _ithread {
46 struct _ithread *next; /* Next thread in the list */
47 struct _ithread *prev; /* Prev thread in the list */
48 PerlInterpreter *interp; /* The threads interpreter */
49 UV tid; /* Threads module's thread id */
50 perl_mutex mutex; /* Mutex for updating things in this struct */
9feacc09 51 int count; /* How many SVs have a reference to us */
fc04eb16
JH
52 int state; /* Detached, joined, finished, etc. */
53 int gimme; /* Context of create */
54 SV *init_function; /* Code to run */
55 SV *params; /* Args to pass function */
68795e93 56#ifdef WIN32
fc04eb16
JH
57 DWORD thr; /* OS's idea if thread id */
58 HANDLE handle; /* OS's waitable handle */
68795e93 59#else
fc04eb16 60 pthread_t thr; /* OS's handle for the thread */
68795e93 61#endif
514612b7 62 IV stack_size;
68795e93
NIS
63} ithread;
64
fc04eb16
JH
65
66/* Used by Perl interpreter for thread context switching */
628ab322
DM
67#define MY_CXT_KEY "threads::_guts" XS_VERSION
68
69typedef struct {
70 ithread *thread;
71} my_cxt_t;
72
73START_MY_CXT
74
75
fc04eb16 76/* Linked list of all threads */
f4cc38af 77static ithread *threads;
68795e93 78
fc04eb16
JH
79/* Protects the creation and destruction of threads*/
80static perl_mutex create_destruct_mutex;
68795e93 81
f4cc38af 82static UV tid_counter = 0;
f4cc38af 83static IV active_threads = 0;
514612b7
JH
84#ifdef THREAD_CREATE_NEEDS_STACK
85static IV default_stack_size = THREAD_CREATE_NEEDS_STACK;
86#else
87static IV default_stack_size = 0;
88#endif
89static IV page_size = 0;
c05ae023
AB
90
91
fc04eb16 92/* Used by Perl interpreter for thread context switching */
f4cc38af 93static void
fc04eb16 94S_ithread_set(pTHX_ ithread *thread)
c05ae023 95{
628ab322
DM
96 dMY_CXT;
97 MY_CXT.thread = thread;
c05ae023
AB
98}
99
fc04eb16
JH
100static ithread *
101S_ithread_get(pTHX)
102{
628ab322 103 dMY_CXT;
fc04eb16 104 return (MY_CXT.thread);
c05ae023
AB
105}
106
107
fc04eb16
JH
108/* Free any data (such as the Perl interpreter) attached to an ithread
109 * structure. This is a bit like undef on SVs, where the SV isn't freed,
110 * but the PVX is. Must be called with thread->mutex already held.
2e676467 111 */
2e676467 112static void
fc04eb16 113S_ithread_clear(pTHX_ ithread *thread)
2e676467
DM
114{
115 PerlInterpreter *interp;
fc04eb16 116
2e676467 117 assert(thread->state & PERL_ITHR_FINISHED &&
f2cba68d 118 thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
2e676467
DM
119
120 interp = thread->interp;
121 if (interp) {
fc04eb16
JH
122 dTHXa(interp);
123
124 PERL_SET_CONTEXT(interp);
125 S_ithread_set(aTHX_ thread);
f2cba68d 126
fc04eb16
JH
127 SvREFCNT_dec(thread->params);
128 thread->params = Nullsv;
2e676467 129
fc04eb16
JH
130 perl_destruct(interp);
131 thread->interp = NULL;
2e676467
DM
132 }
133 if (interp)
fc04eb16
JH
134 perl_free(interp);
135
2e676467
DM
136 PERL_SET_CONTEXT(aTHX);
137}
138
68795e93 139
fc04eb16 140/* Free an ithread structure and any attached data if its count == 0 */
bcd9ca9b 141static void
fc04eb16 142S_ithread_destruct(pTHX_ ithread *thread)
68795e93 143{
385d56e4 144#ifdef WIN32
fc04eb16 145 HANDLE handle;
385d56e4
JH
146#endif
147
fc04eb16 148 MUTEX_LOCK(&thread->mutex);
bcd9ca9b 149
fc04eb16
JH
150 /* Thread is still in use */
151 if (thread->count != 0) {
152 MUTEX_UNLOCK(&thread->mutex);
153 return;
154 }
9feacc09 155
fc04eb16
JH
156 MUTEX_LOCK(&create_destruct_mutex);
157 /* Main thread (0) is immortal and should never get here */
158 assert(thread->tid != 0);
159
160 /* Remove from circular list of threads */
161 thread->next->prev = thread->prev;
162 thread->prev->next = thread->next;
163 thread->next = NULL;
164 thread->prev = NULL;
165 MUTEX_UNLOCK(&create_destruct_mutex);
c2f2a82b 166
fc04eb16
JH
167 /* Thread is now disowned */
168 S_ithread_clear(aTHX_ thread);
385d56e4
JH
169
170#ifdef WIN32
fc04eb16
JH
171 handle = thread->handle;
172 thread->handle = NULL;
385d56e4 173#endif
fc04eb16
JH
174 MUTEX_UNLOCK(&thread->mutex);
175 MUTEX_DESTROY(&thread->mutex);
385d56e4 176
c7667023 177#ifdef WIN32
fc04eb16
JH
178 if (handle)
179 CloseHandle(handle);
c7667023 180#endif
385d56e4 181
fc04eb16
JH
182 /* Call PerlMemShared_free() in the context of the "first" interpreter
183 * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
184 */
185 aTHX = PL_curinterp;
186 PerlMemShared_free(thread);
68795e93
NIS
187}
188
fc04eb16
JH
189
190/* Called on exit */
62375a60
NIS
191int
192Perl_ithread_hook(pTHX)
193{
194 int veto_cleanup = 0;
195 MUTEX_LOCK(&create_destruct_mutex);
fc04eb16
JH
196 if ((aTHX == PL_curinterp) && (active_threads != 1)) {
197 if (ckWARN_d(WARN_THREADS)) {
198 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running", active_threads);
199 }
200 veto_cleanup = 1;
62375a60
NIS
201 }
202 MUTEX_UNLOCK(&create_destruct_mutex);
fc04eb16 203 return (veto_cleanup);
62375a60
NIS
204}
205
68795e93
NIS
206
207/* MAGIC (in mg.h sense) hooks */
208
209int
210ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
211{
fc04eb16 212 ithread *thread = (ithread *)mg->mg_ptr;
45977657 213 SvIV_set(sv, PTR2IV(thread));
68795e93 214 SvIOK_on(sv);
fc04eb16 215 return (0);
68795e93
NIS
216}
217
218int
219ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
220{
f2cba68d
JH
221 ithread *thread = (ithread *)mg->mg_ptr;
222 int cleanup;
223
68795e93 224 MUTEX_LOCK(&thread->mutex);
f2cba68d
JH
225 cleanup = ((--thread->count == 0) &&
226 (thread->state & PERL_ITHR_FINISHED) &&
227 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
228 MUTEX_UNLOCK(&thread->mutex);
229
230 if (cleanup)
231 S_ithread_destruct(aTHX_ thread);
fc04eb16 232 return (0);
68795e93
NIS
233}
234
235int
236ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
237{
fc04eb16 238 ithread *thread = (ithread *)mg->mg_ptr;
68795e93 239 MUTEX_LOCK(&thread->mutex);
68795e93
NIS
240 thread->count++;
241 MUTEX_UNLOCK(&thread->mutex);
fc04eb16 242 return (0);
68795e93
NIS
243}
244
245MGVTBL ithread_vtbl = {
fc04eb16
JH
246 ithread_mg_get, /* get */
247 0, /* set */
248 0, /* len */
249 0, /* clear */
250 ithread_mg_free, /* free */
251 0, /* copy */
252 ithread_mg_dup /* dup */
68795e93
NIS
253};
254
47ba8780 255
514612b7
JH
256/* Provided default, minimum and rational stack sizes */
257static IV
258good_stack_size(pTHX_ IV stack_size)
259{
260 /* Use default stack size if no stack size specified */
261 if (! stack_size)
262 return (default_stack_size);
263
264#ifdef PTHREAD_STACK_MIN
265 /* Can't use less than minimum */
266 if (stack_size < PTHREAD_STACK_MIN) {
267 if (ckWARN_d(WARN_THREADS)) {
268 Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN);
269 }
270 return (PTHREAD_STACK_MIN);
271 }
272#endif
273
274 /* Round up to page size boundary */
275 if (page_size <= 0) {
d305c2c9 276#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
514612b7 277 SETERRNO(0, SS_NORMAL);
d305c2c9 278# ifdef _SC_PAGESIZE
514612b7 279 page_size = sysconf(_SC_PAGESIZE);
d305c2c9 280# else
514612b7 281 page_size = sysconf(_SC_MMAP_PAGE_SIZE);
d305c2c9 282# endif
514612b7
JH
283 if ((long)page_size < 0) {
284 if (errno) {
285 SV * const error = get_sv("@", FALSE);
286 (void)SvUPGRADE(error, SVt_PV);
287 Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error));
288 } else {
289 Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown");
290 }
291 }
d305c2c9
JH
292#else
293# ifdef HAS_GETPAGESIZE
514612b7 294 page_size = getpagesize();
514612b7 295# else
d305c2c9
JH
296# if defined(I_SYS_PARAM) && defined(PAGESIZE)
297 page_size = PAGESIZE;
298# else
514612b7 299 page_size = 8192; /* A conservative default */
d305c2c9 300# endif
514612b7 301# endif
d305c2c9
JH
302 if (page_size <= 0)
303 Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)page_size);
514612b7
JH
304#endif
305 }
306 stack_size = ((stack_size + (page_size - 1)) / page_size) * page_size;
307
308 return (stack_size);
309}
310
311
fc04eb16
JH
312/* Starts executing the thread.
313 * Passed as the C level function to run in the new thread.
b1edfb69 314 */
47ba8780 315#ifdef WIN32
f4cc38af 316static THREAD_RET_TYPE
fc04eb16 317S_ithread_run(LPVOID arg)
47ba8780 318#else
fc04eb16
JH
319static void *
320S_ithread_run(void * arg)
47ba8780 321#endif
fc04eb16
JH
322{
323 ithread *thread = (ithread *)arg;
324 int cleanup;
f2cba68d 325
fc04eb16
JH
326 dTHXa(thread->interp);
327 PERL_SET_CONTEXT(thread->interp);
328 S_ithread_set(aTHX_ thread);
47ba8780 329
68795e93 330#if 0
fc04eb16
JH
331 /* Far from clear messing with ->thr child-side is a good idea */
332 MUTEX_LOCK(&thread->mutex);
47ba8780 333#ifdef WIN32
fc04eb16 334 thread->thr = GetCurrentThreadId();
47ba8780 335#else
fc04eb16 336 thread->thr = pthread_self();
47ba8780 337#endif
fc04eb16 338 MUTEX_UNLOCK(&thread->mutex);
68795e93 339#endif
47ba8780 340
fc04eb16 341 PL_perl_destruct_level = 2;
f2cba68d 342
fc04eb16
JH
343 {
344 AV *params = (AV *)SvRV(thread->params);
345 int len = (int)av_len(params)+1;
346 int ii;
347
348 dSP;
349 ENTER;
350 SAVETMPS;
351
352 /* Put args on the stack */
353 PUSHMARK(SP);
354 for (ii=0; ii < len; ii++) {
355 XPUSHs(av_shift(params));
356 }
357 PUTBACK;
358
359 /* Run the specified function */
360 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
361
362 /* Remove args from stack and put back in params array */
363 SPAGAIN;
364 for (ii=len-1; ii >= 0; ii--) {
365 SV *sv = POPs;
366 av_store(params, ii, SvREFCNT_inc(sv));
367 }
368
369 /* Check for failure */
370 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
371 Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
372 }
373
374 FREETMPS;
375 LEAVE;
376
377 /* Release function ref */
378 SvREFCNT_dec(thread->init_function);
379 thread->init_function = Nullsv;
380 }
62375a60 381
fc04eb16
JH
382 PerlIO_flush((PerlIO *)NULL);
383
384 MUTEX_LOCK(&thread->mutex);
385 /* Mark as finished */
386 thread->state |= PERL_ITHR_FINISHED;
387 /* Cleanup if detached */
388 cleanup = (thread->state & PERL_ITHR_DETACHED);
389 MUTEX_UNLOCK(&thread->mutex);
390
391 if (cleanup)
392 S_ithread_destruct(aTHX_ thread);
393
394 MUTEX_LOCK(&create_destruct_mutex);
395 active_threads--;
396 MUTEX_UNLOCK(&create_destruct_mutex);
91604d21 397
47ba8780 398#ifdef WIN32
fc04eb16 399 return ((DWORD)0);
e8f2bb9a 400#else
fc04eb16 401 return (0);
47ba8780 402#endif
68795e93
NIS
403}
404
fc04eb16
JH
405
406/* Type conversion helper functions */
f4cc38af 407static SV *
68795e93
NIS
408ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
409{
410 SV *sv;
411 MAGIC *mg;
fc04eb16 412
68795e93 413 if (inc) {
fc04eb16
JH
414 MUTEX_LOCK(&thread->mutex);
415 thread->count++;
416 MUTEX_UNLOCK(&thread->mutex);
417 }
418
419 if (! obj) {
420 obj = newSV(0);
68795e93 421 }
fc04eb16
JH
422
423 sv = newSVrv(obj, classname);
424 sv_setiv(sv, PTR2IV(thread));
425 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0);
68795e93
NIS
426 mg->mg_flags |= MGf_DUP;
427 SvREADONLY_on(sv);
fc04eb16
JH
428
429 return (obj);
68795e93 430}
47ba8780 431
f4cc38af 432static ithread *
68795e93
NIS
433SV_to_ithread(pTHX_ SV *sv)
434{
fc04eb16
JH
435 /* Argument is a thread */
436 if (SvROK(sv)) {
437 return (INT2PTR(ithread *, SvIV(SvRV(sv))));
438 }
439 /* Argument is classname, therefore return current thread */
440 return (S_ithread_get(aTHX));
47ba8780
AB
441}
442
47ba8780 443
fc04eb16
JH
444/* threads->create()
445 * Called in context of parent thread.
446 */
f4cc38af 447static SV *
fc04eb16
JH
448S_ithread_create(
449 pTHX_ SV *obj,
450 char *classname,
451 SV *init_function,
514612b7 452 IV stack_size,
fc04eb16 453 SV *params)
68795e93 454{
fc04eb16
JH
455 ithread *thread;
456 CLONE_PARAMS clone_param;
457 ithread *current_thread = S_ithread_get(aTHX);
3b1c3273 458
fc04eb16
JH
459 SV **tmps_tmp = PL_tmps_stack;
460 IV tmps_ix = PL_tmps_ix;
d94006e8 461#ifndef WIN32
fc04eb16
JH
462 int rc_stack_size = 0;
463 int rc_thread_create = 0;
d94006e8 464#endif
3b1c3273 465
fc04eb16
JH
466 MUTEX_LOCK(&create_destruct_mutex);
467
468 /* Allocate thread structure */
469 thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
470 if (!thread) {
471 MUTEX_UNLOCK(&create_destruct_mutex);
472 PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
473 my_exit(1);
474 }
475 Zero(thread, 1, ithread);
476
477 /* Add to threads list */
478 thread->next = threads;
479 thread->prev = threads->prev;
480 threads->prev = thread;
481 thread->prev->next = thread;
c05ae023 482
fc04eb16
JH
483 /* Set count to 1 immediately in case thread exits before
484 * we return to caller!
485 */
486 thread->count = 1;
487
488 MUTEX_INIT(&thread->mutex);
489 thread->tid = tid_counter++;
514612b7 490 thread->stack_size = good_stack_size(aTHX_ stack_size);
fc04eb16
JH
491 thread->gimme = GIMME_V;
492
493 /* "Clone" our interpreter into the thread's interpreter.
494 * This gives thread access to "static data" and code.
495 */
496 PerlIO_flush((PerlIO *)NULL);
497 S_ithread_set(aTHX_ thread);
498
499 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */
500 PL_srand_called = FALSE; /* Set it to false so we can detect if it gets
501 set during the clone */
3b1c3273 502
47ba8780 503#ifdef WIN32
fc04eb16 504 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 505#else
fc04eb16 506 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780 507#endif
47ba8780 508
fc04eb16
JH
509 /* perl_clone() leaves us in new interpreter's context. As it is tricky
510 * to spot an implicit aTHX, create a new scope with aTHX matching the
511 * context for the duration of our work for new interpreter.
512 */
513 {
514 dTHXa(thread->interp);
515
516 MY_CXT_CLONE;
517
518 /* Here we remove END blocks since they should only run in the thread
519 * they are created
520 */
521 SvREFCNT_dec(PL_endav);
522 PL_endav = newAV();
523 clone_param.flags = 0;
524 thread->init_function = sv_dup(init_function, &clone_param);
525 if (SvREFCNT(thread->init_function) == 0) {
526 SvREFCNT_inc(thread->init_function);
527 }
528
529 thread->params = sv_dup(params, &clone_param);
530 SvREFCNT_inc(thread->params);
531
532 /* The code below checks that anything living on the tmps stack and
533 * has been cloned (so it lives in the ptr_table) has a refcount
534 * higher than 0.
535 *
536 * If the refcount is 0 it means that a something on the stack/context
537 * was holding a reference to it and since we init_stacks() in
538 * perl_clone that won't get cleaned and we will get a leaked scalar.
539 * The reason it was cloned was that it lived on the @_ stack.
540 *
541 * Example of this can be found in bugreport 15837 where calls in the
542 * parameter list end up as a temp.
543 *
544 * One could argue that this fix should be in perl_clone.
545 */
546 while (tmps_ix > 0) {
547 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
548 tmps_ix--;
549 if (sv && SvREFCNT(sv) == 0) {
550 SvREFCNT_inc(sv);
551 SvREFCNT_dec(sv);
552 }
553 }
554
555 SvTEMP_off(thread->init_function);
556 ptr_table_free(PL_ptr_table);
557 PL_ptr_table = NULL;
558 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
559 }
560 S_ithread_set(aTHX_ current_thread);
561 PERL_SET_CONTEXT(aTHX);
562
563 /* Create/start the thread */
47ba8780 564#ifdef WIN32
fc04eb16 565 thread->handle = CreateThread(NULL,
514612b7 566 (DWORD)thread->stack_size,
fc04eb16
JH
567 S_ithread_run,
568 (LPVOID)thread,
514612b7 569 STACK_SIZE_PARAM_IS_A_RESERVATION,
fc04eb16 570 &thread->thr);
82c40bf6 571#else
fc04eb16
JH
572 {
573 static pthread_attr_t attr;
574 static int attr_inited = 0;
575 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
576 if (! attr_inited) {
577 pthread_attr_init(&attr);
578 attr_inited = 1;
579 }
580
fa26028c 581# ifdef PTHREAD_ATTR_SETDETACHSTATE
fc04eb16
JH
582 /* Threads start out joinable */
583 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
fa26028c 584# endif
fc04eb16 585
514612b7 586# ifdef _POSIX_THREAD_ATTR_STACKSIZE
fc04eb16 587 /* Set thread's stack size */
514612b7
JH
588 if (thread->stack_size > 0) {
589 rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size);
590 }
3eb37d38
AB
591# endif
592
fc04eb16
JH
593 /* Create the thread */
594 if (! rc_stack_size) {
595# ifdef OLD_PTHREADS_API
596 rc_thread_create = pthread_create(&thread->thr,
597 attr,
598 S_ithread_run,
599 (void *)thread);
600# else
601# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
602 pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
603# endif
604 rc_thread_create = pthread_create(&thread->thr,
605 &attr,
606 S_ithread_run,
607 (void *)thread);
19a077f6 608# endif
fc04eb16 609 }
514612b7
JH
610
611# ifdef _POSIX_THREAD_ATTR_STACKSIZE
612 /* Try to get thread's actual stack size */
613 {
614 size_t stacksize;
615 if (! pthread_attr_getstacksize(&attr, &stacksize)) {
616 if (stacksize) {
617 thread->stack_size = (IV)stacksize;
618 }
619 }
620 }
621# endif
fc04eb16 622 }
82c40bf6 623#endif
bcd9ca9b 624
fc04eb16 625 /* Check for errors */
d94006e8 626#ifdef WIN32
fc04eb16 627 if (thread->handle == NULL) {
d94006e8 628#else
fc04eb16 629 if (rc_stack_size || rc_thread_create) {
d94006e8 630#endif
fc04eb16
JH
631 MUTEX_UNLOCK(&create_destruct_mutex);
632 sv_2mortal(params);
633 S_ithread_destruct(aTHX_ thread);
d94006e8 634#ifndef WIN32
514612b7
JH
635 if (ckWARN_d(WARN_THREADS)) {
636 if (rc_stack_size)
637 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
638 else
639 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
640 }
d94006e8 641#endif
fc04eb16
JH
642 return (&PL_sv_undef);
643 }
644
645 active_threads++;
646 MUTEX_UNLOCK(&create_destruct_mutex);
647
648 sv_2mortal(params);
3b1c3273 649
fc04eb16 650 return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
68795e93 651}
47ba8780 652
73e09c8f 653#endif /* USE_ITHREADS */
e1c44605 654
fcea4b7c 655
fc04eb16 656MODULE = threads PACKAGE = threads PREFIX = ithread_
68795e93 657PROTOTYPES: DISABLE
8222d950 658
73e09c8f
JH
659#ifdef USE_ITHREADS
660
68795e93 661void
f4cc38af
JH
662ithread_create(...)
663 PREINIT:
664 char *classname;
514612b7 665 ithread *thread;
f4cc38af
JH
666 SV *function_to_call;
667 AV *params;
514612b7
JH
668 HV *specs;
669 IV stack_size;
670 int idx;
f4cc38af
JH
671 int ii;
672 CODE:
514612b7
JH
673 if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
674 if (--items < 2)
675 Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
676 specs = (HV*)SvRV(ST(1));
677 idx = 1;
678 } else {
679 if (items < 2)
680 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
681 specs = NULL;
682 idx = 0;
683 }
f4cc38af 684
514612b7
JH
685 if (sv_isobject(ST(0))) {
686 /* $thr->create() */
687 classname = HvNAME(SvSTASH(SvRV(ST(0))));
688 thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
689 stack_size = thread->stack_size;
690 } else {
691 /* threads->create() */
692 classname = (char *)SvPV_nolen(ST(0));
693 stack_size = default_stack_size;
694 }
695
696 function_to_call = ST(idx+1);
697
698 if (specs) {
699 /* stack_size */
700 if (hv_exists(specs, "stack", 5)) {
701 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
702 } else if (hv_exists(specs, "stacksize", 9)) {
703 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
704 } else if (hv_exists(specs, "stack_size", 10)) {
705 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
706 }
707 }
f4cc38af
JH
708
709 /* Function args */
710 params = newAV();
711 if (items > 2) {
514612b7
JH
712 for (ii=2; ii < items ; ii++) {
713 av_push(params, SvREFCNT_inc(ST(idx+ii)));
f4cc38af
JH
714 }
715 }
716
717 /* Create thread */
bcd9ca9b 718 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
514612b7
JH
719 classname,
720 function_to_call,
721 stack_size,
722 newRV_noinc((SV*)params)));
f4cc38af
JH
723 /* XSRETURN(1); - implied */
724
8222d950 725
68795e93 726void
f4cc38af
JH
727ithread_list(...)
728 PREINIT:
729 char *classname;
fc04eb16 730 ithread *thread;
f4cc38af
JH
731 int list_context;
732 IV count = 0;
733 PPCODE:
734 /* Class method only */
735 if (SvROK(ST(0)))
736 Perl_croak(aTHX_ "Usage: threads->list()");
737 classname = (char *)SvPV_nolen(ST(0));
738
739 /* Calling context */
740 list_context = (GIMME_V == G_ARRAY);
741
742 /* Walk through threads list */
743 MUTEX_LOCK(&create_destruct_mutex);
fc04eb16
JH
744 for (thread = threads->next;
745 thread != threads;
746 thread = thread->next)
f4cc38af
JH
747 {
748 /* Ignore detached or joined threads */
fc04eb16 749 if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
f4cc38af
JH
750 continue;
751 }
752 /* Push object on stack if list context */
753 if (list_context) {
fc04eb16 754 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
f4cc38af
JH
755 }
756 count++;
757 }
758 MUTEX_UNLOCK(&create_destruct_mutex);
759 /* If scalar context, send back count */
760 if (! list_context) {
761 XSRETURN_IV(count);
762 }
678a9b6c
AB
763
764
765void
f4cc38af
JH
766ithread_self(...)
767 PREINIT:
768 char *classname;
fcea4b7c 769 ithread *thread;
f4cc38af
JH
770 CODE:
771 /* Class method only */
772 if (SvROK(ST(0)))
773 Perl_croak(aTHX_ "Usage: threads->self()");
774 classname = (char *)SvPV_nolen(ST(0));
775
fcea4b7c
JH
776 thread = S_ithread_get(aTHX);
777
778 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
f4cc38af 779 /* XSRETURN(1); - implied */
47ba8780 780
47ba8780
AB
781
782void
f4cc38af
JH
783ithread_tid(...)
784 PREINIT:
785 ithread *thread;
786 CODE:
787 thread = SV_to_ithread(aTHX_ ST(0));
788 XST_mUV(0, thread->tid);
789 /* XSRETURN(1); - implied */
790
e1c44605 791
f9dff5f5 792void
f4cc38af
JH
793ithread_join(...)
794 PREINIT:
fcea4b7c
JH
795 ithread *thread;
796 int join_err;
f4cc38af
JH
797 AV *params;
798 int len;
799 int ii;
fcea4b7c
JH
800#ifdef WIN32
801 DWORD waitcode;
802#else
803 void *retval;
804#endif
f4cc38af
JH
805 PPCODE:
806 /* Object method only */
807 if (! sv_isobject(ST(0)))
808 Perl_croak(aTHX_ "Usage: $thr->join()");
809
fcea4b7c
JH
810 /* Check if the thread is joinable */
811 thread = SV_to_ithread(aTHX_ ST(0));
812 MUTEX_LOCK(&thread->mutex);
813 join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
814 MUTEX_UNLOCK(&thread->mutex);
815 if (join_err) {
816 if (join_err & PERL_ITHR_DETACHED) {
817 Perl_croak(aTHX_ "Cannot join a detached thread");
818 } else {
819 Perl_croak(aTHX_ "Thread already joined");
820 }
821 }
822
823 /* Join the thread */
824#ifdef WIN32
825 waitcode = WaitForSingleObject(thread->handle, INFINITE);
826#else
827 pthread_join(thread->thr, &retval);
828#endif
829
830 MUTEX_LOCK(&thread->mutex);
831 /* Mark as joined */
832 thread->state |= PERL_ITHR_JOINED;
833
834 /* Get the return value from the call_sv */
835 {
836 AV *params_copy;
837 PerlInterpreter *other_perl;
838 CLONE_PARAMS clone_params;
839 ithread *current_thread;
840
841 params_copy = (AV *)SvRV(thread->params);
842 other_perl = thread->interp;
843 clone_params.stashes = newAV();
844 clone_params.flags = CLONEf_JOIN_IN;
845 PL_ptr_table = ptr_table_new();
846 current_thread = S_ithread_get(aTHX);
847 S_ithread_set(aTHX_ thread);
848 /* Ensure 'meaningful' addresses retain their meaning */
849 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
850 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
851 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
852 params = (AV *)sv_dup((SV*)params_copy, &clone_params);
853 S_ithread_set(aTHX_ current_thread);
854 SvREFCNT_dec(clone_params.stashes);
855 SvREFCNT_inc(params);
856 ptr_table_free(PL_ptr_table);
857 PL_ptr_table = NULL;
858 }
859
860 /* We are finished with the thread */
861 S_ithread_clear(aTHX_ thread);
862 MUTEX_UNLOCK(&thread->mutex);
863
864 /* If no return values, then just return */
f4cc38af
JH
865 if (! params) {
866 XSRETURN_UNDEF;
867 }
868
869 /* Put return values on stack */
870 len = (int)AvFILL(params);
871 for (ii=0; ii <= len; ii++) {
872 SV* param = av_shift(params);
873 XPUSHs(sv_2mortal(param));
874 }
875
876 /* Free return value array */
877 SvREFCNT_dec(params);
878
879
880void
881ithread_yield(...)
882 CODE:
883 YIELD;
884
885
886void
887ithread_detach(...)
888 PREINIT:
889 ithread *thread;
fcea4b7c
JH
890 int detach_err;
891 int cleanup;
f4cc38af
JH
892 CODE:
893 thread = SV_to_ithread(aTHX_ ST(0));
fcea4b7c
JH
894 MUTEX_LOCK(&thread->mutex);
895
896 /* Check if the thread is detachable */
897 if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
898 MUTEX_UNLOCK(&thread->mutex);
899 if (detach_err & PERL_ITHR_DETACHED) {
900 Perl_croak(aTHX_ "Thread already detached");
901 } else {
902 Perl_croak(aTHX_ "Cannot detach a joined thread");
903 }
904 }
905
906 /* Detach the thread */
907 thread->state |= PERL_ITHR_DETACHED;
908#ifdef WIN32
909 /* Windows has no 'detach thread' function */
910#else
911 PERL_THREAD_DETACH(thread->thr);
912#endif
913 /* Cleanup if finished */
914 cleanup = (thread->state & PERL_ITHR_FINISHED);
915 MUTEX_UNLOCK(&thread->mutex);
916
917 if (cleanup)
918 S_ithread_destruct(aTHX_ thread);
f4cc38af 919
47ba8780
AB
920
921void
f4cc38af
JH
922ithread_DESTROY(...)
923 CODE:
fcea4b7c 924 sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
f4cc38af
JH
925
926
927void
928ithread_equal(...)
fc04eb16
JH
929 PREINIT:
930 int are_equal = 0;
f4cc38af 931 CODE:
fc04eb16 932 /* Compares TIDs to determine thread equality */
f4cc38af
JH
933 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
934 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
935 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
fc04eb16
JH
936 are_equal = (thr1->tid == thr2->tid);
937 }
938 if (are_equal) {
939 XST_mYES(0);
f4cc38af 940 } else {
fc04eb16 941 /* Return 0 on false for backward compatibility */
f4cc38af
JH
942 XST_mIV(0, 0);
943 }
944 /* XSRETURN(1); - implied */
945
47ba8780 946
47ba8780 947void
f4cc38af
JH
948ithread_object(...)
949 PREINIT:
950 char *classname;
951 UV tid;
fc04eb16 952 ithread *thread;
f4cc38af
JH
953 int found = 0;
954 CODE:
955 /* Class method only */
956 if (SvROK(ST(0)))
957 Perl_croak(aTHX_ "Usage: threads->object($tid)");
958 classname = (char *)SvPV_nolen(ST(0));
959
960 if ((items < 2) || ! SvOK(ST(1))) {
961 XSRETURN_UNDEF;
962 }
963
fc04eb16 964 /* threads->object($tid) */
f4cc38af
JH
965 tid = SvUV(ST(1));
966
967 /* Walk through threads list */
968 MUTEX_LOCK(&create_destruct_mutex);
fc04eb16
JH
969 for (thread = threads->next;
970 thread != threads;
971 thread = thread->next)
f4cc38af
JH
972 {
973 /* Look for TID, but ignore detached or joined threads */
fc04eb16
JH
974 if ((thread->tid != tid) ||
975 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
f4cc38af
JH
976 {
977 continue;
978 }
979 /* Put object on stack */
fc04eb16 980 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
f4cc38af
JH
981 found = 1;
982 break;
983 }
984 MUTEX_UNLOCK(&create_destruct_mutex);
985 if (! found) {
986 XSRETURN_UNDEF;
987 }
988 /* XSRETURN(1); - implied */
989
990
991void
992ithread__handle(...);
993 PREINIT:
994 ithread *thread;
995 CODE:
996 thread = SV_to_ithread(aTHX_ ST(0));
997#ifdef WIN32
fcea4b7c 998 XST_mUV(0, PTR2UV(&thread->handle));
f4cc38af 999#else
75ba4ae2 1000 XST_mUV(0, PTR2UV(&thread->thr));
f4cc38af
JH
1001#endif
1002 /* XSRETURN(1); - implied */
68795e93 1003
514612b7
JH
1004
1005void
1006ithread_get_stack_size(...)
1007 PREINIT:
1008 IV stack_size;
1009 CODE:
1010 if (sv_isobject(ST(0))) {
1011 /* $thr->get_stack_size() */
1012 ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1013 stack_size = thread->stack_size;
1014 } else {
1015 /* threads->get_stack_size() */
1016 stack_size = default_stack_size;
1017 }
1018 XST_mIV(0, stack_size);
1019 /* XSRETURN(1); - implied */
1020
1021
1022void
1023ithread_set_stack_size(...)
1024 PREINIT:
1025 IV old_size;
1026 CODE:
1027 if (items != 2)
1028 Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1029 if (sv_isobject(ST(0)))
1030 Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1031
1032 old_size = default_stack_size;
1033 default_stack_size = good_stack_size(aTHX_ SvIV(ST(1)));
1034 XST_mIV(0, old_size);
1035 /* XSRETURN(1); - implied */
1036
73e09c8f
JH
1037#endif /* USE_ITHREADS */
1038
fc04eb16 1039
68795e93
NIS
1040BOOT:
1041{
73e09c8f 1042#ifdef USE_ITHREADS
fc04eb16
JH
1043 /* The 'main' thread is thread 0.
1044 * It is detached (unjoinable) and immortal.
1045 */
62375a60 1046
fc04eb16
JH
1047 ithread *thread;
1048 MY_CXT_INIT;
1049
1050 PL_perl_destruct_level = 2;
1051 MUTEX_INIT(&create_destruct_mutex);
1052 MUTEX_LOCK(&create_destruct_mutex);
1053
1054 PL_threadhook = &Perl_ithread_hook;
1055
1056 thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
1057 if (! thread) {
1058 PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
1059 my_exit(1);
1060 }
1061 Zero(thread, 1, ithread);
1062
1063 PL_perl_destruct_level = 2;
1064 MUTEX_INIT(&thread->mutex);
1065
1066 thread->tid = tid_counter++; /* Thread 0 */
1067
1068 /* Head of the threads list */
1069 threads = thread;
1070 thread->next = thread;
1071 thread->prev = thread;
1072
1073 thread->count = 1; /* Immortal */
1074
1075 thread->interp = aTHX;
1076 thread->state = PERL_ITHR_DETACHED; /* Detached */
514612b7 1077 thread->stack_size = default_stack_size;
fc04eb16
JH
1078# ifdef WIN32
1079 thread->thr = GetCurrentThreadId();
1080# else
1081 thread->thr = pthread_self();
1082# endif
1083
1084 active_threads++;
1085
1086 S_ithread_set(aTHX_ thread);
1087 MUTEX_UNLOCK(&create_destruct_mutex);
73e09c8f 1088#endif /* USE_ITHREADS */
68795e93 1089}