This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
tidy index arrangements in new MY_CXT code
[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
6 #ifdef USE_ITHREADS
7
8
9 #ifdef WIN32
10 #include <windows.h>
11 #include <win32thread.h>
12 #else
13 #ifdef OS2
14 typedef perl_os_thread pthread_t;
15 #else
16 #include <pthread.h>
17 #endif
18 #include <thread.h>
19 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
20 #ifdef OLD_PTHREADS_API
21 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
22 #else
23 #define PERL_THREAD_DETACH(t) pthread_detach((t))
24 #endif  /* OLD_PTHREADS_API */
25 #endif
26
27
28
29
30 /* Values for 'state' member */
31 #define PERL_ITHR_JOINABLE              0
32 #define PERL_ITHR_DETACHED              1
33 #define PERL_ITHR_FINISHED              4
34 #define PERL_ITHR_JOINED                2
35
36 typedef struct ithread_s {
37     struct ithread_s *next;     /* Next thread in the list */
38     struct ithread_s *prev;     /* Prev thread in the list */
39     PerlInterpreter *interp;    /* The threads interpreter */
40     I32 tid;                    /* Threads module's thread id */
41     perl_mutex mutex;           /* Mutex for updating things in this struct */
42     I32 count;                  /* How many SVs have a reference to us */
43     signed char state;          /* Are we detached ? */
44     int gimme;                  /* Context of create */
45     SV* init_function;          /* Code to run */
46     SV* params;                 /* Args to pass function */
47 #ifdef WIN32
48         DWORD   thr;            /* OS's idea if thread id */
49         HANDLE handle;          /* OS's waitable handle */
50 #else
51         pthread_t thr;          /* OS's handle for the thread */
52 #endif
53 } ithread;
54
55 ithread *threads;
56
57 /* Macros to supply the aTHX_ in an embed.h like manner */
58 #define ithread_join(thread)            Perl_ithread_join(aTHX_ thread)
59 #define ithread_DESTROY(thread)         Perl_ithread_DESTROY(aTHX_ thread)
60 #define ithread_CLONE(thread)           Perl_ithread_CLONE(aTHX_ thread)
61 #define ithread_detach(thread)          Perl_ithread_detach(aTHX_ thread)
62 #define ithread_tid(thread)             ((thread)->tid)
63 #define ithread_yield(thread)           (YIELD);
64
65 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
66
67 I32 tid_counter = 0;
68 I32 known_threads = 0;
69 I32 active_threads = 0;
70
71
72 void Perl_ithread_set (pTHX_ ithread* thread)
73 {
74   SV* thread_sv = newSViv(PTR2IV(thread));
75   if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
76     croak("%s\n","Internal error, couldn't set TLS");
77   }
78 }
79
80 ithread* Perl_ithread_get (pTHX) {
81   SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
82   if(!thread_sv) {
83     croak("%s\n","Internal error, couldn't get TLS");
84   }
85   return INT2PTR(ithread*,SvIV(*thread_sv));
86 }
87
88
89 /* free any data (such as the perl interpreter) attached to an
90  * ithread structure. This is a bit like undef on SVs, where the SV
91  * isn't freed, but the PVX is.
92  * Must be called with thread->mutex already held
93  */
94
95 static void
96 S_ithread_clear(pTHX_ ithread* thread)
97 {
98     PerlInterpreter *interp;
99     assert(thread->state & PERL_ITHR_FINISHED &&
100             (thread->state & PERL_ITHR_DETACHED ||
101             thread->state & PERL_ITHR_JOINED));
102
103     interp = thread->interp;
104     if (interp) {
105         dTHXa(interp);
106         ithread* current_thread;
107 #ifdef OEMVS
108         void *ptr;
109 #endif
110         PERL_SET_CONTEXT(interp);
111         current_thread = Perl_ithread_get(aTHX);
112         Perl_ithread_set(aTHX_ thread);
113         
114         SvREFCNT_dec(thread->params);
115
116         thread->params = Nullsv;
117         perl_destruct(interp);
118         thread->interp = NULL;
119     }
120     if (interp)
121         perl_free(interp);
122     PERL_SET_CONTEXT(aTHX);
123 }
124
125
126 /*
127  *  free an ithread structure and any attached data if its count == 0
128  */
129 void
130 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
131 {
132         MUTEX_LOCK(&thread->mutex);
133         if (!thread->next) {
134             MUTEX_UNLOCK(&thread->mutex);
135             Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
136         }
137         if (thread->count != 0) {
138                 MUTEX_UNLOCK(&thread->mutex);
139                 return;
140         }
141         MUTEX_LOCK(&create_destruct_mutex);
142         /* Remove from circular list of threads */
143         if (thread->next == thread) {
144             /* last one should never get here ? */
145             threads = NULL;
146         }
147         else {
148             thread->next->prev = thread->prev;
149             thread->prev->next = thread->next;
150             if (threads == thread) {
151                 threads = thread->next;
152             }
153             thread->next = NULL;
154             thread->prev = NULL;
155         }
156         known_threads--;
157         assert( known_threads >= 0 );
158 #if 0
159         Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
160                   thread->tid,thread->interp,aTHX, known_threads);
161 #endif
162         MUTEX_UNLOCK(&create_destruct_mutex);
163         /* Thread is now disowned */
164
165         S_ithread_clear(aTHX_ thread);
166         MUTEX_UNLOCK(&thread->mutex);
167         MUTEX_DESTROY(&thread->mutex);
168 #ifdef WIN32
169         if (thread->handle)
170             CloseHandle(thread->handle);
171         thread->handle = 0;
172 #endif
173         PerlMemShared_free(thread);
174 }
175
176 int
177 Perl_ithread_hook(pTHX)
178 {
179     int veto_cleanup = 0;
180     MUTEX_LOCK(&create_destruct_mutex);
181     if (aTHX == PL_curinterp && active_threads != 1) {
182         if (ckWARN_d(WARN_THREADS))
183             Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
184                                                       (IV)active_threads);
185         veto_cleanup = 1;
186     }
187     MUTEX_UNLOCK(&create_destruct_mutex);
188     return veto_cleanup;
189 }
190
191 void
192 Perl_ithread_detach(pTHX_ ithread *thread)
193 {
194     MUTEX_LOCK(&thread->mutex);
195     if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
196         thread->state |= PERL_ITHR_DETACHED;
197 #ifdef WIN32
198         CloseHandle(thread->handle);
199         thread->handle = 0;
200 #else
201         PERL_THREAD_DETACH(thread->thr);
202 #endif
203     }
204     if ((thread->state & PERL_ITHR_FINISHED) &&
205         (thread->state & PERL_ITHR_DETACHED)) {
206         MUTEX_UNLOCK(&thread->mutex);
207         Perl_ithread_destruct(aTHX_ thread, "detach");
208     }
209     else {
210         MUTEX_UNLOCK(&thread->mutex);
211     }
212 }
213
214 /* MAGIC (in mg.h sense) hooks */
215
216 int
217 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
218 {
219     ithread *thread = (ithread *) mg->mg_ptr;
220     SvIV_set(sv, PTR2IV(thread));
221     SvIOK_on(sv);
222     return 0;
223 }
224
225 int
226 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
227 {
228     ithread *thread = (ithread *) mg->mg_ptr;
229     MUTEX_LOCK(&thread->mutex);
230     thread->count--;
231     if (thread->count == 0) {
232        if(thread->state & PERL_ITHR_FINISHED &&
233           (thread->state & PERL_ITHR_DETACHED ||
234            thread->state & PERL_ITHR_JOINED))
235        {
236             MUTEX_UNLOCK(&thread->mutex);
237             Perl_ithread_destruct(aTHX_ thread, "no reference");
238        }
239        else {
240             MUTEX_UNLOCK(&thread->mutex);
241        }    
242     }
243     else {
244         MUTEX_UNLOCK(&thread->mutex);
245     }
246     return 0;
247 }
248
249 int
250 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
251 {
252     ithread *thread = (ithread *) mg->mg_ptr;
253     MUTEX_LOCK(&thread->mutex);
254     thread->count++;
255     MUTEX_UNLOCK(&thread->mutex);
256     return 0;
257 }
258
259 MGVTBL ithread_vtbl = {
260  ithread_mg_get,        /* get */
261  0,                     /* set */
262  0,                     /* len */
263  0,                     /* clear */
264  ithread_mg_free,       /* free */
265  0,                     /* copy */
266  ithread_mg_dup         /* dup */
267 };
268
269
270 /*
271  *      Starts executing the thread. Needs to clean up memory a tad better.
272  *      Passed as the C level function to run in the new thread
273  */
274
275 #ifdef WIN32
276 THREAD_RET_TYPE
277 Perl_ithread_run(LPVOID arg) {
278 #else
279 void*
280 Perl_ithread_run(void * arg) {
281 #endif
282         ithread* thread = (ithread*) arg;
283         dTHXa(thread->interp);
284         PERL_SET_CONTEXT(thread->interp);
285         Perl_ithread_set(aTHX_ thread);
286
287 #if 0
288         /* Far from clear messing with ->thr child-side is a good idea */
289         MUTEX_LOCK(&thread->mutex);
290 #ifdef WIN32
291         thread->thr = GetCurrentThreadId();
292 #else
293         thread->thr = pthread_self();
294 #endif
295         MUTEX_UNLOCK(&thread->mutex);
296 #endif
297
298         PL_perl_destruct_level = 2;
299
300         {
301                 AV* params = (AV*) SvRV(thread->params);
302                 I32 len = av_len(params)+1;
303                 int i;
304                 dSP;
305                 ENTER;
306                 SAVETMPS;
307                 PUSHMARK(SP);
308                 for(i = 0; i < len; i++) {
309                     XPUSHs(av_shift(params));
310                 }
311                 PUTBACK;
312                 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
313
314                 SPAGAIN;
315                 for (i=len-1; i >= 0; i--) {
316                   SV *sv = POPs;
317                   av_store(params, i, SvREFCNT_inc(sv));
318                 }
319                 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
320                     Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
321                 }
322                 FREETMPS;
323                 LEAVE;
324                 SvREFCNT_dec(thread->init_function);
325         }
326
327         PerlIO_flush((PerlIO*)NULL);
328         MUTEX_LOCK(&thread->mutex);
329         thread->state |= PERL_ITHR_FINISHED;
330
331         if (thread->state & PERL_ITHR_DETACHED) {
332                 MUTEX_UNLOCK(&thread->mutex);
333                 Perl_ithread_destruct(aTHX_ thread, "detached finish");
334         } else {
335                 MUTEX_UNLOCK(&thread->mutex);
336         }
337         MUTEX_LOCK(&create_destruct_mutex);
338         active_threads--;
339         assert( active_threads >= 0 );
340         MUTEX_UNLOCK(&create_destruct_mutex);
341
342 #ifdef WIN32
343         return (DWORD)0;
344 #else
345         return 0;
346 #endif
347 }
348
349 SV *
350 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
351 {
352     SV *sv;
353     MAGIC *mg;
354     if (inc) {
355         MUTEX_LOCK(&thread->mutex);
356         thread->count++;
357         MUTEX_UNLOCK(&thread->mutex);
358     }
359     if (!obj)
360      obj = newSV(0);
361     sv = newSVrv(obj,classname);
362     sv_setiv(sv,PTR2IV(thread));
363     mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
364     mg->mg_flags |= MGf_DUP;
365     SvREADONLY_on(sv);
366     return obj;
367 }
368
369 ithread *
370 SV_to_ithread(pTHX_ SV *sv)
371 {
372     if (SvROK(sv))
373      {
374       return INT2PTR(ithread*, SvIV(SvRV(sv)));
375      }
376     else
377      {
378       return Perl_ithread_get(aTHX);
379      }
380 }
381
382 /*
383  * ithread->create(); ( aka ithread->new() )
384  * Called in context of parent thread
385  */
386
387 SV *
388 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
389 {
390         ithread*        thread;
391         CLONE_PARAMS    clone_param;
392         ithread*        current_thread = Perl_ithread_get(aTHX);
393
394         SV**            tmps_tmp = PL_tmps_stack;
395         I32             tmps_ix  = PL_tmps_ix;
396 #ifndef WIN32
397         int             failure;
398         const char*     panic = NULL;
399 #endif
400
401
402         MUTEX_LOCK(&create_destruct_mutex);
403         thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
404         if (!thread) {  
405             MUTEX_UNLOCK(&create_destruct_mutex);
406             PerlLIO_write(PerlIO_fileno(Perl_error_log),
407                           PL_no_mem, strlen(PL_no_mem));
408             my_exit(1);
409         }
410         Zero(thread,1,ithread);
411         thread->next = threads;
412         thread->prev = threads->prev;
413         threads->prev = thread;
414         thread->prev->next = thread;
415         /* Set count to 1 immediately in case thread exits before
416          * we return to caller !
417          */
418         thread->count = 1;
419         MUTEX_INIT(&thread->mutex);
420         thread->tid = tid_counter++;
421         thread->gimme = GIMME_V;
422
423         /* "Clone" our interpreter into the thread's interpreter
424          * This gives thread access to "static data" and code.
425          */
426
427         PerlIO_flush((PerlIO*)NULL);
428         Perl_ithread_set(aTHX_ thread);
429
430         SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
431                                       value */
432         PL_srand_called = FALSE; /* Set it to false so we can detect
433                                     if it gets set during the clone */
434
435 #ifdef WIN32
436         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
437 #else
438         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
439 #endif
440         /* perl_clone leaves us in new interpreter's context.
441            As it is tricky to spot an implicit aTHX, create a new scope
442            with aTHX matching the context for the duration of
443            our work for new interpreter.
444          */
445         {
446             dTHXa(thread->interp);
447
448             /* Here we remove END blocks since they should only run
449                in the thread they are created
450             */
451             SvREFCNT_dec(PL_endav);
452             PL_endav = newAV();
453             clone_param.flags = 0;
454             thread->init_function = sv_dup(init_function, &clone_param);
455             if (SvREFCNT(thread->init_function) == 0) {
456                 SvREFCNT_inc(thread->init_function);
457             }
458             
459
460
461             thread->params = sv_dup(params, &clone_param);
462             SvREFCNT_inc(thread->params);
463
464
465             /* The code below checks that anything living on
466                the tmps stack and has been cloned (so it lives in the
467                ptr_table) has a refcount higher than 0
468
469                If the refcount is 0 it means that a something on the
470                stack/context was holding a reference to it and
471                since we init_stacks() in perl_clone that won't get
472                cleaned and we will get a leaked scalar.
473                The reason it was cloned was that it lived on the
474                @_ stack.
475
476                Example of this can be found in bugreport 15837
477                where calls in the parameter list end up as a temp
478
479                One could argue that this fix should be in perl_clone
480             */
481                
482
483             while (tmps_ix > 0) { 
484               SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
485               tmps_ix--;
486               if (sv && SvREFCNT(sv) == 0) {
487                 SvREFCNT_inc(sv);
488                 SvREFCNT_dec(sv);
489               }
490             }
491             
492
493
494             SvTEMP_off(thread->init_function);
495             ptr_table_free(PL_ptr_table);
496             PL_ptr_table = NULL;
497             PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
498         }
499         Perl_ithread_set(aTHX_ current_thread);
500         PERL_SET_CONTEXT(aTHX);
501
502         /* Start the thread */
503
504 #ifdef WIN32
505         thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
506                         (LPVOID)thread, 0, &thread->thr);
507 #else
508         {
509           static pthread_attr_t attr;
510           static int attr_inited = 0;
511           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
512           if (!attr_inited) {
513             attr_inited = 1;
514             pthread_attr_init(&attr);
515           }
516 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
517             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
518 #  endif
519 #  ifdef THREAD_CREATE_NEEDS_STACK
520             if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
521               panic = "panic: pthread_attr_setstacksize failed";
522 #  endif
523
524 #ifdef OLD_PTHREADS_API
525             failure
526               = panic ? 1 : pthread_create( &thread->thr, attr,
527                                             Perl_ithread_run, (void *)thread);
528 #else
529 #  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
530           pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
531 #  endif
532           failure
533             = panic ? 1 : pthread_create( &thread->thr, &attr,
534                                           Perl_ithread_run, (void *)thread);
535 #endif
536         }
537 #endif
538         known_threads++;
539         if (
540 #ifdef WIN32
541             thread->handle == NULL
542 #else
543             failure
544 #endif
545             ) {
546           MUTEX_UNLOCK(&create_destruct_mutex);
547           sv_2mortal(params);
548           Perl_ithread_destruct(aTHX_ thread, "create failed");
549 #ifndef WIN32
550           if (panic)
551             Perl_croak(aTHX_ panic);
552 #endif
553           return &PL_sv_undef;
554         }
555         active_threads++;
556         MUTEX_UNLOCK(&create_destruct_mutex);
557         sv_2mortal(params);
558
559         return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
560 }
561
562 SV*
563 Perl_ithread_self (pTHX_ SV *obj, char* Class)
564 {
565    ithread *thread = Perl_ithread_get(aTHX);
566    if (thread)
567         return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
568    else
569         Perl_croak(aTHX_ "panic: cannot find thread data");
570    return NULL; /* silence compiler warning */
571 }
572
573 /*
574  * Joins the thread this code needs to take the returnvalue from the
575  * call_sv and send it back
576  */
577
578 void
579 Perl_ithread_CLONE(pTHX_ SV *obj)
580 {
581     if (SvROK(obj)) {
582         ithread *thread = SV_to_ithread(aTHX_ obj);
583     }
584     else if (ckWARN_d(WARN_THREADS)) {
585         Perl_warn(aTHX_ "CLONE %" SVf,obj);
586     }
587 }
588
589 AV*
590 Perl_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 = Perl_ithread_get(aTHX);
629           Perl_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           Perl_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 void
672 Perl_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_new (classname, function_to_call, ...)
687 char *  classname
688 SV *    function_to_call
689 CODE:
690 {
691     AV* params = newAV();
692     if (items > 2) {
693         int i;
694         for(i = 2; i < items ; i++) {
695             av_push(params, SvREFCNT_inc(ST(i)));
696         }
697     }
698     ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
699     XSRETURN(1);
700 }
701
702 void
703 ithread_list(char *classname)
704 PPCODE:
705 {
706   ithread *curr_thread;
707   MUTEX_LOCK(&create_destruct_mutex);
708   curr_thread = threads;
709   if(curr_thread->tid != 0)     
710     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
711   while(curr_thread) {
712     curr_thread = curr_thread->next;
713     if(curr_thread == threads)
714       break;
715     if(curr_thread->state & PERL_ITHR_DETACHED ||
716        curr_thread->state & PERL_ITHR_JOINED)
717          continue;
718      XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
719   }     
720   MUTEX_UNLOCK(&create_destruct_mutex);
721 }
722
723
724 void
725 ithread_self(char *classname)
726 CODE:
727 {
728         ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
729         XSRETURN(1);
730 }
731
732 int
733 ithread_tid(ithread *thread)
734
735 void
736 ithread_join(SV *obj)
737 PPCODE:
738 {
739   AV* params = Perl_ithread_join(aTHX_ obj);
740   int i;
741   I32 len = AvFILL(params);
742   for (i = 0; i <= len; i++) {
743     SV* tmp = av_shift(params);
744     XPUSHs(tmp);
745     sv_2mortal(tmp);
746   }
747   SvREFCNT_dec(params);
748 }
749
750 void
751 yield(...)
752 CODE:
753 {
754     YIELD;
755 }
756         
757
758 void
759 ithread_detach(ithread *thread)
760
761 void
762 ithread_DESTROY(SV *thread)
763
764 #endif /* USE_ITHREADS */
765
766 BOOT:
767 {
768 #ifdef USE_ITHREADS
769         ithread* thread;
770         PL_perl_destruct_level = 2;
771         MUTEX_INIT(&create_destruct_mutex);
772         MUTEX_LOCK(&create_destruct_mutex);
773         PL_threadhook = &Perl_ithread_hook;
774         thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
775         if (!thread) {
776             PerlLIO_write(PerlIO_fileno(Perl_error_log),
777                           PL_no_mem, strlen(PL_no_mem));
778             my_exit(1);
779         }
780         Zero(thread,1,ithread);
781         PL_perl_destruct_level = 2;
782         MUTEX_INIT(&thread->mutex);
783         threads = thread;
784         thread->next = thread;
785         thread->prev = thread;
786         thread->interp = aTHX;
787         thread->count  = 1;  /* Immortal. */
788         thread->tid = tid_counter++;
789         known_threads++;
790         active_threads++;
791         thread->state = PERL_ITHR_DETACHED;
792 #ifdef WIN32
793         thread->thr = GetCurrentThreadId();
794 #else
795         thread->thr = pthread_self();
796 #endif
797
798         Perl_ithread_set(aTHX_ thread);
799         MUTEX_UNLOCK(&create_destruct_mutex);
800 #endif /* USE_ITHREADS */
801 }
802