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, const char *why)
135 MUTEX_LOCK(&thread->mutex);
137 MUTEX_UNLOCK(&thread->mutex);
138 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
140 if (thread->count != 0) {
141 MUTEX_UNLOCK(&thread->mutex);
144 MUTEX_LOCK(&create_destruct_mutex);
145 /* Remove from circular list of threads */
146 if (thread->next == thread) {
147 /* last one should never get here ? */
151 thread->next->prev = thread->prev;
152 thread->prev->next = thread->next;
153 if (threads == thread) {
154 threads = thread->next;
160 MUTEX_UNLOCK(&create_destruct_mutex);
161 /* Thread is now disowned */
163 S_ithread_clear(aTHX_ thread);
165 MUTEX_UNLOCK(&thread->mutex);
166 MUTEX_DESTROY(&thread->mutex);
169 CloseHandle(thread->handle);
172 PerlMemShared_free(thread);
176 Perl_ithread_hook(pTHX)
178 int veto_cleanup = 0;
179 MUTEX_LOCK(&create_destruct_mutex);
180 if (aTHX == PL_curinterp && active_threads != 1) {
181 if (ckWARN_d(WARN_THREADS))
182 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
186 MUTEX_UNLOCK(&create_destruct_mutex);
191 S_ithread_detach(pTHX_ ithread *thread)
193 MUTEX_LOCK(&thread->mutex);
194 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
195 thread->state |= PERL_ITHR_DETACHED;
197 CloseHandle(thread->handle);
200 PERL_THREAD_DETACH(thread->thr);
203 if ((thread->state & PERL_ITHR_FINISHED) &&
204 (thread->state & PERL_ITHR_DETACHED)) {
205 MUTEX_UNLOCK(&thread->mutex);
206 S_ithread_destruct(aTHX_ thread, "detach");
209 MUTEX_UNLOCK(&thread->mutex);
213 /* MAGIC (in mg.h sense) hooks */
216 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
218 ithread *thread = (ithread *) mg->mg_ptr;
219 SvIV_set(sv, PTR2IV(thread));
225 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
227 ithread *thread = (ithread *) mg->mg_ptr;
228 MUTEX_LOCK(&thread->mutex);
230 if (thread->count == 0) {
231 if(thread->state & PERL_ITHR_FINISHED &&
232 (thread->state & PERL_ITHR_DETACHED ||
233 thread->state & PERL_ITHR_JOINED))
235 MUTEX_UNLOCK(&thread->mutex);
236 S_ithread_destruct(aTHX_ thread, "no reference");
239 MUTEX_UNLOCK(&thread->mutex);
243 MUTEX_UNLOCK(&thread->mutex);
249 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
251 ithread *thread = (ithread *) mg->mg_ptr;
252 MUTEX_LOCK(&thread->mutex);
254 MUTEX_UNLOCK(&thread->mutex);
258 MGVTBL ithread_vtbl = {
259 ithread_mg_get, /* get */
263 ithread_mg_free, /* free */
265 ithread_mg_dup /* dup */
270 * Starts executing the thread. Needs to clean up memory a tad better.
271 * Passed as the C level function to run in the new thread
275 static THREAD_RET_TYPE
276 S_ithread_run(LPVOID arg) {
279 S_ithread_run(void * arg) {
281 ithread* thread = (ithread*) arg;
282 dTHXa(thread->interp);
283 PERL_SET_CONTEXT(thread->interp);
284 S_ithread_set(aTHX_ thread);
287 /* Far from clear messing with ->thr child-side is a good idea */
288 MUTEX_LOCK(&thread->mutex);
290 thread->thr = GetCurrentThreadId();
292 thread->thr = pthread_self();
294 MUTEX_UNLOCK(&thread->mutex);
297 PL_perl_destruct_level = 2;
300 AV* params = (AV*) SvRV(thread->params);
301 int len = (int)av_len(params)+1;
307 for(ii = 0; ii < len; ii++) {
308 XPUSHs(av_shift(params));
311 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
314 for (ii=len-1; ii >= 0; ii--) {
316 av_store(params, ii, SvREFCNT_inc(sv));
318 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
319 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
323 SvREFCNT_dec(thread->init_function);
326 PerlIO_flush((PerlIO*)NULL);
327 MUTEX_LOCK(&thread->mutex);
328 thread->state |= PERL_ITHR_FINISHED;
330 if (thread->state & PERL_ITHR_DETACHED) {
331 MUTEX_UNLOCK(&thread->mutex);
332 S_ithread_destruct(aTHX_ thread, "detached finish");
334 MUTEX_UNLOCK(&thread->mutex);
336 MUTEX_LOCK(&create_destruct_mutex);
338 assert( active_threads >= 0 );
339 MUTEX_UNLOCK(&create_destruct_mutex);
349 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
354 MUTEX_LOCK(&thread->mutex);
356 MUTEX_UNLOCK(&thread->mutex);
360 sv = newSVrv(obj,classname);
361 sv_setiv(sv,PTR2IV(thread));
362 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
363 mg->mg_flags |= MGf_DUP;
369 SV_to_ithread(pTHX_ SV *sv)
373 return INT2PTR(ithread*, SvIV(SvRV(sv)));
377 return S_ithread_get(aTHX);
382 * ithread->create(); ( aka ithread->new() )
383 * Called in context of parent thread
387 S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
390 CLONE_PARAMS clone_param;
391 ithread* current_thread = S_ithread_get(aTHX);
393 SV** tmps_tmp = PL_tmps_stack;
394 IV tmps_ix = PL_tmps_ix;
397 const char* panic = NULL;
401 MUTEX_LOCK(&create_destruct_mutex);
402 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
404 MUTEX_UNLOCK(&create_destruct_mutex);
405 PerlLIO_write(PerlIO_fileno(Perl_error_log),
406 PL_no_mem, strlen(PL_no_mem));
409 Zero(thread,1,ithread);
410 thread->next = threads;
411 thread->prev = threads->prev;
412 threads->prev = thread;
413 thread->prev->next = thread;
414 /* Set count to 1 immediately in case thread exits before
415 * we return to caller !
418 MUTEX_INIT(&thread->mutex);
419 thread->tid = tid_counter++;
420 thread->gimme = GIMME_V;
422 /* "Clone" our interpreter into the thread's interpreter
423 * This gives thread access to "static data" and code.
426 PerlIO_flush((PerlIO*)NULL);
427 S_ithread_set(aTHX_ thread);
429 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
431 PL_srand_called = FALSE; /* Set it to false so we can detect
432 if it gets set during the clone */
435 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
437 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
439 /* perl_clone leaves us in new interpreter's context.
440 As it is tricky to spot an implicit aTHX, create a new scope
441 with aTHX matching the context for the duration of
442 our work for new interpreter.
445 dTHXa(thread->interp);
449 /* Here we remove END blocks since they should only run
450 in the thread they are created
452 SvREFCNT_dec(PL_endav);
454 clone_param.flags = 0;
455 thread->init_function = sv_dup(init_function, &clone_param);
456 if (SvREFCNT(thread->init_function) == 0) {
457 SvREFCNT_inc(thread->init_function);
462 thread->params = sv_dup(params, &clone_param);
463 SvREFCNT_inc(thread->params);
466 /* The code below checks that anything living on
467 the tmps stack and has been cloned (so it lives in the
468 ptr_table) has a refcount higher than 0
470 If the refcount is 0 it means that a something on the
471 stack/context was holding a reference to it and
472 since we init_stacks() in perl_clone that won't get
473 cleaned and we will get a leaked scalar.
474 The reason it was cloned was that it lived on the
477 Example of this can be found in bugreport 15837
478 where calls in the parameter list end up as a temp
480 One could argue that this fix should be in perl_clone
484 while (tmps_ix > 0) {
485 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
487 if (sv && SvREFCNT(sv) == 0) {
495 SvTEMP_off(thread->init_function);
496 ptr_table_free(PL_ptr_table);
498 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
500 S_ithread_set(aTHX_ current_thread);
501 PERL_SET_CONTEXT(aTHX);
503 /* Start the thread */
506 thread->handle = CreateThread(NULL, 0, S_ithread_run,
507 (LPVOID)thread, 0, &thread->thr);
510 static pthread_attr_t attr;
511 static int attr_inited = 0;
512 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
515 pthread_attr_init(&attr);
517 # ifdef PTHREAD_ATTR_SETDETACHSTATE
518 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
520 # ifdef THREAD_CREATE_NEEDS_STACK
521 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
522 panic = "panic: pthread_attr_setstacksize failed";
525 #ifdef OLD_PTHREADS_API
527 = panic ? 1 : pthread_create( &thread->thr, attr,
528 S_ithread_run, (void *)thread);
530 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
531 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
534 = panic ? 1 : pthread_create( &thread->thr, &attr,
535 S_ithread_run, (void *)thread);
542 thread->handle == NULL
547 MUTEX_UNLOCK(&create_destruct_mutex);
549 S_ithread_destruct(aTHX_ thread, "create failed");
552 Perl_croak(aTHX_ panic);
557 MUTEX_UNLOCK(&create_destruct_mutex);
560 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
564 S_ithread_self (pTHX_ SV *obj, char* Class)
566 ithread *thread = S_ithread_get(aTHX);
568 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
570 Perl_croak(aTHX_ "panic: cannot find thread data");
571 return NULL; /* silence compiler warning */
576 * This code takes the return value from the call_sv and sends it back.
579 S_ithread_join(pTHX_ SV *obj)
581 ithread *thread = SV_to_ithread(aTHX_ obj);
582 MUTEX_LOCK(&thread->mutex);
583 if (thread->state & PERL_ITHR_DETACHED) {
584 MUTEX_UNLOCK(&thread->mutex);
585 Perl_croak(aTHX_ "Cannot join a detached thread");
587 else if (thread->state & PERL_ITHR_JOINED) {
588 MUTEX_UNLOCK(&thread->mutex);
589 Perl_croak(aTHX_ "Thread already joined");
598 MUTEX_UNLOCK(&thread->mutex);
600 waitcode = WaitForSingleObject(thread->handle, INFINITE);
601 CloseHandle(thread->handle);
604 pthread_join(thread->thr,&retval);
606 MUTEX_LOCK(&thread->mutex);
608 /* sv_dup over the args */
610 ithread* current_thread;
611 AV* params = (AV*) SvRV(thread->params);
612 PerlInterpreter *other_perl = thread->interp;
613 CLONE_PARAMS clone_params;
614 clone_params.stashes = newAV();
615 clone_params.flags = CLONEf_JOIN_IN;
616 PL_ptr_table = ptr_table_new();
617 current_thread = S_ithread_get(aTHX);
618 S_ithread_set(aTHX_ thread);
619 /* ensure 'meaningful' addresses retain their meaning */
620 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
621 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
622 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
626 I32 len = av_len(params)+1;
628 for(i = 0; i < len; i++) {
629 sv_dump(SvRV(AvARRAY(params)[i]));
633 retparam = (AV*) sv_dup((SV*)params, &clone_params);
636 I32 len = av_len(retparam)+1;
638 for(i = 0; i < len; i++) {
639 sv_dump(SvRV(AvARRAY(retparam)[i]));
643 S_ithread_set(aTHX_ current_thread);
644 SvREFCNT_dec(clone_params.stashes);
645 SvREFCNT_inc(retparam);
646 ptr_table_free(PL_ptr_table);
650 /* We are finished with it */
651 thread->state |= PERL_ITHR_JOINED;
652 S_ithread_clear(aTHX_ thread);
653 MUTEX_UNLOCK(&thread->mutex);
661 S_ithread_DESTROY(pTHX_ SV *sv)
663 ithread *thread = SV_to_ithread(aTHX_ sv);
664 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
667 #endif /* USE_ITHREADS */
669 MODULE = threads PACKAGE = threads PREFIX = ithread_
678 SV *function_to_call;
683 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
685 classname = (char *)SvPV_nolen(ST(0));
686 function_to_call = ST(1);
691 for (ii=2; ii < items; ii++) {
692 av_push(params, SvREFCNT_inc(ST(ii)));
697 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
700 newRV_noinc((SV*)params)));
701 /* XSRETURN(1); - implied */
712 /* Class method only */
714 Perl_croak(aTHX_ "Usage: threads->list()");
715 classname = (char *)SvPV_nolen(ST(0));
717 /* Calling context */
718 list_context = (GIMME_V == G_ARRAY);
720 /* Walk through threads list */
721 MUTEX_LOCK(&create_destruct_mutex);
722 for (thr = threads->next;
726 /* Ignore detached or joined threads */
727 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
730 /* Push object on stack if list context */
732 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
736 MUTEX_UNLOCK(&create_destruct_mutex);
737 /* If scalar context, send back count */
738 if (! list_context) {
748 /* Class method only */
750 Perl_croak(aTHX_ "Usage: threads->self()");
751 classname = (char *)SvPV_nolen(ST(0));
753 ST(0) = sv_2mortal(S_ithread_self(aTHX_ Nullsv, classname));
754 /* XSRETURN(1); - implied */
762 thread = SV_to_ithread(aTHX_ ST(0));
763 XST_mUV(0, thread->tid);
764 /* XSRETURN(1); - implied */
774 /* Object method only */
775 if (! sv_isobject(ST(0)))
776 Perl_croak(aTHX_ "Usage: $thr->join()");
778 /* Join thread and get return values */
779 params = S_ithread_join(aTHX_ ST(0));
784 /* Put return values on stack */
785 len = (int)AvFILL(params);
786 for (ii=0; ii <= len; ii++) {
787 SV* param = av_shift(params);
788 XPUSHs(sv_2mortal(param));
791 /* Free return value array */
792 SvREFCNT_dec(params);
806 thread = SV_to_ithread(aTHX_ ST(0));
807 S_ithread_detach(aTHX_ thread);
813 S_ithread_DESTROY(aTHX_ ST(0));
819 /* Compares TIDs to determine thread equality.
820 * Return 0 on false for backward compatibility.
822 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
823 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
824 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
825 if (thr1->tid == thr2->tid) {
833 /* XSRETURN(1); - implied */
844 /* Class method only */
846 Perl_croak(aTHX_ "Usage: threads->object($tid)");
847 classname = (char *)SvPV_nolen(ST(0));
849 if ((items < 2) || ! SvOK(ST(1))) {
855 /* Walk through threads list */
856 MUTEX_LOCK(&create_destruct_mutex);
857 for (thr = threads->next;
861 /* Look for TID, but ignore detached or joined threads */
862 if ((thr->tid != tid) ||
863 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
867 /* Put object on stack */
868 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
872 MUTEX_UNLOCK(&create_destruct_mutex);
876 /* XSRETURN(1); - implied */
880 ithread__handle(...);
884 thread = SV_to_ithread(aTHX_ ST(0));
886 XST_mUV(0, PTR2UV(thread->handle));
888 XST_mUV(0, PTR2UV(&thread->thr));
890 /* XSRETURN(1); - implied */
892 #endif /* USE_ITHREADS */
899 PL_perl_destruct_level = 2;
900 MUTEX_INIT(&create_destruct_mutex);
901 MUTEX_LOCK(&create_destruct_mutex);
902 PL_threadhook = &Perl_ithread_hook;
903 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
905 PerlLIO_write(PerlIO_fileno(Perl_error_log),
906 PL_no_mem, strlen(PL_no_mem));
909 Zero(thread,1,ithread);
910 PL_perl_destruct_level = 2;
911 MUTEX_INIT(&thread->mutex);
913 thread->next = thread;
914 thread->prev = thread;
915 thread->interp = aTHX;
916 thread->count = 1; /* Immortal. */
917 thread->tid = tid_counter++;
919 thread->state = PERL_ITHR_DETACHED;
921 thread->thr = GetCurrentThreadId();
923 thread->thr = pthread_self();
926 S_ithread_set(aTHX_ thread);
927 MUTEX_UNLOCK(&create_destruct_mutex);
928 #endif /* USE_ITHREADS */