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_JOINED 2
40 #define PERL_ITHR_FINISHED 4
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 int count; /* How many SVs have a reference to us */
49 int 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 MUTEX_LOCK(&create_destruct_mutex);
148 /* Main thread (0) is immortal and should never get here */
149 assert(thread->tid != 0);
151 /* Remove from circular list of threads */
152 thread->next->prev = thread->prev;
153 thread->prev->next = thread->next;
156 MUTEX_UNLOCK(&create_destruct_mutex);
158 /* Thread is now disowned */
159 S_ithread_clear(aTHX_ thread);
162 handle = thread->handle;
163 thread->handle = NULL;
165 MUTEX_UNLOCK(&thread->mutex);
166 MUTEX_DESTROY(&thread->mutex);
173 /* Call PerlMemShared_free() in the context of the "first" interpreter
174 * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
177 PerlMemShared_free(thread);
181 Perl_ithread_hook(pTHX)
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",
191 MUTEX_UNLOCK(&create_destruct_mutex);
196 /* MAGIC (in mg.h sense) hooks */
199 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
201 ithread *thread = (ithread *) mg->mg_ptr;
202 SvIV_set(sv, PTR2IV(thread));
208 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
210 ithread *thread = (ithread *) mg->mg_ptr;
211 MUTEX_LOCK(&thread->mutex);
213 if (thread->count == 0) {
214 if(thread->state & PERL_ITHR_FINISHED &&
215 (thread->state & PERL_ITHR_DETACHED ||
216 thread->state & PERL_ITHR_JOINED))
218 MUTEX_UNLOCK(&thread->mutex);
219 S_ithread_destruct(aTHX_ thread);
222 MUTEX_UNLOCK(&thread->mutex);
226 MUTEX_UNLOCK(&thread->mutex);
232 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
234 ithread *thread = (ithread *) mg->mg_ptr;
235 MUTEX_LOCK(&thread->mutex);
237 MUTEX_UNLOCK(&thread->mutex);
241 MGVTBL ithread_vtbl = {
242 ithread_mg_get, /* get */
246 ithread_mg_free, /* free */
248 ithread_mg_dup /* dup */
253 * Starts executing the thread. Needs to clean up memory a tad better.
254 * Passed as the C level function to run in the new thread
258 static THREAD_RET_TYPE
259 S_ithread_run(LPVOID arg) {
262 S_ithread_run(void * arg) {
264 ithread* thread = (ithread*) arg;
265 dTHXa(thread->interp);
266 PERL_SET_CONTEXT(thread->interp);
267 S_ithread_set(aTHX_ thread);
270 /* Far from clear messing with ->thr child-side is a good idea */
271 MUTEX_LOCK(&thread->mutex);
273 thread->thr = GetCurrentThreadId();
275 thread->thr = pthread_self();
277 MUTEX_UNLOCK(&thread->mutex);
280 PL_perl_destruct_level = 2;
283 AV* params = (AV*) SvRV(thread->params);
284 int len = (int)av_len(params)+1;
290 for(ii = 0; ii < len; ii++) {
291 XPUSHs(av_shift(params));
294 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
297 for (ii=len-1; ii >= 0; ii--) {
299 av_store(params, ii, SvREFCNT_inc(sv));
301 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
302 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
306 SvREFCNT_dec(thread->init_function);
309 PerlIO_flush((PerlIO*)NULL);
310 MUTEX_LOCK(&thread->mutex);
311 thread->state |= PERL_ITHR_FINISHED;
313 if (thread->state & PERL_ITHR_DETACHED) {
314 MUTEX_UNLOCK(&thread->mutex);
315 S_ithread_destruct(aTHX_ thread);
317 MUTEX_UNLOCK(&thread->mutex);
319 MUTEX_LOCK(&create_destruct_mutex);
321 MUTEX_UNLOCK(&create_destruct_mutex);
331 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
336 MUTEX_LOCK(&thread->mutex);
338 MUTEX_UNLOCK(&thread->mutex);
342 sv = newSVrv(obj,classname);
343 sv_setiv(sv,PTR2IV(thread));
344 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
345 mg->mg_flags |= MGf_DUP;
351 SV_to_ithread(pTHX_ SV *sv)
355 return INT2PTR(ithread*, SvIV(SvRV(sv)));
359 return S_ithread_get(aTHX);
364 * ithread->create(); ( aka ithread->new() )
365 * Called in context of parent thread
369 S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
372 CLONE_PARAMS clone_param;
373 ithread* current_thread = S_ithread_get(aTHX);
375 SV** tmps_tmp = PL_tmps_stack;
376 IV tmps_ix = PL_tmps_ix;
378 int rc_stack_size = 0;
379 int rc_thread_create = 0;
383 MUTEX_LOCK(&create_destruct_mutex);
384 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
386 MUTEX_UNLOCK(&create_destruct_mutex);
387 PerlLIO_write(PerlIO_fileno(Perl_error_log),
388 PL_no_mem, strlen(PL_no_mem));
391 Zero(thread,1,ithread);
393 /* Add to threads list */
394 thread->next = threads;
395 thread->prev = threads->prev;
396 threads->prev = thread;
397 thread->prev->next = thread;
399 /* Set count to 1 immediately in case thread exits before
400 * we return to caller !
403 MUTEX_INIT(&thread->mutex);
404 thread->tid = tid_counter++;
405 thread->gimme = GIMME_V;
407 /* "Clone" our interpreter into the thread's interpreter
408 * This gives thread access to "static data" and code.
411 PerlIO_flush((PerlIO*)NULL);
412 S_ithread_set(aTHX_ thread);
414 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
416 PL_srand_called = FALSE; /* Set it to false so we can detect
417 if it gets set during the clone */
420 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
422 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
424 /* perl_clone leaves us in new interpreter's context.
425 As it is tricky to spot an implicit aTHX, create a new scope
426 with aTHX matching the context for the duration of
427 our work for new interpreter.
430 dTHXa(thread->interp);
434 /* Here we remove END blocks since they should only run
435 in the thread they are created
437 SvREFCNT_dec(PL_endav);
439 clone_param.flags = 0;
440 thread->init_function = sv_dup(init_function, &clone_param);
441 if (SvREFCNT(thread->init_function) == 0) {
442 SvREFCNT_inc(thread->init_function);
447 thread->params = sv_dup(params, &clone_param);
448 SvREFCNT_inc(thread->params);
451 /* The code below checks that anything living on
452 the tmps stack and has been cloned (so it lives in the
453 ptr_table) has a refcount higher than 0
455 If the refcount is 0 it means that a something on the
456 stack/context was holding a reference to it and
457 since we init_stacks() in perl_clone that won't get
458 cleaned and we will get a leaked scalar.
459 The reason it was cloned was that it lived on the
462 Example of this can be found in bugreport 15837
463 where calls in the parameter list end up as a temp
465 One could argue that this fix should be in perl_clone
469 while (tmps_ix > 0) {
470 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
472 if (sv && SvREFCNT(sv) == 0) {
480 SvTEMP_off(thread->init_function);
481 ptr_table_free(PL_ptr_table);
483 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
485 S_ithread_set(aTHX_ current_thread);
486 PERL_SET_CONTEXT(aTHX);
488 /* Start the thread */
491 thread->handle = CreateThread(NULL, 0, S_ithread_run,
492 (LPVOID)thread, 0, &thread->thr);
495 static pthread_attr_t attr;
496 static int attr_inited = 0;
497 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
500 pthread_attr_init(&attr);
502 # ifdef PTHREAD_ATTR_SETDETACHSTATE
503 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
505 # ifdef THREAD_CREATE_NEEDS_STACK
506 rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
509 if (! rc_stack_size) {
510 #ifdef OLD_PTHREADS_API
511 rc_thread_create = pthread_create( &thread->thr, attr,
512 S_ithread_run, (void *)thread);
514 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
515 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
517 rc_thread_create = pthread_create( &thread->thr, &attr,
518 S_ithread_run, (void *)thread);
524 /* Check for errors */
526 if (thread->handle == NULL) {
528 if (rc_stack_size || rc_thread_create) {
530 MUTEX_UNLOCK(&create_destruct_mutex);
532 S_ithread_destruct(aTHX_ thread);
534 if (ckWARN_d(WARN_THREADS)) {
535 # ifdef THREAD_CREATE_NEEDS_STACK
537 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", (IV)THREAD_CREATE_NEEDS_STACK, rc_stack_size);
540 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
546 MUTEX_UNLOCK(&create_destruct_mutex);
549 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
552 #endif /* USE_ITHREADS */
555 MODULE = threads PACKAGE = threads PREFIX = ithread_
564 SV *function_to_call;
569 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
571 classname = (char *)SvPV_nolen(ST(0));
572 function_to_call = ST(1);
577 for (ii=2; ii < items; ii++) {
578 av_push(params, SvREFCNT_inc(ST(ii)));
583 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
586 newRV_noinc((SV*)params)));
587 /* XSRETURN(1); - implied */
598 /* Class method only */
600 Perl_croak(aTHX_ "Usage: threads->list()");
601 classname = (char *)SvPV_nolen(ST(0));
603 /* Calling context */
604 list_context = (GIMME_V == G_ARRAY);
606 /* Walk through threads list */
607 MUTEX_LOCK(&create_destruct_mutex);
608 for (thr = threads->next;
612 /* Ignore detached or joined threads */
613 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
616 /* Push object on stack if list context */
618 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
622 MUTEX_UNLOCK(&create_destruct_mutex);
623 /* If scalar context, send back count */
624 if (! list_context) {
635 /* Class method only */
637 Perl_croak(aTHX_ "Usage: threads->self()");
638 classname = (char *)SvPV_nolen(ST(0));
640 thread = S_ithread_get(aTHX);
642 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
643 /* XSRETURN(1); - implied */
651 thread = SV_to_ithread(aTHX_ ST(0));
652 XST_mUV(0, thread->tid);
653 /* XSRETURN(1); - implied */
670 /* Object method only */
671 if (! sv_isobject(ST(0)))
672 Perl_croak(aTHX_ "Usage: $thr->join()");
674 /* Check if the thread is joinable */
675 thread = SV_to_ithread(aTHX_ ST(0));
676 MUTEX_LOCK(&thread->mutex);
677 join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
678 MUTEX_UNLOCK(&thread->mutex);
680 if (join_err & PERL_ITHR_DETACHED) {
681 Perl_croak(aTHX_ "Cannot join a detached thread");
683 Perl_croak(aTHX_ "Thread already joined");
687 /* Join the thread */
689 waitcode = WaitForSingleObject(thread->handle, INFINITE);
691 pthread_join(thread->thr, &retval);
694 MUTEX_LOCK(&thread->mutex);
696 thread->state |= PERL_ITHR_JOINED;
698 /* Get the return value from the call_sv */
701 PerlInterpreter *other_perl;
702 CLONE_PARAMS clone_params;
703 ithread *current_thread;
705 params_copy = (AV *)SvRV(thread->params);
706 other_perl = thread->interp;
707 clone_params.stashes = newAV();
708 clone_params.flags = CLONEf_JOIN_IN;
709 PL_ptr_table = ptr_table_new();
710 current_thread = S_ithread_get(aTHX);
711 S_ithread_set(aTHX_ thread);
712 /* Ensure 'meaningful' addresses retain their meaning */
713 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
714 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
715 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
716 params = (AV *)sv_dup((SV*)params_copy, &clone_params);
717 S_ithread_set(aTHX_ current_thread);
718 SvREFCNT_dec(clone_params.stashes);
719 SvREFCNT_inc(params);
720 ptr_table_free(PL_ptr_table);
724 /* We are finished with the thread */
725 S_ithread_clear(aTHX_ thread);
726 MUTEX_UNLOCK(&thread->mutex);
728 /* If no return values, then just return */
733 /* Put return values on stack */
734 len = (int)AvFILL(params);
735 for (ii=0; ii <= len; ii++) {
736 SV* param = av_shift(params);
737 XPUSHs(sv_2mortal(param));
740 /* Free return value array */
741 SvREFCNT_dec(params);
757 thread = SV_to_ithread(aTHX_ ST(0));
758 MUTEX_LOCK(&thread->mutex);
760 /* Check if the thread is detachable */
761 if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
762 MUTEX_UNLOCK(&thread->mutex);
763 if (detach_err & PERL_ITHR_DETACHED) {
764 Perl_croak(aTHX_ "Thread already detached");
766 Perl_croak(aTHX_ "Cannot detach a joined thread");
770 /* Detach the thread */
771 thread->state |= PERL_ITHR_DETACHED;
773 /* Windows has no 'detach thread' function */
775 PERL_THREAD_DETACH(thread->thr);
777 /* Cleanup if finished */
778 cleanup = (thread->state & PERL_ITHR_FINISHED);
779 MUTEX_UNLOCK(&thread->mutex);
782 S_ithread_destruct(aTHX_ thread);
788 sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
794 /* Compares TIDs to determine thread equality.
795 * Return 0 on false for backward compatibility.
797 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
798 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
799 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
800 if (thr1->tid == thr2->tid) {
808 /* XSRETURN(1); - implied */
819 /* Class method only */
821 Perl_croak(aTHX_ "Usage: threads->object($tid)");
822 classname = (char *)SvPV_nolen(ST(0));
824 if ((items < 2) || ! SvOK(ST(1))) {
830 /* Walk through threads list */
831 MUTEX_LOCK(&create_destruct_mutex);
832 for (thr = threads->next;
836 /* Look for TID, but ignore detached or joined threads */
837 if ((thr->tid != tid) ||
838 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
842 /* Put object on stack */
843 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
847 MUTEX_UNLOCK(&create_destruct_mutex);
851 /* XSRETURN(1); - implied */
855 ithread__handle(...);
859 thread = SV_to_ithread(aTHX_ ST(0));
861 XST_mUV(0, PTR2UV(&thread->handle));
863 XST_mUV(0, PTR2UV(&thread->thr));
865 /* XSRETURN(1); - implied */
867 #endif /* USE_ITHREADS */
872 /* The 'main' thread is thread 0.
873 * It is detached (unjoinable) and immortal.
878 PL_perl_destruct_level = 2;
879 MUTEX_INIT(&create_destruct_mutex);
880 MUTEX_LOCK(&create_destruct_mutex);
881 PL_threadhook = &Perl_ithread_hook;
882 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
884 PerlLIO_write(PerlIO_fileno(Perl_error_log),
885 PL_no_mem, strlen(PL_no_mem));
888 Zero(thread,1,ithread);
889 PL_perl_destruct_level = 2;
890 MUTEX_INIT(&thread->mutex);
892 /* Head of the threads list */
894 thread->next = thread;
895 thread->prev = thread;
897 thread->interp = aTHX;
898 thread->count = 1; /* Immortal. */
899 thread->tid = tid_counter++;
901 thread->state = PERL_ITHR_DETACHED;
903 thread->thr = GetCurrentThreadId();
905 thread->thr = pthread_self();
908 S_ithread_set(aTHX_ thread);
909 MUTEX_UNLOCK(&create_destruct_mutex);
910 #endif /* USE_ITHREADS */