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