1 #define PERL_NO_GET_CONTEXT
11 #include <win32thread.h>
14 typedef perl_os_thread pthread_t;
19 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
20 #ifdef OLD_PTHREADS_API
21 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
23 #define PERL_THREAD_DETACH(t) pthread_detach((t))
24 #endif /* OLD_PTHREADS_API */
30 /* Values for 'state' member */
31 #define PERL_ITHR_JOINABLE 0
32 #define PERL_ITHR_DETACHED 1
33 #define PERL_ITHR_FINISHED 4
34 #define PERL_ITHR_JOINED 2
36 typedef struct ithread_s {
37 struct ithread_s *next; /* Next thread in the list */
38 struct ithread_s *prev; /* Prev thread in the list */
39 PerlInterpreter *interp; /* The threads interpreter */
40 I32 tid; /* Threads module's thread id */
41 perl_mutex mutex; /* Mutex for updating things in this struct */
42 I32 count; /* How many SVs have a reference to us */
43 signed char state; /* Are we detached ? */
44 int gimme; /* Context of create */
45 SV* init_function; /* Code to run */
46 SV* params; /* Args to pass function */
48 DWORD thr; /* OS's idea if thread id */
49 HANDLE handle; /* OS's waitable handle */
51 pthread_t thr; /* OS's handle for the thread */
57 /* Macros to supply the aTHX_ in an embed.h like manner */
58 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
59 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
60 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
61 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
62 #define ithread_tid(thread) ((thread)->tid)
63 #define ithread_yield(thread) (YIELD);
65 static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
68 I32 known_threads = 0;
69 I32 active_threads = 0;
72 void Perl_ithread_set (pTHX_ ithread* thread)
74 SV* thread_sv = newSViv(PTR2IV(thread));
75 if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
76 croak("%s\n","Internal error, couldn't set TLS");
80 ithread* Perl_ithread_get (pTHX) {
81 SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
83 croak("%s\n","Internal error, couldn't get TLS");
85 return INT2PTR(ithread*,SvIV(*thread_sv));
91 * Clear up after thread is done with
94 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
96 PerlInterpreter *freeperl = NULL;
97 MUTEX_LOCK(&thread->mutex);
99 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
101 if (thread->count != 0) {
102 MUTEX_UNLOCK(&thread->mutex);
105 MUTEX_LOCK(&create_destruct_mutex);
106 /* Remove from circular list of threads */
107 if (thread->next == thread) {
108 /* last one should never get here ? */
112 thread->next->prev = thread->prev;
113 thread->prev->next = thread->next;
114 if (threads == thread) {
115 threads = thread->next;
121 assert( known_threads >= 0 );
123 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
124 thread->tid,thread->interp,aTHX, known_threads);
126 MUTEX_UNLOCK(&create_destruct_mutex);
127 /* Thread is now disowned */
130 dTHXa(thread->interp);
131 ithread* current_thread;
135 PERL_SET_CONTEXT(thread->interp);
136 current_thread = Perl_ithread_get(aTHX);
137 Perl_ithread_set(aTHX_ thread);
142 SvREFCNT_dec(thread->params);
146 thread->params = Nullsv;
147 perl_destruct(thread->interp);
148 freeperl = thread->interp;
149 thread->interp = NULL;
151 MUTEX_UNLOCK(&thread->mutex);
152 MUTEX_DESTROY(&thread->mutex);
153 PerlMemShared_free(thread);
157 PERL_SET_CONTEXT(aTHX);
161 Perl_ithread_hook(pTHX)
163 int veto_cleanup = 0;
164 MUTEX_LOCK(&create_destruct_mutex);
165 if (aTHX == PL_curinterp && active_threads != 1) {
166 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
170 MUTEX_UNLOCK(&create_destruct_mutex);
175 Perl_ithread_detach(pTHX_ ithread *thread)
177 MUTEX_LOCK(&thread->mutex);
178 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
179 thread->state |= PERL_ITHR_DETACHED;
181 CloseHandle(thread->handle);
184 PERL_THREAD_DETACH(thread->thr);
187 if ((thread->state & PERL_ITHR_FINISHED) &&
188 (thread->state & PERL_ITHR_DETACHED)) {
189 MUTEX_UNLOCK(&thread->mutex);
190 Perl_ithread_destruct(aTHX_ thread, "detach");
193 MUTEX_UNLOCK(&thread->mutex);
197 /* MAGIC (in mg.h sense) hooks */
200 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
202 ithread *thread = (ithread *) mg->mg_ptr;
203 SvIVX(sv) = PTR2IV(thread);
209 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
211 ithread *thread = (ithread *) mg->mg_ptr;
212 MUTEX_LOCK(&thread->mutex);
214 if (thread->count == 0) {
215 if(thread->state & PERL_ITHR_FINISHED &&
216 (thread->state & PERL_ITHR_DETACHED ||
217 thread->state & PERL_ITHR_JOINED))
219 MUTEX_UNLOCK(&thread->mutex);
220 Perl_ithread_destruct(aTHX_ thread, "no reference");
223 MUTEX_UNLOCK(&thread->mutex);
227 MUTEX_UNLOCK(&thread->mutex);
233 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
235 ithread *thread = (ithread *) mg->mg_ptr;
236 MUTEX_LOCK(&thread->mutex);
238 MUTEX_UNLOCK(&thread->mutex);
242 MGVTBL ithread_vtbl = {
243 ithread_mg_get, /* get */
247 ithread_mg_free, /* free */
249 ithread_mg_dup /* dup */
254 * Starts executing the thread. Needs to clean up memory a tad better.
255 * Passed as the C level function to run in the new thread
260 Perl_ithread_run(LPVOID arg) {
263 Perl_ithread_run(void * arg) {
265 ithread* thread = (ithread*) arg;
266 dTHXa(thread->interp);
267 PERL_SET_CONTEXT(thread->interp);
268 Perl_ithread_set(aTHX_ thread);
271 /* Far from clear messing with ->thr child-side is a good idea */
272 MUTEX_LOCK(&thread->mutex);
274 thread->thr = GetCurrentThreadId();
276 thread->thr = pthread_self();
278 MUTEX_UNLOCK(&thread->mutex);
281 PL_perl_destruct_level = 2;
284 AV* params = (AV*) SvRV(thread->params);
285 I32 len = av_len(params)+1;
291 for(i = 0; i < len; i++) {
292 XPUSHs(av_shift(params));
295 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
298 for (i=len-1; i >= 0; i--) {
300 av_store(params, i, SvREFCNT_inc(sv));
303 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
307 SvREFCNT_dec(thread->init_function);
310 PerlIO_flush((PerlIO*)NULL);
311 MUTEX_LOCK(&thread->mutex);
312 thread->state |= PERL_ITHR_FINISHED;
314 if (thread->state & PERL_ITHR_DETACHED) {
315 MUTEX_UNLOCK(&thread->mutex);
316 Perl_ithread_destruct(aTHX_ thread, "detached finish");
318 MUTEX_UNLOCK(&thread->mutex);
320 MUTEX_LOCK(&create_destruct_mutex);
322 assert( active_threads >= 0 );
323 MUTEX_UNLOCK(&create_destruct_mutex);
333 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
338 MUTEX_LOCK(&thread->mutex);
340 MUTEX_UNLOCK(&thread->mutex);
344 sv = newSVrv(obj,classname);
345 sv_setiv(sv,PTR2IV(thread));
346 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
347 mg->mg_flags |= MGf_DUP;
353 SV_to_ithread(pTHX_ SV *sv)
357 return INT2PTR(ithread*, SvIV(SvRV(sv)));
361 return Perl_ithread_get(aTHX);
366 * ithread->create(); ( aka ithread->new() )
367 * Called in context of parent thread
371 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
374 CLONE_PARAMS clone_param;
375 ithread* current_thread = Perl_ithread_get(aTHX);
377 SV** tmps_tmp = PL_tmps_stack;
378 I32 tmps_ix = PL_tmps_ix;
381 MUTEX_LOCK(&create_destruct_mutex);
382 thread = PerlMemShared_malloc(sizeof(ithread));
383 Zero(thread,1,ithread);
384 thread->next = threads;
385 thread->prev = threads->prev;
386 threads->prev = thread;
387 thread->prev->next = thread;
388 /* Set count to 1 immediately in case thread exits before
389 * we return to caller !
392 MUTEX_INIT(&thread->mutex);
393 thread->tid = tid_counter++;
394 thread->gimme = GIMME_V;
396 /* "Clone" our interpreter into the thread's interpreter
397 * This gives thread access to "static data" and code.
400 PerlIO_flush((PerlIO*)NULL);
401 Perl_ithread_set(aTHX_ thread);
403 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
405 PL_srand_called = FALSE; /* Set it to false so we can detect
406 if it gets set during the clone */
409 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
411 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
413 /* perl_clone leaves us in new interpreter's context.
414 As it is tricky to spot an implicit aTHX, create a new scope
415 with aTHX matching the context for the duration of
416 our work for new interpreter.
419 dTHXa(thread->interp);
421 /* Here we remove END blocks since they should only run
422 in the thread they are created
424 SvREFCNT_dec(PL_endav);
426 clone_param.flags = 0;
427 thread->init_function = sv_dup(init_function, &clone_param);
428 if (SvREFCNT(thread->init_function) == 0) {
429 SvREFCNT_inc(thread->init_function);
434 thread->params = sv_dup(params, &clone_param);
435 SvREFCNT_inc(thread->params);
438 /* The code below checks that anything living on
439 the tmps stack and has been cloned (so it lives in the
440 ptr_table) has a refcount higher than 0
442 If the refcount is 0 it means that a something on the
443 stack/context was holding a reference to it and
444 since we init_stacks() in perl_clone that won't get
445 cleaned and we will get a leaked scalar.
446 The reason it was cloned was that it lived on the
449 Example of this can be found in bugreport 15837
450 where calls in the parameter list end up as a temp
452 One could argue that this fix should be in perl_clone
456 while (tmps_ix > 0) {
457 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
459 if (sv && SvREFCNT(sv) == 0) {
467 SvTEMP_off(thread->init_function);
468 ptr_table_free(PL_ptr_table);
470 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
472 Perl_ithread_set(aTHX_ current_thread);
473 PERL_SET_CONTEXT(aTHX);
475 /* Start the thread */
479 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
480 (LPVOID)thread, 0, &thread->thr);
484 static pthread_attr_t attr;
485 static int attr_inited = 0;
486 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
489 pthread_attr_init(&attr);
491 # ifdef PTHREAD_ATTR_SETDETACHSTATE
492 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
494 # ifdef THREAD_CREATE_NEEDS_STACK
495 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
496 Perl_croak(aTHX_ "panic: pthread_attr_setstacksize failed");
499 #ifdef OLD_PTHREADS_API
500 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
502 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
503 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
505 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
511 MUTEX_UNLOCK(&create_destruct_mutex);
514 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
518 Perl_ithread_self (pTHX_ SV *obj, char* Class)
520 ithread *thread = Perl_ithread_get(aTHX);
522 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
524 Perl_croak(aTHX_ "panic: cannot find thread data");
525 return NULL; /* silence compiler warning */
529 * Joins the thread this code needs to take the returnvalue from the
530 * call_sv and send it back
534 Perl_ithread_CLONE(pTHX_ SV *obj)
538 ithread *thread = SV_to_ithread(aTHX_ obj);
542 Perl_warn(aTHX_ "CLONE %" SVf,obj);
547 Perl_ithread_join(pTHX_ SV *obj)
549 ithread *thread = SV_to_ithread(aTHX_ obj);
550 MUTEX_LOCK(&thread->mutex);
551 if (thread->state & PERL_ITHR_DETACHED) {
552 MUTEX_UNLOCK(&thread->mutex);
553 Perl_croak(aTHX_ "Cannot join a detached thread");
555 else if (thread->state & PERL_ITHR_JOINED) {
556 MUTEX_UNLOCK(&thread->mutex);
557 Perl_croak(aTHX_ "Thread already joined");
566 MUTEX_UNLOCK(&thread->mutex);
568 waitcode = WaitForSingleObject(thread->handle, INFINITE);
570 pthread_join(thread->thr,&retval);
572 MUTEX_LOCK(&thread->mutex);
574 /* sv_dup over the args */
576 ithread* current_thread;
577 AV* params = (AV*) SvRV(thread->params);
578 PerlInterpreter *other_perl = thread->interp;
579 CLONE_PARAMS clone_params;
580 clone_params.stashes = newAV();
581 clone_params.flags |= CLONEf_JOIN_IN;
582 PL_ptr_table = ptr_table_new();
583 current_thread = Perl_ithread_get(aTHX);
584 Perl_ithread_set(aTHX_ thread);
585 /* ensure 'meaningful' addresses retain their meaning */
586 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
587 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
588 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
592 I32 len = av_len(params)+1;
594 for(i = 0; i < len; i++) {
595 sv_dump(SvRV(AvARRAY(params)[i]));
599 retparam = (AV*) sv_dup((SV*)params, &clone_params);
602 I32 len = av_len(retparam)+1;
604 for(i = 0; i < len; i++) {
605 sv_dump(SvRV(AvARRAY(retparam)[i]));
609 Perl_ithread_set(aTHX_ current_thread);
610 SvREFCNT_dec(clone_params.stashes);
611 SvREFCNT_inc(retparam);
612 ptr_table_free(PL_ptr_table);
616 /* We are finished with it */
617 thread->state |= PERL_ITHR_JOINED;
618 MUTEX_UNLOCK(&thread->mutex);
626 Perl_ithread_DESTROY(pTHX_ SV *sv)
628 ithread *thread = SV_to_ithread(aTHX_ sv);
629 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
632 #endif /* USE_ITHREADS */
634 MODULE = threads PACKAGE = threads PREFIX = ithread_
640 ithread_new (classname, function_to_call, ...)
642 SV * function_to_call
645 AV* params = newAV();
648 for(i = 2; i < items ; i++) {
649 av_push(params, SvREFCNT_inc(ST(i)));
652 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
657 ithread_list(char *classname)
660 ithread *curr_thread;
661 MUTEX_LOCK(&create_destruct_mutex);
662 curr_thread = threads;
663 if(curr_thread->tid != 0)
664 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
666 curr_thread = curr_thread->next;
667 if(curr_thread == threads)
669 if(curr_thread->state & PERL_ITHR_DETACHED ||
670 curr_thread->state & PERL_ITHR_JOINED)
672 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
674 MUTEX_UNLOCK(&create_destruct_mutex);
679 ithread_self(char *classname)
682 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
687 ithread_tid(ithread *thread)
690 ithread_join(SV *obj)
693 AV* params = Perl_ithread_join(aTHX_ obj);
695 I32 len = AvFILL(params);
696 for (i = 0; i <= len; i++) {
697 SV* tmp = av_shift(params);
701 SvREFCNT_dec(params);
713 ithread_detach(ithread *thread)
716 ithread_DESTROY(SV *thread)
718 #endif /* USE_ITHREADS */
724 PL_perl_destruct_level = 2;
725 MUTEX_INIT(&create_destruct_mutex);
726 MUTEX_LOCK(&create_destruct_mutex);
727 PL_threadhook = &Perl_ithread_hook;
728 thread = PerlMemShared_malloc(sizeof(ithread));
729 Zero(thread,1,ithread);
730 PL_perl_destruct_level = 2;
731 MUTEX_INIT(&thread->mutex);
733 thread->next = thread;
734 thread->prev = thread;
735 thread->interp = aTHX;
736 thread->count = 1; /* Immortal. */
737 thread->tid = tid_counter++;
740 thread->state = PERL_ITHR_DETACHED;
742 thread->thr = GetCurrentThreadId();
744 thread->thr = pthread_self();
747 Perl_ithread_set(aTHX_ thread);
748 MUTEX_UNLOCK(&create_destruct_mutex);
749 #endif /* USE_ITHREADS */