1 #define PERL_NO_GET_CONTEXT
6 # define NEED_newRV_noinc
7 # define NEED_sv_2pv_nolen
16 # include <win32thread.h>
19 typedef perl_os_thread pthread_t;
24 # define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
25 # ifdef OLD_PTHREADS_API
26 # define PERL_THREAD_DETACH(t) pthread_detach(&(t))
28 # define PERL_THREAD_DETACH(t) pthread_detach((t))
32 /* Values for 'state' member */
33 #define PERL_ITHR_JOINABLE 0
34 #define PERL_ITHR_DETACHED 1
35 #define PERL_ITHR_JOINED 2
36 #define PERL_ITHR_FINISHED 4
38 typedef struct _ithread {
39 struct _ithread *next; /* Next thread in the list */
40 struct _ithread *prev; /* Prev thread in the list */
41 PerlInterpreter *interp; /* The threads interpreter */
42 UV tid; /* Threads module's thread id */
43 perl_mutex mutex; /* Mutex for updating things in this struct */
44 int count; /* How many SVs have a reference to us */
45 int state; /* Detached, joined, finished, etc. */
46 int gimme; /* Context of create */
47 SV *init_function; /* Code to run */
48 SV *params; /* Args to pass function */
50 DWORD thr; /* OS's idea if thread id */
51 HANDLE handle; /* OS's waitable handle */
53 pthread_t thr; /* OS's handle for the thread */
58 /* Used by Perl interpreter for thread context switching */
59 #define MY_CXT_KEY "threads::_guts" XS_VERSION
68 /* Linked list of all threads */
69 static ithread *threads;
71 /* Protects the creation and destruction of threads*/
72 static perl_mutex create_destruct_mutex;
74 static UV tid_counter = 0;
75 static IV active_threads = 0;
78 /* Used by Perl interpreter for thread context switching */
80 S_ithread_set(pTHX_ ithread *thread)
83 MY_CXT.thread = thread;
90 return (MY_CXT.thread);
94 /* Free any data (such as the Perl interpreter) attached to an ithread
95 * structure. This is a bit like undef on SVs, where the SV isn't freed,
96 * but the PVX is. Must be called with thread->mutex already held.
99 S_ithread_clear(pTHX_ ithread *thread)
101 PerlInterpreter *interp;
103 assert(thread->state & PERL_ITHR_FINISHED &&
104 thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
106 interp = thread->interp;
110 PERL_SET_CONTEXT(interp);
111 S_ithread_set(aTHX_ thread);
113 SvREFCNT_dec(thread->params);
114 thread->params = Nullsv;
116 perl_destruct(interp);
117 thread->interp = NULL;
122 PERL_SET_CONTEXT(aTHX);
126 /* 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);
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", active_threads);
188 MUTEX_UNLOCK(&create_destruct_mutex);
189 return (veto_cleanup);
193 /* MAGIC (in mg.h sense) hooks */
196 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
198 ithread *thread = (ithread *)mg->mg_ptr;
199 SvIV_set(sv, PTR2IV(thread));
205 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
207 ithread *thread = (ithread *)mg->mg_ptr;
210 MUTEX_LOCK(&thread->mutex);
211 cleanup = ((--thread->count == 0) &&
212 (thread->state & PERL_ITHR_FINISHED) &&
213 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)));
214 MUTEX_UNLOCK(&thread->mutex);
217 S_ithread_destruct(aTHX_ thread);
222 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
224 ithread *thread = (ithread *)mg->mg_ptr;
225 MUTEX_LOCK(&thread->mutex);
227 MUTEX_UNLOCK(&thread->mutex);
231 MGVTBL ithread_vtbl = {
232 ithread_mg_get, /* get */
236 ithread_mg_free, /* free */
238 ithread_mg_dup /* dup */
242 /* Starts executing the thread.
243 * 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)
253 ithread *thread = (ithread *)arg;
256 dTHXa(thread->interp);
257 PERL_SET_CONTEXT(thread->interp);
258 S_ithread_set(aTHX_ thread);
261 /* Far from clear messing with ->thr child-side is a good idea */
262 MUTEX_LOCK(&thread->mutex);
264 thread->thr = GetCurrentThreadId();
266 thread->thr = pthread_self();
268 MUTEX_UNLOCK(&thread->mutex);
271 PL_perl_destruct_level = 2;
274 AV *params = (AV *)SvRV(thread->params);
275 int len = (int)av_len(params)+1;
282 /* Put args on the stack */
284 for (ii=0; ii < len; ii++) {
285 XPUSHs(av_shift(params));
289 /* Run the specified function */
290 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
292 /* Remove args from stack and put back in params array */
294 for (ii=len-1; ii >= 0; ii--) {
296 av_store(params, ii, SvREFCNT_inc(sv));
299 /* Check for failure */
300 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
301 Perl_warn(aTHX_ "Thread failed to start: %" SVf, ERRSV);
307 /* Release function ref */
308 SvREFCNT_dec(thread->init_function);
309 thread->init_function = Nullsv;
312 PerlIO_flush((PerlIO *)NULL);
314 MUTEX_LOCK(&thread->mutex);
315 /* Mark as finished */
316 thread->state |= PERL_ITHR_FINISHED;
317 /* Cleanup if detached */
318 cleanup = (thread->state & PERL_ITHR_DETACHED);
319 MUTEX_UNLOCK(&thread->mutex);
322 S_ithread_destruct(aTHX_ thread);
324 MUTEX_LOCK(&create_destruct_mutex);
326 MUTEX_UNLOCK(&create_destruct_mutex);
336 /* Type conversion helper functions */
338 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
344 MUTEX_LOCK(&thread->mutex);
346 MUTEX_UNLOCK(&thread->mutex);
353 sv = newSVrv(obj, classname);
354 sv_setiv(sv, PTR2IV(thread));
355 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0);
356 mg->mg_flags |= MGf_DUP;
363 SV_to_ithread(pTHX_ SV *sv)
365 /* Argument is a thread */
367 return (INT2PTR(ithread *, SvIV(SvRV(sv))));
369 /* Argument is classname, therefore return current thread */
370 return (S_ithread_get(aTHX));
375 * Called in context of parent thread.
385 CLONE_PARAMS clone_param;
386 ithread *current_thread = S_ithread_get(aTHX);
388 SV **tmps_tmp = PL_tmps_stack;
389 IV tmps_ix = PL_tmps_ix;
391 int rc_stack_size = 0;
392 int rc_thread_create = 0;
395 MUTEX_LOCK(&create_destruct_mutex);
397 /* Allocate thread structure */
398 thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
400 MUTEX_UNLOCK(&create_destruct_mutex);
401 PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
404 Zero(thread, 1, ithread);
406 /* Add to threads list */
407 thread->next = threads;
408 thread->prev = threads->prev;
409 threads->prev = thread;
410 thread->prev->next = thread;
412 /* Set count to 1 immediately in case thread exits before
413 * we return to caller!
417 MUTEX_INIT(&thread->mutex);
418 thread->tid = tid_counter++;
419 thread->gimme = GIMME_V;
421 /* "Clone" our interpreter into the thread's interpreter.
422 * This gives thread access to "static data" and code.
424 PerlIO_flush((PerlIO *)NULL);
425 S_ithread_set(aTHX_ thread);
427 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */
428 PL_srand_called = FALSE; /* Set it to false so we can detect if it gets
429 set during the clone */
432 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
434 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
437 /* perl_clone() leaves us in new interpreter's context. As it is tricky
438 * to spot an implicit aTHX, create a new scope with aTHX matching the
439 * context for the duration of our work for new interpreter.
442 dTHXa(thread->interp);
446 /* Here we remove END blocks since they should only run in the thread
449 SvREFCNT_dec(PL_endav);
451 clone_param.flags = 0;
452 thread->init_function = sv_dup(init_function, &clone_param);
453 if (SvREFCNT(thread->init_function) == 0) {
454 SvREFCNT_inc(thread->init_function);
457 thread->params = sv_dup(params, &clone_param);
458 SvREFCNT_inc(thread->params);
460 /* The code below checks that anything living on the tmps stack and
461 * has been cloned (so it lives in the ptr_table) has a refcount
464 * If the refcount is 0 it means that a something on the stack/context
465 * was holding a reference to it and since we init_stacks() in
466 * perl_clone that won't get cleaned and we will get a leaked scalar.
467 * The reason it was cloned was that it lived on the @_ stack.
469 * Example of this can be found in bugreport 15837 where calls in the
470 * parameter list end up as a temp.
472 * One could argue that this fix should be in perl_clone.
474 while (tmps_ix > 0) {
475 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
477 if (sv && SvREFCNT(sv) == 0) {
483 SvTEMP_off(thread->init_function);
484 ptr_table_free(PL_ptr_table);
486 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
488 S_ithread_set(aTHX_ current_thread);
489 PERL_SET_CONTEXT(aTHX);
491 /* Create/start the thread */
493 thread->handle = CreateThread(NULL,
501 static pthread_attr_t attr;
502 static int attr_inited = 0;
503 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
505 pthread_attr_init(&attr);
509 # ifdef PTHREAD_ATTR_SETDETACHSTATE
510 /* Threads start out joinable */
511 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
514 # ifdef THREAD_CREATE_NEEDS_STACK
515 /* Set thread's stack size */
516 rc_stack_size = pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK);
519 /* Create the thread */
520 if (! rc_stack_size) {
521 # ifdef OLD_PTHREADS_API
522 rc_thread_create = pthread_create(&thread->thr,
527 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
528 pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
530 rc_thread_create = pthread_create(&thread->thr,
539 /* Check for errors */
541 if (thread->handle == NULL) {
543 if (rc_stack_size || rc_thread_create) {
545 MUTEX_UNLOCK(&create_destruct_mutex);
547 S_ithread_destruct(aTHX_ thread);
549 if (ckWARN_d(WARN_THREADS)) {
550 # ifdef THREAD_CREATE_NEEDS_STACK
552 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", (IV)THREAD_CREATE_NEEDS_STACK, rc_stack_size);
555 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
558 return (&PL_sv_undef);
562 MUTEX_UNLOCK(&create_destruct_mutex);
566 return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
569 #endif /* USE_ITHREADS */
572 MODULE = threads PACKAGE = threads PREFIX = ithread_
581 SV *function_to_call;
586 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
588 classname = (char *)SvPV_nolen(ST(0));
589 function_to_call = ST(1);
594 for (ii=2; ii < items; ii++) {
595 av_push(params, SvREFCNT_inc(ST(ii)));
600 ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
603 newRV_noinc((SV*)params)));
604 /* XSRETURN(1); - implied */
615 /* Class method only */
617 Perl_croak(aTHX_ "Usage: threads->list()");
618 classname = (char *)SvPV_nolen(ST(0));
620 /* Calling context */
621 list_context = (GIMME_V == G_ARRAY);
623 /* Walk through threads list */
624 MUTEX_LOCK(&create_destruct_mutex);
625 for (thread = threads->next;
627 thread = thread->next)
629 /* Ignore detached or joined threads */
630 if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
633 /* Push object on stack if list context */
635 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
639 MUTEX_UNLOCK(&create_destruct_mutex);
640 /* If scalar context, send back count */
641 if (! list_context) {
652 /* Class method only */
654 Perl_croak(aTHX_ "Usage: threads->self()");
655 classname = (char *)SvPV_nolen(ST(0));
657 thread = S_ithread_get(aTHX);
659 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
660 /* XSRETURN(1); - implied */
668 thread = SV_to_ithread(aTHX_ ST(0));
669 XST_mUV(0, thread->tid);
670 /* XSRETURN(1); - implied */
687 /* Object method only */
688 if (! sv_isobject(ST(0)))
689 Perl_croak(aTHX_ "Usage: $thr->join()");
691 /* Check if the thread is joinable */
692 thread = SV_to_ithread(aTHX_ ST(0));
693 MUTEX_LOCK(&thread->mutex);
694 join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
695 MUTEX_UNLOCK(&thread->mutex);
697 if (join_err & PERL_ITHR_DETACHED) {
698 Perl_croak(aTHX_ "Cannot join a detached thread");
700 Perl_croak(aTHX_ "Thread already joined");
704 /* Join the thread */
706 waitcode = WaitForSingleObject(thread->handle, INFINITE);
708 pthread_join(thread->thr, &retval);
711 MUTEX_LOCK(&thread->mutex);
713 thread->state |= PERL_ITHR_JOINED;
715 /* Get the return value from the call_sv */
718 PerlInterpreter *other_perl;
719 CLONE_PARAMS clone_params;
720 ithread *current_thread;
722 params_copy = (AV *)SvRV(thread->params);
723 other_perl = thread->interp;
724 clone_params.stashes = newAV();
725 clone_params.flags = CLONEf_JOIN_IN;
726 PL_ptr_table = ptr_table_new();
727 current_thread = S_ithread_get(aTHX);
728 S_ithread_set(aTHX_ thread);
729 /* Ensure 'meaningful' addresses retain their meaning */
730 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
731 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
732 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
733 params = (AV *)sv_dup((SV*)params_copy, &clone_params);
734 S_ithread_set(aTHX_ current_thread);
735 SvREFCNT_dec(clone_params.stashes);
736 SvREFCNT_inc(params);
737 ptr_table_free(PL_ptr_table);
741 /* We are finished with the thread */
742 S_ithread_clear(aTHX_ thread);
743 MUTEX_UNLOCK(&thread->mutex);
745 /* If no return values, then just return */
750 /* Put return values on stack */
751 len = (int)AvFILL(params);
752 for (ii=0; ii <= len; ii++) {
753 SV* param = av_shift(params);
754 XPUSHs(sv_2mortal(param));
757 /* Free return value array */
758 SvREFCNT_dec(params);
774 thread = SV_to_ithread(aTHX_ ST(0));
775 MUTEX_LOCK(&thread->mutex);
777 /* Check if the thread is detachable */
778 if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
779 MUTEX_UNLOCK(&thread->mutex);
780 if (detach_err & PERL_ITHR_DETACHED) {
781 Perl_croak(aTHX_ "Thread already detached");
783 Perl_croak(aTHX_ "Cannot detach a joined thread");
787 /* Detach the thread */
788 thread->state |= PERL_ITHR_DETACHED;
790 /* Windows has no 'detach thread' function */
792 PERL_THREAD_DETACH(thread->thr);
794 /* Cleanup if finished */
795 cleanup = (thread->state & PERL_ITHR_FINISHED);
796 MUTEX_UNLOCK(&thread->mutex);
799 S_ithread_destruct(aTHX_ thread);
805 sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
813 /* Compares TIDs to determine thread equality */
814 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
815 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
816 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
817 are_equal = (thr1->tid == thr2->tid);
822 /* Return 0 on false for backward compatibility */
825 /* XSRETURN(1); - implied */
836 /* Class method only */
838 Perl_croak(aTHX_ "Usage: threads->object($tid)");
839 classname = (char *)SvPV_nolen(ST(0));
841 if ((items < 2) || ! SvOK(ST(1))) {
845 /* threads->object($tid) */
848 /* Walk through threads list */
849 MUTEX_LOCK(&create_destruct_mutex);
850 for (thread = threads->next;
852 thread = thread->next)
854 /* Look for TID, but ignore detached or joined threads */
855 if ((thread->tid != tid) ||
856 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
860 /* Put object on stack */
861 ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
865 MUTEX_UNLOCK(&create_destruct_mutex);
869 /* XSRETURN(1); - implied */
873 ithread__handle(...);
877 thread = SV_to_ithread(aTHX_ ST(0));
879 XST_mUV(0, PTR2UV(&thread->handle));
881 XST_mUV(0, PTR2UV(&thread->thr));
883 /* XSRETURN(1); - implied */
885 #endif /* USE_ITHREADS */
891 /* The 'main' thread is thread 0.
892 * It is detached (unjoinable) and immortal.
898 PL_perl_destruct_level = 2;
899 MUTEX_INIT(&create_destruct_mutex);
900 MUTEX_LOCK(&create_destruct_mutex);
902 PL_threadhook = &Perl_ithread_hook;
904 thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
906 PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
909 Zero(thread, 1, ithread);
911 PL_perl_destruct_level = 2;
912 MUTEX_INIT(&thread->mutex);
914 thread->tid = tid_counter++; /* Thread 0 */
916 /* Head of the threads list */
918 thread->next = thread;
919 thread->prev = thread;
921 thread->count = 1; /* Immortal */
923 thread->interp = aTHX;
924 thread->state = PERL_ITHR_DETACHED; /* Detached */
926 thread->thr = GetCurrentThreadId();
928 thread->thr = pthread_self();
933 S_ithread_set(aTHX_ thread);
934 MUTEX_UNLOCK(&create_destruct_mutex);
935 #endif /* USE_ITHREADS */