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 known_threads = 0;
76 static IV active_threads = 0;
80 Perl_ithread_set (pTHX_ ithread* thread)
83 MY_CXT.thread = thread;
87 Perl_ithread_get (pTHX) {
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
100 S_ithread_clear(pTHX_ ithread* thread)
102 PerlInterpreter *interp;
103 assert(thread->state & PERL_ITHR_FINISHED &&
104 (thread->state & PERL_ITHR_DETACHED ||
105 thread->state & PERL_ITHR_JOINED));
107 interp = thread->interp;
110 ithread* current_thread;
114 PERL_SET_CONTEXT(interp);
115 current_thread = Perl_ithread_get(aTHX);
116 Perl_ithread_set(aTHX_ thread);
118 SvREFCNT_dec(thread->params);
120 thread->params = Nullsv;
121 perl_destruct(interp);
122 thread->interp = NULL;
126 PERL_SET_CONTEXT(aTHX);
131 * free an ithread structure and any attached data if its count == 0
134 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
136 MUTEX_LOCK(&thread->mutex);
138 MUTEX_UNLOCK(&thread->mutex);
139 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
141 if (thread->count != 0) {
142 MUTEX_UNLOCK(&thread->mutex);
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 ? */
152 thread->next->prev = thread->prev;
153 thread->prev->next = thread->next;
154 if (threads == thread) {
155 threads = thread->next;
161 assert( known_threads >= 0 );
163 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
164 thread->tid,thread->interp,aTHX, known_threads);
166 MUTEX_UNLOCK(&create_destruct_mutex);
167 /* Thread is now disowned */
169 S_ithread_clear(aTHX_ thread);
171 MUTEX_UNLOCK(&thread->mutex);
172 MUTEX_DESTROY(&thread->mutex);
175 CloseHandle(thread->handle);
178 PerlMemShared_free(thread);
182 Perl_ithread_hook(pTHX)
184 int veto_cleanup = 0;
185 MUTEX_LOCK(&create_destruct_mutex);
186 if (aTHX == PL_curinterp && active_threads != 1) {
187 if (ckWARN_d(WARN_THREADS))
188 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
192 MUTEX_UNLOCK(&create_destruct_mutex);
197 Perl_ithread_detach(pTHX_ ithread *thread)
199 MUTEX_LOCK(&thread->mutex);
200 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
201 thread->state |= PERL_ITHR_DETACHED;
203 CloseHandle(thread->handle);
206 PERL_THREAD_DETACH(thread->thr);
209 if ((thread->state & PERL_ITHR_FINISHED) &&
210 (thread->state & PERL_ITHR_DETACHED)) {
211 MUTEX_UNLOCK(&thread->mutex);
212 Perl_ithread_destruct(aTHX_ thread, "detach");
215 MUTEX_UNLOCK(&thread->mutex);
219 /* MAGIC (in mg.h sense) hooks */
222 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
224 ithread *thread = (ithread *) mg->mg_ptr;
225 SvIV_set(sv, PTR2IV(thread));
231 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
233 ithread *thread = (ithread *) mg->mg_ptr;
234 MUTEX_LOCK(&thread->mutex);
236 if (thread->count == 0) {
237 if(thread->state & PERL_ITHR_FINISHED &&
238 (thread->state & PERL_ITHR_DETACHED ||
239 thread->state & PERL_ITHR_JOINED))
241 MUTEX_UNLOCK(&thread->mutex);
242 Perl_ithread_destruct(aTHX_ thread, "no reference");
245 MUTEX_UNLOCK(&thread->mutex);
249 MUTEX_UNLOCK(&thread->mutex);
255 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
257 ithread *thread = (ithread *) mg->mg_ptr;
258 MUTEX_LOCK(&thread->mutex);
260 MUTEX_UNLOCK(&thread->mutex);
264 MGVTBL ithread_vtbl = {
265 ithread_mg_get, /* get */
269 ithread_mg_free, /* free */
271 ithread_mg_dup /* dup */
276 * Starts executing the thread. Needs to clean up memory a tad better.
277 * Passed as the C level function to run in the new thread
281 static THREAD_RET_TYPE
282 Perl_ithread_run(LPVOID arg) {
285 Perl_ithread_run(void * arg) {
287 ithread* thread = (ithread*) arg;
288 dTHXa(thread->interp);
289 PERL_SET_CONTEXT(thread->interp);
290 Perl_ithread_set(aTHX_ thread);
293 /* Far from clear messing with ->thr child-side is a good idea */
294 MUTEX_LOCK(&thread->mutex);
296 thread->thr = GetCurrentThreadId();
298 thread->thr = pthread_self();
300 MUTEX_UNLOCK(&thread->mutex);
303 PL_perl_destruct_level = 2;
306 AV* params = (AV*) SvRV(thread->params);
307 int len = (int)av_len(params)+1;
313 for(ii = 0; ii < len; ii++) {
314 XPUSHs(av_shift(params));
317 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
320 for (ii=len-1; ii >= 0; ii--) {
322 av_store(params, ii, SvREFCNT_inc(sv));
324 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
325 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
329 SvREFCNT_dec(thread->init_function);
332 PerlIO_flush((PerlIO*)NULL);
333 MUTEX_LOCK(&thread->mutex);
334 thread->state |= PERL_ITHR_FINISHED;
336 if (thread->state & PERL_ITHR_DETACHED) {
337 MUTEX_UNLOCK(&thread->mutex);
338 Perl_ithread_destruct(aTHX_ thread, "detached finish");
340 MUTEX_UNLOCK(&thread->mutex);
342 MUTEX_LOCK(&create_destruct_mutex);
344 assert( active_threads >= 0 );
345 MUTEX_UNLOCK(&create_destruct_mutex);
355 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
360 MUTEX_LOCK(&thread->mutex);
362 MUTEX_UNLOCK(&thread->mutex);
366 sv = newSVrv(obj,classname);
367 sv_setiv(sv,PTR2IV(thread));
368 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
369 mg->mg_flags |= MGf_DUP;
375 SV_to_ithread(pTHX_ SV *sv)
379 return INT2PTR(ithread*, SvIV(SvRV(sv)));
383 return Perl_ithread_get(aTHX);
388 * ithread->create(); ( aka ithread->new() )
389 * Called in context of parent thread
393 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
396 CLONE_PARAMS clone_param;
397 ithread* current_thread = Perl_ithread_get(aTHX);
399 SV** tmps_tmp = PL_tmps_stack;
400 IV tmps_ix = PL_tmps_ix;
403 const char* panic = NULL;
407 MUTEX_LOCK(&create_destruct_mutex);
408 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
410 MUTEX_UNLOCK(&create_destruct_mutex);
411 PerlLIO_write(PerlIO_fileno(Perl_error_log),
412 PL_no_mem, strlen(PL_no_mem));
415 Zero(thread,1,ithread);
416 thread->next = threads;
417 thread->prev = threads->prev;
418 threads->prev = thread;
419 thread->prev->next = thread;
420 /* Set count to 1 immediately in case thread exits before
421 * we return to caller !
424 MUTEX_INIT(&thread->mutex);
425 thread->tid = tid_counter++;
426 thread->gimme = GIMME_V;
428 /* "Clone" our interpreter into the thread's interpreter
429 * This gives thread access to "static data" and code.
432 PerlIO_flush((PerlIO*)NULL);
433 Perl_ithread_set(aTHX_ thread);
435 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
437 PL_srand_called = FALSE; /* Set it to false so we can detect
438 if it gets set during the clone */
441 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
443 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
445 /* perl_clone leaves us in new interpreter's context.
446 As it is tricky to spot an implicit aTHX, create a new scope
447 with aTHX matching the context for the duration of
448 our work for new interpreter.
451 dTHXa(thread->interp);
455 /* Here we remove END blocks since they should only run
456 in the thread they are created
458 SvREFCNT_dec(PL_endav);
460 clone_param.flags = 0;
461 thread->init_function = sv_dup(init_function, &clone_param);
462 if (SvREFCNT(thread->init_function) == 0) {
463 SvREFCNT_inc(thread->init_function);
468 thread->params = sv_dup(params, &clone_param);
469 SvREFCNT_inc(thread->params);
472 /* The code below checks that anything living on
473 the tmps stack and has been cloned (so it lives in the
474 ptr_table) has a refcount higher than 0
476 If the refcount is 0 it means that a something on the
477 stack/context was holding a reference to it and
478 since we init_stacks() in perl_clone that won't get
479 cleaned and we will get a leaked scalar.
480 The reason it was cloned was that it lived on the
483 Example of this can be found in bugreport 15837
484 where calls in the parameter list end up as a temp
486 One could argue that this fix should be in perl_clone
490 while (tmps_ix > 0) {
491 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
493 if (sv && SvREFCNT(sv) == 0) {
501 SvTEMP_off(thread->init_function);
502 ptr_table_free(PL_ptr_table);
504 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
506 Perl_ithread_set(aTHX_ current_thread);
507 PERL_SET_CONTEXT(aTHX);
509 /* Start the thread */
512 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
513 (LPVOID)thread, 0, &thread->thr);
516 static pthread_attr_t attr;
517 static int attr_inited = 0;
518 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
521 pthread_attr_init(&attr);
523 # ifdef PTHREAD_ATTR_SETDETACHSTATE
524 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
526 # ifdef THREAD_CREATE_NEEDS_STACK
527 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
528 panic = "panic: pthread_attr_setstacksize failed";
531 #ifdef OLD_PTHREADS_API
533 = panic ? 1 : pthread_create( &thread->thr, attr,
534 Perl_ithread_run, (void *)thread);
536 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
537 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
540 = panic ? 1 : pthread_create( &thread->thr, &attr,
541 Perl_ithread_run, (void *)thread);
548 thread->handle == NULL
553 MUTEX_UNLOCK(&create_destruct_mutex);
555 Perl_ithread_destruct(aTHX_ thread, "create failed");
558 Perl_croak(aTHX_ panic);
563 MUTEX_UNLOCK(&create_destruct_mutex);
566 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
570 Perl_ithread_self (pTHX_ SV *obj, char* Class)
572 ithread *thread = Perl_ithread_get(aTHX);
574 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
576 Perl_croak(aTHX_ "panic: cannot find thread data");
577 return NULL; /* silence compiler warning */
582 * This code takes the return value from the call_sv and sends it back.
585 Perl_ithread_join(pTHX_ SV *obj)
587 ithread *thread = SV_to_ithread(aTHX_ obj);
588 MUTEX_LOCK(&thread->mutex);
589 if (thread->state & PERL_ITHR_DETACHED) {
590 MUTEX_UNLOCK(&thread->mutex);
591 Perl_croak(aTHX_ "Cannot join a detached thread");
593 else if (thread->state & PERL_ITHR_JOINED) {
594 MUTEX_UNLOCK(&thread->mutex);
595 Perl_croak(aTHX_ "Thread already joined");
604 MUTEX_UNLOCK(&thread->mutex);
606 waitcode = WaitForSingleObject(thread->handle, INFINITE);
607 CloseHandle(thread->handle);
610 pthread_join(thread->thr,&retval);
612 MUTEX_LOCK(&thread->mutex);
614 /* sv_dup over the args */
616 ithread* current_thread;
617 AV* params = (AV*) SvRV(thread->params);
618 PerlInterpreter *other_perl = thread->interp;
619 CLONE_PARAMS clone_params;
620 clone_params.stashes = newAV();
621 clone_params.flags = CLONEf_JOIN_IN;
622 PL_ptr_table = ptr_table_new();
623 current_thread = Perl_ithread_get(aTHX);
624 Perl_ithread_set(aTHX_ thread);
625 /* ensure 'meaningful' addresses retain their meaning */
626 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
627 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
628 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
632 I32 len = av_len(params)+1;
634 for(i = 0; i < len; i++) {
635 sv_dump(SvRV(AvARRAY(params)[i]));
639 retparam = (AV*) sv_dup((SV*)params, &clone_params);
642 I32 len = av_len(retparam)+1;
644 for(i = 0; i < len; i++) {
645 sv_dump(SvRV(AvARRAY(retparam)[i]));
649 Perl_ithread_set(aTHX_ current_thread);
650 SvREFCNT_dec(clone_params.stashes);
651 SvREFCNT_inc(retparam);
652 ptr_table_free(PL_ptr_table);
656 /* We are finished with it */
657 thread->state |= PERL_ITHR_JOINED;
658 S_ithread_clear(aTHX_ thread);
659 MUTEX_UNLOCK(&thread->mutex);
667 Perl_ithread_DESTROY(pTHX_ SV *sv)
669 ithread *thread = SV_to_ithread(aTHX_ sv);
670 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
673 #endif /* USE_ITHREADS */
675 MODULE = threads PACKAGE = threads PREFIX = ithread_
684 SV *function_to_call;
689 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
691 classname = (char *)SvPV_nolen(ST(0));
692 function_to_call = ST(1);
697 for (ii=2; ii < items; ii++) {
698 av_push(params, SvREFCNT_inc(ST(ii)));
703 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv,
706 newRV_noinc((SV*)params)));
707 /* XSRETURN(1); - implied */
718 /* Class method only */
720 Perl_croak(aTHX_ "Usage: threads->list()");
721 classname = (char *)SvPV_nolen(ST(0));
723 /* Calling context */
724 list_context = (GIMME_V == G_ARRAY);
726 /* Walk through threads list */
727 MUTEX_LOCK(&create_destruct_mutex);
728 for (thr = threads->next;
732 /* Ignore detached or joined threads */
733 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
736 /* Push object on stack if list context */
738 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
742 MUTEX_UNLOCK(&create_destruct_mutex);
743 /* If scalar context, send back count */
744 if (! list_context) {
754 /* Class method only */
756 Perl_croak(aTHX_ "Usage: threads->self()");
757 classname = (char *)SvPV_nolen(ST(0));
759 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv, classname));
760 /* XSRETURN(1); - implied */
768 thread = SV_to_ithread(aTHX_ ST(0));
769 XST_mUV(0, thread->tid);
770 /* XSRETURN(1); - implied */
780 /* Object method only */
781 if (! sv_isobject(ST(0)))
782 Perl_croak(aTHX_ "Usage: $thr->join()");
784 /* Join thread and get return values */
785 params = Perl_ithread_join(aTHX_ ST(0));
790 /* Put return values on stack */
791 len = (int)AvFILL(params);
792 for (ii=0; ii <= len; ii++) {
793 SV* param = av_shift(params);
794 XPUSHs(sv_2mortal(param));
797 /* Free return value array */
798 SvREFCNT_dec(params);
812 thread = SV_to_ithread(aTHX_ ST(0));
813 Perl_ithread_detach(aTHX_ thread);
819 Perl_ithread_DESTROY(aTHX_ ST(0));
825 /* Compares TIDs to determine thread equality.
826 * Return 0 on false for backward compatibility.
828 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
829 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
830 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
831 if (thr1->tid == thr2->tid) {
839 /* XSRETURN(1); - implied */
850 /* Class method only */
852 Perl_croak(aTHX_ "Usage: threads->object($tid)");
853 classname = (char *)SvPV_nolen(ST(0));
855 if ((items < 2) || ! SvOK(ST(1))) {
861 /* Walk through threads list */
862 MUTEX_LOCK(&create_destruct_mutex);
863 for (thr = threads->next;
867 /* Look for TID, but ignore detached or joined threads */
868 if ((thr->tid != tid) ||
869 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
873 /* Put object on stack */
874 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
878 MUTEX_UNLOCK(&create_destruct_mutex);
882 /* XSRETURN(1); - implied */
886 ithread__handle(...);
890 thread = SV_to_ithread(aTHX_ ST(0));
892 XST_mUV(0, PTR2UV(thread->handle));
894 XST_mUV(0, PTR2UV(thread->thr));
896 /* XSRETURN(1); - implied */
898 #endif /* USE_ITHREADS */
905 PL_perl_destruct_level = 2;
906 MUTEX_INIT(&create_destruct_mutex);
907 MUTEX_LOCK(&create_destruct_mutex);
908 PL_threadhook = &Perl_ithread_hook;
909 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
911 PerlLIO_write(PerlIO_fileno(Perl_error_log),
912 PL_no_mem, strlen(PL_no_mem));
915 Zero(thread,1,ithread);
916 PL_perl_destruct_level = 2;
917 MUTEX_INIT(&thread->mutex);
919 thread->next = thread;
920 thread->prev = thread;
921 thread->interp = aTHX;
922 thread->count = 1; /* Immortal. */
923 thread->tid = tid_counter++;
926 thread->state = PERL_ITHR_DETACHED;
928 thread->thr = GetCurrentThreadId();
930 thread->thr = pthread_self();
933 Perl_ithread_set(aTHX_ thread);
934 MUTEX_UNLOCK(&create_destruct_mutex);
935 #endif /* USE_ITHREADS */