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