1 #define PERL_NO_GET_CONTEXT
10 #include <win32thread.h>
11 #define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
12 #define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
13 #define PERL_THREAD_ALLOC_SPECIFIC(k) \
15 if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
16 PerlIO_printf(PerlIO_stderr(),"panic threads.xs: TlsAlloc");\
22 typedef perl_os_thread pthread_t;
28 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
29 #ifdef OLD_PTHREADS_API
30 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
31 #define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
32 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
33 if(pthread_keycreate(&(k),0)) {\
34 PerlIO_printf(PerlIO_stderr(), "panic threads.xs: pthread_key_create");\
39 #define PERL_THREAD_DETACH(t) pthread_detach((t))
40 #define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
41 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
42 if(pthread_key_create(&(k),0)) {\
43 PerlIO_printf(PerlIO_stderr(), "panic threads.xs: pthread_key_create");\
50 /* Values for 'state' member */
51 #define PERL_ITHR_JOINABLE 0
52 #define PERL_ITHR_DETACHED 1
53 #define PERL_ITHR_FINISHED 4
54 #define PERL_ITHR_JOINED 2
56 typedef struct ithread_s {
57 struct ithread_s *next; /* next thread in the list */
58 struct ithread_s *prev; /* prev thread in the list */
59 PerlInterpreter *interp; /* The threads interpreter */
60 I32 tid; /* threads module's thread id */
61 perl_mutex mutex; /* mutex for updating things in this struct */
62 I32 count; /* how many SVs have a reference to us */
63 signed char state; /* are we detached ? */
64 int gimme; /* Context of create */
65 SV* init_function; /* Code to run */
66 SV* params; /* args to pass function */
68 DWORD thr; /* OS's idea if thread id */
69 HANDLE handle; /* OS's waitable handle */
71 pthread_t thr; /* OS's handle for the thread */
77 /* Macros to supply the aTHX_ in an embed.h like manner */
78 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
79 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
80 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
81 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
82 #define ithread_tid(thread) ((thread)->tid)
83 #define ithread_yield(thread) (YIELD);
85 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
88 I32 known_threads = 0;
89 I32 active_threads = 0;
93 * Clear up after thread is done with
96 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
98 MUTEX_LOCK(&thread->mutex);
100 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
102 if (thread->count != 0) {
103 MUTEX_UNLOCK(&thread->mutex);
106 MUTEX_LOCK(&create_destruct_mutex);
107 /* Remove from circular list of threads */
108 if (thread->next == thread) {
109 /* last one should never get here ? */
113 thread->next->prev = thread->prev;
114 thread->prev->next = thread->next;
115 if (threads == thread) {
116 threads = thread->next;
122 assert( known_threads >= 0 );
124 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
125 thread->tid,thread->interp,aTHX, known_threads);
127 MUTEX_UNLOCK(&create_destruct_mutex);
128 /* Thread is now disowned */
131 dTHXa(thread->interp);
132 ithread* current_thread;
133 PERL_SET_CONTEXT(thread->interp);
134 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
135 PERL_THREAD_SETSPECIFIC(self_key,thread);
139 SvREFCNT_dec(thread->params);
143 thread->params = Nullsv;
144 perl_destruct(thread->interp);
145 perl_free(thread->interp);
146 thread->interp = NULL;
147 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
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_THREAD_SETSPECIFIC(self_key,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)
358 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
363 PERL_THREAD_GETSPECIFIC(self_key,ptr);
364 thread = (ithread *) ptr;
366 PERL_THREAD_GETSPECIFIC(self_key,thread);
373 * iThread->create(); ( aka iThread->new() )
374 * Called in context of parent thread
378 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
381 CLONE_PARAMS clone_param;
382 ithread* current_thread;
384 SV** tmps_tmp = PL_tmps_stack;
385 I32 tmps_ix = PL_tmps_ix;
387 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
388 MUTEX_LOCK(&create_destruct_mutex);
389 thread = PerlMemShared_malloc(sizeof(ithread));
390 Zero(thread,1,ithread);
391 thread->next = threads;
392 thread->prev = threads->prev;
393 threads->prev = thread;
394 thread->prev->next = thread;
395 /* Set count to 1 immediately in case thread exits before
396 * we return to caller !
399 MUTEX_INIT(&thread->mutex);
400 thread->tid = tid_counter++;
401 thread->gimme = GIMME_V;
403 /* "Clone" our interpreter into the thread's interpreter
404 * This gives thread access to "static data" and code.
407 PerlIO_flush((PerlIO*)NULL);
408 PERL_THREAD_SETSPECIFIC(self_key,thread);
410 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
412 PL_srand_called = FALSE; /* Set it to false so we can detect
413 if it gets set during the clone */
416 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
418 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
420 /* perl_clone leaves us in new interpreter's context.
421 As it is tricky to spot an implicit aTHX, create a new scope
422 with aTHX matching the context for the duration of
423 our work for new interpreter.
426 dTHXa(thread->interp);
428 /* Here we remove END blocks since they should only run
429 in the thread they are created
431 SvREFCNT_dec(PL_endav);
433 clone_param.flags = 0;
434 thread->init_function = sv_dup(init_function, &clone_param);
435 if (SvREFCNT(thread->init_function) == 0) {
436 SvREFCNT_inc(thread->init_function);
441 thread->params = sv_dup(params, &clone_param);
442 SvREFCNT_inc(thread->params);
445 /* The code below checks that anything living on
446 the tmps stack and has been cloned (so it lives in the
447 ptr_table) has a refcount higher than 0
449 If the refcount is 0 it means that a something on the
450 stack/context was holding a reference to it and
451 since we init_stacks() in perl_clone that won't get
452 cleaned and we will get a leaked scalar.
453 The reason it was cloned was that it lived on the
456 Example of this can be found in bugreport 15837
457 where calls in the parameter list end up as a temp
459 One could argue that this fix should be in perl_clone
463 while (tmps_ix > 0) {
464 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
466 if (sv && SvREFCNT(sv) == 0) {
474 SvTEMP_off(thread->init_function);
475 ptr_table_free(PL_ptr_table);
477 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
479 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
480 PERL_SET_CONTEXT(aTHX);
482 /* Start the thread */
486 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
487 (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 croak("panic: pthread_attr_setstacksize failed");
506 #ifdef OLD_PTHREADS_API
507 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
509 # ifdef PTHREAD_SCOPE_SYSTEM
510 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
512 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
518 MUTEX_UNLOCK(&create_destruct_mutex);
521 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
525 Perl_ithread_self (pTHX_ SV *obj, char* Class)
530 PERL_THREAD_GETSPECIFIC(self_key,ptr);
531 thread = (ithread *) ptr;
533 PERL_THREAD_GETSPECIFIC(self_key,thread);
536 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
538 Perl_croak(aTHX_ "panic: cannot find thread data");
542 * Joins the thread this code needs to take the returnvalue from the
543 * call_sv and send it back
547 Perl_ithread_CLONE(pTHX_ SV *obj)
551 ithread *thread = SV_to_ithread(aTHX_ obj);
555 Perl_warn(aTHX_ "CLONE %" SVf,obj);
560 Perl_ithread_join(pTHX_ SV *obj)
562 ithread *thread = SV_to_ithread(aTHX_ obj);
563 MUTEX_LOCK(&thread->mutex);
564 if (thread->state & PERL_ITHR_DETACHED) {
565 MUTEX_UNLOCK(&thread->mutex);
566 Perl_croak(aTHX_ "Cannot join a detached thread");
568 else if (thread->state & PERL_ITHR_JOINED) {
569 MUTEX_UNLOCK(&thread->mutex);
570 Perl_croak(aTHX_ "Thread already joined");
579 MUTEX_UNLOCK(&thread->mutex);
581 waitcode = WaitForSingleObject(thread->handle, INFINITE);
583 pthread_join(thread->thr,&retval);
585 MUTEX_LOCK(&thread->mutex);
587 /* sv_dup over the args */
589 ithread* current_thread;
590 AV* params = (AV*) SvRV(thread->params);
591 CLONE_PARAMS clone_params;
592 clone_params.stashes = newAV();
593 clone_params.flags |= CLONEf_JOIN_IN;
594 PL_ptr_table = ptr_table_new();
595 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
596 PERL_THREAD_SETSPECIFIC(self_key,thread);
600 I32 len = av_len(params)+1;
602 for(i = 0; i < len; i++) {
603 sv_dump(SvRV(AvARRAY(params)[i]));
607 retparam = (AV*) sv_dup((SV*)params, &clone_params);
610 I32 len = av_len(retparam)+1;
612 for(i = 0; i < len; i++) {
613 sv_dump(SvRV(AvARRAY(retparam)[i]));
617 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
618 SvREFCNT_dec(clone_params.stashes);
619 SvREFCNT_inc(retparam);
620 ptr_table_free(PL_ptr_table);
624 /* We have finished with it */
625 thread->state |= PERL_ITHR_JOINED;
626 MUTEX_UNLOCK(&thread->mutex);
634 Perl_ithread_DESTROY(pTHX_ SV *sv)
636 ithread *thread = SV_to_ithread(aTHX_ sv);
637 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
640 #endif /* USE_ITHREADS */
642 MODULE = threads PACKAGE = threads PREFIX = ithread_
648 ithread_new (classname, function_to_call, ...)
650 SV * function_to_call
653 AV* params = newAV();
656 for(i = 2; i < items ; i++) {
657 av_push(params, SvREFCNT_inc(ST(i)));
660 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
665 ithread_list(char *classname)
668 ithread *curr_thread;
669 MUTEX_LOCK(&create_destruct_mutex);
670 curr_thread = threads;
671 if(curr_thread->tid != 0)
672 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
674 curr_thread = curr_thread->next;
675 if(curr_thread == threads)
677 if(curr_thread->state & PERL_ITHR_DETACHED ||
678 curr_thread->state & PERL_ITHR_JOINED)
680 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
682 MUTEX_UNLOCK(&create_destruct_mutex);
687 ithread_self(char *classname)
690 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
695 ithread_tid(ithread *thread)
698 ithread_join(SV *obj)
701 AV* params = Perl_ithread_join(aTHX_ obj);
703 I32 len = AvFILL(params);
704 for (i = 0; i <= len; i++) {
705 SV* tmp = av_shift(params);
709 SvREFCNT_dec(params);
721 ithread_detach(ithread *thread)
724 ithread_DESTROY(SV *thread)
726 #endif /* USE_ITHREADS */
732 PL_perl_destruct_level = 2;
733 PERL_THREAD_ALLOC_SPECIFIC(self_key);
734 MUTEX_INIT(&create_destruct_mutex);
735 MUTEX_LOCK(&create_destruct_mutex);
736 PL_threadhook = &Perl_ithread_hook;
737 thread = PerlMemShared_malloc(sizeof(ithread));
738 Zero(thread,1,ithread);
739 PL_perl_destruct_level = 2;
740 MUTEX_INIT(&thread->mutex);
742 thread->next = thread;
743 thread->prev = thread;
744 thread->interp = aTHX;
745 thread->count = 1; /* imortal */
746 thread->tid = tid_counter++;
751 thread->thr = GetCurrentThreadId();
753 thread->thr = pthread_self();
756 PERL_THREAD_SETSPECIFIC(self_key,thread);
757 MUTEX_UNLOCK(&create_destruct_mutex);
758 #endif /* USE_ITHREADS */