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 */
57 /* Macros to supply the aTHX_ in an embed.h like manner */
58 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
59 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
60 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
61 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
62 #define ithread_tid(thread) ((thread)->tid)
63 #define ithread_yield(thread) (YIELD);
65 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
68 I32 known_threads = 0;
69 I32 active_threads = 0;
72 void Perl_ithread_set (pTHX_ ithread* thread)
74 SV* thread_sv = newSViv(PTR2IV(thread));
75 if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
76 croak("%s\n","Internal error, couldn't set TLS");
80 ithread* Perl_ithread_get (pTHX) {
81 SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
83 croak("%s\n","Internal error, couldn't get TLS");
85 return INT2PTR(ithread*,SvIV(*thread_sv));
91 * Clear up after thread is done with
94 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
96 PerlInterpreter *freeperl = NULL;
97 MUTEX_LOCK(&thread->mutex);
99 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
101 if (thread->count != 0) {
102 MUTEX_UNLOCK(&thread->mutex);
105 MUTEX_LOCK(&create_destruct_mutex);
106 /* Remove from circular list of threads */
107 if (thread->next == thread) {
108 /* last one should never get here ? */
112 thread->next->prev = thread->prev;
113 thread->prev->next = thread->next;
114 if (threads == thread) {
115 threads = thread->next;
121 assert( known_threads >= 0 );
123 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
124 thread->tid,thread->interp,aTHX, known_threads);
126 MUTEX_UNLOCK(&create_destruct_mutex);
127 /* Thread is now disowned */
130 dTHXa(thread->interp);
131 ithread* current_thread;
135 PERL_SET_CONTEXT(thread->interp);
136 current_thread = Perl_ithread_get(aTHX);
137 Perl_ithread_set(aTHX_ thread);
142 SvREFCNT_dec(thread->params);
146 thread->params = Nullsv;
147 perl_destruct(thread->interp);
148 freeperl = thread->interp;
149 thread->interp = NULL;
151 MUTEX_UNLOCK(&thread->mutex);
152 MUTEX_DESTROY(&thread->mutex);
155 CloseHandle(thread->handle);
158 PerlMemShared_free(thread);
162 PERL_SET_CONTEXT(aTHX);
166 Perl_ithread_hook(pTHX)
168 int veto_cleanup = 0;
169 MUTEX_LOCK(&create_destruct_mutex);
170 if (aTHX == PL_curinterp && active_threads != 1) {
171 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
175 MUTEX_UNLOCK(&create_destruct_mutex);
180 Perl_ithread_detach(pTHX_ ithread *thread)
182 MUTEX_LOCK(&thread->mutex);
183 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
184 thread->state |= PERL_ITHR_DETACHED;
186 CloseHandle(thread->handle);
189 PERL_THREAD_DETACH(thread->thr);
192 if ((thread->state & PERL_ITHR_FINISHED) &&
193 (thread->state & PERL_ITHR_DETACHED)) {
194 MUTEX_UNLOCK(&thread->mutex);
195 Perl_ithread_destruct(aTHX_ thread, "detach");
198 MUTEX_UNLOCK(&thread->mutex);
202 /* MAGIC (in mg.h sense) hooks */
205 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
207 ithread *thread = (ithread *) mg->mg_ptr;
208 SvIVX(sv) = PTR2IV(thread);
214 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
216 ithread *thread = (ithread *) mg->mg_ptr;
217 MUTEX_LOCK(&thread->mutex);
219 if (thread->count == 0) {
220 if(thread->state & PERL_ITHR_FINISHED &&
221 (thread->state & PERL_ITHR_DETACHED ||
222 thread->state & PERL_ITHR_JOINED))
224 MUTEX_UNLOCK(&thread->mutex);
225 Perl_ithread_destruct(aTHX_ thread, "no reference");
228 MUTEX_UNLOCK(&thread->mutex);
232 MUTEX_UNLOCK(&thread->mutex);
238 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
240 ithread *thread = (ithread *) mg->mg_ptr;
241 MUTEX_LOCK(&thread->mutex);
243 MUTEX_UNLOCK(&thread->mutex);
247 MGVTBL ithread_vtbl = {
248 ithread_mg_get, /* get */
252 ithread_mg_free, /* free */
254 ithread_mg_dup /* dup */
259 * Starts executing the thread. Needs to clean up memory a tad better.
260 * Passed as the C level function to run in the new thread
265 Perl_ithread_run(LPVOID arg) {
268 Perl_ithread_run(void * arg) {
270 ithread* thread = (ithread*) arg;
271 dTHXa(thread->interp);
272 PERL_SET_CONTEXT(thread->interp);
273 Perl_ithread_set(aTHX_ thread);
276 /* Far from clear messing with ->thr child-side is a good idea */
277 MUTEX_LOCK(&thread->mutex);
279 thread->thr = GetCurrentThreadId();
281 thread->thr = pthread_self();
283 MUTEX_UNLOCK(&thread->mutex);
286 PL_perl_destruct_level = 2;
289 AV* params = (AV*) SvRV(thread->params);
290 I32 len = av_len(params)+1;
296 for(i = 0; i < len; i++) {
297 XPUSHs(av_shift(params));
300 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
303 for (i=len-1; i >= 0; i--) {
305 av_store(params, i, SvREFCNT_inc(sv));
308 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
312 SvREFCNT_dec(thread->init_function);
315 PerlIO_flush((PerlIO*)NULL);
316 MUTEX_LOCK(&thread->mutex);
317 thread->state |= PERL_ITHR_FINISHED;
319 if (thread->state & PERL_ITHR_DETACHED) {
320 MUTEX_UNLOCK(&thread->mutex);
321 Perl_ithread_destruct(aTHX_ thread, "detached finish");
323 MUTEX_UNLOCK(&thread->mutex);
325 MUTEX_LOCK(&create_destruct_mutex);
327 assert( active_threads >= 0 );
328 MUTEX_UNLOCK(&create_destruct_mutex);
338 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
343 MUTEX_LOCK(&thread->mutex);
345 MUTEX_UNLOCK(&thread->mutex);
349 sv = newSVrv(obj,classname);
350 sv_setiv(sv,PTR2IV(thread));
351 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
352 mg->mg_flags |= MGf_DUP;
358 SV_to_ithread(pTHX_ SV *sv)
362 return INT2PTR(ithread*, SvIV(SvRV(sv)));
366 return Perl_ithread_get(aTHX);
371 * ithread->create(); ( aka ithread->new() )
372 * Called in context of parent thread
376 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
379 CLONE_PARAMS clone_param;
380 ithread* current_thread = Perl_ithread_get(aTHX);
382 SV** tmps_tmp = PL_tmps_stack;
383 I32 tmps_ix = PL_tmps_ix;
386 const char* panic = NULL;
390 MUTEX_LOCK(&create_destruct_mutex);
391 thread = PerlMemShared_malloc(sizeof(ithread));
392 Zero(thread,1,ithread);
393 thread->next = threads;
394 thread->prev = threads->prev;
395 threads->prev = thread;
396 thread->prev->next = thread;
397 /* Set count to 1 immediately in case thread exits before
398 * we return to caller !
401 MUTEX_INIT(&thread->mutex);
402 thread->tid = tid_counter++;
403 thread->gimme = GIMME_V;
405 /* "Clone" our interpreter into the thread's interpreter
406 * This gives thread access to "static data" and code.
409 PerlIO_flush((PerlIO*)NULL);
410 Perl_ithread_set(aTHX_ thread);
412 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
414 PL_srand_called = FALSE; /* Set it to false so we can detect
415 if it gets set during the clone */
418 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
420 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
422 /* perl_clone leaves us in new interpreter's context.
423 As it is tricky to spot an implicit aTHX, create a new scope
424 with aTHX matching the context for the duration of
425 our work for new interpreter.
428 dTHXa(thread->interp);
430 /* Here we remove END blocks since they should only run
431 in the thread they are created
433 SvREFCNT_dec(PL_endav);
435 clone_param.flags = 0;
436 thread->init_function = sv_dup(init_function, &clone_param);
437 if (SvREFCNT(thread->init_function) == 0) {
438 SvREFCNT_inc(thread->init_function);
443 thread->params = sv_dup(params, &clone_param);
444 SvREFCNT_inc(thread->params);
447 /* The code below checks that anything living on
448 the tmps stack and has been cloned (so it lives in the
449 ptr_table) has a refcount higher than 0
451 If the refcount is 0 it means that a something on the
452 stack/context was holding a reference to it and
453 since we init_stacks() in perl_clone that won't get
454 cleaned and we will get a leaked scalar.
455 The reason it was cloned was that it lived on the
458 Example of this can be found in bugreport 15837
459 where calls in the parameter list end up as a temp
461 One could argue that this fix should be in perl_clone
465 while (tmps_ix > 0) {
466 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
468 if (sv && SvREFCNT(sv) == 0) {
476 SvTEMP_off(thread->init_function);
477 ptr_table_free(PL_ptr_table);
479 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
481 Perl_ithread_set(aTHX_ current_thread);
482 PERL_SET_CONTEXT(aTHX);
484 /* Start the thread */
487 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
488 (LPVOID)thread, 0, &thread->thr);
491 static pthread_attr_t attr;
492 static int attr_inited = 0;
493 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
496 pthread_attr_init(&attr);
498 # ifdef PTHREAD_ATTR_SETDETACHSTATE
499 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
501 # ifdef THREAD_CREATE_NEEDS_STACK
502 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
503 panic = "panic: pthread_attr_setstacksize failed";
506 #ifdef OLD_PTHREADS_API
508 = panic ? 1 : pthread_create( &thread->thr, attr,
509 Perl_ithread_run, (void *)thread);
511 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
512 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
515 = panic ? 1 : pthread_create( &thread->thr, &attr,
516 Perl_ithread_run, (void *)thread);
523 thread->handle == NULL
528 MUTEX_UNLOCK(&create_destruct_mutex);
530 Perl_ithread_destruct(aTHX_ thread, "create failed");
533 Perl_croak(aTHX_ panic);
538 MUTEX_UNLOCK(&create_destruct_mutex);
541 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
545 Perl_ithread_self (pTHX_ SV *obj, char* Class)
547 ithread *thread = Perl_ithread_get(aTHX);
549 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
551 Perl_croak(aTHX_ "panic: cannot find thread data");
552 return NULL; /* silence compiler warning */
556 * Joins the thread this code needs to take the returnvalue from the
557 * call_sv and send it back
561 Perl_ithread_CLONE(pTHX_ SV *obj)
565 ithread *thread = SV_to_ithread(aTHX_ obj);
569 Perl_warn(aTHX_ "CLONE %" SVf,obj);
574 Perl_ithread_join(pTHX_ SV *obj)
576 ithread *thread = SV_to_ithread(aTHX_ obj);
577 MUTEX_LOCK(&thread->mutex);
578 if (thread->state & PERL_ITHR_DETACHED) {
579 MUTEX_UNLOCK(&thread->mutex);
580 Perl_croak(aTHX_ "Cannot join a detached thread");
582 else if (thread->state & PERL_ITHR_JOINED) {
583 MUTEX_UNLOCK(&thread->mutex);
584 Perl_croak(aTHX_ "Thread already joined");
593 MUTEX_UNLOCK(&thread->mutex);
595 waitcode = WaitForSingleObject(thread->handle, INFINITE);
596 CloseHandle(thread->handle);
599 pthread_join(thread->thr,&retval);
601 MUTEX_LOCK(&thread->mutex);
603 /* sv_dup over the args */
605 ithread* current_thread;
606 AV* params = (AV*) SvRV(thread->params);
607 PerlInterpreter *other_perl = thread->interp;
608 CLONE_PARAMS clone_params;
609 clone_params.stashes = newAV();
610 clone_params.flags |= CLONEf_JOIN_IN;
611 PL_ptr_table = ptr_table_new();
612 current_thread = Perl_ithread_get(aTHX);
613 Perl_ithread_set(aTHX_ thread);
614 /* ensure 'meaningful' addresses retain their meaning */
615 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
616 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
617 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
621 I32 len = av_len(params)+1;
623 for(i = 0; i < len; i++) {
624 sv_dump(SvRV(AvARRAY(params)[i]));
628 retparam = (AV*) sv_dup((SV*)params, &clone_params);
631 I32 len = av_len(retparam)+1;
633 for(i = 0; i < len; i++) {
634 sv_dump(SvRV(AvARRAY(retparam)[i]));
638 Perl_ithread_set(aTHX_ current_thread);
639 SvREFCNT_dec(clone_params.stashes);
640 SvREFCNT_inc(retparam);
641 ptr_table_free(PL_ptr_table);
645 /* We are finished with it */
646 thread->state |= PERL_ITHR_JOINED;
647 MUTEX_UNLOCK(&thread->mutex);
655 Perl_ithread_DESTROY(pTHX_ SV *sv)
657 ithread *thread = SV_to_ithread(aTHX_ sv);
658 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
661 #endif /* USE_ITHREADS */
663 MODULE = threads PACKAGE = threads PREFIX = ithread_
669 ithread_new (classname, function_to_call, ...)
671 SV * function_to_call
674 AV* params = newAV();
677 for(i = 2; i < items ; i++) {
678 av_push(params, SvREFCNT_inc(ST(i)));
681 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
686 ithread_list(char *classname)
689 ithread *curr_thread;
690 MUTEX_LOCK(&create_destruct_mutex);
691 curr_thread = threads;
692 if(curr_thread->tid != 0)
693 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
695 curr_thread = curr_thread->next;
696 if(curr_thread == threads)
698 if(curr_thread->state & PERL_ITHR_DETACHED ||
699 curr_thread->state & PERL_ITHR_JOINED)
701 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
703 MUTEX_UNLOCK(&create_destruct_mutex);
708 ithread_self(char *classname)
711 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
716 ithread_tid(ithread *thread)
719 ithread_join(SV *obj)
722 AV* params = Perl_ithread_join(aTHX_ obj);
724 I32 len = AvFILL(params);
725 for (i = 0; i <= len; i++) {
726 SV* tmp = av_shift(params);
730 SvREFCNT_dec(params);
742 ithread_detach(ithread *thread)
745 ithread_DESTROY(SV *thread)
747 #endif /* USE_ITHREADS */
753 PL_perl_destruct_level = 2;
754 MUTEX_INIT(&create_destruct_mutex);
755 MUTEX_LOCK(&create_destruct_mutex);
756 PL_threadhook = &Perl_ithread_hook;
757 thread = PerlMemShared_malloc(sizeof(ithread));
758 Zero(thread,1,ithread);
759 PL_perl_destruct_level = 2;
760 MUTEX_INIT(&thread->mutex);
762 thread->next = thread;
763 thread->prev = thread;
764 thread->interp = aTHX;
765 thread->count = 1; /* Immortal. */
766 thread->tid = tid_counter++;
769 thread->state = PERL_ITHR_DETACHED;
771 thread->thr = GetCurrentThreadId();
773 thread->thr = pthread_self();
776 Perl_ithread_set(aTHX_ thread);
777 MUTEX_UNLOCK(&create_destruct_mutex);
778 #endif /* USE_ITHREADS */