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");\
24 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
25 #ifdef OLD_PTHREADS_API
26 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
27 #define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
28 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
29 if(pthread_keycreate(&(k),0)) {\
30 PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
35 #define PERL_THREAD_DETACH(t) pthread_detach((t))
36 #define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
37 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
38 if(pthread_key_create(&(k),0)) {\
39 PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
46 /* Values for 'state' member */
47 #define PERL_ITHR_JOINABLE 0
48 #define PERL_ITHR_DETACHED 1
49 #define PERL_ITHR_FINISHED 4
50 #define PERL_ITHR_JOINED 2
52 typedef struct ithread_s {
53 struct ithread_s *next; /* next thread in the list */
54 struct ithread_s *prev; /* prev thread in the list */
55 PerlInterpreter *interp; /* The threads interpreter */
56 I32 tid; /* threads module's thread id */
57 perl_mutex mutex; /* mutex for updating things in this struct */
58 I32 count; /* how many SVs have a reference to us */
59 signed char state; /* are we detached ? */
60 int gimme; /* Context of create */
61 SV* init_function; /* Code to run */
62 SV* params; /* args to pass function */
64 DWORD thr; /* OS's idea if thread id */
65 HANDLE handle; /* OS's waitable handle */
67 pthread_t thr; /* OS's handle for the thread */
73 /* Macros to supply the aTHX_ in an embed.h like manner */
74 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
75 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
76 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
77 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
78 #define ithread_tid(thread) ((thread)->tid)
79 #define ithread_yield(thread) (YIELD);
81 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
84 I32 known_threads = 0;
85 I32 active_threads = 0;
89 * Clear up after thread is done with
92 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
94 MUTEX_LOCK(&thread->mutex);
96 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
98 if (thread->count != 0) {
99 MUTEX_UNLOCK(&thread->mutex);
102 MUTEX_LOCK(&create_destruct_mutex);
103 /* Remove from circular list of threads */
104 if (thread->next == thread) {
105 /* last one should never get here ? */
109 thread->next->prev = thread->prev;
110 thread->prev->next = thread->next;
111 if (threads == thread) {
112 threads = thread->next;
118 assert( known_threads >= 0 );
120 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
121 thread->tid,thread->interp,aTHX, known_threads);
123 MUTEX_UNLOCK(&create_destruct_mutex);
124 /* Thread is now disowned */
127 dTHXa(thread->interp);
128 ithread* current_thread;
129 PERL_SET_CONTEXT(thread->interp);
130 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
131 PERL_THREAD_SETSPECIFIC(self_key,thread);
135 SvREFCNT_dec(thread->params);
139 thread->params = Nullsv;
140 perl_destruct(thread->interp);
141 perl_free(thread->interp);
142 thread->interp = NULL;
143 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
146 MUTEX_UNLOCK(&thread->mutex);
147 MUTEX_DESTROY(&thread->mutex);
148 PerlMemShared_free(thread);
150 PERL_SET_CONTEXT(aTHX);
154 Perl_ithread_hook(pTHX)
156 int veto_cleanup = 0;
157 MUTEX_LOCK(&create_destruct_mutex);
158 if (aTHX == PL_curinterp && active_threads != 1) {
159 Perl_warn(aTHX_ "A thread exited while %" IVdf " other threads were still running",
163 MUTEX_UNLOCK(&create_destruct_mutex);
168 Perl_ithread_detach(pTHX_ ithread *thread)
170 MUTEX_LOCK(&thread->mutex);
171 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
172 thread->state |= PERL_ITHR_DETACHED;
174 CloseHandle(thread->handle);
177 PERL_THREAD_DETACH(thread->thr);
180 if ((thread->state & PERL_ITHR_FINISHED) &&
181 (thread->state & PERL_ITHR_DETACHED)) {
182 MUTEX_UNLOCK(&thread->mutex);
183 Perl_ithread_destruct(aTHX_ thread, "detach");
186 MUTEX_UNLOCK(&thread->mutex);
190 /* MAGIC (in mg.h sense) hooks */
193 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
195 ithread *thread = (ithread *) mg->mg_ptr;
196 SvIVX(sv) = PTR2IV(thread);
202 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
204 ithread *thread = (ithread *) mg->mg_ptr;
205 MUTEX_LOCK(&thread->mutex);
207 if (thread->count == 0) {
208 if(thread->state & PERL_ITHR_FINISHED &&
209 (thread->state & PERL_ITHR_DETACHED ||
210 thread->state & PERL_ITHR_JOINED))
212 MUTEX_UNLOCK(&thread->mutex);
213 Perl_ithread_destruct(aTHX_ thread, "no reference");
216 MUTEX_UNLOCK(&thread->mutex);
220 MUTEX_UNLOCK(&thread->mutex);
226 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
228 ithread *thread = (ithread *) mg->mg_ptr;
229 MUTEX_LOCK(&thread->mutex);
231 MUTEX_UNLOCK(&thread->mutex);
235 MGVTBL ithread_vtbl = {
236 ithread_mg_get, /* get */
240 ithread_mg_free, /* free */
242 ithread_mg_dup /* dup */
247 * Starts executing the thread. Needs to clean up memory a tad better.
248 * Passed as the C level function to run in the new thread
253 Perl_ithread_run(LPVOID arg) {
256 Perl_ithread_run(void * arg) {
258 ithread* thread = (ithread*) arg;
259 dTHXa(thread->interp);
260 PERL_SET_CONTEXT(thread->interp);
261 PERL_THREAD_SETSPECIFIC(self_key,thread);
264 /* Far from clear messing with ->thr child-side is a good idea */
265 MUTEX_LOCK(&thread->mutex);
267 thread->thr = GetCurrentThreadId();
269 thread->thr = pthread_self();
271 MUTEX_UNLOCK(&thread->mutex);
274 PL_perl_destruct_level = 2;
277 AV* params = (AV*) SvRV(thread->params);
278 I32 len = av_len(params)+1;
284 for(i = 0; i < len; i++) {
285 XPUSHs(av_shift(params));
288 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
291 for (i=len-1; i >= 0; i--) {
293 av_store(params, i, SvREFCNT_inc(sv));
296 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
300 SvREFCNT_dec(thread->init_function);
303 PerlIO_flush((PerlIO*)NULL);
304 MUTEX_LOCK(&thread->mutex);
305 thread->state |= PERL_ITHR_FINISHED;
307 if (thread->state & PERL_ITHR_DETACHED) {
308 MUTEX_UNLOCK(&thread->mutex);
309 Perl_ithread_destruct(aTHX_ thread, "detached finish");
311 MUTEX_UNLOCK(&thread->mutex);
313 MUTEX_LOCK(&create_destruct_mutex);
315 assert( active_threads >= 0 );
316 MUTEX_UNLOCK(&create_destruct_mutex);
326 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
331 MUTEX_LOCK(&thread->mutex);
333 MUTEX_UNLOCK(&thread->mutex);
337 sv = newSVrv(obj,classname);
338 sv_setiv(sv,PTR2IV(thread));
339 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
340 mg->mg_flags |= MGf_DUP;
346 SV_to_ithread(pTHX_ SV *sv)
351 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
355 PERL_THREAD_GETSPECIFIC(self_key,thread);
361 * iThread->create(); ( aka iThread->new() )
362 * Called in context of parent thread
366 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
369 CLONE_PARAMS clone_param;
370 ithread* current_thread;
372 SV** tmps_tmp = PL_tmps_stack;
373 I32 tmps_ix = PL_tmps_ix;
375 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
376 MUTEX_LOCK(&create_destruct_mutex);
377 thread = PerlMemShared_malloc(sizeof(ithread));
378 Zero(thread,1,ithread);
379 thread->next = threads;
380 thread->prev = threads->prev;
381 threads->prev = thread;
382 thread->prev->next = thread;
383 /* Set count to 1 immediately in case thread exits before
384 * we return to caller !
387 MUTEX_INIT(&thread->mutex);
388 thread->tid = tid_counter++;
389 thread->gimme = GIMME_V;
391 /* "Clone" our interpreter into the thread's interpreter
392 * This gives thread access to "static data" and code.
395 PerlIO_flush((PerlIO*)NULL);
396 PERL_THREAD_SETSPECIFIC(self_key,thread);
401 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
403 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
405 /* perl_clone leaves us in new interpreter's context.
406 As it is tricky to spot an implicit aTHX, create a new scope
407 with aTHX matching the context for the duration of
408 our work for new interpreter.
411 dTHXa(thread->interp);
412 /* Here we remove END blocks since they should only run
413 in the thread they are created
415 SvREFCNT_dec(PL_endav);
417 clone_param.flags = 0;
418 thread->init_function = sv_dup(init_function, &clone_param);
419 if (SvREFCNT(thread->init_function) == 0) {
420 SvREFCNT_inc(thread->init_function);
425 thread->params = sv_dup(params, &clone_param);
426 SvREFCNT_inc(thread->params);
429 /* The code below checks that anything living on
430 the tmps stack and has been cloned (so it lives in the
431 ptr_table) has a refcount higher than 0
433 If the refcount is 0 it means that a something on the
434 stack/context was holding a reference to it and
435 since we init_stacks() in perl_clone that won't get
436 cleaned and we will get a leaked scalar.
437 The reason it was cloned was that it lived on the
440 Example of this can be found in bugreport 15837
441 where calls in the parameter list end up as a temp
443 One could argue that this fix should be in perl_clone
447 while (tmps_ix > 0) {
448 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
450 if (sv && SvREFCNT(sv) == 0) {
458 SvTEMP_off(thread->init_function);
459 ptr_table_free(PL_ptr_table);
461 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
463 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
464 PERL_SET_CONTEXT(aTHX);
466 /* Start the thread */
470 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
471 (LPVOID)thread, 0, &thread->thr);
475 static pthread_attr_t attr;
476 static int attr_inited = 0;
477 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
480 pthread_attr_init(&attr);
482 # ifdef PTHREAD_ATTR_SETDETACHSTATE
483 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
485 # ifdef THREAD_CREATE_NEEDS_STACK
486 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
487 croak("panic: pthread_attr_setstacksize failed");
490 #ifdef OLD_PTHREADS_API
491 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
493 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
499 MUTEX_UNLOCK(&create_destruct_mutex);
502 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
506 Perl_ithread_self (pTHX_ SV *obj, char* Class)
509 PERL_THREAD_GETSPECIFIC(self_key,thread);
510 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
514 * Joins the thread this code needs to take the returnvalue from the
515 * call_sv and send it back
519 Perl_ithread_CLONE(pTHX_ SV *obj)
523 ithread *thread = SV_to_ithread(aTHX_ obj);
527 Perl_warn(aTHX_ "CLONE %" SVf,obj);
532 Perl_ithread_join(pTHX_ SV *obj)
534 ithread *thread = SV_to_ithread(aTHX_ obj);
535 MUTEX_LOCK(&thread->mutex);
536 if (thread->state & PERL_ITHR_DETACHED) {
537 MUTEX_UNLOCK(&thread->mutex);
538 Perl_croak(aTHX_ "Cannot join a detached thread");
540 else if (thread->state & PERL_ITHR_JOINED) {
541 MUTEX_UNLOCK(&thread->mutex);
542 Perl_croak(aTHX_ "Thread already joined");
551 MUTEX_UNLOCK(&thread->mutex);
553 waitcode = WaitForSingleObject(thread->handle, INFINITE);
555 pthread_join(thread->thr,&retval);
557 MUTEX_LOCK(&thread->mutex);
559 /* sv_dup over the args */
561 ithread* current_thread;
562 AV* params = (AV*) SvRV(thread->params);
563 CLONE_PARAMS clone_params;
564 clone_params.stashes = newAV();
565 clone_params.flags |= CLONEf_JOIN_IN;
566 PL_ptr_table = ptr_table_new();
567 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
568 PERL_THREAD_SETSPECIFIC(self_key,thread);
572 I32 len = av_len(params)+1;
574 for(i = 0; i < len; i++) {
575 sv_dump(SvRV(AvARRAY(params)[i]));
579 retparam = (AV*) sv_dup((SV*)params, &clone_params);
582 I32 len = av_len(retparam)+1;
584 for(i = 0; i < len; i++) {
585 sv_dump(SvRV(AvARRAY(retparam)[i]));
589 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
590 SvREFCNT_dec(clone_params.stashes);
591 SvREFCNT_inc(retparam);
592 ptr_table_free(PL_ptr_table);
596 /* We have finished with it */
597 thread->state |= PERL_ITHR_JOINED;
598 MUTEX_UNLOCK(&thread->mutex);
599 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
606 Perl_ithread_DESTROY(pTHX_ SV *sv)
608 ithread *thread = SV_to_ithread(aTHX_ sv);
609 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
612 #endif /* USE_ITHREADS */
614 MODULE = threads PACKAGE = threads PREFIX = ithread_
620 ithread_new (classname, function_to_call, ...)
622 SV * function_to_call
625 AV* params = newAV();
628 for(i = 2; i < items ; i++) {
629 av_push(params, SvREFCNT_inc(ST(i)));
632 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
637 ithread_list(char *classname)
640 ithread *curr_thread;
641 MUTEX_LOCK(&create_destruct_mutex);
642 curr_thread = threads;
643 if(curr_thread->tid != 0)
644 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
646 curr_thread = curr_thread->next;
647 if(curr_thread == threads)
649 if(curr_thread->state & PERL_ITHR_DETACHED ||
650 curr_thread->state & PERL_ITHR_JOINED)
652 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
654 MUTEX_UNLOCK(&create_destruct_mutex);
659 ithread_self(char *classname)
662 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
667 ithread_tid(ithread *thread)
670 ithread_join(SV *obj)
673 AV* params = Perl_ithread_join(aTHX_ obj);
675 I32 len = AvFILL(params);
676 for (i = 0; i <= len; i++) {
677 SV* tmp = av_shift(params);
681 SvREFCNT_dec(params);
693 ithread_detach(ithread *thread)
696 ithread_DESTROY(SV *thread)
698 #endif /* USE_ITHREADS */
704 PL_perl_destruct_level = 2;
705 PERL_THREAD_ALLOC_SPECIFIC(self_key);
706 MUTEX_INIT(&create_destruct_mutex);
707 MUTEX_LOCK(&create_destruct_mutex);
708 PL_threadhook = &Perl_ithread_hook;
709 thread = PerlMemShared_malloc(sizeof(ithread));
710 Zero(thread,1,ithread);
711 PL_perl_destruct_level = 2;
712 MUTEX_INIT(&thread->mutex);
714 thread->next = thread;
715 thread->prev = thread;
716 thread->interp = aTHX;
717 thread->count = 1; /* imortal */
718 thread->tid = tid_counter++;
723 thread->thr = GetCurrentThreadId();
725 thread->thr = pthread_self();
728 PERL_THREAD_SETSPECIFIC(self_key,thread);
729 MUTEX_UNLOCK(&create_destruct_mutex);
730 #endif /* USE_ITHREADS */