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