This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
640bb31b2bf4af6d1b967e811c38e75cf0c32c26
[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_FINISHED              4
40 #define PERL_ITHR_JOINED                2
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     IV count;                   /* How many SVs have a reference to us */
49     signed char 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         /* Remove from circular list of threads */
148         MUTEX_LOCK(&create_destruct_mutex);
149         thread->next->prev = thread->prev;
150         thread->prev->next = thread->next;
151         thread->next = NULL;
152         thread->prev = NULL;
153         MUTEX_UNLOCK(&create_destruct_mutex);
154
155         /* Thread is now disowned */
156         S_ithread_clear(aTHX_ thread);
157
158 #ifdef WIN32
159         handle = thread->handle;
160         thread->handle = NULL;
161 #endif
162         MUTEX_UNLOCK(&thread->mutex);
163         MUTEX_DESTROY(&thread->mutex);
164
165 #ifdef WIN32
166         if (handle)
167             CloseHandle(handle);
168 #endif
169
170         /* Call PerlMemShared_free() in the context of the "first" interpreter
171          * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
172          */
173         aTHX = PL_curinterp;
174         PerlMemShared_free(thread);
175 }
176
177 int
178 Perl_ithread_hook(pTHX)
179 {
180     int veto_cleanup = 0;
181     MUTEX_LOCK(&create_destruct_mutex);
182     if (aTHX == PL_curinterp && active_threads != 1) {
183         if (ckWARN_d(WARN_THREADS))
184             Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
185                                                       active_threads);
186         veto_cleanup = 1;
187     }
188     MUTEX_UNLOCK(&create_destruct_mutex);
189     return veto_cleanup;
190 }
191
192 static void
193 S_ithread_detach(pTHX_ ithread *thread)
194 {
195     MUTEX_LOCK(&thread->mutex);
196     if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
197         thread->state |= PERL_ITHR_DETACHED;
198 #ifdef WIN32
199         CloseHandle(thread->handle);
200         thread->handle = 0;
201 #else
202         PERL_THREAD_DETACH(thread->thr);
203 #endif
204     }
205     if ((thread->state & PERL_ITHR_FINISHED) &&
206         (thread->state & PERL_ITHR_DETACHED)) {
207         MUTEX_UNLOCK(&thread->mutex);
208         S_ithread_destruct(aTHX_ thread);
209     }
210     else {
211         MUTEX_UNLOCK(&thread->mutex);
212     }
213 }
214
215 /* MAGIC (in mg.h sense) hooks */
216
217 int
218 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
219 {
220     ithread *thread = (ithread *) mg->mg_ptr;
221     SvIV_set(sv, PTR2IV(thread));
222     SvIOK_on(sv);
223     return 0;
224 }
225
226 int
227 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
228 {
229     ithread *thread = (ithread *) mg->mg_ptr;
230     MUTEX_LOCK(&thread->mutex);
231     thread->count--;
232     if (thread->count == 0) {
233        if(thread->state & PERL_ITHR_FINISHED &&
234           (thread->state & PERL_ITHR_DETACHED ||
235            thread->state & PERL_ITHR_JOINED))
236        {
237             MUTEX_UNLOCK(&thread->mutex);
238             S_ithread_destruct(aTHX_ thread);
239        }
240        else {
241             MUTEX_UNLOCK(&thread->mutex);
242        }    
243     }
244     else {
245         MUTEX_UNLOCK(&thread->mutex);
246     }
247     return 0;
248 }
249
250 int
251 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
252 {
253     ithread *thread = (ithread *) mg->mg_ptr;
254     MUTEX_LOCK(&thread->mutex);
255     thread->count++;
256     MUTEX_UNLOCK(&thread->mutex);
257     return 0;
258 }
259
260 MGVTBL ithread_vtbl = {
261  ithread_mg_get,        /* get */
262  0,                     /* set */
263  0,                     /* len */
264  0,                     /* clear */
265  ithread_mg_free,       /* free */
266  0,                     /* copy */
267  ithread_mg_dup         /* dup */
268 };
269
270
271 /*
272  *      Starts executing the thread. Needs to clean up memory a tad better.
273  *      Passed as the C level function to run in the new thread
274  */
275
276 #ifdef WIN32
277 static THREAD_RET_TYPE
278 S_ithread_run(LPVOID arg) {
279 #else
280 static void*
281 S_ithread_run(void * arg) {
282 #endif
283         ithread* thread = (ithread*) arg;
284         dTHXa(thread->interp);
285         PERL_SET_CONTEXT(thread->interp);
286         S_ithread_set(aTHX_ thread);
287
288 #if 0
289         /* Far from clear messing with ->thr child-side is a good idea */
290         MUTEX_LOCK(&thread->mutex);
291 #ifdef WIN32
292         thread->thr = GetCurrentThreadId();
293 #else
294         thread->thr = pthread_self();
295 #endif
296         MUTEX_UNLOCK(&thread->mutex);
297 #endif
298
299         PL_perl_destruct_level = 2;
300
301         {
302                 AV* params = (AV*) SvRV(thread->params);
303                 int len = (int)av_len(params)+1;
304                 int ii;
305                 dSP;
306                 ENTER;
307                 SAVETMPS;
308                 PUSHMARK(SP);
309                 for(ii = 0; ii < len; ii++) {
310                     XPUSHs(av_shift(params));
311                 }
312                 PUTBACK;
313                 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
314
315                 SPAGAIN;
316                 for (ii=len-1; ii >= 0; ii--) {
317                   SV *sv = POPs;
318                   av_store(params, ii, SvREFCNT_inc(sv));
319                 }
320                 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
321                     Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
322                 }
323                 FREETMPS;
324                 LEAVE;
325                 SvREFCNT_dec(thread->init_function);
326         }
327
328         PerlIO_flush((PerlIO*)NULL);
329         MUTEX_LOCK(&thread->mutex);
330         thread->state |= PERL_ITHR_FINISHED;
331
332         if (thread->state & PERL_ITHR_DETACHED) {
333                 MUTEX_UNLOCK(&thread->mutex);
334                 S_ithread_destruct(aTHX_ thread);
335         } else {
336                 MUTEX_UNLOCK(&thread->mutex);
337         }
338         MUTEX_LOCK(&create_destruct_mutex);
339         active_threads--;
340         assert( active_threads >= 0 );
341         MUTEX_UNLOCK(&create_destruct_mutex);
342
343 #ifdef WIN32
344         return (DWORD)0;
345 #else
346         return 0;
347 #endif
348 }
349
350 static SV *
351 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
352 {
353     SV *sv;
354     MAGIC *mg;
355     if (inc) {
356         MUTEX_LOCK(&thread->mutex);
357         thread->count++;
358         MUTEX_UNLOCK(&thread->mutex);
359     }
360     if (!obj)
361      obj = newSV(0);
362     sv = newSVrv(obj,classname);
363     sv_setiv(sv,PTR2IV(thread));
364     mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
365     mg->mg_flags |= MGf_DUP;
366     SvREADONLY_on(sv);
367     return obj;
368 }
369
370 static ithread *
371 SV_to_ithread(pTHX_ SV *sv)
372 {
373     if (SvROK(sv))
374      {
375       return INT2PTR(ithread*, SvIV(SvRV(sv)));
376      }
377     else
378      {
379       return S_ithread_get(aTHX);
380      }
381 }
382
383 /*
384  * ithread->create(); ( aka ithread->new() )
385  * Called in context of parent thread
386  */
387
388 static SV *
389 S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
390 {
391         ithread*        thread;
392         CLONE_PARAMS    clone_param;
393         ithread*        current_thread = S_ithread_get(aTHX);
394
395         SV**            tmps_tmp = PL_tmps_stack;
396         IV              tmps_ix  = PL_tmps_ix;
397 #ifndef WIN32
398         int             failure;
399         const char*     panic = NULL;
400 #endif
401
402
403         MUTEX_LOCK(&create_destruct_mutex);
404         thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
405         if (!thread) {  
406             MUTEX_UNLOCK(&create_destruct_mutex);
407             PerlLIO_write(PerlIO_fileno(Perl_error_log),
408                           PL_no_mem, strlen(PL_no_mem));
409             my_exit(1);
410         }
411         Zero(thread,1,ithread);
412
413         /* Add to threads list */
414         thread->next = threads;
415         thread->prev = threads->prev;
416         threads->prev = thread;
417         thread->prev->next = thread;
418
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         S_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         S_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, S_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                                             S_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                                           S_ithread_run, (void *)thread);
541 #endif
542         }
543 #endif
544
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           S_ithread_destruct(aTHX_ thread);
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 static SV*
569 S_ithread_self (pTHX_ SV *obj, char* Class)
570 {
571    ithread *thread = S_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.
581  * This code takes the return value from the call_sv and sends it back.
582  */
583 static AV*
584 S_ithread_join(pTHX_ SV *obj)
585 {
586     ithread *thread = SV_to_ithread(aTHX_ obj);
587     MUTEX_LOCK(&thread->mutex);
588     if (thread->state & PERL_ITHR_DETACHED) {
589         MUTEX_UNLOCK(&thread->mutex);
590         Perl_croak(aTHX_ "Cannot join a detached thread");
591     }
592     else if (thread->state & PERL_ITHR_JOINED) {
593         MUTEX_UNLOCK(&thread->mutex);
594         Perl_croak(aTHX_ "Thread already joined");
595     }
596     else {
597         AV* retparam;
598 #ifdef WIN32
599         DWORD waitcode;
600 #else
601         void *retval;
602 #endif
603         MUTEX_UNLOCK(&thread->mutex);
604 #ifdef WIN32
605         waitcode = WaitForSingleObject(thread->handle, INFINITE);
606         CloseHandle(thread->handle);
607         thread->handle = 0;
608 #else
609         pthread_join(thread->thr,&retval);
610 #endif
611         MUTEX_LOCK(&thread->mutex);
612         
613         /* sv_dup over the args */
614         {
615           ithread*        current_thread;
616           AV* params = (AV*) SvRV(thread->params);      
617           PerlInterpreter *other_perl = thread->interp;
618           CLONE_PARAMS clone_params;
619           clone_params.stashes = newAV();
620           clone_params.flags = CLONEf_JOIN_IN;
621           PL_ptr_table = ptr_table_new();
622           current_thread = S_ithread_get(aTHX);
623           S_ithread_set(aTHX_ thread);
624           /* ensure 'meaningful' addresses retain their meaning */
625           ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
626           ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
627           ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
628
629 #if 0
630           {
631             I32 len = av_len(params)+1;
632             I32 i;
633             for(i = 0; i < len; i++) {
634               sv_dump(SvRV(AvARRAY(params)[i]));
635             }
636           }
637 #endif
638           retparam = (AV*) sv_dup((SV*)params, &clone_params);
639 #if 0
640           {
641             I32 len = av_len(retparam)+1;
642             I32 i;
643             for(i = 0; i < len; i++) {
644                 sv_dump(SvRV(AvARRAY(retparam)[i]));
645             }
646           }
647 #endif
648           S_ithread_set(aTHX_ current_thread);
649           SvREFCNT_dec(clone_params.stashes);
650           SvREFCNT_inc(retparam);
651           ptr_table_free(PL_ptr_table);
652           PL_ptr_table = NULL;
653
654         }
655         /* We are finished with it */
656         thread->state |= PERL_ITHR_JOINED;
657         S_ithread_clear(aTHX_ thread);
658         MUTEX_UNLOCK(&thread->mutex);
659         
660         return retparam;
661     }
662     return (AV*)NULL;
663 }
664
665 static void
666 S_ithread_DESTROY(pTHX_ SV *sv)
667 {
668     ithread *thread = SV_to_ithread(aTHX_ sv);
669     sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
670 }
671
672 #endif /* USE_ITHREADS */
673
674 MODULE = threads                PACKAGE = threads       PREFIX = ithread_
675 PROTOTYPES: DISABLE
676
677 #ifdef USE_ITHREADS
678
679 void
680 ithread_create(...)
681     PREINIT:
682         char *classname;
683         SV *function_to_call;
684         AV *params;
685         int ii;
686     CODE:
687         if (items < 2)
688             Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
689
690         classname = (char *)SvPV_nolen(ST(0));
691         function_to_call = ST(1);
692
693         /* Function args */
694         params = newAV();
695         if (items > 2) {
696             for (ii=2; ii < items; ii++) {
697                 av_push(params, SvREFCNT_inc(ST(ii)));
698             }
699         }
700
701         /* Create thread */
702         ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
703                                                classname,
704                                                function_to_call,
705                                                newRV_noinc((SV*)params)));
706         /* XSRETURN(1); - implied */
707
708
709 void
710 ithread_list(...)
711     PREINIT:
712         char *classname;
713         ithread *thr;
714         int list_context;
715         IV count = 0;
716     PPCODE:
717         /* Class method only */
718         if (SvROK(ST(0)))
719             Perl_croak(aTHX_ "Usage: threads->list()");
720         classname = (char *)SvPV_nolen(ST(0));
721
722         /* Calling context */
723         list_context = (GIMME_V == G_ARRAY);
724
725         /* Walk through threads list */
726         MUTEX_LOCK(&create_destruct_mutex);
727         for (thr = threads->next;
728              thr != threads;
729              thr = thr->next)
730         {
731             /* Ignore detached or joined threads */
732             if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
733                 continue;
734             }
735             /* Push object on stack if list context */
736             if (list_context) {
737                 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
738             }
739             count++;
740         }
741         MUTEX_UNLOCK(&create_destruct_mutex);
742         /* If scalar context, send back count */
743         if (! list_context) {
744             XSRETURN_IV(count);
745         }
746
747
748 void
749 ithread_self(...)
750     PREINIT:
751         char *classname;
752     CODE:
753         /* Class method only */
754         if (SvROK(ST(0)))
755             Perl_croak(aTHX_ "Usage: threads->self()");
756         classname = (char *)SvPV_nolen(ST(0));
757
758         ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname));
759         /* XSRETURN(1); - implied */
760
761
762 void
763 ithread_tid(...)
764     PREINIT:
765         ithread *thread;
766     CODE:
767         thread = SV_to_ithread(aTHX_ ST(0));
768         XST_mUV(0, thread->tid);
769         /* XSRETURN(1); - implied */
770
771
772 void
773 ithread_join(...)
774     PREINIT:
775         AV *params;
776         int len;
777         int ii;
778     PPCODE:
779         /* Object method only */
780         if (! sv_isobject(ST(0)))
781             Perl_croak(aTHX_ "Usage: $thr->join()");
782
783         /* Join thread and get return values */
784         params = S_ithread_join(aTHX_ ST(0));
785         if (! params) {
786             XSRETURN_UNDEF;
787         }
788
789         /* Put return values on stack */
790         len = (int)AvFILL(params);
791         for (ii=0; ii <= len; ii++) {
792             SV* param = av_shift(params);
793             XPUSHs(sv_2mortal(param));
794         }
795
796         /* Free return value array */
797         SvREFCNT_dec(params);
798
799
800 void
801 ithread_yield(...)
802     CODE:
803         YIELD;
804
805
806 void
807 ithread_detach(...)
808     PREINIT:
809         ithread *thread;
810     CODE:
811         thread = SV_to_ithread(aTHX_ ST(0));
812         S_ithread_detach(aTHX_ thread);
813
814
815 void
816 ithread_DESTROY(...)
817     CODE:
818         S_ithread_DESTROY(aTHX_ ST(0));
819
820
821 void
822 ithread_equal(...)
823     CODE:
824         /* Compares TIDs to determine thread equality.
825          * Return 0 on false for backward compatibility.
826          */
827         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
828             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
829             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
830             if (thr1->tid == thr2->tid) {
831                 XST_mYES(0);
832             } else {
833                 XST_mIV(0, 0);
834             }
835         } else {
836             XST_mIV(0, 0);
837         }
838         /* XSRETURN(1); - implied */
839
840
841 void
842 ithread_object(...)
843     PREINIT:
844         char *classname;
845         UV tid;
846         ithread *thr;
847         int found = 0;
848     CODE:
849         /* Class method only */
850         if (SvROK(ST(0)))
851             Perl_croak(aTHX_ "Usage: threads->object($tid)");
852         classname = (char *)SvPV_nolen(ST(0));
853
854         if ((items < 2) || ! SvOK(ST(1))) {
855             XSRETURN_UNDEF;
856         }
857
858         tid = SvUV(ST(1));
859
860         /* Walk through threads list */
861         MUTEX_LOCK(&create_destruct_mutex);
862         for (thr = threads->next;
863              thr != threads;
864              thr = thr->next)
865         {
866             /* Look for TID, but ignore detached or joined threads */
867             if ((thr->tid != tid) ||
868                 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
869             {
870                 continue;
871             }
872             /* Put object on stack */
873             ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
874             found = 1;
875             break;
876         }
877         MUTEX_UNLOCK(&create_destruct_mutex);
878         if (! found) {
879             XSRETURN_UNDEF;
880         }
881         /* XSRETURN(1); - implied */
882
883
884 void
885 ithread__handle(...);
886     PREINIT:
887         ithread *thread;
888     CODE:
889         thread = SV_to_ithread(aTHX_ ST(0));
890 #ifdef WIN32
891         XST_mUV(0, PTR2UV(thread->handle));
892 #else
893         XST_mUV(0, PTR2UV(&thread->thr));
894 #endif
895         /* XSRETURN(1); - implied */
896
897 #endif /* USE_ITHREADS */
898
899 BOOT:
900 {
901 #ifdef USE_ITHREADS
902         MY_CXT_INIT;
903         ithread* thread;
904         PL_perl_destruct_level = 2;
905         MUTEX_INIT(&create_destruct_mutex);
906         MUTEX_LOCK(&create_destruct_mutex);
907         PL_threadhook = &Perl_ithread_hook;
908         thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
909         if (!thread) {
910             PerlLIO_write(PerlIO_fileno(Perl_error_log),
911                           PL_no_mem, strlen(PL_no_mem));
912             my_exit(1);
913         }
914         Zero(thread,1,ithread);
915         PL_perl_destruct_level = 2;
916         MUTEX_INIT(&thread->mutex);
917
918         /* Head of the threads list */
919         threads = thread;
920         thread->next = thread;
921         thread->prev = thread;
922
923         thread->interp = aTHX;
924         thread->count  = 1;  /* Immortal. */
925         thread->tid = tid_counter++;
926         active_threads++;
927         thread->state = PERL_ITHR_DETACHED;
928 #ifdef WIN32
929         thread->thr = GetCurrentThreadId();
930 #else
931         thread->thr = pthread_self();
932 #endif
933
934         S_ithread_set(aTHX_ thread);
935         MUTEX_UNLOCK(&create_destruct_mutex);
936 #endif /* USE_ITHREADS */
937 }
938