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|PERL_ITHR_JOINED));
105 interp = thread->interp;
109 PERL_SET_CONTEXT(interp);
110 S_ithread_set(aTHX_ thread);
112 SvREFCNT_dec(thread->params);
114 thread->params = Nullsv;
115 perl_destruct(interp);
116 thread->interp = NULL;
120 PERL_SET_CONTEXT(aTHX);
125 * free an ithread structure and any attached data if its count == 0
128 S_ithread_destruct (pTHX_ ithread* thread)
134 MUTEX_LOCK(&thread->mutex);
136 /* Thread is still in use */
137 if (thread->count != 0) {
138 MUTEX_UNLOCK(&thread->mutex);
142 MUTEX_LOCK(&create_destruct_mutex);
143 /* Main thread (0) is immortal and should never get here */
144 assert(thread->tid != 0);
146 /* Remove from circular list of threads */
147 thread->next->prev = thread->prev;
148 thread->prev->next = thread->next;
151 MUTEX_UNLOCK(&create_destruct_mutex);
153 /* Thread is now disowned */
154 S_ithread_clear(aTHX_ thread);
157 handle = thread->handle;
158 thread->handle = NULL;
160 MUTEX_UNLOCK(&thread->mutex);
161 MUTEX_DESTROY(&thread->mutex);
168 /* Call PerlMemShared_free() in the context of the "first" interpreter
169 * per http://www.nntp.perl.org/group/perl.perl5.porters/110772
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 /* MAGIC (in mg.h sense) hooks */
194 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
196 ithread *thread = (ithread *) mg->mg_ptr;
197 SvIV_set(sv, PTR2IV(thread));
203 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
205 ithread *thread = (ithread *)mg->mg_ptr;
208 MUTEX_LOCK(&thread->mutex);
209 cleanup = ((--thread->count == 0) &&
210 (thread->state & PERL_ITHR_FINISHED) &&
211 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
212 MUTEX_UNLOCK(&thread->mutex);
215 S_ithread_destruct(aTHX_ thread);
220 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
222 ithread *thread = (ithread *) mg->mg_ptr;
223 MUTEX_LOCK(&thread->mutex);
225 MUTEX_UNLOCK(&thread->mutex);
229 MGVTBL ithread_vtbl = {
230 ithread_mg_get, /* get */
234 ithread_mg_free, /* free */
236 ithread_mg_dup /* dup */
241 * Starts executing the thread. Needs to clean up memory a tad better.
242 * Passed as the C level function to run in the new thread
246 static THREAD_RET_TYPE
247 S_ithread_run(LPVOID arg) {
250 S_ithread_run(void * arg) {
252 ithread* thread = (ithread*) arg;
255 dTHXa(thread->interp);
256 PERL_SET_CONTEXT(thread->interp);
257 S_ithread_set(aTHX_ thread);
260 /* Far from clear messing with ->thr child-side is a good idea */
261 MUTEX_LOCK(&thread->mutex);
263 thread->thr = GetCurrentThreadId();
265 thread->thr = pthread_self();
267 MUTEX_UNLOCK(&thread->mutex);
270 PL_perl_destruct_level = 2;
273 AV* params = (AV*) SvRV(thread->params);
274 int len = (int)av_len(params)+1;
280 for(ii = 0; ii < len; ii++) {
281 XPUSHs(av_shift(params));
284 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
287 for (ii=len-1; ii >= 0; ii--) {
289 av_store(params, ii, SvREFCNT_inc(sv));
291 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
292 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
297 /* Release function ref */
298 SvREFCNT_dec(thread->init_function);
299 thread->init_function = Nullsv;
302 PerlIO_flush((PerlIO*)NULL);
304 MUTEX_LOCK(&thread->mutex);
305 /* Mark as finished */
306 thread->state |= PERL_ITHR_FINISHED;
307 /* Cleanup if detached */
308 cleanup = (thread->state & PERL_ITHR_DETACHED);
309 MUTEX_UNLOCK(&thread->mutex);
312 S_ithread_destruct(aTHX_ thread);
314 MUTEX_LOCK(&create_destruct_mutex);
316 MUTEX_UNLOCK(&create_destruct_mutex);
326 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
331 MUTEX_LOCK(&thread->mutex);
333 MUTEX_UNLOCK(&thread->mutex);
337 sv = newSVrv(obj,classname);
338 sv_setiv(sv,PTR2IV(thread));
339 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
340 mg->mg_flags |= MGf_DUP;
346 SV_to_ithread(pTHX_ SV *sv)
350 return INT2PTR(ithread*, SvIV(SvRV(sv)));
354 return S_ithread_get(aTHX);
359 * ithread->create(); ( aka ithread->new() )
360 * Called in context of parent thread
364 S_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
367 CLONE_PARAMS clone_param;
368 ithread* current_thread = S_ithread_get(aTHX);
370 SV** tmps_tmp = PL_tmps_stack;
371 IV tmps_ix = PL_tmps_ix;
373 int rc_stack_size = 0;
374 int rc_thread_create = 0;
378 MUTEX_LOCK(&create_destruct_mutex);
379 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
381 MUTEX_UNLOCK(&create_destruct_mutex);
382 PerlLIO_write(PerlIO_fileno(Perl_error_log),
383 PL_no_mem, strlen(PL_no_mem));
386 Zero(thread,1,ithread);
388 /* Add to threads list */
389 thread->next = threads;
390 thread->prev = threads->prev;
391 threads->prev = thread;
392 thread->prev->next = thread;
394 /* Set count to 1 immediately in case thread exits before
395 * we return to caller !
398 MUTEX_INIT(&thread->mutex);
399 thread->tid = tid_counter++;
400 thread->gimme = GIMME_V;
402 /* "Clone" our interpreter into the thread's interpreter
403 * This gives thread access to "static data" and code.
406 PerlIO_flush((PerlIO*)NULL);
407 S_ithread_set(aTHX_ thread);
409 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
411 PL_srand_called = FALSE; /* Set it to false so we can detect
412 if it gets set during the clone */
415 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
417 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
419 /* perl_clone leaves us in new interpreter's context.
420 As it is tricky to spot an implicit aTHX, create a new scope
421 with aTHX matching the context for the duration of
422 our work for new interpreter.
425 dTHXa(thread->interp);
429 /* Here we remove END blocks since they should only run
430 in the thread they are created
432 SvREFCNT_dec(PL_endav);
434 clone_param.flags = 0;
435 thread->init_function = sv_dup(init_function, &clone_param);
436 if (SvREFCNT(thread->init_function) == 0) {
437 SvREFCNT_inc(thread->init_function);
442 thread->params = sv_dup(params, &clone_param);
443 SvREFCNT_inc(thread->params);
446 /* The code below checks that anything living on
447 the tmps stack and has been cloned (so it lives in the
448 ptr_table) has a refcount higher than 0
450 If the refcount is 0 it means that a something on the
451 stack/context was holding a reference to it and
452 since we init_stacks() in perl_clone that won't get
453 cleaned and we will get a leaked scalar.
454 The reason it was cloned was that it lived on the
457 Example of this can be found in bugreport 15837
458 where calls in the parameter list end up as a temp
460 One could argue that this fix should be in perl_clone
464 while (tmps_ix > 0) {
465 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
467 if (sv && SvREFCNT(sv) == 0) {
475 SvTEMP_off(thread->init_function);
476 ptr_table_free(PL_ptr_table);
478 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
480 S_ithread_set(aTHX_ current_thread);
481 PERL_SET_CONTEXT(aTHX);
483 /* Start the thread */
486 thread->handle = CreateThread(NULL, 0, S_ithread_run,
487 (LPVOID)thread, 0, &thread->thr);
490 static pthread_attr_t attr;
491 static int attr_inited = 0;
492 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
495 pthread_attr_init(&attr);
497 # ifdef PTHREAD_ATTR_SETDETACHSTATE
498 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
500 # ifdef THREAD_CREATE_NEEDS_STACK
501 rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
504 if (! rc_stack_size) {
505 #ifdef OLD_PTHREADS_API
506 rc_thread_create = pthread_create( &thread->thr, attr,
507 S_ithread_run, (void *)thread);
509 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
510 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
512 rc_thread_create = pthread_create( &thread->thr, &attr,
513 S_ithread_run, (void *)thread);
519 /* Check for errors */
521 if (thread->handle == NULL) {
523 if (rc_stack_size || rc_thread_create) {
525 MUTEX_UNLOCK(&create_destruct_mutex);
527 S_ithread_destruct(aTHX_ thread);
529 if (ckWARN_d(WARN_THREADS)) {
530 # ifdef THREAD_CREATE_NEEDS_STACK
532 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", (IV)THREAD_CREATE_NEEDS_STACK, rc_stack_size);
535 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
541 MUTEX_UNLOCK(&create_destruct_mutex);
544 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
547 #endif /* USE_ITHREADS */
550 MODULE = threads PACKAGE = threads PREFIX = ithread_
559 SV *function_to_call;
564 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
566 classname = (char *)SvPV_nolen(ST(0));
567 function_to_call = ST(1);
572 for (ii=2; ii < items; ii++) {
573 av_push(params, SvREFCNT_inc(ST(ii)));
578 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
581 newRV_noinc((SV*)params)));
582 /* XSRETURN(1); - implied */
593 /* Class method only */
595 Perl_croak(aTHX_ "Usage: threads->list()");
596 classname = (char *)SvPV_nolen(ST(0));
598 /* Calling context */
599 list_context = (GIMME_V == G_ARRAY);
601 /* Walk through threads list */
602 MUTEX_LOCK(&create_destruct_mutex);
603 for (thr = threads->next;
607 /* Ignore detached or joined threads */
608 if (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
611 /* Push object on stack if list context */
613 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE)));
617 MUTEX_UNLOCK(&create_destruct_mutex);
618 /* If scalar context, send back count */
619 if (! list_context) {
630 /* Class method only */
632 Perl_croak(aTHX_ "Usage: threads->self()");
633 classname = (char *)SvPV_nolen(ST(0));
635 thread = S_ithread_get(aTHX);
637 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
638 /* XSRETURN(1); - implied */
646 thread = SV_to_ithread(aTHX_ ST(0));
647 XST_mUV(0, thread->tid);
648 /* XSRETURN(1); - implied */
665 /* Object method only */
666 if (! sv_isobject(ST(0)))
667 Perl_croak(aTHX_ "Usage: $thr->join()");
669 /* Check if the thread is joinable */
670 thread = SV_to_ithread(aTHX_ ST(0));
671 MUTEX_LOCK(&thread->mutex);
672 join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
673 MUTEX_UNLOCK(&thread->mutex);
675 if (join_err & PERL_ITHR_DETACHED) {
676 Perl_croak(aTHX_ "Cannot join a detached thread");
678 Perl_croak(aTHX_ "Thread already joined");
682 /* Join the thread */
684 waitcode = WaitForSingleObject(thread->handle, INFINITE);
686 pthread_join(thread->thr, &retval);
689 MUTEX_LOCK(&thread->mutex);
691 thread->state |= PERL_ITHR_JOINED;
693 /* Get the return value from the call_sv */
696 PerlInterpreter *other_perl;
697 CLONE_PARAMS clone_params;
698 ithread *current_thread;
700 params_copy = (AV *)SvRV(thread->params);
701 other_perl = thread->interp;
702 clone_params.stashes = newAV();
703 clone_params.flags = CLONEf_JOIN_IN;
704 PL_ptr_table = ptr_table_new();
705 current_thread = S_ithread_get(aTHX);
706 S_ithread_set(aTHX_ thread);
707 /* Ensure 'meaningful' addresses retain their meaning */
708 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
709 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
710 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
711 params = (AV *)sv_dup((SV*)params_copy, &clone_params);
712 S_ithread_set(aTHX_ current_thread);
713 SvREFCNT_dec(clone_params.stashes);
714 SvREFCNT_inc(params);
715 ptr_table_free(PL_ptr_table);
719 /* We are finished with the thread */
720 S_ithread_clear(aTHX_ thread);
721 MUTEX_UNLOCK(&thread->mutex);
723 /* If no return values, then just return */
728 /* Put return values on stack */
729 len = (int)AvFILL(params);
730 for (ii=0; ii <= len; ii++) {
731 SV* param = av_shift(params);
732 XPUSHs(sv_2mortal(param));
735 /* Free return value array */
736 SvREFCNT_dec(params);
752 thread = SV_to_ithread(aTHX_ ST(0));
753 MUTEX_LOCK(&thread->mutex);
755 /* Check if the thread is detachable */
756 if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
757 MUTEX_UNLOCK(&thread->mutex);
758 if (detach_err & PERL_ITHR_DETACHED) {
759 Perl_croak(aTHX_ "Thread already detached");
761 Perl_croak(aTHX_ "Cannot detach a joined thread");
765 /* Detach the thread */
766 thread->state |= PERL_ITHR_DETACHED;
768 /* Windows has no 'detach thread' function */
770 PERL_THREAD_DETACH(thread->thr);
772 /* Cleanup if finished */
773 cleanup = (thread->state & PERL_ITHR_FINISHED);
774 MUTEX_UNLOCK(&thread->mutex);
777 S_ithread_destruct(aTHX_ thread);
783 sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
789 /* Compares TIDs to determine thread equality.
790 * Return 0 on false for backward compatibility.
792 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
793 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
794 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
795 if (thr1->tid == thr2->tid) {
803 /* XSRETURN(1); - implied */
814 /* Class method only */
816 Perl_croak(aTHX_ "Usage: threads->object($tid)");
817 classname = (char *)SvPV_nolen(ST(0));
819 if ((items < 2) || ! SvOK(ST(1))) {
825 /* Walk through threads list */
826 MUTEX_LOCK(&create_destruct_mutex);
827 for (thr = threads->next;
831 /* Look for TID, but ignore detached or joined threads */
832 if ((thr->tid != tid) ||
833 (thr->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
837 /* Put object on stack */
838 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ NULL, thr, classname, TRUE));
842 MUTEX_UNLOCK(&create_destruct_mutex);
846 /* XSRETURN(1); - implied */
850 ithread__handle(...);
854 thread = SV_to_ithread(aTHX_ ST(0));
856 XST_mUV(0, PTR2UV(&thread->handle));
858 XST_mUV(0, PTR2UV(&thread->thr));
860 /* XSRETURN(1); - implied */
862 #endif /* USE_ITHREADS */
867 /* The 'main' thread is thread 0.
868 * It is detached (unjoinable) and immortal.
873 PL_perl_destruct_level = 2;
874 MUTEX_INIT(&create_destruct_mutex);
875 MUTEX_LOCK(&create_destruct_mutex);
876 PL_threadhook = &Perl_ithread_hook;
877 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
879 PerlLIO_write(PerlIO_fileno(Perl_error_log),
880 PL_no_mem, strlen(PL_no_mem));
883 Zero(thread,1,ithread);
884 PL_perl_destruct_level = 2;
885 MUTEX_INIT(&thread->mutex);
887 /* Head of the threads list */
889 thread->next = thread;
890 thread->prev = thread;
892 thread->interp = aTHX;
893 thread->count = 1; /* Immortal. */
894 thread->tid = tid_counter++;
896 thread->state = PERL_ITHR_DETACHED;
898 thread->thr = GetCurrentThreadId();
900 thread->thr = pthread_self();
903 S_ithread_set(aTHX_ thread);
904 MUTEX_UNLOCK(&create_destruct_mutex);
905 #endif /* USE_ITHREADS */