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 # define PERL_THREAD_GETSPECIFIC_THREAD(k, t) STMT_START { void *gsptr; PERL_THREAD_GETSPECIFIC(k, gsptr); t = (ithread *) gsptr; } STMT_END
52 # define PERL_THREAD_GETSPECIFIC_THREAD(k, t) PERL_THREAD_GETSPECIFIC(k, t)
55 /* Values for 'state' member */
56 #define PERL_ITHR_JOINABLE 0
57 #define PERL_ITHR_DETACHED 1
58 #define PERL_ITHR_FINISHED 4
59 #define PERL_ITHR_JOINED 2
61 typedef struct ithread_s {
62 struct ithread_s *next; /* Next thread in the list */
63 struct ithread_s *prev; /* Prev thread in the list */
64 PerlInterpreter *interp; /* The threads interpreter */
65 I32 tid; /* Threads module's thread id */
66 perl_mutex mutex; /* Mutex for updating things in this struct */
67 I32 count; /* How many SVs have a reference to us */
68 signed char state; /* Are we detached ? */
69 int gimme; /* Context of create */
70 SV* init_function; /* Code to run */
71 SV* params; /* Args to pass function */
73 DWORD thr; /* OS's idea if thread id */
74 HANDLE handle; /* OS's waitable handle */
76 pthread_t thr; /* OS's handle for the thread */
82 /* Macros to supply the aTHX_ in an embed.h like manner */
83 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
84 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
85 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
86 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
87 #define ithread_tid(thread) ((thread)->tid)
88 #define ithread_yield(thread) (YIELD);
90 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
93 I32 known_threads = 0;
94 I32 active_threads = 0;
98 * Clear up after thread is done with
101 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
103 MUTEX_LOCK(&thread->mutex);
105 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
107 if (thread->count != 0) {
108 MUTEX_UNLOCK(&thread->mutex);
111 MUTEX_LOCK(&create_destruct_mutex);
112 /* Remove from circular list of threads */
113 if (thread->next == thread) {
114 /* last one should never get here ? */
118 thread->next->prev = thread->prev;
119 thread->prev->next = thread->next;
120 if (threads == thread) {
121 threads = thread->next;
127 assert( known_threads >= 0 );
129 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
130 thread->tid,thread->interp,aTHX, known_threads);
132 MUTEX_UNLOCK(&create_destruct_mutex);
133 /* Thread is now disowned */
136 dTHXa(thread->interp);
137 ithread* current_thread;
141 PERL_SET_CONTEXT(thread->interp);
142 PERL_THREAD_GETSPECIFIC_THREAD(self_key, current_thread);
143 PERL_THREAD_SETSPECIFIC(self_key,thread);
147 SvREFCNT_dec(thread->params);
151 thread->params = Nullsv;
152 perl_destruct(thread->interp);
153 perl_free(thread->interp);
154 thread->interp = NULL;
155 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
158 MUTEX_UNLOCK(&thread->mutex);
159 MUTEX_DESTROY(&thread->mutex);
160 PerlMemShared_free(thread);
162 PERL_SET_CONTEXT(aTHX);
166 Perl_ithread_hook(pTHX)
168 int veto_cleanup = 0;
169 MUTEX_LOCK(&create_destruct_mutex);
170 if (aTHX == PL_curinterp && active_threads != 1) {
171 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
175 MUTEX_UNLOCK(&create_destruct_mutex);
180 Perl_ithread_detach(pTHX_ ithread *thread)
182 MUTEX_LOCK(&thread->mutex);
183 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
184 thread->state |= PERL_ITHR_DETACHED;
186 CloseHandle(thread->handle);
189 PERL_THREAD_DETACH(thread->thr);
192 if ((thread->state & PERL_ITHR_FINISHED) &&
193 (thread->state & PERL_ITHR_DETACHED)) {
194 MUTEX_UNLOCK(&thread->mutex);
195 Perl_ithread_destruct(aTHX_ thread, "detach");
198 MUTEX_UNLOCK(&thread->mutex);
202 /* MAGIC (in mg.h sense) hooks */
205 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
207 ithread *thread = (ithread *) mg->mg_ptr;
208 SvIVX(sv) = PTR2IV(thread);
214 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
216 ithread *thread = (ithread *) mg->mg_ptr;
217 MUTEX_LOCK(&thread->mutex);
219 if (thread->count == 0) {
220 if(thread->state & PERL_ITHR_FINISHED &&
221 (thread->state & PERL_ITHR_DETACHED ||
222 thread->state & PERL_ITHR_JOINED))
224 MUTEX_UNLOCK(&thread->mutex);
225 Perl_ithread_destruct(aTHX_ thread, "no reference");
228 MUTEX_UNLOCK(&thread->mutex);
232 MUTEX_UNLOCK(&thread->mutex);
238 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
240 ithread *thread = (ithread *) mg->mg_ptr;
241 MUTEX_LOCK(&thread->mutex);
243 MUTEX_UNLOCK(&thread->mutex);
247 MGVTBL ithread_vtbl = {
248 ithread_mg_get, /* get */
252 ithread_mg_free, /* free */
254 ithread_mg_dup /* dup */
259 * Starts executing the thread. Needs to clean up memory a tad better.
260 * Passed as the C level function to run in the new thread
265 Perl_ithread_run(LPVOID arg) {
268 Perl_ithread_run(void * arg) {
270 ithread* thread = (ithread*) arg;
271 dTHXa(thread->interp);
272 PERL_SET_CONTEXT(thread->interp);
273 PERL_THREAD_SETSPECIFIC(self_key,thread);
276 /* Far from clear messing with ->thr child-side is a good idea */
277 MUTEX_LOCK(&thread->mutex);
279 thread->thr = GetCurrentThreadId();
281 thread->thr = pthread_self();
283 MUTEX_UNLOCK(&thread->mutex);
286 PL_perl_destruct_level = 2;
289 AV* params = (AV*) SvRV(thread->params);
290 I32 len = av_len(params)+1;
296 for(i = 0; i < len; i++) {
297 XPUSHs(av_shift(params));
300 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
303 for (i=len-1; i >= 0; i--) {
305 av_store(params, i, SvREFCNT_inc(sv));
308 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
312 SvREFCNT_dec(thread->init_function);
315 PerlIO_flush((PerlIO*)NULL);
316 MUTEX_LOCK(&thread->mutex);
317 thread->state |= PERL_ITHR_FINISHED;
319 if (thread->state & PERL_ITHR_DETACHED) {
320 MUTEX_UNLOCK(&thread->mutex);
321 Perl_ithread_destruct(aTHX_ thread, "detached finish");
323 MUTEX_UNLOCK(&thread->mutex);
325 MUTEX_LOCK(&create_destruct_mutex);
327 assert( active_threads >= 0 );
328 MUTEX_UNLOCK(&create_destruct_mutex);
338 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
343 MUTEX_LOCK(&thread->mutex);
345 MUTEX_UNLOCK(&thread->mutex);
349 sv = newSVrv(obj,classname);
350 sv_setiv(sv,PTR2IV(thread));
351 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
352 mg->mg_flags |= MGf_DUP;
358 SV_to_ithread(pTHX_ SV *sv)
363 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
367 PERL_THREAD_GETSPECIFIC_THREAD(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_THREAD(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 Perl_croak(aTHX_ "panic: pthread_attr_setstacksize failed");
506 #ifdef OLD_PTHREADS_API
507 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
509 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(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)
528 PERL_THREAD_GETSPECIFIC_THREAD(self_key, thread);
530 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
532 Perl_croak(aTHX_ "panic: cannot find thread data");
536 * Joins the thread this code needs to take the returnvalue from the
537 * call_sv and send it back
541 Perl_ithread_CLONE(pTHX_ SV *obj)
545 ithread *thread = SV_to_ithread(aTHX_ obj);
549 Perl_warn(aTHX_ "CLONE %" SVf,obj);
554 Perl_ithread_join(pTHX_ SV *obj)
556 ithread *thread = SV_to_ithread(aTHX_ obj);
557 MUTEX_LOCK(&thread->mutex);
558 if (thread->state & PERL_ITHR_DETACHED) {
559 MUTEX_UNLOCK(&thread->mutex);
560 Perl_croak(aTHX_ "Cannot join a detached thread");
562 else if (thread->state & PERL_ITHR_JOINED) {
563 MUTEX_UNLOCK(&thread->mutex);
564 Perl_croak(aTHX_ "Thread already joined");
573 MUTEX_UNLOCK(&thread->mutex);
575 waitcode = WaitForSingleObject(thread->handle, INFINITE);
577 pthread_join(thread->thr,&retval);
579 MUTEX_LOCK(&thread->mutex);
581 /* sv_dup over the args */
583 ithread* current_thread;
584 AV* params = (AV*) SvRV(thread->params);
585 CLONE_PARAMS clone_params;
586 clone_params.stashes = newAV();
587 clone_params.flags |= CLONEf_JOIN_IN;
588 PL_ptr_table = ptr_table_new();
589 PERL_THREAD_GETSPECIFIC_THREAD(self_key, current_thread);
590 PERL_THREAD_SETSPECIFIC(self_key,thread);
594 I32 len = av_len(params)+1;
596 for(i = 0; i < len; i++) {
597 sv_dump(SvRV(AvARRAY(params)[i]));
601 retparam = (AV*) sv_dup((SV*)params, &clone_params);
604 I32 len = av_len(retparam)+1;
606 for(i = 0; i < len; i++) {
607 sv_dump(SvRV(AvARRAY(retparam)[i]));
611 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
612 SvREFCNT_dec(clone_params.stashes);
613 SvREFCNT_inc(retparam);
614 ptr_table_free(PL_ptr_table);
618 /* We are finished with it */
619 thread->state |= PERL_ITHR_JOINED;
620 MUTEX_UNLOCK(&thread->mutex);
628 Perl_ithread_DESTROY(pTHX_ SV *sv)
630 ithread *thread = SV_to_ithread(aTHX_ sv);
631 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
634 #endif /* USE_ITHREADS */
636 MODULE = threads PACKAGE = threads PREFIX = ithread_
642 ithread_new (classname, function_to_call, ...)
644 SV * function_to_call
647 AV* params = newAV();
650 for(i = 2; i < items ; i++) {
651 av_push(params, SvREFCNT_inc(ST(i)));
654 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
659 ithread_list(char *classname)
662 ithread *curr_thread;
663 MUTEX_LOCK(&create_destruct_mutex);
664 curr_thread = threads;
665 if(curr_thread->tid != 0)
666 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
668 curr_thread = curr_thread->next;
669 if(curr_thread == threads)
671 if(curr_thread->state & PERL_ITHR_DETACHED ||
672 curr_thread->state & PERL_ITHR_JOINED)
674 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
676 MUTEX_UNLOCK(&create_destruct_mutex);
681 ithread_self(char *classname)
684 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
689 ithread_tid(ithread *thread)
692 ithread_join(SV *obj)
695 AV* params = Perl_ithread_join(aTHX_ obj);
697 I32 len = AvFILL(params);
698 for (i = 0; i <= len; i++) {
699 SV* tmp = av_shift(params);
703 SvREFCNT_dec(params);
715 ithread_detach(ithread *thread)
718 ithread_DESTROY(SV *thread)
720 #endif /* USE_ITHREADS */
726 PL_perl_destruct_level = 2;
727 PERL_THREAD_ALLOC_SPECIFIC(self_key);
728 MUTEX_INIT(&create_destruct_mutex);
729 MUTEX_LOCK(&create_destruct_mutex);
730 PL_threadhook = &Perl_ithread_hook;
731 thread = PerlMemShared_malloc(sizeof(ithread));
732 Zero(thread,1,ithread);
733 PL_perl_destruct_level = 2;
734 MUTEX_INIT(&thread->mutex);
736 thread->next = thread;
737 thread->prev = thread;
738 thread->interp = aTHX;
739 thread->count = 1; /* Immortal. */
740 thread->tid = tid_counter++;
743 thread->state = PERL_ITHR_DETACHED;
745 thread->thr = GetCurrentThreadId();
747 thread->thr = pthread_self();
750 PERL_THREAD_SETSPECIFIC(self_key,thread);
751 MUTEX_UNLOCK(&create_destruct_mutex);
752 #endif /* USE_ITHREADS */