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);
170 MUTEX_UNLOCK(&thread->mutex);
171 MUTEX_DESTROY(&thread->mutex);
174 CloseHandle(thread->handle);
177 PerlMemShared_free(thread);
181 Perl_ithread_hook(pTHX)
183 int veto_cleanup = 0;
184 MUTEX_LOCK(&create_destruct_mutex);
185 if (aTHX == PL_curinterp && active_threads != 1) {
186 if (ckWARN_d(WARN_THREADS))
187 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
191 MUTEX_UNLOCK(&create_destruct_mutex);
196 Perl_ithread_detach(pTHX_ ithread *thread)
198 MUTEX_LOCK(&thread->mutex);
199 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
200 thread->state |= PERL_ITHR_DETACHED;
202 CloseHandle(thread->handle);
205 PERL_THREAD_DETACH(thread->thr);
208 if ((thread->state & PERL_ITHR_FINISHED) &&
209 (thread->state & PERL_ITHR_DETACHED)) {
210 MUTEX_UNLOCK(&thread->mutex);
211 Perl_ithread_destruct(aTHX_ thread, "detach");
214 MUTEX_UNLOCK(&thread->mutex);
218 /* MAGIC (in mg.h sense) hooks */
221 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
223 ithread *thread = (ithread *) mg->mg_ptr;
224 SvIV_set(sv, PTR2IV(thread));
230 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
232 ithread *thread = (ithread *) mg->mg_ptr;
233 MUTEX_LOCK(&thread->mutex);
235 if (thread->count == 0) {
236 if(thread->state & PERL_ITHR_FINISHED &&
237 (thread->state & PERL_ITHR_DETACHED ||
238 thread->state & PERL_ITHR_JOINED))
240 MUTEX_UNLOCK(&thread->mutex);
241 Perl_ithread_destruct(aTHX_ thread, "no reference");
244 MUTEX_UNLOCK(&thread->mutex);
248 MUTEX_UNLOCK(&thread->mutex);
254 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
256 ithread *thread = (ithread *) mg->mg_ptr;
257 MUTEX_LOCK(&thread->mutex);
259 MUTEX_UNLOCK(&thread->mutex);
263 MGVTBL ithread_vtbl = {
264 ithread_mg_get, /* get */
268 ithread_mg_free, /* free */
270 ithread_mg_dup /* dup */
275 * Starts executing the thread. Needs to clean up memory a tad better.
276 * Passed as the C level function to run in the new thread
281 Perl_ithread_run(LPVOID arg) {
284 Perl_ithread_run(void * arg) {
286 ithread* thread = (ithread*) arg;
287 dTHXa(thread->interp);
288 PERL_SET_CONTEXT(thread->interp);
289 Perl_ithread_set(aTHX_ thread);
292 /* Far from clear messing with ->thr child-side is a good idea */
293 MUTEX_LOCK(&thread->mutex);
295 thread->thr = GetCurrentThreadId();
297 thread->thr = pthread_self();
299 MUTEX_UNLOCK(&thread->mutex);
302 PL_perl_destruct_level = 2;
305 AV* params = (AV*) SvRV(thread->params);
306 I32 len = av_len(params)+1;
312 for(i = 0; i < len; i++) {
313 XPUSHs(av_shift(params));
316 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
319 for (i=len-1; i >= 0; i--) {
321 av_store(params, i, SvREFCNT_inc(sv));
323 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
324 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
328 SvREFCNT_dec(thread->init_function);
331 PerlIO_flush((PerlIO*)NULL);
332 MUTEX_LOCK(&thread->mutex);
333 thread->state |= PERL_ITHR_FINISHED;
335 if (thread->state & PERL_ITHR_DETACHED) {
336 MUTEX_UNLOCK(&thread->mutex);
337 Perl_ithread_destruct(aTHX_ thread, "detached finish");
339 MUTEX_UNLOCK(&thread->mutex);
341 MUTEX_LOCK(&create_destruct_mutex);
343 assert( active_threads >= 0 );
344 MUTEX_UNLOCK(&create_destruct_mutex);
354 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
359 MUTEX_LOCK(&thread->mutex);
361 MUTEX_UNLOCK(&thread->mutex);
365 sv = newSVrv(obj,classname);
366 sv_setiv(sv,PTR2IV(thread));
367 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
368 mg->mg_flags |= MGf_DUP;
374 SV_to_ithread(pTHX_ SV *sv)
378 return INT2PTR(ithread*, SvIV(SvRV(sv)));
382 return Perl_ithread_get(aTHX);
387 * ithread->create(); ( aka ithread->new() )
388 * Called in context of parent thread
392 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
395 CLONE_PARAMS clone_param;
396 ithread* current_thread = Perl_ithread_get(aTHX);
398 SV** tmps_tmp = PL_tmps_stack;
399 I32 tmps_ix = PL_tmps_ix;
402 const char* panic = NULL;
406 MUTEX_LOCK(&create_destruct_mutex);
407 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
409 MUTEX_UNLOCK(&create_destruct_mutex);
410 PerlLIO_write(PerlIO_fileno(Perl_error_log),
411 PL_no_mem, strlen(PL_no_mem));
414 Zero(thread,1,ithread);
415 thread->next = threads;
416 thread->prev = threads->prev;
417 threads->prev = thread;
418 thread->prev->next = thread;
419 /* Set count to 1 immediately in case thread exits before
420 * we return to caller !
423 MUTEX_INIT(&thread->mutex);
424 thread->tid = tid_counter++;
425 thread->gimme = GIMME_V;
427 /* "Clone" our interpreter into the thread's interpreter
428 * This gives thread access to "static data" and code.
431 PerlIO_flush((PerlIO*)NULL);
432 Perl_ithread_set(aTHX_ thread);
434 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
436 PL_srand_called = FALSE; /* Set it to false so we can detect
437 if it gets set during the clone */
440 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
442 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
444 /* perl_clone leaves us in new interpreter's context.
445 As it is tricky to spot an implicit aTHX, create a new scope
446 with aTHX matching the context for the duration of
447 our work for new interpreter.
450 dTHXa(thread->interp);
454 /* Here we remove END blocks since they should only run
455 in the thread they are created
457 SvREFCNT_dec(PL_endav);
459 clone_param.flags = 0;
460 thread->init_function = sv_dup(init_function, &clone_param);
461 if (SvREFCNT(thread->init_function) == 0) {
462 SvREFCNT_inc(thread->init_function);
467 thread->params = sv_dup(params, &clone_param);
468 SvREFCNT_inc(thread->params);
471 /* The code below checks that anything living on
472 the tmps stack and has been cloned (so it lives in the
473 ptr_table) has a refcount higher than 0
475 If the refcount is 0 it means that a something on the
476 stack/context was holding a reference to it and
477 since we init_stacks() in perl_clone that won't get
478 cleaned and we will get a leaked scalar.
479 The reason it was cloned was that it lived on the
482 Example of this can be found in bugreport 15837
483 where calls in the parameter list end up as a temp
485 One could argue that this fix should be in perl_clone
489 while (tmps_ix > 0) {
490 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
492 if (sv && SvREFCNT(sv) == 0) {
500 SvTEMP_off(thread->init_function);
501 ptr_table_free(PL_ptr_table);
503 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
505 Perl_ithread_set(aTHX_ current_thread);
506 PERL_SET_CONTEXT(aTHX);
508 /* Start the thread */
511 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
512 (LPVOID)thread, 0, &thread->thr);
515 static pthread_attr_t attr;
516 static int attr_inited = 0;
517 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
520 pthread_attr_init(&attr);
522 # ifdef PTHREAD_ATTR_SETDETACHSTATE
523 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
525 # ifdef THREAD_CREATE_NEEDS_STACK
526 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
527 panic = "panic: pthread_attr_setstacksize failed";
530 #ifdef OLD_PTHREADS_API
532 = panic ? 1 : pthread_create( &thread->thr, attr,
533 Perl_ithread_run, (void *)thread);
535 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
536 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
539 = panic ? 1 : pthread_create( &thread->thr, &attr,
540 Perl_ithread_run, (void *)thread);
547 thread->handle == NULL
552 MUTEX_UNLOCK(&create_destruct_mutex);
554 Perl_ithread_destruct(aTHX_ thread, "create failed");
557 Perl_croak(aTHX_ panic);
562 MUTEX_UNLOCK(&create_destruct_mutex);
565 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
569 Perl_ithread_self (pTHX_ SV *obj, char* Class)
571 ithread *thread = Perl_ithread_get(aTHX);
573 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
575 Perl_croak(aTHX_ "panic: cannot find thread data");
576 return NULL; /* silence compiler warning */
580 * Joins the thread this code needs to take the returnvalue from the
581 * call_sv and send it back
585 Perl_ithread_CLONE(pTHX_ SV *obj)
588 ithread *thread = SV_to_ithread(aTHX_ obj);
590 else if (ckWARN_d(WARN_THREADS)) {
591 Perl_warn(aTHX_ "CLONE %" SVf,obj);
596 Perl_ithread_join(pTHX_ SV *obj)
598 ithread *thread = SV_to_ithread(aTHX_ obj);
599 MUTEX_LOCK(&thread->mutex);
600 if (thread->state & PERL_ITHR_DETACHED) {
601 MUTEX_UNLOCK(&thread->mutex);
602 Perl_croak(aTHX_ "Cannot join a detached thread");
604 else if (thread->state & PERL_ITHR_JOINED) {
605 MUTEX_UNLOCK(&thread->mutex);
606 Perl_croak(aTHX_ "Thread already joined");
615 MUTEX_UNLOCK(&thread->mutex);
617 waitcode = WaitForSingleObject(thread->handle, INFINITE);
618 CloseHandle(thread->handle);
621 pthread_join(thread->thr,&retval);
623 MUTEX_LOCK(&thread->mutex);
625 /* sv_dup over the args */
627 ithread* current_thread;
628 AV* params = (AV*) SvRV(thread->params);
629 PerlInterpreter *other_perl = thread->interp;
630 CLONE_PARAMS clone_params;
631 clone_params.stashes = newAV();
632 clone_params.flags |= CLONEf_JOIN_IN;
633 PL_ptr_table = ptr_table_new();
634 current_thread = Perl_ithread_get(aTHX);
635 Perl_ithread_set(aTHX_ thread);
636 /* ensure 'meaningful' addresses retain their meaning */
637 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
638 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
639 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
643 I32 len = av_len(params)+1;
645 for(i = 0; i < len; i++) {
646 sv_dump(SvRV(AvARRAY(params)[i]));
650 retparam = (AV*) sv_dup((SV*)params, &clone_params);
653 I32 len = av_len(retparam)+1;
655 for(i = 0; i < len; i++) {
656 sv_dump(SvRV(AvARRAY(retparam)[i]));
660 Perl_ithread_set(aTHX_ current_thread);
661 SvREFCNT_dec(clone_params.stashes);
662 SvREFCNT_inc(retparam);
663 ptr_table_free(PL_ptr_table);
667 /* We are finished with it */
668 thread->state |= PERL_ITHR_JOINED;
669 S_ithread_clear(aTHX_ thread);
670 MUTEX_UNLOCK(&thread->mutex);
678 Perl_ithread_DESTROY(pTHX_ SV *sv)
680 ithread *thread = SV_to_ithread(aTHX_ sv);
681 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
684 #endif /* USE_ITHREADS */
686 MODULE = threads PACKAGE = threads PREFIX = ithread_
692 ithread_new (classname, function_to_call, ...)
694 SV * function_to_call
697 AV* params = newAV();
700 for(i = 2; i < items ; i++) {
701 av_push(params, SvREFCNT_inc(ST(i)));
704 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
709 ithread_list(char *classname)
712 ithread *curr_thread;
713 MUTEX_LOCK(&create_destruct_mutex);
714 curr_thread = threads;
715 if(curr_thread->tid != 0)
716 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
718 curr_thread = curr_thread->next;
719 if(curr_thread == threads)
721 if(curr_thread->state & PERL_ITHR_DETACHED ||
722 curr_thread->state & PERL_ITHR_JOINED)
724 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
726 MUTEX_UNLOCK(&create_destruct_mutex);
731 ithread_self(char *classname)
734 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
739 ithread_tid(ithread *thread)
742 ithread_join(SV *obj)
745 AV* params = Perl_ithread_join(aTHX_ obj);
747 I32 len = AvFILL(params);
748 for (i = 0; i <= len; i++) {
749 SV* tmp = av_shift(params);
753 SvREFCNT_dec(params);
765 ithread_detach(ithread *thread)
768 ithread_DESTROY(SV *thread)
770 #endif /* USE_ITHREADS */
777 PL_perl_destruct_level = 2;
778 MUTEX_INIT(&create_destruct_mutex);
779 MUTEX_LOCK(&create_destruct_mutex);
780 PL_threadhook = &Perl_ithread_hook;
781 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
783 PerlLIO_write(PerlIO_fileno(Perl_error_log),
784 PL_no_mem, strlen(PL_no_mem));
787 Zero(thread,1,ithread);
788 PL_perl_destruct_level = 2;
789 MUTEX_INIT(&thread->mutex);
791 thread->next = thread;
792 thread->prev = thread;
793 thread->interp = aTHX;
794 thread->count = 1; /* Immortal. */
795 thread->tid = tid_counter++;
798 thread->state = PERL_ITHR_DETACHED;
800 thread->thr = GetCurrentThreadId();
802 thread->thr = pthread_self();
805 Perl_ithread_set(aTHX_ thread);
806 MUTEX_UNLOCK(&create_destruct_mutex);
807 #endif /* USE_ITHREADS */