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 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");
522 return NULL; /* silence compiler warning */
526 * Joins the thread this code needs to take the returnvalue from the
527 * call_sv and send it back
531 Perl_ithread_CLONE(pTHX_ SV *obj)
535 ithread *thread = SV_to_ithread(aTHX_ obj);
539 Perl_warn(aTHX_ "CLONE %" SVf,obj);
544 Perl_ithread_join(pTHX_ SV *obj)
546 ithread *thread = SV_to_ithread(aTHX_ obj);
547 MUTEX_LOCK(&thread->mutex);
548 if (thread->state & PERL_ITHR_DETACHED) {
549 MUTEX_UNLOCK(&thread->mutex);
550 Perl_croak(aTHX_ "Cannot join a detached thread");
552 else if (thread->state & PERL_ITHR_JOINED) {
553 MUTEX_UNLOCK(&thread->mutex);
554 Perl_croak(aTHX_ "Thread already joined");
563 MUTEX_UNLOCK(&thread->mutex);
565 waitcode = WaitForSingleObject(thread->handle, INFINITE);
567 pthread_join(thread->thr,&retval);
569 MUTEX_LOCK(&thread->mutex);
571 /* sv_dup over the args */
573 ithread* current_thread;
574 AV* params = (AV*) SvRV(thread->params);
575 CLONE_PARAMS clone_params;
576 clone_params.stashes = newAV();
577 clone_params.flags |= CLONEf_JOIN_IN;
578 PL_ptr_table = ptr_table_new();
579 current_thread = Perl_ithread_get(aTHX);
580 Perl_ithread_set(aTHX_ thread);
584 I32 len = av_len(params)+1;
586 for(i = 0; i < len; i++) {
587 sv_dump(SvRV(AvARRAY(params)[i]));
591 retparam = (AV*) sv_dup((SV*)params, &clone_params);
594 I32 len = av_len(retparam)+1;
596 for(i = 0; i < len; i++) {
597 sv_dump(SvRV(AvARRAY(retparam)[i]));
601 Perl_ithread_set(aTHX_ current_thread);
602 SvREFCNT_dec(clone_params.stashes);
603 SvREFCNT_inc(retparam);
604 ptr_table_free(PL_ptr_table);
608 /* We are finished with it */
609 thread->state |= PERL_ITHR_JOINED;
610 MUTEX_UNLOCK(&thread->mutex);
618 Perl_ithread_DESTROY(pTHX_ SV *sv)
620 ithread *thread = SV_to_ithread(aTHX_ sv);
621 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
624 #endif /* USE_ITHREADS */
626 MODULE = threads PACKAGE = threads PREFIX = ithread_
632 ithread_new (classname, function_to_call, ...)
634 SV * function_to_call
637 AV* params = newAV();
640 for(i = 2; i < items ; i++) {
641 av_push(params, SvREFCNT_inc(ST(i)));
644 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
649 ithread_list(char *classname)
652 ithread *curr_thread;
653 MUTEX_LOCK(&create_destruct_mutex);
654 curr_thread = threads;
655 if(curr_thread->tid != 0)
656 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
658 curr_thread = curr_thread->next;
659 if(curr_thread == threads)
661 if(curr_thread->state & PERL_ITHR_DETACHED ||
662 curr_thread->state & PERL_ITHR_JOINED)
664 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
666 MUTEX_UNLOCK(&create_destruct_mutex);
671 ithread_self(char *classname)
674 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
679 ithread_tid(ithread *thread)
682 ithread_join(SV *obj)
685 AV* params = Perl_ithread_join(aTHX_ obj);
687 I32 len = AvFILL(params);
688 for (i = 0; i <= len; i++) {
689 SV* tmp = av_shift(params);
693 SvREFCNT_dec(params);
705 ithread_detach(ithread *thread)
708 ithread_DESTROY(SV *thread)
710 #endif /* USE_ITHREADS */
716 PL_perl_destruct_level = 2;
717 MUTEX_INIT(&create_destruct_mutex);
718 MUTEX_LOCK(&create_destruct_mutex);
719 PL_threadhook = &Perl_ithread_hook;
720 thread = PerlMemShared_malloc(sizeof(ithread));
721 Zero(thread,1,ithread);
722 PL_perl_destruct_level = 2;
723 MUTEX_INIT(&thread->mutex);
725 thread->next = thread;
726 thread->prev = thread;
727 thread->interp = aTHX;
728 thread->count = 1; /* Immortal. */
729 thread->tid = tid_counter++;
732 thread->state = PERL_ITHR_DETACHED;
734 thread->thr = GetCurrentThreadId();
736 thread->thr = pthread_self();
739 Perl_ithread_set(aTHX_ thread);
740 MUTEX_UNLOCK(&create_destruct_mutex);
741 #endif /* USE_ITHREADS */