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.h: 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.h: 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.h: 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 " other threads were still 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)
355 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
359 PERL_THREAD_GETSPECIFIC(self_key,thread);
365 * iThread->create(); ( aka iThread->new() )
366 * Called in context of parent thread
370 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
373 CLONE_PARAMS clone_param;
374 ithread* current_thread;
376 SV** tmps_tmp = PL_tmps_stack;
377 I32 tmps_ix = PL_tmps_ix;
379 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
380 MUTEX_LOCK(&create_destruct_mutex);
381 thread = PerlMemShared_malloc(sizeof(ithread));
382 Zero(thread,1,ithread);
383 thread->next = threads;
384 thread->prev = threads->prev;
385 threads->prev = thread;
386 thread->prev->next = thread;
387 /* Set count to 1 immediately in case thread exits before
388 * we return to caller !
391 MUTEX_INIT(&thread->mutex);
392 thread->tid = tid_counter++;
393 thread->gimme = GIMME_V;
395 /* "Clone" our interpreter into the thread's interpreter
396 * This gives thread access to "static data" and code.
399 PerlIO_flush((PerlIO*)NULL);
400 PERL_THREAD_SETSPECIFIC(self_key,thread);
405 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
407 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
409 /* perl_clone leaves us in new interpreter's context.
410 As it is tricky to spot an implicit aTHX, create a new scope
411 with aTHX matching the context for the duration of
412 our work for new interpreter.
415 dTHXa(thread->interp);
416 /* Here we remove END blocks since they should only run
417 in the thread they are created
419 SvREFCNT_dec(PL_endav);
421 clone_param.flags = 0;
422 thread->init_function = sv_dup(init_function, &clone_param);
423 if (SvREFCNT(thread->init_function) == 0) {
424 SvREFCNT_inc(thread->init_function);
429 thread->params = sv_dup(params, &clone_param);
430 SvREFCNT_inc(thread->params);
433 /* The code below checks that anything living on
434 the tmps stack and has been cloned (so it lives in the
435 ptr_table) has a refcount higher than 0
437 If the refcount is 0 it means that a something on the
438 stack/context was holding a reference to it and
439 since we init_stacks() in perl_clone that won't get
440 cleaned and we will get a leaked scalar.
441 The reason it was cloned was that it lived on the
444 Example of this can be found in bugreport 15837
445 where calls in the parameter list end up as a temp
447 One could argue that this fix should be in perl_clone
451 while (tmps_ix > 0) {
452 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
454 if (sv && SvREFCNT(sv) == 0) {
462 SvTEMP_off(thread->init_function);
463 ptr_table_free(PL_ptr_table);
465 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
467 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
468 PERL_SET_CONTEXT(aTHX);
470 /* Start the thread */
474 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
475 (LPVOID)thread, 0, &thread->thr);
479 static pthread_attr_t attr;
480 static int attr_inited = 0;
481 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
484 pthread_attr_init(&attr);
486 # ifdef PTHREAD_ATTR_SETDETACHSTATE
487 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
489 # ifdef THREAD_CREATE_NEEDS_STACK
490 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
491 croak("panic: pthread_attr_setstacksize failed");
494 #ifdef OLD_PTHREADS_API
495 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
497 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
503 MUTEX_UNLOCK(&create_destruct_mutex);
506 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
510 Perl_ithread_self (pTHX_ SV *obj, char* Class)
513 PERL_THREAD_GETSPECIFIC(self_key,thread);
514 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
518 * Joins the thread this code needs to take the returnvalue from the
519 * call_sv and send it back
523 Perl_ithread_CLONE(pTHX_ SV *obj)
527 ithread *thread = SV_to_ithread(aTHX_ obj);
531 Perl_warn(aTHX_ "CLONE %" SVf,obj);
536 Perl_ithread_join(pTHX_ SV *obj)
538 ithread *thread = SV_to_ithread(aTHX_ obj);
539 MUTEX_LOCK(&thread->mutex);
540 if (thread->state & PERL_ITHR_DETACHED) {
541 MUTEX_UNLOCK(&thread->mutex);
542 Perl_croak(aTHX_ "Cannot join a detached thread");
544 else if (thread->state & PERL_ITHR_JOINED) {
545 MUTEX_UNLOCK(&thread->mutex);
546 Perl_croak(aTHX_ "Thread already joined");
555 MUTEX_UNLOCK(&thread->mutex);
557 waitcode = WaitForSingleObject(thread->handle, INFINITE);
559 pthread_join(thread->thr,&retval);
561 MUTEX_LOCK(&thread->mutex);
563 /* sv_dup over the args */
565 ithread* current_thread;
566 AV* params = (AV*) SvRV(thread->params);
567 CLONE_PARAMS clone_params;
568 clone_params.stashes = newAV();
569 clone_params.flags |= CLONEf_JOIN_IN;
570 PL_ptr_table = ptr_table_new();
571 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
572 PERL_THREAD_SETSPECIFIC(self_key,thread);
576 I32 len = av_len(params)+1;
578 for(i = 0; i < len; i++) {
579 sv_dump(SvRV(AvARRAY(params)[i]));
583 retparam = (AV*) sv_dup((SV*)params, &clone_params);
586 I32 len = av_len(retparam)+1;
588 for(i = 0; i < len; i++) {
589 sv_dump(SvRV(AvARRAY(retparam)[i]));
593 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
594 SvREFCNT_dec(clone_params.stashes);
595 SvREFCNT_inc(retparam);
596 ptr_table_free(PL_ptr_table);
600 /* We have finished with it */
601 thread->state |= PERL_ITHR_JOINED;
602 MUTEX_UNLOCK(&thread->mutex);
603 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
610 Perl_ithread_DESTROY(pTHX_ SV *sv)
612 ithread *thread = SV_to_ithread(aTHX_ sv);
613 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
616 #endif /* USE_ITHREADS */
618 MODULE = threads PACKAGE = threads PREFIX = ithread_
624 ithread_new (classname, function_to_call, ...)
626 SV * function_to_call
629 AV* params = newAV();
632 for(i = 2; i < items ; i++) {
633 av_push(params, SvREFCNT_inc(ST(i)));
636 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
641 ithread_list(char *classname)
644 ithread *curr_thread;
645 MUTEX_LOCK(&create_destruct_mutex);
646 curr_thread = threads;
647 if(curr_thread->tid != 0)
648 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
650 curr_thread = curr_thread->next;
651 if(curr_thread == threads)
653 if(curr_thread->state & PERL_ITHR_DETACHED ||
654 curr_thread->state & PERL_ITHR_JOINED)
656 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
658 MUTEX_UNLOCK(&create_destruct_mutex);
663 ithread_self(char *classname)
666 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
671 ithread_tid(ithread *thread)
674 ithread_join(SV *obj)
677 AV* params = Perl_ithread_join(aTHX_ obj);
679 I32 len = AvFILL(params);
680 for (i = 0; i <= len; i++) {
681 SV* tmp = av_shift(params);
685 SvREFCNT_dec(params);
697 ithread_detach(ithread *thread)
700 ithread_DESTROY(SV *thread)
702 #endif /* USE_ITHREADS */
708 PL_perl_destruct_level = 2;
709 PERL_THREAD_ALLOC_SPECIFIC(self_key);
710 MUTEX_INIT(&create_destruct_mutex);
711 MUTEX_LOCK(&create_destruct_mutex);
712 PL_threadhook = &Perl_ithread_hook;
713 thread = PerlMemShared_malloc(sizeof(ithread));
714 Zero(thread,1,ithread);
715 PL_perl_destruct_level = 2;
716 MUTEX_INIT(&thread->mutex);
718 thread->next = thread;
719 thread->prev = thread;
720 thread->interp = aTHX;
721 thread->count = 1; /* imortal */
722 thread->tid = tid_counter++;
727 thread->thr = GetCurrentThreadId();
729 thread->thr = pthread_self();
732 PERL_THREAD_SETSPECIFIC(self_key,thread);
733 MUTEX_UNLOCK(&create_destruct_mutex);
734 #endif /* USE_ITHREADS */