This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
f6b57d636c44e16065d8c9a9914ae1b5caad6dad
[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
90 /*
91  *  Clear up after thread is done with
92  */
93 void
94 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
95 {
96         PerlInterpreter *freeperl = NULL;
97         MUTEX_LOCK(&thread->mutex);
98         if (!thread->next) {
99             Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
100         }
101         if (thread->count != 0) {
102                 MUTEX_UNLOCK(&thread->mutex);
103                 return;
104         }
105         MUTEX_LOCK(&create_destruct_mutex);
106         /* Remove from circular list of threads */
107         if (thread->next == thread) {
108             /* last one should never get here ? */
109             threads = NULL;
110         }
111         else {
112             thread->next->prev = thread->prev;
113             thread->prev->next = thread->next;
114             if (threads == thread) {
115                 threads = thread->next;
116             }
117             thread->next = NULL;
118             thread->prev = NULL;
119         }
120         known_threads--;
121         assert( known_threads >= 0 );
122 #if 0
123         Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
124                   thread->tid,thread->interp,aTHX, known_threads);
125 #endif
126         MUTEX_UNLOCK(&create_destruct_mutex);
127         /* Thread is now disowned */
128
129         if(thread->interp) {
130             dTHXa(thread->interp);
131             ithread*        current_thread;
132 #ifdef OEMVS
133             void *ptr;
134 #endif
135             PERL_SET_CONTEXT(thread->interp);
136             current_thread = Perl_ithread_get(aTHX);
137             Perl_ithread_set(aTHX_ thread);
138
139
140
141             
142             SvREFCNT_dec(thread->params);
143
144
145
146             thread->params = Nullsv;
147             perl_destruct(thread->interp);
148             freeperl = thread->interp;
149             thread->interp = NULL;
150         }
151         MUTEX_UNLOCK(&thread->mutex);
152         MUTEX_DESTROY(&thread->mutex);
153 #ifdef WIN32
154         if (thread->handle)
155             CloseHandle(thread->handle);
156         thread->handle = 0;
157 #endif
158         PerlMemShared_free(thread);
159         if (freeperl)
160             perl_free(freeperl);
161
162         PERL_SET_CONTEXT(aTHX);
163 }
164
165 int
166 Perl_ithread_hook(pTHX)
167 {
168     int veto_cleanup = 0;
169     MUTEX_LOCK(&create_destruct_mutex);
170     if (aTHX == PL_curinterp && active_threads != 1) {
171         Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
172                                                 (IV)active_threads);
173         veto_cleanup = 1;
174     }
175     MUTEX_UNLOCK(&create_destruct_mutex);
176     return veto_cleanup;
177 }
178
179 void
180 Perl_ithread_detach(pTHX_ ithread *thread)
181 {
182     MUTEX_LOCK(&thread->mutex);
183     if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
184         thread->state |= PERL_ITHR_DETACHED;
185 #ifdef WIN32
186         CloseHandle(thread->handle);
187         thread->handle = 0;
188 #else
189         PERL_THREAD_DETACH(thread->thr);
190 #endif
191     }
192     if ((thread->state & PERL_ITHR_FINISHED) &&
193         (thread->state & PERL_ITHR_DETACHED)) {
194         MUTEX_UNLOCK(&thread->mutex);
195         Perl_ithread_destruct(aTHX_ thread, "detach");
196     }
197     else {
198         MUTEX_UNLOCK(&thread->mutex);
199     }
200 }
201
202 /* MAGIC (in mg.h sense) hooks */
203
204 int
205 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
206 {
207     ithread *thread = (ithread *) mg->mg_ptr;
208     SvIV_set(sv, PTR2IV(thread));
209     SvIOK_on(sv);
210     return 0;
211 }
212
213 int
214 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
215 {
216     ithread *thread = (ithread *) mg->mg_ptr;
217     MUTEX_LOCK(&thread->mutex);
218     thread->count--;
219     if (thread->count == 0) {
220        if(thread->state & PERL_ITHR_FINISHED &&
221           (thread->state & PERL_ITHR_DETACHED ||
222            thread->state & PERL_ITHR_JOINED))
223        {
224             MUTEX_UNLOCK(&thread->mutex);
225             Perl_ithread_destruct(aTHX_ thread, "no reference");
226        }
227        else {
228             MUTEX_UNLOCK(&thread->mutex);
229        }    
230     }
231     else {
232         MUTEX_UNLOCK(&thread->mutex);
233     }
234     return 0;
235 }
236
237 int
238 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
239 {
240     ithread *thread = (ithread *) mg->mg_ptr;
241     MUTEX_LOCK(&thread->mutex);
242     thread->count++;
243     MUTEX_UNLOCK(&thread->mutex);
244     return 0;
245 }
246
247 MGVTBL ithread_vtbl = {
248  ithread_mg_get,        /* get */
249  0,                     /* set */
250  0,                     /* len */
251  0,                     /* clear */
252  ithread_mg_free,       /* free */
253  0,                     /* copy */
254  ithread_mg_dup         /* dup */
255 };
256
257
258 /*
259  *      Starts executing the thread. Needs to clean up memory a tad better.
260  *      Passed as the C level function to run in the new thread
261  */
262
263 #ifdef WIN32
264 THREAD_RET_TYPE
265 Perl_ithread_run(LPVOID arg) {
266 #else
267 void*
268 Perl_ithread_run(void * arg) {
269 #endif
270         ithread* thread = (ithread*) arg;
271         dTHXa(thread->interp);
272         PERL_SET_CONTEXT(thread->interp);
273         Perl_ithread_set(aTHX_ thread);
274
275 #if 0
276         /* Far from clear messing with ->thr child-side is a good idea */
277         MUTEX_LOCK(&thread->mutex);
278 #ifdef WIN32
279         thread->thr = GetCurrentThreadId();
280 #else
281         thread->thr = pthread_self();
282 #endif
283         MUTEX_UNLOCK(&thread->mutex);
284 #endif
285
286         PL_perl_destruct_level = 2;
287
288         {
289                 AV* params = (AV*) SvRV(thread->params);
290                 I32 len = av_len(params)+1;
291                 int i;
292                 dSP;
293                 ENTER;
294                 SAVETMPS;
295                 PUSHMARK(SP);
296                 for(i = 0; i < len; i++) {
297                     XPUSHs(av_shift(params));
298                 }
299                 PUTBACK;
300                 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
301
302                 SPAGAIN;
303                 for (i=len-1; i >= 0; i--) {
304                   SV *sv = POPs;
305                   av_store(params, i, SvREFCNT_inc(sv));
306                 }
307                 if (SvTRUE(ERRSV)) {
308                     Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
309                 }
310                 FREETMPS;
311                 LEAVE;
312                 SvREFCNT_dec(thread->init_function);
313         }
314
315         PerlIO_flush((PerlIO*)NULL);
316         MUTEX_LOCK(&thread->mutex);
317         thread->state |= PERL_ITHR_FINISHED;
318
319         if (thread->state & PERL_ITHR_DETACHED) {
320                 MUTEX_UNLOCK(&thread->mutex);
321                 Perl_ithread_destruct(aTHX_ thread, "detached finish");
322         } else {
323                 MUTEX_UNLOCK(&thread->mutex);
324         }
325         MUTEX_LOCK(&create_destruct_mutex);
326         active_threads--;
327         assert( active_threads >= 0 );
328         MUTEX_UNLOCK(&create_destruct_mutex);
329
330 #ifdef WIN32
331         return (DWORD)0;
332 #else
333         return 0;
334 #endif
335 }
336
337 SV *
338 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
339 {
340     SV *sv;
341     MAGIC *mg;
342     if (inc) {
343         MUTEX_LOCK(&thread->mutex);
344         thread->count++;
345         MUTEX_UNLOCK(&thread->mutex);
346     }
347     if (!obj)
348      obj = newSV(0);
349     sv = newSVrv(obj,classname);
350     sv_setiv(sv,PTR2IV(thread));
351     mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
352     mg->mg_flags |= MGf_DUP;
353     SvREADONLY_on(sv);
354     return obj;
355 }
356
357 ithread *
358 SV_to_ithread(pTHX_ SV *sv)
359 {
360     if (SvROK(sv))
361      {
362       return INT2PTR(ithread*, SvIV(SvRV(sv)));
363      }
364     else
365      {
366       return Perl_ithread_get(aTHX);
367      }
368 }
369
370 /*
371  * ithread->create(); ( aka ithread->new() )
372  * Called in context of parent thread
373  */
374
375 SV *
376 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
377 {
378         ithread*        thread;
379         CLONE_PARAMS    clone_param;
380         ithread*        current_thread = Perl_ithread_get(aTHX);
381
382         SV**            tmps_tmp = PL_tmps_stack;
383         I32             tmps_ix  = PL_tmps_ix;
384 #ifndef WIN32
385         int             failure;
386         const char*     panic = NULL;
387 #endif
388
389
390         MUTEX_LOCK(&create_destruct_mutex);
391         thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
392         if (!thread) {  
393             MUTEX_UNLOCK(&create_destruct_mutex);
394             PerlLIO_write(PerlIO_fileno(Perl_error_log),
395                           PL_no_mem, strlen(PL_no_mem));
396             my_exit(1);
397         }
398         Zero(thread,1,ithread);
399         thread->next = threads;
400         thread->prev = threads->prev;
401         threads->prev = thread;
402         thread->prev->next = thread;
403         /* Set count to 1 immediately in case thread exits before
404          * we return to caller !
405          */
406         thread->count = 1;
407         MUTEX_INIT(&thread->mutex);
408         thread->tid = tid_counter++;
409         thread->gimme = GIMME_V;
410
411         /* "Clone" our interpreter into the thread's interpreter
412          * This gives thread access to "static data" and code.
413          */
414
415         PerlIO_flush((PerlIO*)NULL);
416         Perl_ithread_set(aTHX_ thread);
417
418         SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
419                                       value */
420         PL_srand_called = FALSE; /* Set it to false so we can detect
421                                     if it gets set during the clone */
422
423 #ifdef WIN32
424         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
425 #else
426         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
427 #endif
428         /* perl_clone leaves us in new interpreter's context.
429            As it is tricky to spot an implicit aTHX, create a new scope
430            with aTHX matching the context for the duration of
431            our work for new interpreter.
432          */
433         {
434             dTHXa(thread->interp);
435
436             /* Here we remove END blocks since they should only run
437                in the thread they are created
438             */
439             SvREFCNT_dec(PL_endav);
440             PL_endav = newAV();
441             clone_param.flags = 0;
442             thread->init_function = sv_dup(init_function, &clone_param);
443             if (SvREFCNT(thread->init_function) == 0) {
444                 SvREFCNT_inc(thread->init_function);
445             }
446             
447
448
449             thread->params = sv_dup(params, &clone_param);
450             SvREFCNT_inc(thread->params);
451
452
453             /* The code below checks that anything living on
454                the tmps stack and has been cloned (so it lives in the
455                ptr_table) has a refcount higher than 0
456
457                If the refcount is 0 it means that a something on the
458                stack/context was holding a reference to it and
459                since we init_stacks() in perl_clone that won't get
460                cleaned and we will get a leaked scalar.
461                The reason it was cloned was that it lived on the
462                @_ stack.
463
464                Example of this can be found in bugreport 15837
465                where calls in the parameter list end up as a temp
466
467                One could argue that this fix should be in perl_clone
468             */
469                
470
471             while (tmps_ix > 0) { 
472               SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
473               tmps_ix--;
474               if (sv && SvREFCNT(sv) == 0) {
475                 SvREFCNT_inc(sv);
476                 SvREFCNT_dec(sv);
477               }
478             }
479             
480
481
482             SvTEMP_off(thread->init_function);
483             ptr_table_free(PL_ptr_table);
484             PL_ptr_table = NULL;
485             PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
486         }
487         Perl_ithread_set(aTHX_ current_thread);
488         PERL_SET_CONTEXT(aTHX);
489
490         /* Start the thread */
491
492 #ifdef WIN32
493         thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
494                         (LPVOID)thread, 0, &thread->thr);
495 #else
496         {
497           static pthread_attr_t attr;
498           static int attr_inited = 0;
499           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
500           if (!attr_inited) {
501             attr_inited = 1;
502             pthread_attr_init(&attr);
503           }
504 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
505             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
506 #  endif
507 #  ifdef THREAD_CREATE_NEEDS_STACK
508             if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
509               panic = "panic: pthread_attr_setstacksize failed";
510 #  endif
511
512 #ifdef OLD_PTHREADS_API
513             failure
514               = panic ? 1 : pthread_create( &thread->thr, attr,
515                                             Perl_ithread_run, (void *)thread);
516 #else
517 #  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
518           pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
519 #  endif
520           failure
521             = panic ? 1 : pthread_create( &thread->thr, &attr,
522                                           Perl_ithread_run, (void *)thread);
523 #endif
524         }
525 #endif
526         known_threads++;
527         if (
528 #ifdef WIN32
529             thread->handle == NULL
530 #else
531             failure
532 #endif
533             ) {
534           MUTEX_UNLOCK(&create_destruct_mutex);
535           sv_2mortal(params);
536           Perl_ithread_destruct(aTHX_ thread, "create failed");
537 #ifndef WIN32
538           if (panic)
539             Perl_croak(aTHX_ panic);
540 #endif
541           return &PL_sv_undef;
542         }
543         active_threads++;
544         MUTEX_UNLOCK(&create_destruct_mutex);
545         sv_2mortal(params);
546
547         return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
548 }
549
550 SV*
551 Perl_ithread_self (pTHX_ SV *obj, char* Class)
552 {
553    ithread *thread = Perl_ithread_get(aTHX);
554    if (thread)
555         return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
556    else
557         Perl_croak(aTHX_ "panic: cannot find thread data");
558    return NULL; /* silence compiler warning */
559 }
560
561 /*
562  * Joins the thread this code needs to take the returnvalue from the
563  * call_sv and send it back
564  */
565
566 void
567 Perl_ithread_CLONE(pTHX_ SV *obj)
568 {
569  if (SvROK(obj))
570   {
571    ithread *thread = SV_to_ithread(aTHX_ obj);
572   }
573  else
574   {
575    Perl_warn(aTHX_ "CLONE %" SVf,obj);
576   }
577 }
578
579 AV*
580 Perl_ithread_join(pTHX_ SV *obj)
581 {
582     ithread *thread = SV_to_ithread(aTHX_ obj);
583     MUTEX_LOCK(&thread->mutex);
584     if (thread->state & PERL_ITHR_DETACHED) {
585         MUTEX_UNLOCK(&thread->mutex);
586         Perl_croak(aTHX_ "Cannot join a detached thread");
587     }
588     else if (thread->state & PERL_ITHR_JOINED) {
589         MUTEX_UNLOCK(&thread->mutex);
590         Perl_croak(aTHX_ "Thread already joined");
591     }
592     else {
593         AV* retparam;
594 #ifdef WIN32
595         DWORD waitcode;
596 #else
597         void *retval;
598 #endif
599         MUTEX_UNLOCK(&thread->mutex);
600 #ifdef WIN32
601         waitcode = WaitForSingleObject(thread->handle, INFINITE);
602         CloseHandle(thread->handle);
603         thread->handle = 0;
604 #else
605         pthread_join(thread->thr,&retval);
606 #endif
607         MUTEX_LOCK(&thread->mutex);
608         
609         /* sv_dup over the args */
610         {
611           ithread*        current_thread;
612           AV* params = (AV*) SvRV(thread->params);      
613           PerlInterpreter *other_perl = thread->interp;
614           CLONE_PARAMS clone_params;
615           clone_params.stashes = newAV();
616           clone_params.flags |= CLONEf_JOIN_IN;
617           PL_ptr_table = ptr_table_new();
618           PL_shared_hek_table = ptr_table_new();
619           current_thread = Perl_ithread_get(aTHX);
620           Perl_ithread_set(aTHX_ thread);
621           /* ensure 'meaningful' addresses retain their meaning */
622           ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
623           ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
624           ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
625
626 #if 0
627           {
628             I32 len = av_len(params)+1;
629             I32 i;
630             for(i = 0; i < len; i++) {
631               sv_dump(SvRV(AvARRAY(params)[i]));
632             }
633           }
634 #endif
635           retparam = (AV*) sv_dup((SV*)params, &clone_params);
636 #if 0
637           {
638             I32 len = av_len(retparam)+1;
639             I32 i;
640             for(i = 0; i < len; i++) {
641                 sv_dump(SvRV(AvARRAY(retparam)[i]));
642             }
643           }
644 #endif
645           Perl_ithread_set(aTHX_ current_thread);
646           SvREFCNT_dec(clone_params.stashes);
647           SvREFCNT_inc(retparam);
648           ptr_table_free(PL_ptr_table);
649           PL_ptr_table = NULL;
650           ptr_table_free(PL_shared_hek_table);
651           PL_shared_hek_table = NULL;
652
653         }
654         /* We are finished with it */
655         thread->state |= PERL_ITHR_JOINED;
656         MUTEX_UNLOCK(&thread->mutex);
657         
658         return retparam;
659     }
660     return (AV*)NULL;
661 }
662
663 void
664 Perl_ithread_DESTROY(pTHX_ SV *sv)
665 {
666     ithread *thread = SV_to_ithread(aTHX_ sv);
667     sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
668 }
669
670 #endif /* USE_ITHREADS */
671
672 MODULE = threads                PACKAGE = threads       PREFIX = ithread_
673 PROTOTYPES: DISABLE
674
675 #ifdef USE_ITHREADS
676
677 void
678 ithread_new (classname, function_to_call, ...)
679 char *  classname
680 SV *    function_to_call
681 CODE:
682 {
683     AV* params = newAV();
684     if (items > 2) {
685         int i;
686         for(i = 2; i < items ; i++) {
687             av_push(params, SvREFCNT_inc(ST(i)));
688         }
689     }
690     ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
691     XSRETURN(1);
692 }
693
694 void
695 ithread_list(char *classname)
696 PPCODE:
697 {
698   ithread *curr_thread;
699   MUTEX_LOCK(&create_destruct_mutex);
700   curr_thread = threads;
701   if(curr_thread->tid != 0)     
702     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
703   while(curr_thread) {
704     curr_thread = curr_thread->next;
705     if(curr_thread == threads)
706       break;
707     if(curr_thread->state & PERL_ITHR_DETACHED ||
708        curr_thread->state & PERL_ITHR_JOINED)
709          continue;
710      XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
711   }     
712   MUTEX_UNLOCK(&create_destruct_mutex);
713 }
714
715
716 void
717 ithread_self(char *classname)
718 CODE:
719 {
720         ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
721         XSRETURN(1);
722 }
723
724 int
725 ithread_tid(ithread *thread)
726
727 void
728 ithread_join(SV *obj)
729 PPCODE:
730 {
731   AV* params = Perl_ithread_join(aTHX_ obj);
732   int i;
733   I32 len = AvFILL(params);
734   for (i = 0; i <= len; i++) {
735     SV* tmp = av_shift(params);
736     XPUSHs(tmp);
737     sv_2mortal(tmp);
738   }
739   SvREFCNT_dec(params);
740 }
741
742 void
743 yield(...)
744 CODE:
745 {
746     YIELD;
747 }
748         
749
750 void
751 ithread_detach(ithread *thread)
752
753 void
754 ithread_DESTROY(SV *thread)
755
756 #endif /* USE_ITHREADS */
757
758 BOOT:
759 {
760 #ifdef USE_ITHREADS
761         ithread* thread;
762         PL_perl_destruct_level = 2;
763         MUTEX_INIT(&create_destruct_mutex);
764         MUTEX_LOCK(&create_destruct_mutex);
765         PL_threadhook = &Perl_ithread_hook;
766         thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
767         if (!thread) {
768             PerlLIO_write(PerlIO_fileno(Perl_error_log),
769                           PL_no_mem, strlen(PL_no_mem));
770             my_exit(1);
771         }
772         Zero(thread,1,ithread);
773         PL_perl_destruct_level = 2;
774         MUTEX_INIT(&thread->mutex);
775         threads = thread;
776         thread->next = thread;
777         thread->prev = thread;
778         thread->interp = aTHX;
779         thread->count  = 1;  /* Immortal. */
780         thread->tid = tid_counter++;
781         known_threads++;
782         active_threads++;
783         thread->state = PERL_ITHR_DETACHED;
784 #ifdef WIN32
785         thread->thr = GetCurrentThreadId();
786 #else
787         thread->thr = pthread_self();
788 #endif
789
790         Perl_ithread_set(aTHX_ thread);
791         MUTEX_UNLOCK(&create_destruct_mutex);
792 #endif /* USE_ITHREADS */
793 }
794