This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rationalise refcounting of thread structures
[perl5.git] / ext / threads / threads.xs
1 #define PERL_NO_GET_CONTEXT
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "XSUB.h"
5 /* Workaround for XSUB.h bug under WIN32 */
6 #ifdef WIN32
7 #  undef setjmp
8 #  if !defined(__BORLANDC__)
9 #    define setjmp(x) _setjmp(x)
10 #  endif
11 #endif
12 #ifdef HAS_PPPORT_H
13 #  define NEED_PL_signals
14 #  define NEED_newRV_noinc
15 #  define NEED_sv_2pv_nolen
16 #  include "ppport.h"
17 #  include "threads.h"
18 #endif
19
20 #ifdef USE_ITHREADS
21
22 #ifdef WIN32
23 #  include <windows.h>
24    /* Supposed to be in Winbase.h */
25 #  ifndef STACK_SIZE_PARAM_IS_A_RESERVATION
26 #    define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000
27 #  endif
28 #  include <win32thread.h>
29 #else
30 #  ifdef OS2
31 typedef perl_os_thread pthread_t;
32 #  else
33 #    include <pthread.h>
34 #  endif
35 #  include <thread.h>
36 #  define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
37 #  ifdef OLD_PTHREADS_API
38 #    define PERL_THREAD_DETACH(t) pthread_detach(&(t))
39 #  else
40 #    define PERL_THREAD_DETACH(t) pthread_detach((t))
41 #  endif
42 #endif
43 #if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM)
44 #  include <sys/param.h>
45 #endif
46
47 /* Values for 'state' member */
48 #define PERL_ITHR_DETACHED           1 /* thread has been detached */
49 #define PERL_ITHR_JOINED             2 /* thread has been joined */
50 #define PERL_ITHR_FINISHED           4 /* thread has finished execution */
51 #define PERL_ITHR_THREAD_EXIT_ONLY   8 /* exit() only exits current thread */
52 #define PERL_ITHR_NONVIABLE         16 /* thread creation failed */
53 #define PERL_ITHR_DIED              32 /* thread finished by dying */
54
55 #define PERL_ITHR_UNCALLABLE  (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)
56
57
58 typedef struct _ithread {
59     struct _ithread *next;      /* Next thread in the list */
60     struct _ithread *prev;      /* Prev thread in the list */
61     PerlInterpreter *interp;    /* The threads interpreter */
62     UV tid;                     /* Threads module's thread id */
63     perl_mutex mutex;           /* Mutex for updating things in this struct */
64     int count;                  /* reference count. See S_ithread_create */
65     int state;                  /* Detached, joined, finished, etc. */
66     int gimme;                  /* Context of create */
67     SV *init_function;          /* Code to run */
68     SV *params;                 /* Args to pass function */
69 #ifdef WIN32
70     DWORD  thr;                 /* OS's idea if thread id */
71     HANDLE handle;              /* OS's waitable handle */
72 #else
73     pthread_t thr;              /* OS's handle for the thread */
74 #endif
75     IV stack_size;
76     SV *err;                    /* Error from abnormally terminated thread */
77     char *err_class;            /* Error object's classname if applicable */
78 } ithread;
79
80
81 #define MY_CXT_KEY "threads::_cxt" XS_VERSION
82
83 typedef struct {
84     /* Used by Perl interpreter for thread context switching */
85     ithread *context;
86 } my_cxt_t;
87
88 START_MY_CXT
89
90
91 #define MY_POOL_KEY "threads::_pool" XS_VERSION
92
93 typedef struct {
94     /* Structure for 'main' thread
95      * Also forms the 'base' for the doubly-linked list of threads */
96     ithread main_thread;
97
98     /* Protects the creation and destruction of threads*/
99     perl_mutex create_destruct_mutex;
100
101     UV tid_counter;
102     IV joinable_threads;
103     IV running_threads;
104     IV detached_threads;
105     IV default_stack_size;
106     IV page_size;
107 } my_pool_t;
108
109 #define dMY_POOL \
110     SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY,               \
111                                sizeof(MY_POOL_KEY)-1, TRUE);            \
112     my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv))
113
114 #define MY_POOL (*my_poolp)
115
116
117 /* Used by Perl interpreter for thread context switching */
118 STATIC void
119 S_ithread_set(pTHX_ ithread *thread)
120 {
121     dMY_CXT;
122     MY_CXT.context = thread;
123 }
124
125 STATIC ithread *
126 S_ithread_get(pTHX)
127 {
128     dMY_CXT;
129     return (MY_CXT.context);
130 }
131
132
133 /* Free any data (such as the Perl interpreter) attached to an ithread
134  * structure.  This is a bit like undef on SVs, where the SV isn't freed,
135  * but the PVX is.  Must be called with thread->mutex already held.
136  */
137 STATIC void
138 S_ithread_clear(pTHX_ ithread *thread)
139 {
140     PerlInterpreter *interp;
141
142     assert(((thread->state & PERL_ITHR_FINISHED) &&
143             (thread->state & PERL_ITHR_UNCALLABLE))
144                 ||
145            (thread->state & PERL_ITHR_NONVIABLE));
146
147     interp = thread->interp;
148     if (interp) {
149         dTHXa(interp);
150
151         PERL_SET_CONTEXT(interp);
152         S_ithread_set(aTHX_ thread);
153
154         SvREFCNT_dec(thread->params);
155         thread->params = Nullsv;
156
157         if (thread->err) {
158             SvREFCNT_dec(thread->err);
159             thread->err = Nullsv;
160         }
161
162         perl_destruct(interp);
163         perl_free(interp);
164         thread->interp = NULL;
165     }
166
167     PERL_SET_CONTEXT(aTHX);
168 }
169
170
171 /* Decrement the refcount of an ithread, and if it reaches zero, free it.
172  * Must be called with the mutex held.
173  * On return, mutex is released (or destroyed) */
174
175 STATIC void
176 S_ithread_free(pTHX_ ithread *thread)
177 {
178 #ifdef WIN32
179     HANDLE handle;
180 #endif
181     dMY_POOL;
182
183     if (! (thread->state & PERL_ITHR_NONVIABLE)) {
184         assert(thread->count > 0);
185         if (--thread->count > 0) {
186             MUTEX_UNLOCK(&thread->mutex);
187             return;
188         }
189         assert((thread->state & PERL_ITHR_FINISHED)
190             && (thread->state & PERL_ITHR_UNCALLABLE));
191     }
192     MUTEX_UNLOCK(&thread->mutex);
193
194     /* Main thread (0) is immortal and should never get here */
195     assert(thread->tid != 0);
196
197     /* Remove from circular list of threads */
198     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
199     assert(thread->prev && thread->next);
200     thread->next->prev = thread->prev;
201     thread->prev->next = thread->next;
202     thread->next = NULL;
203     thread->prev = NULL;
204     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
205
206     /* Thread is now disowned */
207     MUTEX_LOCK(&thread->mutex);
208     S_ithread_clear(aTHX_ thread);
209
210 #ifdef WIN32
211     handle = thread->handle;
212     thread->handle = NULL;
213 #endif
214     MUTEX_UNLOCK(&thread->mutex);
215     MUTEX_DESTROY(&thread->mutex);
216
217 #ifdef WIN32
218     if (handle) {
219         CloseHandle(handle);
220     }
221 #endif
222
223     /* Call PerlMemShared_free() in the context of the "first" interpreter
224      * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
225      */
226     aTHX = MY_POOL.main_thread.interp;
227     PerlMemShared_free(thread);
228 }
229
230
231
232 static void
233 S_ithread_count_inc(pTHX_ ithread *thread)
234 {
235     MUTEX_LOCK(&thread->mutex);
236     thread->count++;
237     MUTEX_UNLOCK(&thread->mutex);
238 }
239
240
241
242 /* Warn if exiting with any unjoined threads */
243 STATIC int
244 S_exit_warning(pTHX)
245 {
246     int veto_cleanup;
247     dMY_POOL;
248
249     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
250     veto_cleanup = (MY_POOL.running_threads || MY_POOL.joinable_threads);
251     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
252
253     if (veto_cleanup) {
254         if (ckWARN_d(WARN_THREADS)) {
255             Perl_warn(aTHX_ "Perl exited with active threads:\n\t%"
256                             IVdf " running and unjoined\n\t%"
257                             IVdf " finished and unjoined\n\t%"
258                             IVdf " running and detached\n",
259                             MY_POOL.running_threads,
260                             MY_POOL.joinable_threads,
261                             MY_POOL.detached_threads);
262         }
263     }
264
265     return (veto_cleanup);
266 }
267
268 /* Called on exit from main thread */
269 int
270 Perl_ithread_hook(pTHX)
271 {
272     dMY_POOL;
273     return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0);
274 }
275
276
277 /* MAGIC (in mg.h sense) hooks */
278
279 int
280 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
281 {
282     ithread *thread = (ithread *)mg->mg_ptr;
283     SvIV_set(sv, PTR2IV(thread));
284     SvIOK_on(sv);
285     return (0);
286 }
287
288 int
289 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
290 {
291     ithread *thread = (ithread *)mg->mg_ptr;
292     MUTEX_LOCK(&thread->mutex);
293     S_ithread_free(aTHX_ thread); /* releases MUTEX */
294     return (0);
295 }
296
297
298 int
299 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
300 {
301     S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr);
302     return (0);
303 }
304
305 MGVTBL ithread_vtbl = {
306     ithread_mg_get,     /* get */
307     0,                  /* set */
308     0,                  /* len */
309     0,                  /* clear */
310     ithread_mg_free,    /* free */
311     0,                  /* copy */
312     ithread_mg_dup      /* dup */
313 };
314
315
316 /* Provided default, minimum and rational stack sizes */
317 STATIC IV
318 S_good_stack_size(pTHX_ IV stack_size)
319 {
320     dMY_POOL;
321
322     /* Use default stack size if no stack size specified */
323     if (! stack_size) {
324         return (MY_POOL.default_stack_size);
325     }
326
327 #ifdef PTHREAD_STACK_MIN
328     /* Can't use less than minimum */
329     if (stack_size < PTHREAD_STACK_MIN) {
330         if (ckWARN(WARN_THREADS)) {
331             Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN);
332         }
333         return (PTHREAD_STACK_MIN);
334     }
335 #endif
336
337     /* Round up to page size boundary */
338     if (MY_POOL.page_size <= 0) {
339 #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
340         SETERRNO(0, SS_NORMAL);
341 #  ifdef _SC_PAGESIZE
342         MY_POOL.page_size = sysconf(_SC_PAGESIZE);
343 #  else
344         MY_POOL.page_size = sysconf(_SC_MMAP_PAGE_SIZE);
345 #  endif
346         if ((long)MY_POOL.page_size < 0) {
347             if (errno) {
348                 SV * const error = get_sv("@", FALSE);
349                 (void)SvUPGRADE(error, SVt_PV);
350                 Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error));
351             } else {
352                 Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown");
353             }
354         }
355 #else
356 #  ifdef HAS_GETPAGESIZE
357         MY_POOL.page_size = getpagesize();
358 #  else
359 #    if defined(I_SYS_PARAM) && defined(PAGESIZE)
360         MY_POOL.page_size = PAGESIZE;
361 #    else
362         MY_POOL.page_size = 8192;   /* A conservative default */
363 #    endif
364 #  endif
365         if (MY_POOL.page_size <= 0) {
366             Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size);
367         }
368 #endif
369     }
370     stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size;
371
372     return (stack_size);
373 }
374
375
376 /* Starts executing the thread.
377  * Passed as the C level function to run in the new thread.
378  */
379 #ifdef WIN32
380 STATIC THREAD_RET_TYPE
381 S_ithread_run(LPVOID arg)
382 #else
383 STATIC void *
384 S_ithread_run(void * arg)
385 #endif
386 {
387     ithread *thread = (ithread *)arg;
388     int jmp_rc = 0;
389     I32 oldscope;
390     int exit_app = 0;   /* Thread terminated using 'exit' */
391     int exit_code = 0;
392     int died = 0;       /* Thread terminated abnormally */
393
394     dJMPENV;
395
396     dTHXa(thread->interp);
397
398     dMY_POOL;
399
400     /* Blocked until ->create() call finishes */
401     MUTEX_LOCK(&thread->mutex);
402     MUTEX_UNLOCK(&thread->mutex);
403
404     PERL_SET_CONTEXT(thread->interp);
405     S_ithread_set(aTHX_ thread);
406
407     PL_perl_destruct_level = 2;
408
409     {
410         AV *params = (AV *)SvRV(thread->params);
411         int len = (int)av_len(params)+1;
412         int ii;
413
414         dSP;
415         ENTER;
416         SAVETMPS;
417
418         /* Put args on the stack */
419         PUSHMARK(SP);
420         for (ii=0; ii < len; ii++) {
421             XPUSHs(av_shift(params));
422         }
423         PUTBACK;
424
425         oldscope = PL_scopestack_ix;
426         JMPENV_PUSH(jmp_rc);
427         if (jmp_rc == 0) {
428             /* Run the specified function */
429             len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
430         } else if (jmp_rc == 2) {
431             /* Thread exited */
432             exit_app = 1;
433             exit_code = STATUS_CURRENT;
434             while (PL_scopestack_ix > oldscope) {
435                 LEAVE;
436             }
437         }
438         JMPENV_POP;
439
440         /* Remove args from stack and put back in params array */
441         SPAGAIN;
442         for (ii=len-1; ii >= 0; ii--) {
443             SV *sv = POPs;
444             if (jmp_rc == 0) {
445                 av_store(params, ii, SvREFCNT_inc(sv));
446             }
447         }
448
449         FREETMPS;
450         LEAVE;
451
452         /* Check for abnormal termination */
453         if (SvTRUE(ERRSV)) {
454             died = PERL_ITHR_DIED;
455             thread->err = newSVsv(ERRSV);
456             /* If ERRSV is an object, remember the classname and then
457              * rebless into 'main' so it will survive 'cloning'
458              */
459             if (sv_isobject(thread->err)) {
460                 thread->err_class = HvNAME(SvSTASH(SvRV(thread->err)));
461                 sv_bless(thread->err, gv_stashpv("main", 0));
462             }
463
464             if (ckWARN_d(WARN_THREADS)) {
465                 oldscope = PL_scopestack_ix;
466                 JMPENV_PUSH(jmp_rc);
467                 if (jmp_rc == 0) {
468                     /* Warn that thread died */
469                     Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
470                 } else if (jmp_rc == 2) {
471                     /* Warn handler exited */
472                     exit_app = 1;
473                     exit_code = STATUS_CURRENT;
474                     while (PL_scopestack_ix > oldscope) {
475                         LEAVE;
476                     }
477                 }
478                 JMPENV_POP;
479             }
480         }
481
482         /* Release function ref */
483         SvREFCNT_dec(thread->init_function);
484         thread->init_function = Nullsv;
485     }
486
487     PerlIO_flush((PerlIO *)NULL);
488
489     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
490     MUTEX_LOCK(&thread->mutex);
491     /* Mark as finished */
492     thread->state |= (PERL_ITHR_FINISHED | died);
493     /* Clear exit flag if required */
494     if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) {
495         exit_app = 0;
496     }
497
498     /* Adjust thread status counts */
499     if (thread->state & PERL_ITHR_DETACHED) {
500         MY_POOL.detached_threads--;
501     } else {
502         MY_POOL.running_threads--;
503         MY_POOL.joinable_threads++;
504     }
505     MUTEX_UNLOCK(&thread->mutex);
506     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
507
508     /* Exit application if required */
509     if (exit_app) {
510         oldscope = PL_scopestack_ix;
511         JMPENV_PUSH(jmp_rc);
512         if (jmp_rc == 0) {
513             /* Warn if there are unjoined threads */
514             S_exit_warning(aTHX);
515         } else if (jmp_rc == 2) {
516             /* Warn handler exited */
517             exit_code = STATUS_CURRENT;
518             while (PL_scopestack_ix > oldscope) {
519                 LEAVE;
520             }
521         }
522         JMPENV_POP;
523
524         my_exit(exit_code);
525     }
526
527     MUTEX_LOCK(&thread->mutex);
528     S_ithread_free(aTHX_ thread); /* releases MUTEX */
529
530 #ifdef WIN32
531     return ((DWORD)0);
532 #else
533     return (0);
534 #endif
535 }
536
537
538 /* Type conversion helper functions */
539
540 STATIC SV *
541 S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
542 {
543     SV *sv;
544     MAGIC *mg;
545
546     if (inc)
547         S_ithread_count_inc(aTHX_ thread);
548
549     if (! obj) {
550         obj = newSV(0);
551     }
552
553     sv = newSVrv(obj, classname);
554     sv_setiv(sv, PTR2IV(thread));
555     mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0);
556     mg->mg_flags |= MGf_DUP;
557     SvREADONLY_on(sv);
558
559     return (obj);
560 }
561
562 STATIC ithread *
563 S_SV_to_ithread(pTHX_ SV *sv)
564 {
565     /* Argument is a thread */
566     if (SvROK(sv)) {
567       return (INT2PTR(ithread *, SvIV(SvRV(sv))));
568     }
569     /* Argument is classname, therefore return current thread */
570     return (S_ithread_get(aTHX));
571 }
572
573
574 /* threads->create()
575  * Called in context of parent thread.
576  * Called with MY_POOL.create_destruct_mutex locked.  (Unlocked on error.)
577  */
578 STATIC ithread *
579 S_ithread_create(
580         pTHX_ SV *init_function,
581         IV        stack_size,
582         int       gimme,
583         int       exit_opt,
584         SV       *params)
585 {
586     ithread     *thread;
587     ithread     *current_thread = S_ithread_get(aTHX);
588
589     SV         **tmps_tmp = PL_tmps_stack;
590     IV           tmps_ix  = PL_tmps_ix;
591 #ifndef WIN32
592     int          rc_stack_size = 0;
593     int          rc_thread_create = 0;
594 #endif
595     dMY_POOL;
596
597     /* Allocate thread structure in context of the main thread's interpreter */
598     {
599         PERL_SET_CONTEXT(MY_POOL.main_thread.interp);
600         thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
601     }
602     PERL_SET_CONTEXT(aTHX);
603     if (!thread) {
604         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
605         PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
606         my_exit(1);
607     }
608     Zero(thread, 1, ithread);
609
610     /* Add to threads list */
611     thread->next = &MY_POOL.main_thread;
612     thread->prev = MY_POOL.main_thread.prev;
613     MY_POOL.main_thread.prev = thread;
614     thread->prev->next = thread;
615
616     /* 1 ref to be held by the local var 'thread' in S_ithread_run()
617      * 1 ref to be held by the threads object that we assume we will
618      *       be embedded in upon our return
619      * 1 ref to be the responsibility of join/detach, so we don't get freed
620              until join/detach, even if no thread objects remain. This
621              allows the following to work:
622                  { threads->new(sub{...}); } threads->object(1)->join;
623      */
624     thread->count = 3;
625
626     /* Block new thread until ->create() call finishes */
627     MUTEX_INIT(&thread->mutex);
628     MUTEX_LOCK(&thread->mutex);
629
630     thread->tid = MY_POOL.tid_counter++;
631     thread->stack_size = S_good_stack_size(aTHX_ stack_size);
632     thread->gimme = gimme;
633     thread->state = exit_opt;
634
635     /* "Clone" our interpreter into the thread's interpreter.
636      * This gives thread access to "static data" and code.
637      */
638     PerlIO_flush((PerlIO *)NULL);
639     S_ithread_set(aTHX_ thread);
640
641     SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */
642     PL_srand_called = FALSE;   /* Set it to false so we can detect if it gets
643                                   set during the clone */
644
645 #ifdef WIN32
646     thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
647 #else
648     thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
649 #endif
650
651     /* perl_clone() leaves us in new interpreter's context.  As it is tricky
652      * to spot an implicit aTHX, create a new scope with aTHX matching the
653      * context for the duration of our work for new interpreter.
654      */
655     {
656         CLONE_PARAMS clone_param;
657
658         dTHXa(thread->interp);
659
660         MY_CXT_CLONE;
661
662         /* Here we remove END blocks since they should only run in the thread
663          * they are created
664          */
665         SvREFCNT_dec(PL_endav);
666         PL_endav = newAV();
667
668         clone_param.flags = 0;
669         if (SvPOK(init_function)) {
670             thread->init_function = newSV(0);
671             sv_copypv(thread->init_function, init_function);
672         } else {
673             thread->init_function = sv_dup(init_function, &clone_param);
674             if (SvREFCNT(thread->init_function) == 0) {
675                 SvREFCNT_inc_void(thread->init_function);
676             }
677         }
678
679         thread->params = sv_dup(params, &clone_param);
680         SvREFCNT_inc_void(thread->params);
681
682         /* The code below checks that anything living on the tmps stack and
683          * has been cloned (so it lives in the ptr_table) has a refcount
684          * higher than 0.
685          *
686          * If the refcount is 0 it means that a something on the stack/context
687          * was holding a reference to it and since we init_stacks() in
688          * perl_clone that won't get cleaned and we will get a leaked scalar.
689          * The reason it was cloned was that it lived on the @_ stack.
690          *
691          * Example of this can be found in bugreport 15837 where calls in the
692          * parameter list end up as a temp.
693          *
694          * One could argue that this fix should be in perl_clone.
695          */
696         while (tmps_ix > 0) {
697             SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
698             tmps_ix--;
699             if (sv && SvREFCNT(sv) == 0) {
700                 SvREFCNT_inc_void(sv);
701                 SvREFCNT_dec(sv);
702             }
703         }
704
705         SvTEMP_off(thread->init_function);
706         ptr_table_free(PL_ptr_table);
707         PL_ptr_table = NULL;
708         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
709     }
710     S_ithread_set(aTHX_ current_thread);
711     PERL_SET_CONTEXT(aTHX);
712
713     /* Create/start the thread */
714 #ifdef WIN32
715     thread->handle = CreateThread(NULL,
716                                   (DWORD)thread->stack_size,
717                                   S_ithread_run,
718                                   (LPVOID)thread,
719                                   STACK_SIZE_PARAM_IS_A_RESERVATION,
720                                   &thread->thr);
721 #else
722     {
723         STATIC pthread_attr_t attr;
724         STATIC int attr_inited = 0;
725         STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE;
726         if (! attr_inited) {
727             pthread_attr_init(&attr);
728             attr_inited = 1;
729         }
730
731 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
732         /* Threads start out joinable */
733         PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
734 #  endif
735
736 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
737         /* Set thread's stack size */
738         if (thread->stack_size > 0) {
739             rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size);
740         }
741 #  endif
742
743         /* Create the thread */
744         if (! rc_stack_size) {
745 #  ifdef OLD_PTHREADS_API
746             rc_thread_create = pthread_create(&thread->thr,
747                                               attr,
748                                               S_ithread_run,
749                                               (void *)thread);
750 #  else
751 #    if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
752             pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
753 #    endif
754             rc_thread_create = pthread_create(&thread->thr,
755                                               &attr,
756                                               S_ithread_run,
757                                               (void *)thread);
758 #  endif
759         }
760
761 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
762         /* Try to get thread's actual stack size */
763         {
764             size_t stacksize;
765 #ifdef HPUX1020
766             stacksize = pthread_attr_getstacksize(attr);
767 #else
768             if (! pthread_attr_getstacksize(&attr, &stacksize))
769 #endif
770                 if (stacksize > 0) {
771                     thread->stack_size = (IV)stacksize;
772                 }
773         }
774 #  endif
775     }
776 #endif
777
778     /* Check for errors */
779 #ifdef WIN32
780     if (thread->handle == NULL) {
781 #else
782     if (rc_stack_size || rc_thread_create) {
783 #endif
784         /* Must unlock mutex for destruct call */
785         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
786         sv_2mortal(params);
787         thread->state |= PERL_ITHR_NONVIABLE;
788         S_ithread_free(aTHX_ thread); /* releases MUTEX */
789 #ifndef WIN32
790         if (ckWARN_d(WARN_THREADS)) {
791             if (rc_stack_size) {
792                 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
793             } else {
794                 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
795             }
796         }
797 #endif
798         return (NULL);
799     }
800
801     MY_POOL.running_threads++;
802     sv_2mortal(params);
803     return (thread);
804 }
805
806 #endif /* USE_ITHREADS */
807
808
809 MODULE = threads    PACKAGE = threads    PREFIX = ithread_
810 PROTOTYPES: DISABLE
811
812 #ifdef USE_ITHREADS
813
814 void
815 ithread_create(...)
816     PREINIT:
817         char *classname;
818         ithread *thread;
819         SV *function_to_call;
820         AV *params;
821         HV *specs;
822         IV stack_size;
823         int context;
824         int exit_opt;
825         SV *thread_exit_only;
826         char *str;
827         int idx;
828         int ii;
829         dMY_POOL;
830     CODE:
831         if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
832             if (--items < 2) {
833                 Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
834             }
835             specs = (HV*)SvRV(ST(1));
836             idx = 1;
837         } else {
838             if (items < 2) {
839                 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
840             }
841             specs = NULL;
842             idx = 0;
843         }
844
845         if (sv_isobject(ST(0))) {
846             /* $thr->create() */
847             classname = HvNAME(SvSTASH(SvRV(ST(0))));
848             thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
849             MUTEX_LOCK(&thread->mutex);
850             stack_size = thread->stack_size;
851             exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY;
852             MUTEX_UNLOCK(&thread->mutex);
853         } else {
854             /* threads->create() */
855             classname = (char *)SvPV_nolen(ST(0));
856             stack_size = MY_POOL.default_stack_size;
857             thread_exit_only = get_sv("threads::thread_exit_only", TRUE);
858             exit_opt = (SvTRUE(thread_exit_only))
859                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
860         }
861
862         function_to_call = ST(idx+1);
863
864         context = -1;
865         if (specs) {
866             /* stack_size */
867             if (hv_exists(specs, "stack", 5)) {
868                 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
869             } else if (hv_exists(specs, "stacksize", 9)) {
870                 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
871             } else if (hv_exists(specs, "stack_size", 10)) {
872                 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
873             }
874
875             /* context */
876             if (hv_exists(specs, "context", 7)) {
877                 str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
878                 switch (*str) {
879                     case 'a':
880                     case 'A':
881                         context = G_ARRAY;
882                         break;
883                     case 's':
884                     case 'S':
885                         context = G_SCALAR;
886                         break;
887                     case 'v':
888                     case 'V':
889                         context = G_VOID;
890                         break;
891                     default:
892                         Perl_croak(aTHX_ "Invalid context: %s", str);
893                 }
894             } else if (hv_exists(specs, "array", 5)) {
895                 if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
896                     context = G_ARRAY;
897                 }
898             } else if (hv_exists(specs, "scalar", 6)) {
899                 if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
900                     context = G_SCALAR;
901                 }
902             } else if (hv_exists(specs, "void", 4)) {
903                 if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
904                     context = G_VOID;
905                 }
906             }
907
908             /* exit => thread_only */
909             if (hv_exists(specs, "exit", 4)) {
910                 str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
911                 exit_opt = (*str == 't' || *str == 'T')
912                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
913             }
914         }
915         if (context == -1) {
916             context = GIMME_V;  /* Implicit context */
917         } else {
918             context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
919         }
920
921         /* Function args */
922         params = newAV();
923         if (items > 2) {
924             for (ii=2; ii < items ; ii++) {
925                 av_push(params, SvREFCNT_inc(ST(idx+ii)));
926             }
927         }
928
929         /* Create thread */
930         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
931         thread = S_ithread_create(aTHX_ function_to_call,
932                                         stack_size,
933                                         context,
934                                         exit_opt,
935                                         newRV_noinc((SV*)params));
936         if (! thread) {
937             XSRETURN_UNDEF;     /* Mutex already unlocked */
938         }
939         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE));
940         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
941
942         /* Let thread run */
943         MUTEX_UNLOCK(&thread->mutex);
944
945         /* XSRETURN(1); - implied */
946
947
948 void
949 ithread_list(...)
950     PREINIT:
951         char *classname;
952         ithread *thread;
953         int list_context;
954         IV count = 0;
955         int want_running = 0;
956         int state;
957         dMY_POOL;
958     PPCODE:
959         /* Class method only */
960         if (SvROK(ST(0))) {
961             Perl_croak(aTHX_ "Usage: threads->list(...)");
962         }
963         classname = (char *)SvPV_nolen(ST(0));
964
965         /* Calling context */
966         list_context = (GIMME_V == G_ARRAY);
967
968         /* Running or joinable parameter */
969         if (items > 1) {
970             want_running = SvTRUE(ST(1));
971         }
972
973         /* Walk through threads list */
974         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
975         for (thread = MY_POOL.main_thread.next;
976              thread != &MY_POOL.main_thread;
977              thread = thread->next)
978         {
979             MUTEX_LOCK(&thread->mutex);
980             state = thread->state;
981             MUTEX_UNLOCK(&thread->mutex);
982
983             /* Ignore detached or joined threads */
984             if (state & PERL_ITHR_UNCALLABLE) {
985                 continue;
986             }
987
988             /* Filter per parameter */
989             if (items > 1) {
990                 if (want_running) {
991                     if (state & PERL_ITHR_FINISHED) {
992                         continue;   /* Not running */
993                     }
994                 } else {
995                     if (! (state & PERL_ITHR_FINISHED)) {
996                         continue;   /* Still running - not joinable yet */
997                     }
998                 }
999             }
1000
1001             /* Push object on stack if list context */
1002             if (list_context) {
1003                 XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
1004             }
1005             count++;
1006         }
1007         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1008         /* If scalar context, send back count */
1009         if (! list_context) {
1010             XSRETURN_IV(count);
1011         }
1012
1013
1014 void
1015 ithread_self(...)
1016     PREINIT:
1017         char *classname;
1018         ithread *thread;
1019     CODE:
1020         /* Class method only */
1021         if ((items != 1) || SvROK(ST(0))) {
1022             Perl_croak(aTHX_ "Usage: threads->self()");
1023         }
1024         classname = (char *)SvPV_nolen(ST(0));
1025
1026         thread = S_ithread_get(aTHX);
1027
1028         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1029         /* XSRETURN(1); - implied */
1030
1031
1032 void
1033 ithread_tid(...)
1034     PREINIT:
1035         ithread *thread;
1036     CODE:
1037         PERL_UNUSED_VAR(items);
1038         thread = S_SV_to_ithread(aTHX_ ST(0));
1039         XST_mUV(0, thread->tid);
1040         /* XSRETURN(1); - implied */
1041
1042
1043 void
1044 ithread_join(...)
1045     PREINIT:
1046         ithread *thread;
1047         ithread *current_thread;
1048         int join_err;
1049         AV *params;
1050         int len;
1051         int ii;
1052 #ifdef WIN32
1053         DWORD waitcode;
1054 #else
1055         int rc_join;
1056         void *retval;
1057 #endif
1058         dMY_POOL;
1059     PPCODE:
1060         /* Object method only */
1061         if ((items != 1) || ! sv_isobject(ST(0))) {
1062             Perl_croak(aTHX_ "Usage: $thr->join()");
1063         }
1064
1065         /* Check if the thread is joinable and not ourselves */
1066         thread = S_SV_to_ithread(aTHX_ ST(0));
1067         current_thread = S_ithread_get(aTHX);
1068
1069         MUTEX_LOCK(&thread->mutex);
1070         if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1071             MUTEX_UNLOCK(&thread->mutex);
1072             Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED)
1073                                 ? "Cannot join a detached thread"
1074                                 : "Thread already joined");
1075         } else if (thread->tid == current_thread->tid) {
1076             MUTEX_UNLOCK(&thread->mutex);
1077             Perl_croak(aTHX_ "Cannot join self");
1078         }
1079
1080         /* Mark as joined */
1081         thread->state |= PERL_ITHR_JOINED;
1082         MUTEX_UNLOCK(&thread->mutex);
1083
1084         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1085         MY_POOL.joinable_threads--;
1086         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1087
1088         /* Join the thread */
1089 #ifdef WIN32
1090         if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) {
1091             /* Timeout/abandonment unexpected here; check $^E */
1092             Perl_croak(aTHX_ "PANIC: underlying join failed");
1093         };
1094 #else
1095         if ((rc_join = pthread_join(thread->thr, &retval)) != 0) {
1096             /* In progress/deadlock/unknown unexpected here; check $! */
1097             errno = rc_join;
1098             Perl_croak(aTHX_ "PANIC: underlying join failed");
1099         };
1100 #endif
1101
1102         MUTEX_LOCK(&thread->mutex);
1103         /* Get the return value from the call_sv */
1104         /* Objects do not survive this process - FIXME */
1105         {
1106             AV *params_copy;
1107             PerlInterpreter *other_perl;
1108             CLONE_PARAMS clone_params;
1109
1110             params_copy = (AV *)SvRV(thread->params);
1111             other_perl = thread->interp;
1112             clone_params.stashes = newAV();
1113             clone_params.flags = CLONEf_JOIN_IN;
1114             PL_ptr_table = ptr_table_new();
1115             S_ithread_set(aTHX_ thread);
1116             /* Ensure 'meaningful' addresses retain their meaning */
1117             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1118             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1119             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1120             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
1121             S_ithread_set(aTHX_ current_thread);
1122             SvREFCNT_dec(clone_params.stashes);
1123             SvREFCNT_inc_void(params);
1124             ptr_table_free(PL_ptr_table);
1125             PL_ptr_table = NULL;
1126         }
1127
1128         /* If thread didn't die, then we can free its interpreter */
1129         if (! (thread->state & PERL_ITHR_DIED)) {
1130             S_ithread_clear(aTHX_ thread);
1131         }
1132         S_ithread_free(aTHX_ thread); /* releases MUTEX */
1133
1134         /* If no return values, then just return */
1135         if (! params) {
1136             XSRETURN_UNDEF;
1137         }
1138
1139         /* Put return values on stack */
1140         len = (int)AvFILL(params);
1141         for (ii=0; ii <= len; ii++) {
1142             SV* param = av_shift(params);
1143             XPUSHs(sv_2mortal(param));
1144         }
1145
1146         /* Free return value array */
1147         SvREFCNT_dec(params);
1148
1149
1150 void
1151 ithread_yield(...)
1152     CODE:
1153         PERL_UNUSED_VAR(items);
1154         YIELD;
1155
1156
1157 void
1158 ithread_detach(...)
1159     PREINIT:
1160         ithread *thread;
1161         int detach_err;
1162         dMY_POOL;
1163     CODE:
1164         PERL_UNUSED_VAR(items);
1165
1166         /* Detach the thread */
1167         thread = S_SV_to_ithread(aTHX_ ST(0));
1168         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1169         MUTEX_LOCK(&thread->mutex);
1170         if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1171             /* Thread is detachable */
1172             thread->state |= PERL_ITHR_DETACHED;
1173 #ifdef WIN32
1174             /* Windows has no 'detach thread' function */
1175 #else
1176             PERL_THREAD_DETACH(thread->thr);
1177 #endif
1178             if (thread->state & PERL_ITHR_FINISHED) {
1179                 MY_POOL.joinable_threads--;
1180             } else {
1181                 MY_POOL.running_threads--;
1182                 MY_POOL.detached_threads++;
1183             }
1184         }
1185         MUTEX_UNLOCK(&thread->mutex);
1186         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1187
1188         if (detach_err) {
1189             Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED)
1190                                 ? "Thread already detached"
1191                                 : "Cannot detach a joined thread");
1192         }
1193
1194         /* If thread is finished and didn't die,
1195          * then we can free its interpreter */
1196         MUTEX_LOCK(&thread->mutex);
1197         if ((thread->state & PERL_ITHR_FINISHED) &&
1198             ! (thread->state & PERL_ITHR_DIED))
1199         {
1200             S_ithread_clear(aTHX_ thread);
1201         }
1202         S_ithread_free(aTHX_ thread); /* releases MUTEX */
1203
1204
1205
1206 void
1207 ithread_kill(...)
1208     PREINIT:
1209         ithread *thread;
1210         char *sig_name;
1211         IV signal;
1212     CODE:
1213         /* Must have safe signals */
1214         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
1215             Perl_croak(aTHX_ "Cannot signal threads without safe signals");
1216         }
1217
1218         /* Object method only */
1219         if ((items != 2) || ! sv_isobject(ST(0))) {
1220             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
1221         }
1222
1223         /* Get signal */
1224         sig_name = SvPV_nolen(ST(1));
1225         if (isALPHA(*sig_name)) {
1226             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') {
1227                 sig_name += 3;
1228             }
1229             if ((signal = whichsig(sig_name)) < 0) {
1230                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
1231             }
1232         } else {
1233             signal = SvIV(ST(1));
1234         }
1235
1236         /* Set the signal for the thread */
1237         thread = S_SV_to_ithread(aTHX_ ST(0));
1238         MUTEX_LOCK(&thread->mutex);
1239         if (thread->interp) {
1240             dTHXa(thread->interp);
1241             PL_psig_pend[signal]++;
1242             PL_sig_pending = 1;
1243         }
1244         MUTEX_UNLOCK(&thread->mutex);
1245
1246         /* Return the thread to allow for method chaining */
1247         ST(0) = ST(0);
1248         /* XSRETURN(1); - implied */
1249
1250
1251 void
1252 ithread_DESTROY(...)
1253     CODE:
1254         PERL_UNUSED_VAR(items);
1255         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
1256
1257
1258 void
1259 ithread_equal(...)
1260     PREINIT:
1261         int are_equal = 0;
1262     CODE:
1263         PERL_UNUSED_VAR(items);
1264
1265         /* Compares TIDs to determine thread equality */
1266         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1267             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1268             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
1269             are_equal = (thr1->tid == thr2->tid);
1270         }
1271         if (are_equal) {
1272             XST_mYES(0);
1273         } else {
1274             /* Return 0 on false for backward compatibility */
1275             XST_mIV(0, 0);
1276         }
1277         /* XSRETURN(1); - implied */
1278
1279
1280 void
1281 ithread_object(...)
1282     PREINIT:
1283         char *classname;
1284         UV tid;
1285         ithread *thread;
1286         int state;
1287         int have_obj = 0;
1288         dMY_POOL;
1289     CODE:
1290         /* Class method only */
1291         if (SvROK(ST(0))) {
1292             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1293         }
1294         classname = (char *)SvPV_nolen(ST(0));
1295
1296         if ((items < 2) || ! SvOK(ST(1))) {
1297             XSRETURN_UNDEF;
1298         }
1299
1300         /* threads->object($tid) */
1301         tid = SvUV(ST(1));
1302
1303         /* Walk through threads list */
1304         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1305         for (thread = MY_POOL.main_thread.next;
1306              thread != &MY_POOL.main_thread;
1307              thread = thread->next)
1308         {
1309             /* Look for TID */
1310             if (thread->tid == tid) {
1311                 /* Ignore if detached or joined */
1312                 MUTEX_LOCK(&thread->mutex);
1313                 state = thread->state;
1314                 MUTEX_UNLOCK(&thread->mutex);
1315                 if (! (state & PERL_ITHR_UNCALLABLE)) {
1316                     /* Put object on stack */
1317                     ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1318                     have_obj = 1;
1319                 }
1320                 break;
1321             }
1322         }
1323         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1324
1325         if (! have_obj) {
1326             XSRETURN_UNDEF;
1327         }
1328         /* XSRETURN(1); - implied */
1329
1330
1331 void
1332 ithread__handle(...);
1333     PREINIT:
1334         ithread *thread;
1335     CODE:
1336         PERL_UNUSED_VAR(items);
1337         thread = S_SV_to_ithread(aTHX_ ST(0));
1338 #ifdef WIN32
1339         XST_mUV(0, PTR2UV(&thread->handle));
1340 #else
1341         XST_mUV(0, PTR2UV(&thread->thr));
1342 #endif
1343         /* XSRETURN(1); - implied */
1344
1345
1346 void
1347 ithread_get_stack_size(...)
1348     PREINIT:
1349         IV stack_size;
1350         dMY_POOL;
1351     CODE:
1352         PERL_UNUSED_VAR(items);
1353         if (sv_isobject(ST(0))) {
1354             /* $thr->get_stack_size() */
1355             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1356             stack_size = thread->stack_size;
1357         } else {
1358             /* threads->get_stack_size() */
1359             stack_size = MY_POOL.default_stack_size;
1360         }
1361         XST_mIV(0, stack_size);
1362         /* XSRETURN(1); - implied */
1363
1364
1365 void
1366 ithread_set_stack_size(...)
1367     PREINIT:
1368         IV old_size;
1369         dMY_POOL;
1370     CODE:
1371         if (items != 2) {
1372             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1373         }
1374         if (sv_isobject(ST(0))) {
1375             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1376         }
1377
1378         old_size = MY_POOL.default_stack_size;
1379         MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1)));
1380         XST_mIV(0, old_size);
1381         /* XSRETURN(1); - implied */
1382
1383
1384 void
1385 ithread_is_running(...)
1386     PREINIT:
1387         ithread *thread;
1388     CODE:
1389         /* Object method only */
1390         if ((items != 1) || ! sv_isobject(ST(0))) {
1391             Perl_croak(aTHX_ "Usage: $thr->is_running()");
1392         }
1393
1394         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1395         MUTEX_LOCK(&thread->mutex);
1396         ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
1397         MUTEX_UNLOCK(&thread->mutex);
1398         /* XSRETURN(1); - implied */
1399
1400
1401 void
1402 ithread_is_detached(...)
1403     PREINIT:
1404         ithread *thread;
1405     CODE:
1406         PERL_UNUSED_VAR(items);
1407         thread = S_SV_to_ithread(aTHX_ ST(0));
1408         MUTEX_LOCK(&thread->mutex);
1409         ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
1410         MUTEX_UNLOCK(&thread->mutex);
1411         /* XSRETURN(1); - implied */
1412
1413
1414 void
1415 ithread_is_joinable(...)
1416     PREINIT:
1417         ithread *thread;
1418     CODE:
1419         /* Object method only */
1420         if ((items != 1) || ! sv_isobject(ST(0))) {
1421             Perl_croak(aTHX_ "Usage: $thr->is_joinable()");
1422         }
1423
1424         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1425         MUTEX_LOCK(&thread->mutex);
1426         ST(0) = ((thread->state & PERL_ITHR_FINISHED) &&
1427                  ! (thread->state & PERL_ITHR_UNCALLABLE))
1428             ? &PL_sv_yes : &PL_sv_no;
1429         MUTEX_UNLOCK(&thread->mutex);
1430         /* XSRETURN(1); - implied */
1431
1432
1433 void
1434 ithread_wantarray(...)
1435     PREINIT:
1436         ithread *thread;
1437     CODE:
1438         PERL_UNUSED_VAR(items);
1439         thread = S_SV_to_ithread(aTHX_ ST(0));
1440         ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
1441                 (thread->gimme & G_VOID)  ? &PL_sv_undef
1442                            /* G_SCALAR */ : &PL_sv_no;
1443         /* XSRETURN(1); - implied */
1444
1445
1446 void
1447 ithread_set_thread_exit_only(...)
1448     PREINIT:
1449         ithread *thread;
1450     CODE:
1451         if (items != 2) {
1452             Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)");
1453         }
1454         thread = S_SV_to_ithread(aTHX_ ST(0));
1455         MUTEX_LOCK(&thread->mutex);
1456         if (SvTRUE(ST(1))) {
1457             thread->state |= PERL_ITHR_THREAD_EXIT_ONLY;
1458         } else {
1459             thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY;
1460         }
1461         MUTEX_UNLOCK(&thread->mutex);
1462
1463
1464 void
1465 ithread_error(...)
1466     PREINIT:
1467         ithread *thread;
1468         SV *err = NULL;
1469     CODE:
1470         /* Object method only */
1471         if ((items != 1) || ! sv_isobject(ST(0))) {
1472             Perl_croak(aTHX_ "Usage: $thr->err()");
1473         }
1474
1475         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1476         MUTEX_LOCK(&thread->mutex);
1477
1478         /* If thread died, then clone the error into the calling thread */
1479         if (thread->state & PERL_ITHR_DIED) {
1480             PerlInterpreter *other_perl;
1481             CLONE_PARAMS clone_params;
1482             ithread *current_thread;
1483
1484             other_perl = thread->interp;
1485             clone_params.stashes = newAV();
1486             clone_params.flags = CLONEf_JOIN_IN;
1487             PL_ptr_table = ptr_table_new();
1488             current_thread = S_ithread_get(aTHX);
1489             S_ithread_set(aTHX_ thread);
1490             /* Ensure 'meaningful' addresses retain their meaning */
1491             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1492             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1493             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1494             err = sv_dup(thread->err, &clone_params);
1495             S_ithread_set(aTHX_ current_thread);
1496             SvREFCNT_dec(clone_params.stashes);
1497             SvREFCNT_inc_void(err);
1498             /* If error was an object, bless it into the correct class */
1499             if (thread->err_class) {
1500                 sv_bless(err, gv_stashpv(thread->err_class, 1));
1501             }
1502             ptr_table_free(PL_ptr_table);
1503             PL_ptr_table = NULL;
1504         }
1505
1506         MUTEX_UNLOCK(&thread->mutex);
1507
1508         if (! err) {
1509             XSRETURN_UNDEF;
1510         }
1511
1512         ST(0) = sv_2mortal(err);
1513         /* XSRETURN(1); - implied */
1514
1515
1516 #endif /* USE_ITHREADS */
1517
1518
1519 BOOT:
1520 {
1521 #ifdef USE_ITHREADS
1522     SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY,
1523                                sizeof(MY_POOL_KEY)-1, TRUE);
1524     my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1));
1525
1526     MY_CXT_INIT;
1527
1528     Zero(my_poolp, 1, my_pool_t);
1529     sv_setuv(my_pool_sv, PTR2UV(my_poolp));
1530
1531     PL_perl_destruct_level = 2;
1532     MUTEX_INIT(&MY_POOL.create_destruct_mutex);
1533     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1534
1535     PL_threadhook = &Perl_ithread_hook;
1536
1537     MY_POOL.tid_counter = 1;
1538 #  ifdef THREAD_CREATE_NEEDS_STACK
1539     MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK;
1540 #  endif
1541
1542     /* The 'main' thread is thread 0.
1543      * It is detached (unjoinable) and immortal.
1544      */
1545
1546     MUTEX_INIT(&MY_POOL.main_thread.mutex);
1547
1548     /* Head of the threads list */
1549     MY_POOL.main_thread.next = &MY_POOL.main_thread;
1550     MY_POOL.main_thread.prev = &MY_POOL.main_thread;
1551
1552     MY_POOL.main_thread.count = 1;                  /* Immortal */
1553
1554     MY_POOL.main_thread.interp = aTHX;
1555     MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */
1556     MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size;
1557 #  ifdef WIN32
1558     MY_POOL.main_thread.thr = GetCurrentThreadId();
1559 #  else
1560     MY_POOL.main_thread.thr = pthread_self();
1561 #  endif
1562
1563     S_ithread_set(aTHX_ &MY_POOL.main_thread);
1564     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1565 #endif /* USE_ITHREADS */
1566 }