1 #define PERL_NO_GET_CONTEXT
11 #include <win32thread.h>
14 typedef perl_os_thread pthread_t;
19 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
20 #ifdef OLD_PTHREADS_API
21 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
23 #define PERL_THREAD_DETACH(t) pthread_detach((t))
24 #endif /* OLD_PTHREADS_API */
30 /* Values for 'state' member */
31 #define PERL_ITHR_JOINABLE 0
32 #define PERL_ITHR_DETACHED 1
33 #define PERL_ITHR_FINISHED 4
34 #define PERL_ITHR_JOINED 2
36 typedef struct ithread_s {
37 struct ithread_s *next; /* Next thread in the list */
38 struct ithread_s *prev; /* Prev thread in the list */
39 PerlInterpreter *interp; /* The threads interpreter */
40 I32 tid; /* Threads module's thread id */
41 perl_mutex mutex; /* Mutex for updating things in this struct */
42 I32 count; /* How many SVs have a reference to us */
43 signed char state; /* Are we detached ? */
44 int gimme; /* Context of create */
45 SV* init_function; /* Code to run */
46 SV* params; /* Args to pass function */
48 DWORD thr; /* OS's idea if thread id */
49 HANDLE handle; /* OS's waitable handle */
51 pthread_t thr; /* OS's handle for the thread */
55 #define MY_CXT_KEY "threads::_guts" XS_VERSION
66 /* Macros to supply the aTHX_ in an embed.h like manner */
67 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
68 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
69 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
70 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
71 #define ithread_tid(thread) ((thread)->tid)
72 #define ithread_yield(thread) (YIELD);
74 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
77 I32 known_threads = 0;
78 I32 active_threads = 0;
81 void Perl_ithread_set (pTHX_ ithread* thread)
84 MY_CXT.thread = thread;
87 ithread* 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
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 I32 len = av_len(params)+1;
313 for(i = 0; i < len; i++) {
314 XPUSHs(av_shift(params));
317 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
320 for (i=len-1; i >= 0; i--) {
322 av_store(params, i, 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 I32 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 */
581 * Joins the thread this code needs to take the returnvalue from the
582 * call_sv and send it back
586 Perl_ithread_CLONE(pTHX_ SV *obj)
589 ithread *thread = SV_to_ithread(aTHX_ obj);
591 else if (ckWARN_d(WARN_THREADS)) {
592 Perl_warn(aTHX_ "CLONE %" SVf,obj);
597 Perl_ithread_join(pTHX_ SV *obj)
599 ithread *thread = SV_to_ithread(aTHX_ obj);
600 MUTEX_LOCK(&thread->mutex);
601 if (thread->state & PERL_ITHR_DETACHED) {
602 MUTEX_UNLOCK(&thread->mutex);
603 Perl_croak(aTHX_ "Cannot join a detached thread");
605 else if (thread->state & PERL_ITHR_JOINED) {
606 MUTEX_UNLOCK(&thread->mutex);
607 Perl_croak(aTHX_ "Thread already joined");
616 MUTEX_UNLOCK(&thread->mutex);
618 waitcode = WaitForSingleObject(thread->handle, INFINITE);
619 CloseHandle(thread->handle);
622 pthread_join(thread->thr,&retval);
624 MUTEX_LOCK(&thread->mutex);
626 /* sv_dup over the args */
628 ithread* current_thread;
629 AV* params = (AV*) SvRV(thread->params);
630 PerlInterpreter *other_perl = thread->interp;
631 CLONE_PARAMS clone_params;
632 clone_params.stashes = newAV();
633 clone_params.flags = CLONEf_JOIN_IN;
634 PL_ptr_table = ptr_table_new();
635 current_thread = Perl_ithread_get(aTHX);
636 Perl_ithread_set(aTHX_ thread);
637 /* ensure 'meaningful' addresses retain their meaning */
638 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
639 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
640 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
644 I32 len = av_len(params)+1;
646 for(i = 0; i < len; i++) {
647 sv_dump(SvRV(AvARRAY(params)[i]));
651 retparam = (AV*) sv_dup((SV*)params, &clone_params);
654 I32 len = av_len(retparam)+1;
656 for(i = 0; i < len; i++) {
657 sv_dump(SvRV(AvARRAY(retparam)[i]));
661 Perl_ithread_set(aTHX_ current_thread);
662 SvREFCNT_dec(clone_params.stashes);
663 SvREFCNT_inc(retparam);
664 ptr_table_free(PL_ptr_table);
668 /* We are finished with it */
669 thread->state |= PERL_ITHR_JOINED;
670 S_ithread_clear(aTHX_ thread);
671 MUTEX_UNLOCK(&thread->mutex);
679 Perl_ithread_DESTROY(pTHX_ SV *sv)
681 ithread *thread = SV_to_ithread(aTHX_ sv);
682 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
685 #endif /* USE_ITHREADS */
687 MODULE = threads PACKAGE = threads PREFIX = ithread_
693 ithread_new (classname, function_to_call, ...)
695 SV * function_to_call
698 AV* params = newAV();
701 for(i = 2; i < items ; i++) {
702 av_push(params, SvREFCNT_inc(ST(i)));
705 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
710 ithread_list(char *classname)
713 ithread *curr_thread;
714 MUTEX_LOCK(&create_destruct_mutex);
715 curr_thread = threads;
716 if(curr_thread->tid != 0)
717 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
719 curr_thread = curr_thread->next;
720 if(curr_thread == threads)
722 if(curr_thread->state & PERL_ITHR_DETACHED ||
723 curr_thread->state & PERL_ITHR_JOINED)
725 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
727 MUTEX_UNLOCK(&create_destruct_mutex);
732 ithread_self(char *classname)
735 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
740 ithread_tid(ithread *thread)
743 ithread_join(SV *obj)
746 AV* params = Perl_ithread_join(aTHX_ obj);
748 I32 len = AvFILL(params);
749 for (i = 0; i <= len; i++) {
750 SV* tmp = av_shift(params);
754 SvREFCNT_dec(params);
766 ithread_detach(ithread *thread)
769 ithread_DESTROY(SV *thread)
771 #endif /* USE_ITHREADS */
778 PL_perl_destruct_level = 2;
779 MUTEX_INIT(&create_destruct_mutex);
780 MUTEX_LOCK(&create_destruct_mutex);
781 PL_threadhook = &Perl_ithread_hook;
782 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
784 PerlLIO_write(PerlIO_fileno(Perl_error_log),
785 PL_no_mem, strlen(PL_no_mem));
788 Zero(thread,1,ithread);
789 PL_perl_destruct_level = 2;
790 MUTEX_INIT(&thread->mutex);
792 thread->next = thread;
793 thread->prev = thread;
794 thread->interp = aTHX;
795 thread->count = 1; /* Immortal. */
796 thread->tid = tid_counter++;
799 thread->state = PERL_ITHR_DETACHED;
801 thread->thr = GetCurrentThreadId();
803 thread->thr = pthread_self();
806 Perl_ithread_set(aTHX_ thread);
807 MUTEX_UNLOCK(&create_destruct_mutex);
808 #endif /* USE_ITHREADS */