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 " 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)
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_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
498 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
504 MUTEX_UNLOCK(&create_destruct_mutex);
507 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
511 Perl_ithread_self (pTHX_ SV *obj, char* Class)
514 PERL_THREAD_GETSPECIFIC(self_key,thread);
515 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
519 * Joins the thread this code needs to take the returnvalue from the
520 * call_sv and send it back
524 Perl_ithread_CLONE(pTHX_ SV *obj)
528 ithread *thread = SV_to_ithread(aTHX_ obj);
532 Perl_warn(aTHX_ "CLONE %" SVf,obj);
537 Perl_ithread_join(pTHX_ SV *obj)
539 ithread *thread = SV_to_ithread(aTHX_ obj);
540 MUTEX_LOCK(&thread->mutex);
541 if (thread->state & PERL_ITHR_DETACHED) {
542 MUTEX_UNLOCK(&thread->mutex);
543 Perl_croak(aTHX_ "Cannot join a detached thread");
545 else if (thread->state & PERL_ITHR_JOINED) {
546 MUTEX_UNLOCK(&thread->mutex);
547 Perl_croak(aTHX_ "Thread already joined");
556 MUTEX_UNLOCK(&thread->mutex);
558 waitcode = WaitForSingleObject(thread->handle, INFINITE);
560 pthread_join(thread->thr,&retval);
562 MUTEX_LOCK(&thread->mutex);
564 /* sv_dup over the args */
566 ithread* current_thread;
567 AV* params = (AV*) SvRV(thread->params);
568 CLONE_PARAMS clone_params;
569 clone_params.stashes = newAV();
570 clone_params.flags |= CLONEf_JOIN_IN;
571 PL_ptr_table = ptr_table_new();
572 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
573 PERL_THREAD_SETSPECIFIC(self_key,thread);
577 I32 len = av_len(params)+1;
579 for(i = 0; i < len; i++) {
580 sv_dump(SvRV(AvARRAY(params)[i]));
584 retparam = (AV*) sv_dup((SV*)params, &clone_params);
587 I32 len = av_len(retparam)+1;
589 for(i = 0; i < len; i++) {
590 sv_dump(SvRV(AvARRAY(retparam)[i]));
594 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
595 SvREFCNT_dec(clone_params.stashes);
596 SvREFCNT_inc(retparam);
597 ptr_table_free(PL_ptr_table);
601 /* We have finished with it */
602 thread->state |= PERL_ITHR_JOINED;
603 MUTEX_UNLOCK(&thread->mutex);
611 Perl_ithread_DESTROY(pTHX_ SV *sv)
613 ithread *thread = SV_to_ithread(aTHX_ sv);
614 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
617 #endif /* USE_ITHREADS */
619 MODULE = threads PACKAGE = threads PREFIX = ithread_
625 ithread_new (classname, function_to_call, ...)
627 SV * function_to_call
630 AV* params = newAV();
633 for(i = 2; i < items ; i++) {
634 av_push(params, SvREFCNT_inc(ST(i)));
637 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
642 ithread_list(char *classname)
645 ithread *curr_thread;
646 MUTEX_LOCK(&create_destruct_mutex);
647 curr_thread = threads;
648 if(curr_thread->tid != 0)
649 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
651 curr_thread = curr_thread->next;
652 if(curr_thread == threads)
654 if(curr_thread->state & PERL_ITHR_DETACHED ||
655 curr_thread->state & PERL_ITHR_JOINED)
657 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
659 MUTEX_UNLOCK(&create_destruct_mutex);
664 ithread_self(char *classname)
667 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
672 ithread_tid(ithread *thread)
675 ithread_join(SV *obj)
678 AV* params = Perl_ithread_join(aTHX_ obj);
680 I32 len = AvFILL(params);
681 for (i = 0; i <= len; i++) {
682 SV* tmp = av_shift(params);
686 SvREFCNT_dec(params);
698 ithread_detach(ithread *thread)
701 ithread_DESTROY(SV *thread)
703 #endif /* USE_ITHREADS */
709 PL_perl_destruct_level = 2;
710 PERL_THREAD_ALLOC_SPECIFIC(self_key);
711 MUTEX_INIT(&create_destruct_mutex);
712 MUTEX_LOCK(&create_destruct_mutex);
713 PL_threadhook = &Perl_ithread_hook;
714 thread = PerlMemShared_malloc(sizeof(ithread));
715 Zero(thread,1,ithread);
716 PL_perl_destruct_level = 2;
717 MUTEX_INIT(&thread->mutex);
719 thread->next = thread;
720 thread->prev = thread;
721 thread->interp = aTHX;
722 thread->count = 1; /* imortal */
723 thread->tid = tid_counter++;
728 thread->thr = GetCurrentThreadId();
730 thread->thr = pthread_self();
733 PERL_THREAD_SETSPECIFIC(self_key,thread);
734 MUTEX_UNLOCK(&create_destruct_mutex);
735 #endif /* USE_ITHREADS */