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);
132 SvREFCNT_dec(thread->params);
133 thread->params = Nullsv;
134 perl_destruct(thread->interp);
135 perl_free(thread->interp);
136 thread->interp = NULL;
137 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
140 MUTEX_UNLOCK(&thread->mutex);
141 MUTEX_DESTROY(&thread->mutex);
142 PerlMemShared_free(thread);
144 PERL_SET_CONTEXT(aTHX);
148 Perl_ithread_hook(pTHX)
150 int veto_cleanup = 0;
151 MUTEX_LOCK(&create_destruct_mutex);
152 if (aTHX == PL_curinterp && active_threads != 1) {
153 Perl_warn(aTHX_ "A thread exited while %" IVdf " other threads were still running",
157 MUTEX_UNLOCK(&create_destruct_mutex);
162 Perl_ithread_detach(pTHX_ ithread *thread)
164 MUTEX_LOCK(&thread->mutex);
165 if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
166 thread->state |= PERL_ITHR_DETACHED;
168 CloseHandle(thread->handle);
171 PERL_THREAD_DETACH(thread->thr);
174 if ((thread->state & PERL_ITHR_FINISHED) &&
175 (thread->state & PERL_ITHR_DETACHED)) {
176 MUTEX_UNLOCK(&thread->mutex);
177 Perl_ithread_destruct(aTHX_ thread, "detach");
180 MUTEX_UNLOCK(&thread->mutex);
184 /* MAGIC (in mg.h sense) hooks */
187 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
189 ithread *thread = (ithread *) mg->mg_ptr;
190 SvIVX(sv) = PTR2IV(thread);
196 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
198 ithread *thread = (ithread *) mg->mg_ptr;
199 MUTEX_LOCK(&thread->mutex);
201 if (thread->count == 0) {
202 if(thread->state & PERL_ITHR_FINISHED &&
203 (thread->state & PERL_ITHR_DETACHED ||
204 thread->state & PERL_ITHR_JOINED))
206 MUTEX_UNLOCK(&thread->mutex);
207 Perl_ithread_destruct(aTHX_ thread, "no reference");
210 MUTEX_UNLOCK(&thread->mutex);
214 MUTEX_UNLOCK(&thread->mutex);
220 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
222 ithread *thread = (ithread *) mg->mg_ptr;
223 MUTEX_LOCK(&thread->mutex);
225 MUTEX_UNLOCK(&thread->mutex);
229 MGVTBL ithread_vtbl = {
230 ithread_mg_get, /* get */
234 ithread_mg_free, /* free */
236 ithread_mg_dup /* dup */
241 * Starts executing the thread. Needs to clean up memory a tad better.
242 * Passed as the C level function to run in the new thread
247 Perl_ithread_run(LPVOID arg) {
250 Perl_ithread_run(void * arg) {
252 ithread* thread = (ithread*) arg;
253 dTHXa(thread->interp);
254 PERL_SET_CONTEXT(thread->interp);
255 PERL_THREAD_SETSPECIFIC(self_key,thread);
258 /* Far from clear messing with ->thr child-side is a good idea */
259 MUTEX_LOCK(&thread->mutex);
261 thread->thr = GetCurrentThreadId();
263 thread->thr = pthread_self();
265 MUTEX_UNLOCK(&thread->mutex);
268 PL_perl_destruct_level = 2;
271 AV* params = (AV*) SvRV(thread->params);
272 I32 len = av_len(params)+1;
278 for(i = 0; i < len; i++) {
279 XPUSHs(av_shift(params));
282 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
285 for (i=len-1; i >= 0; i--) {
287 av_store(params, i, SvREFCNT_inc(sv));
290 Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
294 SvREFCNT_dec(thread->init_function);
297 PerlIO_flush((PerlIO*)NULL);
298 MUTEX_LOCK(&thread->mutex);
299 thread->state |= PERL_ITHR_FINISHED;
301 if (thread->state & PERL_ITHR_DETACHED) {
302 MUTEX_UNLOCK(&thread->mutex);
303 Perl_ithread_destruct(aTHX_ thread, "detached finish");
305 MUTEX_UNLOCK(&thread->mutex);
307 MUTEX_LOCK(&create_destruct_mutex);
309 assert( active_threads >= 0 );
310 MUTEX_UNLOCK(&create_destruct_mutex);
320 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
325 MUTEX_LOCK(&thread->mutex);
327 MUTEX_UNLOCK(&thread->mutex);
331 sv = newSVrv(obj,classname);
332 sv_setiv(sv,PTR2IV(thread));
333 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
334 mg->mg_flags |= MGf_DUP;
340 SV_to_ithread(pTHX_ SV *sv)
345 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
349 PERL_THREAD_GETSPECIFIC(self_key,thread);
355 * iThread->create(); ( aka iThread->new() )
356 * Called in context of parent thread
360 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
363 CLONE_PARAMS clone_param;
364 ithread* current_thread;
365 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
366 MUTEX_LOCK(&create_destruct_mutex);
367 thread = PerlMemShared_malloc(sizeof(ithread));
368 Zero(thread,1,ithread);
369 thread->next = threads;
370 thread->prev = threads->prev;
371 threads->prev = thread;
372 thread->prev->next = thread;
373 /* Set count to 1 immediately in case thread exits before
374 * we return to caller !
377 MUTEX_INIT(&thread->mutex);
378 thread->tid = tid_counter++;
379 thread->gimme = GIMME_V;
381 /* "Clone" our interpreter into the thread's interpreter
382 * This gives thread access to "static data" and code.
385 PerlIO_flush((PerlIO*)NULL);
386 PERL_THREAD_SETSPECIFIC(self_key,thread);
388 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
390 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
392 /* perl_clone leaves us in new interpreter's context.
393 As it is tricky to spot an implicit aTHX, create a new scope
394 with aTHX matching the context for the duration of
395 our work for new interpreter.
398 dTHXa(thread->interp);
399 /* Here we remove END blocks since they should only run
400 in the thread they are created
402 SvREFCNT_dec(PL_endav);
404 clone_param.flags = 0;
405 thread->init_function = sv_dup(init_function, &clone_param);
406 if (SvREFCNT(thread->init_function) == 0) {
407 SvREFCNT_inc(thread->init_function);
410 thread->params = sv_dup(params, &clone_param);
411 SvREFCNT_inc(thread->params);
412 SvTEMP_off(thread->init_function);
413 ptr_table_free(PL_ptr_table);
415 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
417 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
418 PERL_SET_CONTEXT(aTHX);
420 /* Start the thread */
424 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
425 (LPVOID)thread, 0, &thread->thr);
429 static pthread_attr_t attr;
430 static int attr_inited = 0;
431 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
434 pthread_attr_init(&attr);
436 # ifdef PTHREAD_ATTR_SETDETACHSTATE
437 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
439 # ifdef THREAD_CREATE_NEEDS_STACK
440 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
441 croak("panic: pthread_attr_setstacksize failed");
444 #ifdef OLD_PTHREADS_API
445 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
447 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
453 MUTEX_UNLOCK(&create_destruct_mutex);
455 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
459 Perl_ithread_self (pTHX_ SV *obj, char* Class)
462 PERL_THREAD_GETSPECIFIC(self_key,thread);
463 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
467 * Joins the thread this code needs to take the returnvalue from the
468 * call_sv and send it back
472 Perl_ithread_CLONE(pTHX_ SV *obj)
476 ithread *thread = SV_to_ithread(aTHX_ obj);
480 Perl_warn(aTHX_ "CLONE %" SVf,obj);
485 Perl_ithread_join(pTHX_ SV *obj)
487 ithread *thread = SV_to_ithread(aTHX_ obj);
488 MUTEX_LOCK(&thread->mutex);
489 if (thread->state & PERL_ITHR_DETACHED) {
490 MUTEX_UNLOCK(&thread->mutex);
491 Perl_croak(aTHX_ "Cannot join a detached thread");
493 else if (thread->state & PERL_ITHR_JOINED) {
494 MUTEX_UNLOCK(&thread->mutex);
495 Perl_croak(aTHX_ "Thread already joined");
504 MUTEX_UNLOCK(&thread->mutex);
506 waitcode = WaitForSingleObject(thread->handle, INFINITE);
508 pthread_join(thread->thr,&retval);
510 MUTEX_LOCK(&thread->mutex);
512 /* sv_dup over the args */
514 ithread* current_thread;
515 AV* params = (AV*) SvRV(thread->params);
516 CLONE_PARAMS clone_params;
517 clone_params.stashes = newAV();
518 clone_params.flags |= CLONEf_JOIN_IN;
519 PL_ptr_table = ptr_table_new();
520 PERL_THREAD_GETSPECIFIC(self_key,current_thread);
521 PERL_THREAD_SETSPECIFIC(self_key,thread);
525 I32 len = av_len(params)+1;
527 for(i = 0; i < len; i++) {
528 sv_dump(SvRV(AvARRAY(params)[i]));
532 retparam = (AV*) sv_dup((SV*)params, &clone_params);
535 I32 len = av_len(retparam)+1;
537 for(i = 0; i < len; i++) {
538 sv_dump(SvRV(AvARRAY(retparam)[i]));
542 PERL_THREAD_SETSPECIFIC(self_key,current_thread);
543 SvREFCNT_dec(clone_params.stashes);
544 SvREFCNT_inc(retparam);
545 ptr_table_free(PL_ptr_table);
549 /* We have finished with it */
550 thread->state |= PERL_ITHR_JOINED;
551 MUTEX_UNLOCK(&thread->mutex);
552 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
559 Perl_ithread_DESTROY(pTHX_ SV *sv)
561 ithread *thread = SV_to_ithread(aTHX_ sv);
562 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
565 #endif /* USE_ITHREADS */
567 MODULE = threads PACKAGE = threads PREFIX = ithread_
573 ithread_new (classname, function_to_call, ...)
575 SV * function_to_call
578 AV* params = newAV();
581 for(i = 2; i < items ; i++) {
582 av_push(params, SvREFCNT_inc(ST(i)));
585 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
590 ithread_list(char *classname)
593 ithread *curr_thread;
594 MUTEX_LOCK(&create_destruct_mutex);
595 curr_thread = threads;
596 if(curr_thread->tid != 0)
597 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
599 curr_thread = curr_thread->next;
600 if(curr_thread == threads)
602 if(curr_thread->state & PERL_ITHR_DETACHED ||
603 curr_thread->state & PERL_ITHR_JOINED)
605 PUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
607 MUTEX_UNLOCK(&create_destruct_mutex);
612 ithread_self(char *classname)
615 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
620 ithread_tid(ithread *thread)
623 ithread_join(SV *obj)
626 AV* params = Perl_ithread_join(aTHX_ obj);
628 I32 len = AvFILL(params);
629 for (i = 0; i <= len; i++) {
630 SV* tmp = av_shift(params);
634 SvREFCNT_dec(params);
646 ithread_detach(ithread *thread)
649 ithread_DESTROY(SV *thread)
651 #endif /* USE_ITHREADS */
657 PL_perl_destruct_level = 2;
658 PERL_THREAD_ALLOC_SPECIFIC(self_key);
659 MUTEX_INIT(&create_destruct_mutex);
660 MUTEX_LOCK(&create_destruct_mutex);
661 PL_threadhook = &Perl_ithread_hook;
662 thread = PerlMemShared_malloc(sizeof(ithread));
663 Zero(thread,1,ithread);
664 PL_perl_destruct_level = 2;
665 MUTEX_INIT(&thread->mutex);
667 thread->next = thread;
668 thread->prev = thread;
669 thread->interp = aTHX;
670 thread->count = 1; /* imortal */
671 thread->tid = tid_counter++;
676 thread->thr = GetCurrentThreadId();
678 thread->thr = pthread_self();
681 PERL_THREAD_SETSPECIFIC(self_key,thread);
682 MUTEX_UNLOCK(&create_destruct_mutex);
683 #endif /* USE_ITHREADS */