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((IV)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 (ithread*)SvIV(*thread_sv);
91 * Clear up after thread is done with
94 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
96 MUTEX_LOCK(&thread->mutex);
98 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
100 if (thread->count != 0) {
101 MUTEX_UNLOCK(&thread->mutex);
104 MUTEX_LOCK(&create_destruct_mutex);
105 /* Remove from circular list of threads */
106 if (thread->next == thread) {
107 /* last one should never get here ? */
111 thread->next->prev = thread->prev;
112 thread->prev->next = thread->next;
113 if (threads == thread) {
114 threads = thread->next;
120 assert( known_threads >= 0 );
122 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
123 thread->tid,thread->interp,aTHX, known_threads);
125 MUTEX_UNLOCK(&create_destruct_mutex);
126 /* Thread is now disowned */
129 dTHXa(thread->interp);
130 ithread* current_thread;
134 PERL_SET_CONTEXT(thread->interp);
135 current_thread = Perl_ithread_get(aTHX);
136 Perl_ithread_set(aTHX_ thread);
141 SvREFCNT_dec(thread->params);
145 thread->params = Nullsv;
146 perl_destruct(thread->interp);
147 perl_free(thread->interp);
148 thread->interp = NULL;
150 MUTEX_UNLOCK(&thread->mutex);
151 MUTEX_DESTROY(&thread->mutex);
152 PerlMemShared_free(thread);
154 PERL_SET_CONTEXT(aTHX);
158 Perl_ithread_hook(pTHX)
160 int veto_cleanup = 0;
161 MUTEX_LOCK(&create_destruct_mutex);
162 if (aTHX == PL_curinterp && active_threads != 1) {
163 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
167 MUTEX_UNLOCK(&create_destruct_mutex);
172 Perl_ithread_detach(pTHX_ ithread *thread)
174 MUTEX_LOCK(&thread->mutex);
175 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
176 thread->state |= PERL_ITHR_DETACHED;
178 CloseHandle(thread->handle);
181 PERL_THREAD_DETACH(thread->thr);
184 if ((thread->state & PERL_ITHR_FINISHED) &&
185 (thread->state & PERL_ITHR_DETACHED)) {
186 MUTEX_UNLOCK(&thread->mutex);
187 Perl_ithread_destruct(aTHX_ thread, "detach");
190 MUTEX_UNLOCK(&thread->mutex);
194 /* MAGIC (in mg.h sense) hooks */
197 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
199 ithread *thread = (ithread *) mg->mg_ptr;
200 SvIVX(sv) = PTR2IV(thread);
206 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
208 ithread *thread = (ithread *) mg->mg_ptr;
209 MUTEX_LOCK(&thread->mutex);
211 if (thread->count == 0) {
212 if(thread->state & PERL_ITHR_FINISHED &&
213 (thread->state & PERL_ITHR_DETACHED ||
214 thread->state & PERL_ITHR_JOINED))
216 MUTEX_UNLOCK(&thread->mutex);
217 Perl_ithread_destruct(aTHX_ thread, "no reference");
220 MUTEX_UNLOCK(&thread->mutex);
224 MUTEX_UNLOCK(&thread->mutex);
230 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
232 ithread *thread = (ithread *) mg->mg_ptr;
233 MUTEX_LOCK(&thread->mutex);
235 MUTEX_UNLOCK(&thread->mutex);
239 MGVTBL ithread_vtbl = {
240 ithread_mg_get, /* get */
244 ithread_mg_free, /* free */
246 ithread_mg_dup /* dup */
251 * Starts executing the thread. Needs to clean up memory a tad better.
252 * Passed as the C level function to run in the new thread
257 Perl_ithread_run(LPVOID arg) {
260 Perl_ithread_run(void * arg) {
262 ithread* thread = (ithread*) arg;
263 dTHXa(thread->interp);
264 PERL_SET_CONTEXT(thread->interp);
265 Perl_ithread_set(aTHX_ thread);
268 /* Far from clear messing with ->thr child-side is a good idea */
269 MUTEX_LOCK(&thread->mutex);
271 thread->thr = GetCurrentThreadId();
273 thread->thr = pthread_self();
275 MUTEX_UNLOCK(&thread->mutex);
278 PL_perl_destruct_level = 2;
281 AV* params = (AV*) SvRV(thread->params);
282 I32 len = av_len(params)+1;
288 for(i = 0; i < len; i++) {
289 XPUSHs(av_shift(params));
292 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
295 for (i=len-1; i >= 0; i--) {
297 av_store(params, i, SvREFCNT_inc(sv));
300 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
304 SvREFCNT_dec(thread->init_function);
307 PerlIO_flush((PerlIO*)NULL);
308 MUTEX_LOCK(&thread->mutex);
309 thread->state |= PERL_ITHR_FINISHED;
311 if (thread->state & PERL_ITHR_DETACHED) {
312 MUTEX_UNLOCK(&thread->mutex);
313 Perl_ithread_destruct(aTHX_ thread, "detached finish");
315 MUTEX_UNLOCK(&thread->mutex);
317 MUTEX_LOCK(&create_destruct_mutex);
319 assert( active_threads >= 0 );
320 MUTEX_UNLOCK(&create_destruct_mutex);
330 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
335 MUTEX_LOCK(&thread->mutex);
337 MUTEX_UNLOCK(&thread->mutex);
341 sv = newSVrv(obj,classname);
342 sv_setiv(sv,PTR2IV(thread));
343 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
344 mg->mg_flags |= MGf_DUP;
350 SV_to_ithread(pTHX_ SV *sv)
354 return INT2PTR(ithread*, SvIV(SvRV(sv)));
358 return Perl_ithread_get(aTHX);
363 * ithread->create(); ( aka ithread->new() )
364 * Called in context of parent thread
368 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
371 CLONE_PARAMS clone_param;
372 ithread* current_thread = Perl_ithread_get(aTHX);
374 SV** tmps_tmp = PL_tmps_stack;
375 I32 tmps_ix = PL_tmps_ix;
378 MUTEX_LOCK(&create_destruct_mutex);
379 thread = PerlMemShared_malloc(sizeof(ithread));
380 Zero(thread,1,ithread);
381 thread->next = threads;
382 thread->prev = threads->prev;
383 threads->prev = thread;
384 thread->prev->next = thread;
385 /* Set count to 1 immediately in case thread exits before
386 * we return to caller !
389 MUTEX_INIT(&thread->mutex);
390 thread->tid = tid_counter++;
391 thread->gimme = GIMME_V;
393 /* "Clone" our interpreter into the thread's interpreter
394 * This gives thread access to "static data" and code.
397 PerlIO_flush((PerlIO*)NULL);
398 Perl_ithread_set(aTHX_ thread);
400 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
402 PL_srand_called = FALSE; /* Set it to false so we can detect
403 if it gets set during the clone */
406 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
408 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
410 /* perl_clone leaves us in new interpreter's context.
411 As it is tricky to spot an implicit aTHX, create a new scope
412 with aTHX matching the context for the duration of
413 our work for new interpreter.
416 dTHXa(thread->interp);
418 /* Here we remove END blocks since they should only run
419 in the thread they are created
421 SvREFCNT_dec(PL_endav);
423 clone_param.flags = 0;
424 thread->init_function = sv_dup(init_function, &clone_param);
425 if (SvREFCNT(thread->init_function) == 0) {
426 SvREFCNT_inc(thread->init_function);
431 thread->params = sv_dup(params, &clone_param);
432 SvREFCNT_inc(thread->params);
435 /* The code below checks that anything living on
436 the tmps stack and has been cloned (so it lives in the
437 ptr_table) has a refcount higher than 0
439 If the refcount is 0 it means that a something on the
440 stack/context was holding a reference to it and
441 since we init_stacks() in perl_clone that won't get
442 cleaned and we will get a leaked scalar.
443 The reason it was cloned was that it lived on the
446 Example of this can be found in bugreport 15837
447 where calls in the parameter list end up as a temp
449 One could argue that this fix should be in perl_clone
453 while (tmps_ix > 0) {
454 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
456 if (sv && SvREFCNT(sv) == 0) {
464 SvTEMP_off(thread->init_function);
465 ptr_table_free(PL_ptr_table);
467 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
469 Perl_ithread_set(aTHX_ current_thread);
470 PERL_SET_CONTEXT(aTHX);
472 /* Start the thread */
476 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
477 (LPVOID)thread, 0, &thread->thr);
481 static pthread_attr_t attr;
482 static int attr_inited = 0;
483 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
486 pthread_attr_init(&attr);
488 # ifdef PTHREAD_ATTR_SETDETACHSTATE
489 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
491 # ifdef THREAD_CREATE_NEEDS_STACK
492 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
493 Perl_croak(aTHX_ "panic: pthread_attr_setstacksize failed");
496 #ifdef OLD_PTHREADS_API
497 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
499 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
500 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
502 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
508 MUTEX_UNLOCK(&create_destruct_mutex);
511 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
515 Perl_ithread_self (pTHX_ SV *obj, char* Class)
517 ithread *thread = Perl_ithread_get(aTHX);
519 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
521 Perl_croak(aTHX_ "panic: cannot find thread data");
525 * Joins the thread this code needs to take the returnvalue from the
526 * call_sv and send it back
530 Perl_ithread_CLONE(pTHX_ SV *obj)
534 ithread *thread = SV_to_ithread(aTHX_ obj);
538 Perl_warn(aTHX_ "CLONE %" SVf,obj);
543 Perl_ithread_join(pTHX_ SV *obj)
545 ithread *thread = SV_to_ithread(aTHX_ obj);
546 MUTEX_LOCK(&thread->mutex);
547 if (thread->state & PERL_ITHR_DETACHED) {
548 MUTEX_UNLOCK(&thread->mutex);
549 Perl_croak(aTHX_ "Cannot join a detached thread");
551 else if (thread->state & PERL_ITHR_JOINED) {
552 MUTEX_UNLOCK(&thread->mutex);
553 Perl_croak(aTHX_ "Thread already joined");
562 MUTEX_UNLOCK(&thread->mutex);
564 waitcode = WaitForSingleObject(thread->handle, INFINITE);
566 pthread_join(thread->thr,&retval);
568 MUTEX_LOCK(&thread->mutex);
570 /* sv_dup over the args */
572 ithread* current_thread;
573 AV* params = (AV*) SvRV(thread->params);
574 CLONE_PARAMS clone_params;
575 clone_params.stashes = newAV();
576 clone_params.flags |= CLONEf_JOIN_IN;
577 PL_ptr_table = ptr_table_new();
578 current_thread = Perl_ithread_get(aTHX);
579 Perl_ithread_set(aTHX_ thread);
583 I32 len = av_len(params)+1;
585 for(i = 0; i < len; i++) {
586 sv_dump(SvRV(AvARRAY(params)[i]));
590 retparam = (AV*) sv_dup((SV*)params, &clone_params);
593 I32 len = av_len(retparam)+1;
595 for(i = 0; i < len; i++) {
596 sv_dump(SvRV(AvARRAY(retparam)[i]));
600 Perl_ithread_set(aTHX_ current_thread);
601 SvREFCNT_dec(clone_params.stashes);
602 SvREFCNT_inc(retparam);
603 ptr_table_free(PL_ptr_table);
607 /* We are finished with it */
608 thread->state |= PERL_ITHR_JOINED;
609 MUTEX_UNLOCK(&thread->mutex);
617 Perl_ithread_DESTROY(pTHX_ SV *sv)
619 ithread *thread = SV_to_ithread(aTHX_ sv);
620 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
623 #endif /* USE_ITHREADS */
625 MODULE = threads PACKAGE = threads PREFIX = ithread_
631 ithread_new (classname, function_to_call, ...)
633 SV * function_to_call
636 AV* params = newAV();
639 for(i = 2; i < items ; i++) {
640 av_push(params, SvREFCNT_inc(ST(i)));
643 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
648 ithread_list(char *classname)
651 ithread *curr_thread;
652 MUTEX_LOCK(&create_destruct_mutex);
653 curr_thread = threads;
654 if(curr_thread->tid != 0)
655 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
657 curr_thread = curr_thread->next;
658 if(curr_thread == threads)
660 if(curr_thread->state & PERL_ITHR_DETACHED ||
661 curr_thread->state & PERL_ITHR_JOINED)
663 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
665 MUTEX_UNLOCK(&create_destruct_mutex);
670 ithread_self(char *classname)
673 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
678 ithread_tid(ithread *thread)
681 ithread_join(SV *obj)
684 AV* params = Perl_ithread_join(aTHX_ obj);
686 I32 len = AvFILL(params);
687 for (i = 0; i <= len; i++) {
688 SV* tmp = av_shift(params);
692 SvREFCNT_dec(params);
704 ithread_detach(ithread *thread)
707 ithread_DESTROY(SV *thread)
709 #endif /* USE_ITHREADS */
715 PL_perl_destruct_level = 2;
716 MUTEX_INIT(&create_destruct_mutex);
717 MUTEX_LOCK(&create_destruct_mutex);
718 PL_threadhook = &Perl_ithread_hook;
719 thread = PerlMemShared_malloc(sizeof(ithread));
720 Zero(thread,1,ithread);
721 PL_perl_destruct_level = 2;
722 MUTEX_INIT(&thread->mutex);
724 thread->next = thread;
725 thread->prev = thread;
726 thread->interp = aTHX;
727 thread->count = 1; /* Immortal. */
728 thread->tid = tid_counter++;
731 thread->state = PERL_ITHR_DETACHED;
733 thread->thr = GetCurrentThreadId();
735 thread->thr = pthread_self();
738 Perl_ithread_set(aTHX_ thread);
739 MUTEX_UNLOCK(&create_destruct_mutex);
740 #endif /* USE_ITHREADS */