1 #define PERL_NO_GET_CONTEXT
6 # define NEED_newRV_noinc
7 # define NEED_sv_2pv_nolen
17 #include <win32thread.h>
20 typedef perl_os_thread pthread_t;
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))
29 #define PERL_THREAD_DETACH(t) pthread_detach((t))
30 #endif /* OLD_PTHREADS_API */
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
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 */
54 DWORD thr; /* OS's idea if thread id */
55 HANDLE handle; /* OS's waitable handle */
57 pthread_t thr; /* OS's handle for the thread */
61 #define MY_CXT_KEY "threads::_guts" XS_VERSION
70 static ithread *threads;
72 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
74 static UV tid_counter = 0;
75 static IV active_threads = 0;
79 S_ithread_set (pTHX_ ithread* thread)
82 MY_CXT.thread = thread;
86 S_ithread_get (pTHX) {
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
99 S_ithread_clear(pTHX_ ithread* thread)
101 PerlInterpreter *interp;
102 assert(thread->state & PERL_ITHR_FINISHED &&
103 (thread->state & PERL_ITHR_DETACHED ||
104 thread->state & PERL_ITHR_JOINED));
106 interp = thread->interp;
109 ithread* current_thread;
113 PERL_SET_CONTEXT(interp);
114 current_thread = S_ithread_get(aTHX);
115 S_ithread_set(aTHX_ thread);
117 SvREFCNT_dec(thread->params);
119 thread->params = Nullsv;
120 perl_destruct(interp);
121 thread->interp = NULL;
125 PERL_SET_CONTEXT(aTHX);
130 * free an ithread structure and any attached data if its count == 0
133 S_ithread_destruct (pTHX_ ithread* thread)
139 MUTEX_LOCK(&thread->mutex);
141 /* Thread is still in use */
142 if (thread->count != 0) {
143 MUTEX_UNLOCK(&thread->mutex);
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;
153 MUTEX_UNLOCK(&create_destruct_mutex);
155 /* Thread is now disowned */
156 S_ithread_clear(aTHX_ thread);
159 handle = thread->handle;
160 thread->handle = NULL;
162 MUTEX_UNLOCK(&thread->mutex);
163 MUTEX_DESTROY(&thread->mutex);
170 /* Call PerlMemShared_free() in the context of the "first" interpreter
171 * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
174 PerlMemShared_free(thread);
178 Perl_ithread_hook(pTHX)
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",
188 MUTEX_UNLOCK(&create_destruct_mutex);
193 S_ithread_detach(pTHX_ ithread *thread)
195 MUTEX_LOCK(&thread->mutex);
196 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
197 thread->state |= PERL_ITHR_DETACHED;
199 CloseHandle(thread->handle);
202 PERL_THREAD_DETACH(thread->thr);
205 if ((thread->state & PERL_ITHR_FINISHED) &&
206 (thread->state & PERL_ITHR_DETACHED)) {
207 MUTEX_UNLOCK(&thread->mutex);
208 S_ithread_destruct(aTHX_ thread);
211 MUTEX_UNLOCK(&thread->mutex);
215 /* MAGIC (in mg.h sense) hooks */
218 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
220 ithread *thread = (ithread *) mg->mg_ptr;
221 SvIV_set(sv, PTR2IV(thread));
227 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
229 ithread *thread = (ithread *) mg->mg_ptr;
230 MUTEX_LOCK(&thread->mutex);
232 if (thread->count == 0) {
233 if(thread->state & PERL_ITHR_FINISHED &&
234 (thread->state & PERL_ITHR_DETACHED ||
235 thread->state & PERL_ITHR_JOINED))
237 MUTEX_UNLOCK(&thread->mutex);
238 S_ithread_destruct(aTHX_ thread);
241 MUTEX_UNLOCK(&thread->mutex);
245 MUTEX_UNLOCK(&thread->mutex);
251 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
253 ithread *thread = (ithread *) mg->mg_ptr;
254 MUTEX_LOCK(&thread->mutex);
256 MUTEX_UNLOCK(&thread->mutex);
260 MGVTBL ithread_vtbl = {
261 ithread_mg_get, /* get */
265 ithread_mg_free, /* free */
267 ithread_mg_dup /* dup */
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
277 static THREAD_RET_TYPE
278 S_ithread_run(LPVOID arg) {
281 S_ithread_run(void * arg) {
283 ithread* thread = (ithread*) arg;
284 dTHXa(thread->interp);
285 PERL_SET_CONTEXT(thread->interp);
286 S_ithread_set(aTHX_ thread);
289 /* Far from clear messing with ->thr child-side is a good idea */
290 MUTEX_LOCK(&thread->mutex);
292 thread->thr = GetCurrentThreadId();
294 thread->thr = pthread_self();
296 MUTEX_UNLOCK(&thread->mutex);
299 PL_perl_destruct_level = 2;
302 AV* params = (AV*) SvRV(thread->params);
303 int len = (int)av_len(params)+1;
309 for(ii = 0; ii < len; ii++) {
310 XPUSHs(av_shift(params));
313 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
316 for (ii=len-1; ii >= 0; ii--) {
318 av_store(params, ii, SvREFCNT_inc(sv));
320 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
321 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
325 SvREFCNT_dec(thread->init_function);
328 PerlIO_flush((PerlIO*)NULL);
329 MUTEX_LOCK(&thread->mutex);
330 thread->state |= PERL_ITHR_FINISHED;
332 if (thread->state & PERL_ITHR_DETACHED) {
333 MUTEX_UNLOCK(&thread->mutex);
334 S_ithread_destruct(aTHX_ thread);
336 MUTEX_UNLOCK(&thread->mutex);
338 MUTEX_LOCK(&create_destruct_mutex);
340 assert( active_threads >= 0 );
341 MUTEX_UNLOCK(&create_destruct_mutex);
351 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
356 MUTEX_LOCK(&thread->mutex);
358 MUTEX_UNLOCK(&thread->mutex);
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;
371 SV_to_ithread(pTHX_ SV *sv)
375 return INT2PTR(ithread*, SvIV(SvRV(sv)));
379 return S_ithread_get(aTHX);
384 * ithread->create(); ( aka ithread->new() )
385 * Called in context of parent thread
389 S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
392 CLONE_PARAMS clone_param;
393 ithread* current_thread = S_ithread_get(aTHX);
395 SV** tmps_tmp = PL_tmps_stack;
396 IV tmps_ix = PL_tmps_ix;
399 const char* panic = NULL;
403 MUTEX_LOCK(&create_destruct_mutex);
404 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
406 MUTEX_UNLOCK(&create_destruct_mutex);
407 PerlLIO_write(PerlIO_fileno(Perl_error_log),
408 PL_no_mem, strlen(PL_no_mem));
411 Zero(thread,1,ithread);
413 /* Add to threads list */
414 thread->next = threads;
415 thread->prev = threads->prev;
416 threads->prev = thread;
417 thread->prev->next = thread;
419 /* Set count to 1 immediately in case thread exits before
420 * we return to caller !
423 MUTEX_INIT(&thread->mutex);
424 thread->tid = tid_counter++;
425 thread->gimme = GIMME_V;
427 /* "Clone" our interpreter into the thread's interpreter
428 * This gives thread access to "static data" and code.
431 PerlIO_flush((PerlIO*)NULL);
432 S_ithread_set(aTHX_ thread);
434 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
436 PL_srand_called = FALSE; /* Set it to false so we can detect
437 if it gets set during the clone */
440 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
442 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
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.
450 dTHXa(thread->interp);
454 /* Here we remove END blocks since they should only run
455 in the thread they are created
457 SvREFCNT_dec(PL_endav);
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);
467 thread->params = sv_dup(params, &clone_param);
468 SvREFCNT_inc(thread->params);
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
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
482 Example of this can be found in bugreport 15837
483 where calls in the parameter list end up as a temp
485 One could argue that this fix should be in perl_clone
489 while (tmps_ix > 0) {
490 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
492 if (sv && SvREFCNT(sv) == 0) {
500 SvTEMP_off(thread->init_function);
501 ptr_table_free(PL_ptr_table);
503 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
505 S_ithread_set(aTHX_ current_thread);
506 PERL_SET_CONTEXT(aTHX);
508 /* Start the thread */
511 thread->handle = CreateThread(NULL, 0, S_ithread_run,
512 (LPVOID)thread, 0, &thread->thr);
515 static pthread_attr_t attr;
516 static int attr_inited = 0;
517 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
520 pthread_attr_init(&attr);
522 # ifdef PTHREAD_ATTR_SETDETACHSTATE
523 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
525 # ifdef THREAD_CREATE_NEEDS_STACK
526 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
527 panic = "panic: pthread_attr_setstacksize failed";
530 #ifdef OLD_PTHREADS_API
532 = panic ? 1 : pthread_create( &thread->thr, attr,
533 S_ithread_run, (void *)thread);
535 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
536 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
539 = panic ? 1 : pthread_create( &thread->thr, &attr,
540 S_ithread_run, (void *)thread);
547 thread->handle == NULL
552 MUTEX_UNLOCK(&create_destruct_mutex);
554 S_ithread_destruct(aTHX_ thread);
557 Perl_croak(aTHX_ panic);
562 MUTEX_UNLOCK(&create_destruct_mutex);
565 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
569 S_ithread_self (pTHX_ SV *obj, char* Class)
571 ithread *thread = S_ithread_get(aTHX);
573 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
575 Perl_croak(aTHX_ "panic: cannot find thread data");
576 return NULL; /* silence compiler warning */
581 * This code takes the return value from the call_sv and sends it back.
584 S_ithread_join(pTHX_ SV *obj)
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");
592 else if (thread->state & PERL_ITHR_JOINED) {
593 MUTEX_UNLOCK(&thread->mutex);
594 Perl_croak(aTHX_ "Thread already joined");
603 MUTEX_UNLOCK(&thread->mutex);
605 waitcode = WaitForSingleObject(thread->handle, INFINITE);
606 CloseHandle(thread->handle);
609 pthread_join(thread->thr,&retval);
611 MUTEX_LOCK(&thread->mutex);
613 /* sv_dup over the args */
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);
631 I32 len = av_len(params)+1;
633 for(i = 0; i < len; i++) {
634 sv_dump(SvRV(AvARRAY(params)[i]));
638 retparam = (AV*) sv_dup((SV*)params, &clone_params);
641 I32 len = av_len(retparam)+1;
643 for(i = 0; i < len; i++) {
644 sv_dump(SvRV(AvARRAY(retparam)[i]));
648 S_ithread_set(aTHX_ current_thread);
649 SvREFCNT_dec(clone_params.stashes);
650 SvREFCNT_inc(retparam);
651 ptr_table_free(PL_ptr_table);
655 /* We are finished with it */
656 thread->state |= PERL_ITHR_JOINED;
657 S_ithread_clear(aTHX_ thread);
658 MUTEX_UNLOCK(&thread->mutex);
666 S_ithread_DESTROY(pTHX_ SV *sv)
668 ithread *thread = SV_to_ithread(aTHX_ sv);
669 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
672 #endif /* USE_ITHREADS */
674 MODULE = threads PACKAGE = threads PREFIX = ithread_
683 SV *function_to_call;
688 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
690 classname = (char *)SvPV_nolen(ST(0));
691 function_to_call = ST(1);
696 for (ii=2; ii < items; ii++) {
697 av_push(params, SvREFCNT_inc(ST(ii)));
702 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
705 newRV_noinc((SV*)params)));
706 /* XSRETURN(1); - implied */
717 /* Class method only */
719 Perl_croak(aTHX_ "Usage: threads->list()");
720 classname = (char *)SvPV_nolen(ST(0));
722 /* Calling context */
723 list_context = (GIMME_V == G_ARRAY);
725 /* Walk through threads list */
726 MUTEX_LOCK(&create_destruct_mutex);
727 for (thr = threads->next;
731 /* Ignore detached or joined threads */
732 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
735 /* Push object on stack if list context */
737 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
741 MUTEX_UNLOCK(&create_destruct_mutex);
742 /* If scalar context, send back count */
743 if (! list_context) {
753 /* Class method only */
755 Perl_croak(aTHX_ "Usage: threads->self()");
756 classname = (char *)SvPV_nolen(ST(0));
758 ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname));
759 /* XSRETURN(1); - implied */
767 thread = SV_to_ithread(aTHX_ ST(0));
768 XST_mUV(0, thread->tid);
769 /* XSRETURN(1); - implied */
779 /* Object method only */
780 if (! sv_isobject(ST(0)))
781 Perl_croak(aTHX_ "Usage: $thr->join()");
783 /* Join thread and get return values */
784 params = S_ithread_join(aTHX_ ST(0));
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));
796 /* Free return value array */
797 SvREFCNT_dec(params);
811 thread = SV_to_ithread(aTHX_ ST(0));
812 S_ithread_detach(aTHX_ thread);
818 S_ithread_DESTROY(aTHX_ ST(0));
824 /* Compares TIDs to determine thread equality.
825 * Return 0 on false for backward compatibility.
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) {
838 /* XSRETURN(1); - implied */
849 /* Class method only */
851 Perl_croak(aTHX_ "Usage: threads->object($tid)");
852 classname = (char *)SvPV_nolen(ST(0));
854 if ((items < 2) || ! SvOK(ST(1))) {
860 /* Walk through threads list */
861 MUTEX_LOCK(&create_destruct_mutex);
862 for (thr = threads->next;
866 /* Look for TID, but ignore detached or joined threads */
867 if ((thr->tid != tid) ||
868 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
872 /* Put object on stack */
873 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
877 MUTEX_UNLOCK(&create_destruct_mutex);
881 /* XSRETURN(1); - implied */
885 ithread__handle(...);
889 thread = SV_to_ithread(aTHX_ ST(0));
891 XST_mUV(0, PTR2UV(thread->handle));
893 XST_mUV(0, PTR2UV(&thread->thr));
895 /* XSRETURN(1); - implied */
897 #endif /* USE_ITHREADS */
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));
910 PerlLIO_write(PerlIO_fileno(Perl_error_log),
911 PL_no_mem, strlen(PL_no_mem));
914 Zero(thread,1,ithread);
915 PL_perl_destruct_level = 2;
916 MUTEX_INIT(&thread->mutex);
918 /* Head of the threads list */
920 thread->next = thread;
921 thread->prev = thread;
923 thread->interp = aTHX;
924 thread->count = 1; /* Immortal. */
925 thread->tid = tid_counter++;
927 thread->state = PERL_ITHR_DETACHED;
929 thread->thr = GetCurrentThreadId();
931 thread->thr = pthread_self();
934 S_ithread_set(aTHX_ thread);
935 MUTEX_UNLOCK(&create_destruct_mutex);
936 #endif /* USE_ITHREADS */