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));
89 /* free any data (such as the perl interpreter) attached to an
90 * ithread structure. This is a bit like undef on SVs, where the SV
91 * isn't freed, but the PVX is.
92 * Must be called with thread->mutex already held
96 S_ithread_clear(pTHX_ ithread* thread)
98 PerlInterpreter *interp;
99 assert(thread->state & PERL_ITHR_FINISHED &&
100 (thread->state & PERL_ITHR_DETACHED ||
101 thread->state & PERL_ITHR_JOINED));
103 interp = thread->interp;
106 ithread* current_thread;
110 PERL_SET_CONTEXT(interp);
111 current_thread = Perl_ithread_get(aTHX);
112 Perl_ithread_set(aTHX_ thread);
114 SvREFCNT_dec(thread->params);
116 thread->params = Nullsv;
117 perl_destruct(interp);
118 thread->interp = NULL;
122 PERL_SET_CONTEXT(aTHX);
127 * free an ithread structure and any attached data if its count == 0
130 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
132 MUTEX_LOCK(&thread->mutex);
134 MUTEX_UNLOCK(&thread->mutex);
135 Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
137 if (thread->count != 0) {
138 MUTEX_UNLOCK(&thread->mutex);
141 MUTEX_LOCK(&create_destruct_mutex);
142 /* Remove from circular list of threads */
143 if (thread->next == thread) {
144 /* last one should never get here ? */
148 thread->next->prev = thread->prev;
149 thread->prev->next = thread->next;
150 if (threads == thread) {
151 threads = thread->next;
157 assert( known_threads >= 0 );
159 Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
160 thread->tid,thread->interp,aTHX, known_threads);
162 MUTEX_UNLOCK(&create_destruct_mutex);
163 /* Thread is now disowned */
165 S_ithread_clear(aTHX_ thread);
166 MUTEX_UNLOCK(&thread->mutex);
167 MUTEX_DESTROY(&thread->mutex);
170 CloseHandle(thread->handle);
173 PerlMemShared_free(thread);
177 Perl_ithread_hook(pTHX)
179 int veto_cleanup = 0;
180 MUTEX_LOCK(&create_destruct_mutex);
181 if (aTHX == PL_curinterp && active_threads != 1) {
182 if (ckWARN_d(WARN_THREADS))
183 Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
187 MUTEX_UNLOCK(&create_destruct_mutex);
192 Perl_ithread_detach(pTHX_ ithread *thread)
194 MUTEX_LOCK(&thread->mutex);
195 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
196 thread->state |= PERL_ITHR_DETACHED;
198 CloseHandle(thread->handle);
201 PERL_THREAD_DETACH(thread->thr);
204 if ((thread->state & PERL_ITHR_FINISHED) &&
205 (thread->state & PERL_ITHR_DETACHED)) {
206 MUTEX_UNLOCK(&thread->mutex);
207 Perl_ithread_destruct(aTHX_ thread, "detach");
210 MUTEX_UNLOCK(&thread->mutex);
214 /* MAGIC (in mg.h sense) hooks */
217 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
219 ithread *thread = (ithread *) mg->mg_ptr;
220 SvIV_set(sv, PTR2IV(thread));
226 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
228 ithread *thread = (ithread *) mg->mg_ptr;
229 MUTEX_LOCK(&thread->mutex);
231 if (thread->count == 0) {
232 if(thread->state & PERL_ITHR_FINISHED &&
233 (thread->state & PERL_ITHR_DETACHED ||
234 thread->state & PERL_ITHR_JOINED))
236 MUTEX_UNLOCK(&thread->mutex);
237 Perl_ithread_destruct(aTHX_ thread, "no reference");
240 MUTEX_UNLOCK(&thread->mutex);
244 MUTEX_UNLOCK(&thread->mutex);
250 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
252 ithread *thread = (ithread *) mg->mg_ptr;
253 MUTEX_LOCK(&thread->mutex);
255 MUTEX_UNLOCK(&thread->mutex);
259 MGVTBL ithread_vtbl = {
260 ithread_mg_get, /* get */
264 ithread_mg_free, /* free */
266 ithread_mg_dup /* dup */
271 * Starts executing the thread. Needs to clean up memory a tad better.
272 * Passed as the C level function to run in the new thread
277 Perl_ithread_run(LPVOID arg) {
280 Perl_ithread_run(void * arg) {
282 ithread* thread = (ithread*) arg;
283 dTHXa(thread->interp);
284 PERL_SET_CONTEXT(thread->interp);
285 Perl_ithread_set(aTHX_ thread);
288 /* Far from clear messing with ->thr child-side is a good idea */
289 MUTEX_LOCK(&thread->mutex);
291 thread->thr = GetCurrentThreadId();
293 thread->thr = pthread_self();
295 MUTEX_UNLOCK(&thread->mutex);
298 PL_perl_destruct_level = 2;
301 AV* params = (AV*) SvRV(thread->params);
302 I32 len = av_len(params)+1;
308 for(i = 0; i < len; i++) {
309 XPUSHs(av_shift(params));
312 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
315 for (i=len-1; i >= 0; i--) {
317 av_store(params, i, SvREFCNT_inc(sv));
319 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
320 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
324 SvREFCNT_dec(thread->init_function);
327 PerlIO_flush((PerlIO*)NULL);
328 MUTEX_LOCK(&thread->mutex);
329 thread->state |= PERL_ITHR_FINISHED;
331 if (thread->state & PERL_ITHR_DETACHED) {
332 MUTEX_UNLOCK(&thread->mutex);
333 Perl_ithread_destruct(aTHX_ thread, "detached finish");
335 MUTEX_UNLOCK(&thread->mutex);
337 MUTEX_LOCK(&create_destruct_mutex);
339 assert( active_threads >= 0 );
340 MUTEX_UNLOCK(&create_destruct_mutex);
350 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
355 MUTEX_LOCK(&thread->mutex);
357 MUTEX_UNLOCK(&thread->mutex);
361 sv = newSVrv(obj,classname);
362 sv_setiv(sv,PTR2IV(thread));
363 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
364 mg->mg_flags |= MGf_DUP;
370 SV_to_ithread(pTHX_ SV *sv)
374 return INT2PTR(ithread*, SvIV(SvRV(sv)));
378 return Perl_ithread_get(aTHX);
383 * ithread->create(); ( aka ithread->new() )
384 * Called in context of parent thread
388 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
391 CLONE_PARAMS clone_param;
392 ithread* current_thread = Perl_ithread_get(aTHX);
394 SV** tmps_tmp = PL_tmps_stack;
395 I32 tmps_ix = PL_tmps_ix;
398 const char* panic = NULL;
402 MUTEX_LOCK(&create_destruct_mutex);
403 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
405 MUTEX_UNLOCK(&create_destruct_mutex);
406 PerlLIO_write(PerlIO_fileno(Perl_error_log),
407 PL_no_mem, strlen(PL_no_mem));
410 Zero(thread,1,ithread);
411 thread->next = threads;
412 thread->prev = threads->prev;
413 threads->prev = thread;
414 thread->prev->next = thread;
415 /* Set count to 1 immediately in case thread exits before
416 * we return to caller !
419 MUTEX_INIT(&thread->mutex);
420 thread->tid = tid_counter++;
421 thread->gimme = GIMME_V;
423 /* "Clone" our interpreter into the thread's interpreter
424 * This gives thread access to "static data" and code.
427 PerlIO_flush((PerlIO*)NULL);
428 Perl_ithread_set(aTHX_ thread);
430 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
432 PL_srand_called = FALSE; /* Set it to false so we can detect
433 if it gets set during the clone */
436 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
438 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
440 /* perl_clone leaves us in new interpreter's context.
441 As it is tricky to spot an implicit aTHX, create a new scope
442 with aTHX matching the context for the duration of
443 our work for new interpreter.
446 dTHXa(thread->interp);
448 /* Here we remove END blocks since they should only run
449 in the thread they are created
451 SvREFCNT_dec(PL_endav);
453 clone_param.flags = 0;
454 thread->init_function = sv_dup(init_function, &clone_param);
455 if (SvREFCNT(thread->init_function) == 0) {
456 SvREFCNT_inc(thread->init_function);
461 thread->params = sv_dup(params, &clone_param);
462 SvREFCNT_inc(thread->params);
465 /* The code below checks that anything living on
466 the tmps stack and has been cloned (so it lives in the
467 ptr_table) has a refcount higher than 0
469 If the refcount is 0 it means that a something on the
470 stack/context was holding a reference to it and
471 since we init_stacks() in perl_clone that won't get
472 cleaned and we will get a leaked scalar.
473 The reason it was cloned was that it lived on the
476 Example of this can be found in bugreport 15837
477 where calls in the parameter list end up as a temp
479 One could argue that this fix should be in perl_clone
483 while (tmps_ix > 0) {
484 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
486 if (sv && SvREFCNT(sv) == 0) {
494 SvTEMP_off(thread->init_function);
495 ptr_table_free(PL_ptr_table);
497 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
499 Perl_ithread_set(aTHX_ current_thread);
500 PERL_SET_CONTEXT(aTHX);
502 /* Start the thread */
505 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
506 (LPVOID)thread, 0, &thread->thr);
509 static pthread_attr_t attr;
510 static int attr_inited = 0;
511 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
514 pthread_attr_init(&attr);
516 # ifdef PTHREAD_ATTR_SETDETACHSTATE
517 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
519 # ifdef THREAD_CREATE_NEEDS_STACK
520 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
521 panic = "panic: pthread_attr_setstacksize failed";
524 #ifdef OLD_PTHREADS_API
526 = panic ? 1 : pthread_create( &thread->thr, attr,
527 Perl_ithread_run, (void *)thread);
529 # if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
530 pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
533 = panic ? 1 : pthread_create( &thread->thr, &attr,
534 Perl_ithread_run, (void *)thread);
541 thread->handle == NULL
546 MUTEX_UNLOCK(&create_destruct_mutex);
548 Perl_ithread_destruct(aTHX_ thread, "create failed");
551 Perl_croak(aTHX_ panic);
556 MUTEX_UNLOCK(&create_destruct_mutex);
559 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
563 Perl_ithread_self (pTHX_ SV *obj, char* Class)
565 ithread *thread = Perl_ithread_get(aTHX);
567 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
569 Perl_croak(aTHX_ "panic: cannot find thread data");
570 return NULL; /* silence compiler warning */
574 * Joins the thread this code needs to take the returnvalue from the
575 * call_sv and send it back
579 Perl_ithread_CLONE(pTHX_ SV *obj)
582 ithread *thread = SV_to_ithread(aTHX_ obj);
584 else if (ckWARN_d(WARN_THREADS)) {
585 Perl_warn(aTHX_ "CLONE %" SVf,obj);
590 Perl_ithread_join(pTHX_ SV *obj)
592 ithread *thread = SV_to_ithread(aTHX_ obj);
593 MUTEX_LOCK(&thread->mutex);
594 if (thread->state & PERL_ITHR_DETACHED) {
595 MUTEX_UNLOCK(&thread->mutex);
596 Perl_croak(aTHX_ "Cannot join a detached thread");
598 else if (thread->state & PERL_ITHR_JOINED) {
599 MUTEX_UNLOCK(&thread->mutex);
600 Perl_croak(aTHX_ "Thread already joined");
609 MUTEX_UNLOCK(&thread->mutex);
611 waitcode = WaitForSingleObject(thread->handle, INFINITE);
612 CloseHandle(thread->handle);
615 pthread_join(thread->thr,&retval);
617 MUTEX_LOCK(&thread->mutex);
619 /* sv_dup over the args */
621 ithread* current_thread;
622 AV* params = (AV*) SvRV(thread->params);
623 PerlInterpreter *other_perl = thread->interp;
624 CLONE_PARAMS clone_params;
625 clone_params.stashes = newAV();
626 clone_params.flags |= CLONEf_JOIN_IN;
627 PL_ptr_table = ptr_table_new();
628 current_thread = Perl_ithread_get(aTHX);
629 Perl_ithread_set(aTHX_ thread);
630 /* ensure 'meaningful' addresses retain their meaning */
631 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
632 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
633 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
637 I32 len = av_len(params)+1;
639 for(i = 0; i < len; i++) {
640 sv_dump(SvRV(AvARRAY(params)[i]));
644 retparam = (AV*) sv_dup((SV*)params, &clone_params);
647 I32 len = av_len(retparam)+1;
649 for(i = 0; i < len; i++) {
650 sv_dump(SvRV(AvARRAY(retparam)[i]));
654 Perl_ithread_set(aTHX_ current_thread);
655 SvREFCNT_dec(clone_params.stashes);
656 SvREFCNT_inc(retparam);
657 ptr_table_free(PL_ptr_table);
661 /* We are finished with it */
662 thread->state |= PERL_ITHR_JOINED;
663 S_ithread_clear(aTHX_ thread);
664 MUTEX_UNLOCK(&thread->mutex);
672 Perl_ithread_DESTROY(pTHX_ SV *sv)
674 ithread *thread = SV_to_ithread(aTHX_ sv);
675 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
678 #endif /* USE_ITHREADS */
680 MODULE = threads PACKAGE = threads PREFIX = ithread_
686 ithread_new (classname, function_to_call, ...)
688 SV * function_to_call
691 AV* params = newAV();
694 for(i = 2; i < items ; i++) {
695 av_push(params, SvREFCNT_inc(ST(i)));
698 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
703 ithread_list(char *classname)
706 ithread *curr_thread;
707 MUTEX_LOCK(&create_destruct_mutex);
708 curr_thread = threads;
709 if(curr_thread->tid != 0)
710 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
712 curr_thread = curr_thread->next;
713 if(curr_thread == threads)
715 if(curr_thread->state & PERL_ITHR_DETACHED ||
716 curr_thread->state & PERL_ITHR_JOINED)
718 XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
720 MUTEX_UNLOCK(&create_destruct_mutex);
725 ithread_self(char *classname)
728 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
733 ithread_tid(ithread *thread)
736 ithread_join(SV *obj)
739 AV* params = Perl_ithread_join(aTHX_ obj);
741 I32 len = AvFILL(params);
742 for (i = 0; i <= len; i++) {
743 SV* tmp = av_shift(params);
747 SvREFCNT_dec(params);
759 ithread_detach(ithread *thread)
762 ithread_DESTROY(SV *thread)
764 #endif /* USE_ITHREADS */
770 PL_perl_destruct_level = 2;
771 MUTEX_INIT(&create_destruct_mutex);
772 MUTEX_LOCK(&create_destruct_mutex);
773 PL_threadhook = &Perl_ithread_hook;
774 thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
776 PerlLIO_write(PerlIO_fileno(Perl_error_log),
777 PL_no_mem, strlen(PL_no_mem));
780 Zero(thread,1,ithread);
781 PL_perl_destruct_level = 2;
782 MUTEX_INIT(&thread->mutex);
784 thread->next = thread;
785 thread->prev = thread;
786 thread->interp = aTHX;
787 thread->count = 1; /* Immortal. */
788 thread->tid = tid_counter++;
791 thread->state = PERL_ITHR_DETACHED;
793 thread->thr = GetCurrentThreadId();
795 thread->thr = pthread_self();
798 Perl_ithread_set(aTHX_ thread);
799 MUTEX_UNLOCK(&create_destruct_mutex);
800 #endif /* USE_ITHREADS */