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 SvIV_set(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 = (ithread *) PerlMemShared_malloc(sizeof(ithread));
393 MUTEX_UNLOCK(&create_destruct_mutex);
394 PerlLIO_write(PerlIO_fileno(Perl_error_log),
395 PL_no_mem, strlen(PL_no_mem));
398 Zero(thread,1,ithread);
399 thread->next = threads;
400 thread->prev = threads->prev;
401 threads->prev = thread;
402 thread->prev->next = thread;
403 /* Set count to 1 immediately in case thread exits before
404 * we return to caller !
407 MUTEX_INIT(&thread->mutex);
408 thread->tid = tid_counter++;
409 thread->gimme = GIMME_V;
411 /* "Clone" our interpreter into the thread's interpreter
412 * This gives thread access to "static data" and code.
415 PerlIO_flush((PerlIO*)NULL);
416 Perl_ithread_set(aTHX_ thread);
418 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
420 PL_srand_called = FALSE; /* Set it to false so we can detect
421 if it gets set during the clone */
424 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
426 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
428 /* perl_clone leaves us in new interpreter's context.
429 As it is tricky to spot an implicit aTHX, create a new scope
430 with aTHX matching the context for the duration of
431 our work for new interpreter.
434 dTHXa(thread->interp);
436 /* Here we remove END blocks since they should only run
437 in the thread they are created
439 SvREFCNT_dec(PL_endav);
441 clone_param.flags = 0;
442 thread->init_function = sv_dup(init_function, &clone_param);
443 if (SvREFCNT(thread->init_function) == 0) {
444 SvREFCNT_inc(thread->init_function);
449 thread->params = sv_dup(params, &clone_param);
450 SvREFCNT_inc(thread->params);
453 /* The code below checks that anything living on
454 the tmps stack and has been cloned (so it lives in the
455 ptr_table) has a refcount higher than 0
457 If the refcount is 0 it means that a something on the
458 stack/context was holding a reference to it and
459 since we init_stacks() in perl_clone that won't get
460 cleaned and we will get a leaked scalar.
461 The reason it was cloned was that it lived on the
464 Example of this can be found in bugreport 15837
465 where calls in the parameter list end up as a temp
467 One could argue that this fix should be in perl_clone
471 while (tmps_ix > 0) {
472 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
474 if (sv && SvREFCNT(sv) == 0) {
482 SvTEMP_off(thread->init_function);
483 ptr_table_free(PL_ptr_table);
485 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
487 Perl_ithread_set(aTHX_ current_thread);
488 PERL_SET_CONTEXT(aTHX);
490 /* Start the thread */
493 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
494 (LPVOID)thread, 0, &thread->thr);
497 static pthread_attr_t attr;
498 static int attr_inited = 0;
499 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
502 pthread_attr_init(&attr);
504 # ifdef PTHREAD_ATTR_SETDETACHSTATE
505 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
507 # ifdef THREAD_CREATE_NEEDS_STACK
508 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
509 panic = "panic: pthread_attr_setstacksize failed";
512 #ifdef OLD_PTHREADS_API
514 = panic ? 1 : pthread_create( &thread->thr, attr,
515 Perl_ithread_run, (void *)thread);
517 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
518 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
521 = panic ? 1 : pthread_create( &thread->thr, &attr,
522 Perl_ithread_run, (void *)thread);
529 thread->handle == NULL
534 MUTEX_UNLOCK(&create_destruct_mutex);
536 Perl_ithread_destruct(aTHX_ thread, "create failed");
539 Perl_croak(aTHX_ panic);
544 MUTEX_UNLOCK(&create_destruct_mutex);
547 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
551 Perl_ithread_self (pTHX_ SV *obj, char* Class)
553 ithread *thread = Perl_ithread_get(aTHX);
555 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
557 Perl_croak(aTHX_ "panic: cannot find thread data");
558 return NULL; /* silence compiler warning */
562 * Joins the thread this code needs to take the returnvalue from the
563 * call_sv and send it back
567 Perl_ithread_CLONE(pTHX_ SV *obj)
571 ithread *thread = SV_to_ithread(aTHX_ obj);
575 Perl_warn(aTHX_ "CLONE %" SVf,obj);
580 Perl_ithread_join(pTHX_ SV *obj)
582 ithread *thread = SV_to_ithread(aTHX_ obj);
583 MUTEX_LOCK(&thread->mutex);
584 if (thread->state & PERL_ITHR_DETACHED) {
585 MUTEX_UNLOCK(&thread->mutex);
586 Perl_croak(aTHX_ "Cannot join a detached thread");
588 else if (thread->state & PERL_ITHR_JOINED) {
589 MUTEX_UNLOCK(&thread->mutex);
590 Perl_croak(aTHX_ "Thread already joined");
599 MUTEX_UNLOCK(&thread->mutex);
601 waitcode = WaitForSingleObject(thread->handle, INFINITE);
602 CloseHandle(thread->handle);
605 pthread_join(thread->thr,&retval);
607 MUTEX_LOCK(&thread->mutex);
609 /* sv_dup over the args */
611 ithread* current_thread;
612 AV* params = (AV*) SvRV(thread->params);
613 PerlInterpreter *other_perl = thread->interp;
614 CLONE_PARAMS clone_params;
615 clone_params.stashes = newAV();
616 clone_params.flags |= CLONEf_JOIN_IN;
617 PL_ptr_table = ptr_table_new();
618 PL_shared_hek_table = ptr_table_new();
619 current_thread = Perl_ithread_get(aTHX);
620 Perl_ithread_set(aTHX_ thread);
621 /* ensure 'meaningful' addresses retain their meaning */
622 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
623 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
624 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
628 I32 len = av_len(params)+1;
630 for(i = 0; i < len; i++) {
631 sv_dump(SvRV(AvARRAY(params)[i]));
635 retparam = (AV*) sv_dup((SV*)params, &clone_params);
638 I32 len = av_len(retparam)+1;
640 for(i = 0; i < len; i++) {
641 sv_dump(SvRV(AvARRAY(retparam)[i]));
645 Perl_ithread_set(aTHX_ current_thread);
646 SvREFCNT_dec(clone_params.stashes);
647 SvREFCNT_inc(retparam);
648 ptr_table_free(PL_ptr_table);
650 ptr_table_free(PL_shared_hek_table);
651 PL_shared_hek_table = NULL;
654 /* We are finished with it */
655 thread->state |= PERL_ITHR_JOINED;
656 MUTEX_UNLOCK(&thread->mutex);
664 Perl_ithread_DESTROY(pTHX_ SV *sv)
666 ithread *thread = SV_to_ithread(aTHX_ sv);
667 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
670 #endif /* USE_ITHREADS */
672 MODULE = threads PACKAGE = threads PREFIX = ithread_
678 ithread_new (classname, function_to_call, ...)
680 SV * function_to_call
683 AV* params = newAV();
686 for(i = 2; i < items ; i++) {
687 av_push(params, SvREFCNT_inc(ST(i)));
690 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
695 ithread_list(char *classname)
698 ithread *curr_thread;
699 MUTEX_LOCK(&create_destruct_mutex);
700 curr_thread = threads;
701 if(curr_thread->tid != 0)
702 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
704 curr_thread = curr_thread->next;
705 if(curr_thread == threads)
707 if(curr_thread->state & PERL_ITHR_DETACHED ||
708 curr_thread->state & PERL_ITHR_JOINED)
710 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
712 MUTEX_UNLOCK(&create_destruct_mutex);
717 ithread_self(char *classname)
720 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
725 ithread_tid(ithread *thread)
728 ithread_join(SV *obj)
731 AV* params = Perl_ithread_join(aTHX_ obj);
733 I32 len = AvFILL(params);
734 for (i = 0; i <= len; i++) {
735 SV* tmp = av_shift(params);
739 SvREFCNT_dec(params);
751 ithread_detach(ithread *thread)
754 ithread_DESTROY(SV *thread)
756 #endif /* USE_ITHREADS */
762 PL_perl_destruct_level = 2;
763 MUTEX_INIT(&create_destruct_mutex);
764 MUTEX_LOCK(&create_destruct_mutex);
765 PL_threadhook = &Perl_ithread_hook;
766 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
768 PerlLIO_write(PerlIO_fileno(Perl_error_log),
769 PL_no_mem, strlen(PL_no_mem));
772 Zero(thread,1,ithread);
773 PL_perl_destruct_level = 2;
774 MUTEX_INIT(&thread->mutex);
776 thread->next = thread;
777 thread->prev = thread;
778 thread->interp = aTHX;
779 thread->count = 1; /* Immortal. */
780 thread->tid = tid_counter++;
783 thread->state = PERL_ITHR_DETACHED;
785 thread->thr = GetCurrentThreadId();
787 thread->thr = pthread_self();
790 Perl_ithread_set(aTHX_ thread);
791 MUTEX_UNLOCK(&create_destruct_mutex);
792 #endif /* USE_ITHREADS */