This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make threads use MY_CXT API rather than using PL_modglobal
[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 #define MY_CXT_KEY "threads::_guts" XS_VERSION
56
57 typedef struct {
58     ithread *thread;
59 } my_cxt_t;
60
61 START_MY_CXT
62
63
64 ithread *threads;
65
66 /* Macros to supply the aTHX_ in an embed.h like manner */
67 #define ithread_join(thread)            Perl_ithread_join(aTHX_ thread)
68 #define ithread_DESTROY(thread)         Perl_ithread_DESTROY(aTHX_ thread)
69 #define ithread_CLONE(thread)           Perl_ithread_CLONE(aTHX_ thread)
70 #define ithread_detach(thread)          Perl_ithread_detach(aTHX_ thread)
71 #define ithread_tid(thread)             ((thread)->tid)
72 #define ithread_yield(thread)           (YIELD);
73
74 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
75
76 I32 tid_counter = 0;
77 I32 known_threads = 0;
78 I32 active_threads = 0;
79
80
81 void Perl_ithread_set (pTHX_ ithread* thread)
82 {
83     dMY_CXT;
84     MY_CXT.thread = thread;
85 }
86
87 ithread* Perl_ithread_get (pTHX) {
88     dMY_CXT;
89     return MY_CXT.thread;
90 }
91
92
93 /* free any data (such as the perl interpreter) attached to an
94  * ithread structure. This is a bit like undef on SVs, where the SV
95  * isn't freed, but the PVX is.
96  * Must be called with thread->mutex already held
97  */
98
99 static void
100 S_ithread_clear(pTHX_ ithread* thread)
101 {
102     PerlInterpreter *interp;
103     assert(thread->state & PERL_ITHR_FINISHED &&
104             (thread->state & PERL_ITHR_DETACHED ||
105             thread->state & PERL_ITHR_JOINED));
106
107     interp = thread->interp;
108     if (interp) {
109         dTHXa(interp);
110         ithread* current_thread;
111 #ifdef OEMVS
112         void *ptr;
113 #endif
114         PERL_SET_CONTEXT(interp);
115         current_thread = Perl_ithread_get(aTHX);
116         Perl_ithread_set(aTHX_ thread);
117         
118         SvREFCNT_dec(thread->params);
119
120         thread->params = Nullsv;
121         perl_destruct(interp);
122         thread->interp = NULL;
123     }
124     if (interp)
125         perl_free(interp);
126     PERL_SET_CONTEXT(aTHX);
127 }
128
129
130 /*
131  *  free an ithread structure and any attached data if its count == 0
132  */
133 void
134 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
135 {
136         MUTEX_LOCK(&thread->mutex);
137         if (!thread->next) {
138             MUTEX_UNLOCK(&thread->mutex);
139             Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
140         }
141         if (thread->count != 0) {
142                 MUTEX_UNLOCK(&thread->mutex);
143                 return;
144         }
145         MUTEX_LOCK(&create_destruct_mutex);
146         /* Remove from circular list of threads */
147         if (thread->next == thread) {
148             /* last one should never get here ? */
149             threads = NULL;
150         }
151         else {
152             thread->next->prev = thread->prev;
153             thread->prev->next = thread->next;
154             if (threads == thread) {
155                 threads = thread->next;
156             }
157             thread->next = NULL;
158             thread->prev = NULL;
159         }
160         known_threads--;
161         assert( known_threads >= 0 );
162 #if 0
163         Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
164                   thread->tid,thread->interp,aTHX, known_threads);
165 #endif
166         MUTEX_UNLOCK(&create_destruct_mutex);
167         /* Thread is now disowned */
168
169         S_ithread_clear(aTHX_ thread);
170         MUTEX_UNLOCK(&thread->mutex);
171         MUTEX_DESTROY(&thread->mutex);
172 #ifdef WIN32
173         if (thread->handle)
174             CloseHandle(thread->handle);
175         thread->handle = 0;
176 #endif
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                                                       (IV)active_threads);
189         veto_cleanup = 1;
190     }
191     MUTEX_UNLOCK(&create_destruct_mutex);
192     return veto_cleanup;
193 }
194
195 void
196 Perl_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         Perl_ithread_destruct(aTHX_ thread, "detach");
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             Perl_ithread_destruct(aTHX_ thread, "no reference");
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 THREAD_RET_TYPE
281 Perl_ithread_run(LPVOID arg) {
282 #else
283 void*
284 Perl_ithread_run(void * arg) {
285 #endif
286         ithread* thread = (ithread*) arg;
287         dTHXa(thread->interp);
288         PERL_SET_CONTEXT(thread->interp);
289         Perl_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                 I32 len = av_len(params)+1;
307                 int i;
308                 dSP;
309                 ENTER;
310                 SAVETMPS;
311                 PUSHMARK(SP);
312                 for(i = 0; i < len; i++) {
313                     XPUSHs(av_shift(params));
314                 }
315                 PUTBACK;
316                 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
317
318                 SPAGAIN;
319                 for (i=len-1; i >= 0; i--) {
320                   SV *sv = POPs;
321                   av_store(params, i, 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                 Perl_ithread_destruct(aTHX_ thread, "detached finish");
338         } else {
339                 MUTEX_UNLOCK(&thread->mutex);
340         }
341         MUTEX_LOCK(&create_destruct_mutex);
342         active_threads--;
343         assert( active_threads >= 0 );
344         MUTEX_UNLOCK(&create_destruct_mutex);
345
346 #ifdef WIN32
347         return (DWORD)0;
348 #else
349         return 0;
350 #endif
351 }
352
353 SV *
354 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
355 {
356     SV *sv;
357     MAGIC *mg;
358     if (inc) {
359         MUTEX_LOCK(&thread->mutex);
360         thread->count++;
361         MUTEX_UNLOCK(&thread->mutex);
362     }
363     if (!obj)
364      obj = newSV(0);
365     sv = newSVrv(obj,classname);
366     sv_setiv(sv,PTR2IV(thread));
367     mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
368     mg->mg_flags |= MGf_DUP;
369     SvREADONLY_on(sv);
370     return obj;
371 }
372
373 ithread *
374 SV_to_ithread(pTHX_ SV *sv)
375 {
376     if (SvROK(sv))
377      {
378       return INT2PTR(ithread*, SvIV(SvRV(sv)));
379      }
380     else
381      {
382       return Perl_ithread_get(aTHX);
383      }
384 }
385
386 /*
387  * ithread->create(); ( aka ithread->new() )
388  * Called in context of parent thread
389  */
390
391 SV *
392 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
393 {
394         ithread*        thread;
395         CLONE_PARAMS    clone_param;
396         ithread*        current_thread = Perl_ithread_get(aTHX);
397
398         SV**            tmps_tmp = PL_tmps_stack;
399         I32             tmps_ix  = PL_tmps_ix;
400 #ifndef WIN32
401         int             failure;
402         const char*     panic = NULL;
403 #endif
404
405
406         MUTEX_LOCK(&create_destruct_mutex);
407         thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
408         if (!thread) {  
409             MUTEX_UNLOCK(&create_destruct_mutex);
410             PerlLIO_write(PerlIO_fileno(Perl_error_log),
411                           PL_no_mem, strlen(PL_no_mem));
412             my_exit(1);
413         }
414         Zero(thread,1,ithread);
415         thread->next = threads;
416         thread->prev = threads->prev;
417         threads->prev = thread;
418         thread->prev->next = thread;
419         /* Set count to 1 immediately in case thread exits before
420          * we return to caller !
421          */
422         thread->count = 1;
423         MUTEX_INIT(&thread->mutex);
424         thread->tid = tid_counter++;
425         thread->gimme = GIMME_V;
426
427         /* "Clone" our interpreter into the thread's interpreter
428          * This gives thread access to "static data" and code.
429          */
430
431         PerlIO_flush((PerlIO*)NULL);
432         Perl_ithread_set(aTHX_ thread);
433
434         SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
435                                       value */
436         PL_srand_called = FALSE; /* Set it to false so we can detect
437                                     if it gets set during the clone */
438
439 #ifdef WIN32
440         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
441 #else
442         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
443 #endif
444         /* perl_clone leaves us in new interpreter's context.
445            As it is tricky to spot an implicit aTHX, create a new scope
446            with aTHX matching the context for the duration of
447            our work for new interpreter.
448          */
449         {
450             dTHXa(thread->interp);
451
452             MY_CXT_CLONE;
453
454             /* Here we remove END blocks since they should only run
455                in the thread they are created
456             */
457             SvREFCNT_dec(PL_endav);
458             PL_endav = newAV();
459             clone_param.flags = 0;
460             thread->init_function = sv_dup(init_function, &clone_param);
461             if (SvREFCNT(thread->init_function) == 0) {
462                 SvREFCNT_inc(thread->init_function);
463             }
464             
465
466
467             thread->params = sv_dup(params, &clone_param);
468             SvREFCNT_inc(thread->params);
469
470
471             /* The code below checks that anything living on
472                the tmps stack and has been cloned (so it lives in the
473                ptr_table) has a refcount higher than 0
474
475                If the refcount is 0 it means that a something on the
476                stack/context was holding a reference to it and
477                since we init_stacks() in perl_clone that won't get
478                cleaned and we will get a leaked scalar.
479                The reason it was cloned was that it lived on the
480                @_ stack.
481
482                Example of this can be found in bugreport 15837
483                where calls in the parameter list end up as a temp
484
485                One could argue that this fix should be in perl_clone
486             */
487                
488
489             while (tmps_ix > 0) { 
490               SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
491               tmps_ix--;
492               if (sv && SvREFCNT(sv) == 0) {
493                 SvREFCNT_inc(sv);
494                 SvREFCNT_dec(sv);
495               }
496             }
497             
498
499
500             SvTEMP_off(thread->init_function);
501             ptr_table_free(PL_ptr_table);
502             PL_ptr_table = NULL;
503             PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
504         }
505         Perl_ithread_set(aTHX_ current_thread);
506         PERL_SET_CONTEXT(aTHX);
507
508         /* Start the thread */
509
510 #ifdef WIN32
511         thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
512                         (LPVOID)thread, 0, &thread->thr);
513 #else
514         {
515           static pthread_attr_t attr;
516           static int attr_inited = 0;
517           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
518           if (!attr_inited) {
519             attr_inited = 1;
520             pthread_attr_init(&attr);
521           }
522 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
523             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
524 #  endif
525 #  ifdef THREAD_CREATE_NEEDS_STACK
526             if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
527               panic = "panic: pthread_attr_setstacksize failed";
528 #  endif
529
530 #ifdef OLD_PTHREADS_API
531             failure
532               = panic ? 1 : pthread_create( &thread->thr, attr,
533                                             Perl_ithread_run, (void *)thread);
534 #else
535 #  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
536           pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
537 #  endif
538           failure
539             = panic ? 1 : pthread_create( &thread->thr, &attr,
540                                           Perl_ithread_run, (void *)thread);
541 #endif
542         }
543 #endif
544         known_threads++;
545         if (
546 #ifdef WIN32
547             thread->handle == NULL
548 #else
549             failure
550 #endif
551             ) {
552           MUTEX_UNLOCK(&create_destruct_mutex);
553           sv_2mortal(params);
554           Perl_ithread_destruct(aTHX_ thread, "create failed");
555 #ifndef WIN32
556           if (panic)
557             Perl_croak(aTHX_ panic);
558 #endif
559           return &PL_sv_undef;
560         }
561         active_threads++;
562         MUTEX_UNLOCK(&create_destruct_mutex);
563         sv_2mortal(params);
564
565         return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
566 }
567
568 SV*
569 Perl_ithread_self (pTHX_ SV *obj, char* Class)
570 {
571    ithread *thread = Perl_ithread_get(aTHX);
572    if (thread)
573         return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
574    else
575         Perl_croak(aTHX_ "panic: cannot find thread data");
576    return NULL; /* silence compiler warning */
577 }
578
579 /*
580  * Joins the thread this code needs to take the returnvalue from the
581  * call_sv and send it back
582  */
583
584 void
585 Perl_ithread_CLONE(pTHX_ SV *obj)
586 {
587     if (SvROK(obj)) {
588         ithread *thread = SV_to_ithread(aTHX_ obj);
589     }
590     else if (ckWARN_d(WARN_THREADS)) {
591         Perl_warn(aTHX_ "CLONE %" SVf,obj);
592     }
593 }
594
595 AV*
596 Perl_ithread_join(pTHX_ SV *obj)
597 {
598     ithread *thread = SV_to_ithread(aTHX_ obj);
599     MUTEX_LOCK(&thread->mutex);
600     if (thread->state & PERL_ITHR_DETACHED) {
601         MUTEX_UNLOCK(&thread->mutex);
602         Perl_croak(aTHX_ "Cannot join a detached thread");
603     }
604     else if (thread->state & PERL_ITHR_JOINED) {
605         MUTEX_UNLOCK(&thread->mutex);
606         Perl_croak(aTHX_ "Thread already joined");
607     }
608     else {
609         AV* retparam;
610 #ifdef WIN32
611         DWORD waitcode;
612 #else
613         void *retval;
614 #endif
615         MUTEX_UNLOCK(&thread->mutex);
616 #ifdef WIN32
617         waitcode = WaitForSingleObject(thread->handle, INFINITE);
618         CloseHandle(thread->handle);
619         thread->handle = 0;
620 #else
621         pthread_join(thread->thr,&retval);
622 #endif
623         MUTEX_LOCK(&thread->mutex);
624         
625         /* sv_dup over the args */
626         {
627           ithread*        current_thread;
628           AV* params = (AV*) SvRV(thread->params);      
629           PerlInterpreter *other_perl = thread->interp;
630           CLONE_PARAMS clone_params;
631           clone_params.stashes = newAV();
632           clone_params.flags |= CLONEf_JOIN_IN;
633           PL_ptr_table = ptr_table_new();
634           current_thread = Perl_ithread_get(aTHX);
635           Perl_ithread_set(aTHX_ thread);
636           /* ensure 'meaningful' addresses retain their meaning */
637           ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
638           ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
639           ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
640
641 #if 0
642           {
643             I32 len = av_len(params)+1;
644             I32 i;
645             for(i = 0; i < len; i++) {
646               sv_dump(SvRV(AvARRAY(params)[i]));
647             }
648           }
649 #endif
650           retparam = (AV*) sv_dup((SV*)params, &clone_params);
651 #if 0
652           {
653             I32 len = av_len(retparam)+1;
654             I32 i;
655             for(i = 0; i < len; i++) {
656                 sv_dump(SvRV(AvARRAY(retparam)[i]));
657             }
658           }
659 #endif
660           Perl_ithread_set(aTHX_ current_thread);
661           SvREFCNT_dec(clone_params.stashes);
662           SvREFCNT_inc(retparam);
663           ptr_table_free(PL_ptr_table);
664           PL_ptr_table = NULL;
665
666         }
667         /* We are finished with it */
668         thread->state |= PERL_ITHR_JOINED;
669         S_ithread_clear(aTHX_ thread);
670         MUTEX_UNLOCK(&thread->mutex);
671         
672         return retparam;
673     }
674     return (AV*)NULL;
675 }
676
677 void
678 Perl_ithread_DESTROY(pTHX_ SV *sv)
679 {
680     ithread *thread = SV_to_ithread(aTHX_ sv);
681     sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
682 }
683
684 #endif /* USE_ITHREADS */
685
686 MODULE = threads                PACKAGE = threads       PREFIX = ithread_
687 PROTOTYPES: DISABLE
688
689 #ifdef USE_ITHREADS
690
691 void
692 ithread_new (classname, function_to_call, ...)
693 char *  classname
694 SV *    function_to_call
695 CODE:
696 {
697     AV* params = newAV();
698     if (items > 2) {
699         int i;
700         for(i = 2; i < items ; i++) {
701             av_push(params, SvREFCNT_inc(ST(i)));
702         }
703     }
704     ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
705     XSRETURN(1);
706 }
707
708 void
709 ithread_list(char *classname)
710 PPCODE:
711 {
712   ithread *curr_thread;
713   MUTEX_LOCK(&create_destruct_mutex);
714   curr_thread = threads;
715   if(curr_thread->tid != 0)     
716     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
717   while(curr_thread) {
718     curr_thread = curr_thread->next;
719     if(curr_thread == threads)
720       break;
721     if(curr_thread->state & PERL_ITHR_DETACHED ||
722        curr_thread->state & PERL_ITHR_JOINED)
723          continue;
724      XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
725   }     
726   MUTEX_UNLOCK(&create_destruct_mutex);
727 }
728
729
730 void
731 ithread_self(char *classname)
732 CODE:
733 {
734         ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
735         XSRETURN(1);
736 }
737
738 int
739 ithread_tid(ithread *thread)
740
741 void
742 ithread_join(SV *obj)
743 PPCODE:
744 {
745   AV* params = Perl_ithread_join(aTHX_ obj);
746   int i;
747   I32 len = AvFILL(params);
748   for (i = 0; i <= len; i++) {
749     SV* tmp = av_shift(params);
750     XPUSHs(tmp);
751     sv_2mortal(tmp);
752   }
753   SvREFCNT_dec(params);
754 }
755
756 void
757 yield(...)
758 CODE:
759 {
760     YIELD;
761 }
762         
763
764 void
765 ithread_detach(ithread *thread)
766
767 void
768 ithread_DESTROY(SV *thread)
769
770 #endif /* USE_ITHREADS */
771
772 BOOT:
773 {
774         MY_CXT_INIT;
775 #ifdef USE_ITHREADS
776         ithread* thread;
777         PL_perl_destruct_level = 2;
778         MUTEX_INIT(&create_destruct_mutex);
779         MUTEX_LOCK(&create_destruct_mutex);
780         PL_threadhook = &Perl_ithread_hook;
781         thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
782         if (!thread) {
783             PerlLIO_write(PerlIO_fileno(Perl_error_log),
784                           PL_no_mem, strlen(PL_no_mem));
785             my_exit(1);
786         }
787         Zero(thread,1,ithread);
788         PL_perl_destruct_level = 2;
789         MUTEX_INIT(&thread->mutex);
790         threads = thread;
791         thread->next = thread;
792         thread->prev = thread;
793         thread->interp = aTHX;
794         thread->count  = 1;  /* Immortal. */
795         thread->tid = tid_counter++;
796         known_threads++;
797         active_threads++;
798         thread->state = PERL_ITHR_DETACHED;
799 #ifdef WIN32
800         thread->thr = GetCurrentThreadId();
801 #else
802         thread->thr = pthread_self();
803 #endif
804
805         Perl_ithread_set(aTHX_ thread);
806         MUTEX_UNLOCK(&create_destruct_mutex);
807 #endif /* USE_ITHREADS */
808 }
809