1 #define PERL_NO_GET_CONTEXT
8 #include <win32thread.h>
9 #define PERL_THREAD_SETSPECIFIC(k,v) TlsSetValue(k,v)
10 #define PERL_THREAD_GETSPECIFIC(k,v) v = TlsGetValue(k)
11 #define PERL_THREAD_ALLOC_SPECIFIC(k) \
13 if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
14 PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
22 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
23 #ifdef OLD_PTHREADS_API
24 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
25 #define PERL_THREAD_GETSPECIFIC(k,v) pthread_getspecific(k,&v)
26 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
27 if(pthread_keycreate(&(k),0)) {\
28 PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
33 #define PERL_THREAD_DETACH(t) pthread_detach((t))
34 #define PERL_THREAD_GETSPECIFIC(k,v) v = pthread_getspecific(k)
35 #define PERL_THREAD_ALLOC_SPECIFIC(k) STMT_START {\
36 if(pthread_key_create(&(k),0)) {\
37 PerlIO_printf(PerlIO_stderr(), "panic threads.h: pthread_key_create");\
44 typedef struct ithread_s {
45 struct ithread_s *next; /* next thread in the list */
46 struct ithread_s *prev; /* prev thread in the list */
47 PerlInterpreter *interp; /* The threads interpreter */
48 I32 tid; /* threads module's thread id */
49 perl_mutex mutex; /* mutex for updating things in this struct */
50 I32 count; /* how many SVs have a reference to us */
51 signed char detached; /* are we detached ? */
52 int gimme; /* Context of create */
53 SV* init_function; /* Code to run */
54 SV* params; /* args to pass function */
56 DWORD thr; /* OS's idea if thread id */
57 HANDLE handle; /* OS's waitable handle */
59 pthread_t thr; /* OS's handle for the thread */
65 /* Macros to supply the aTHX_ in an embed.h like manner */
66 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
67 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
68 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
69 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
70 #define ithread_tid(thread) ((thread)->tid)
72 static perl_mutex create_mutex; /* protects the creation of threads ??? */
79 * Clear up after thread is done with
82 Perl_ithread_destruct (pTHX_ ithread* thread)
84 MUTEX_LOCK(&thread->mutex);
85 if (thread->count != 0) {
86 MUTEX_UNLOCK(&thread->mutex);
89 MUTEX_LOCK(&create_mutex);
90 /* Remove from circular list of threads */
91 if (thread->next == thread) {
92 /* last one should never get here ? */
96 thread->next->prev = thread->prev->next;
97 thread->prev->next = thread->next->prev;
98 if (threads == thread) {
99 threads = thread->next;
102 MUTEX_UNLOCK(&create_mutex);
103 /* Thread is now disowned */
105 Perl_warn(aTHX_ "destruct %d @ %p by %p",
106 thread->tid,thread->interp,aTHX);
108 if (thread->interp) {
109 dTHXa(thread->interp);
110 PERL_SET_CONTEXT(thread->interp);
111 perl_destruct(thread->interp);
112 perl_free(thread->interp);
113 thread->interp = NULL;
115 PERL_SET_CONTEXT(aTHX);
116 MUTEX_UNLOCK(&thread->mutex);
120 /* MAGIC (in mg.h sense) hooks */
123 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
125 ithread *thread = (ithread *) mg->mg_ptr;
126 SvIVX(sv) = PTR2IV(thread);
132 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
134 ithread *thread = (ithread *) mg->mg_ptr;
135 MUTEX_LOCK(&thread->mutex);
137 MUTEX_UNLOCK(&thread->mutex);
138 /* This is safe as it re-checks count */
139 Perl_ithread_destruct(aTHX_ thread);
144 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
146 ithread *thread = (ithread *) mg->mg_ptr;
147 MUTEX_LOCK(&thread->mutex);
149 MUTEX_UNLOCK(&thread->mutex);
153 MGVTBL ithread_vtbl = {
154 ithread_mg_get, /* get */
158 ithread_mg_free, /* free */
160 ithread_mg_dup /* dup */
165 * Starts executing the thread. Needs to clean up memory a tad better.
166 * Passed as the C level function to run in the new thread
171 Perl_ithread_run(LPVOID arg) {
174 Perl_ithread_run(void * arg) {
176 ithread* thread = (ithread*) arg;
177 dTHXa(thread->interp);
178 PERL_SET_CONTEXT(thread->interp);
179 PERL_THREAD_SETSPECIFIC(self_key,thread);
182 /* Far from clear messing with ->thr child-side is a good idea */
183 MUTEX_LOCK(&thread->mutex);
185 thread->thr = GetCurrentThreadId();
187 thread->thr = pthread_self();
189 MUTEX_UNLOCK(&thread->mutex);
192 PL_perl_destruct_level = 2;
195 AV* params = (AV*) SvRV(thread->params);
196 I32 len = av_len(params)+1;
202 for(i = 0; i < len; i++) {
203 XPUSHs(av_shift(params));
206 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
208 for (i=len-1; i >= 0; i--) {
210 av_store(params, i, SvREFCNT_inc(sv));
214 Perl_warn(aTHX_ "Died:%_",ERRSV);
218 SvREFCNT_dec(thread->init_function);
221 PerlIO_flush((PerlIO*)NULL);
222 MUTEX_LOCK(&thread->mutex);
223 if (thread->detached & 1) {
224 MUTEX_UNLOCK(&thread->mutex);
225 SvREFCNT_dec(thread->params);
226 thread->params = Nullsv;
227 Perl_ithread_destruct(aTHX_ thread);
229 thread->detached |= 4;
230 MUTEX_UNLOCK(&thread->mutex);
240 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
245 MUTEX_LOCK(&thread->mutex);
247 MUTEX_UNLOCK(&thread->mutex);
251 sv = newSVrv(obj,classname);
252 sv_setiv(sv,PTR2IV(thread));
253 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
254 mg->mg_flags |= MGf_DUP;
260 SV_to_ithread(pTHX_ SV *sv)
265 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
269 PERL_THREAD_GETSPECIFIC(self_key,thread);
275 * iThread->create(); ( aka iThread->new() )
276 * Called in context of parent thread
280 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
283 CLONE_PARAMS clone_param;
285 MUTEX_LOCK(&create_mutex);
286 thread = PerlMemShared_malloc(sizeof(ithread));
287 Zero(thread,1,ithread);
288 thread->next = threads;
289 thread->prev = threads->prev;
290 thread->prev->next = thread;
291 /* Set count to 1 immediately in case thread exits before
292 * we return to caller !
295 MUTEX_INIT(&thread->mutex);
296 thread->tid = tid_counter++;
297 thread->gimme = GIMME_V;
298 thread->detached = (thread->gimme == G_VOID) ? 1 : 0;
300 /* "Clone" our interpreter into the thread's interpreter
301 * This gives thread access to "static data" and code.
304 PerlIO_flush((PerlIO*)NULL);
307 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
309 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
311 /* perl_clone leaves us in new interpreter's context.
312 As it is tricky to spot implcit aTHX create a new scope
313 with aTHX matching the context for the duration of
314 our work for new interpreter.
317 dTHXa(thread->interp);
318 /* Here we remove END blocks since they should only run
319 in the thread they are created
321 SvREFCNT_dec(PL_endav);
323 clone_param.flags = 0;
324 thread->init_function = sv_dup(init_function, &clone_param);
325 if (SvREFCNT(thread->init_function) == 0) {
326 SvREFCNT_inc(thread->init_function);
329 thread->params = sv_dup(params, &clone_param);
330 SvREFCNT_inc(thread->params);
331 SvTEMP_off(thread->init_function);
332 ptr_table_free(PL_ptr_table);
336 PERL_SET_CONTEXT(aTHX);
338 /* Start the thread */
342 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
343 (LPVOID)thread, 0, &thread->thr);
347 static pthread_attr_t attr;
348 static int attr_inited = 0;
349 sigset_t fullmask, oldmask;
350 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
353 pthread_attr_init(&attr);
355 # ifdef PTHREAD_ATTR_SETDETACHSTATE
356 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
358 # ifdef THREAD_CREATE_NEEDS_STACK
359 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
360 croak("panic: pthread_attr_setstacksize failed");
363 #ifdef OLD_PTHREADS_API
364 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
366 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
370 MUTEX_UNLOCK(&create_mutex);
371 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
375 Perl_ithread_self (pTHX_ SV *obj, char* Class)
378 PERL_THREAD_GETSPECIFIC(self_key,thread);
379 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
383 * Joins the thread this code needs to take the returnvalue from the
384 * call_sv and send it back
388 Perl_ithread_CLONE(pTHX_ SV *obj)
392 ithread *thread = SV_to_ithread(aTHX_ obj);
396 Perl_warn(aTHX_ "CLONE %_",obj);
401 Perl_ithread_join(pTHX_ SV *obj)
403 ithread *thread = SV_to_ithread(aTHX_ obj);
404 MUTEX_LOCK(&thread->mutex);
405 if (thread->detached & 1) {
406 MUTEX_UNLOCK(&thread->mutex);
407 Perl_croak(aTHX_ "Cannot join a detached thread");
409 else if (thread->detached & 2) {
410 MUTEX_UNLOCK(&thread->mutex);
411 Perl_croak(aTHX_ "Thread already joined");
420 MUTEX_UNLOCK(&thread->mutex);
422 waitcode = WaitForSingleObject(thread->handle, INFINITE);
424 pthread_join(thread->thr,&retval);
426 MUTEX_LOCK(&thread->mutex);
429 AV* params = (AV*) SvRV(thread->params);
430 CLONE_PARAMS clone_params;
431 clone_params.stashes = newAV();
432 PL_ptr_table = ptr_table_new();
433 retparam = (AV*) sv_dup((SV*)params, &clone_params);
434 SvREFCNT_dec(clone_params.stashes);
435 SvREFCNT_inc(retparam);
436 ptr_table_free(PL_ptr_table);
440 /* sv_dup over the args */
441 /* We have finished with it */
442 thread->detached |= 2;
443 MUTEX_UNLOCK(&thread->mutex);
444 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
445 Perl_ithread_destruct(aTHX_ thread);
452 Perl_ithread_detach(pTHX_ ithread *thread)
454 MUTEX_LOCK(&thread->mutex);
455 if (!thread->detached) {
456 thread->detached = 1;
458 CloseHandle(thread->handle);
461 PERL_THREAD_DETACH(thread->thr);
464 MUTEX_UNLOCK(&thread->mutex);
469 Perl_ithread_DESTROY(pTHX_ SV *sv)
471 ithread *thread = SV_to_ithread(aTHX_ sv);
472 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
477 MODULE = threads PACKAGE = threads PREFIX = ithread_
481 ithread_new (classname, function_to_call, ...)
483 SV * function_to_call
486 AV* params = newAV();
489 for(i = 2; i < items ; i++) {
490 av_push(params, ST(i));
493 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
498 ithread_self(char *classname)
501 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
506 ithread_tid(ithread *thread)
509 ithread_join(SV *obj)
512 AV* params = Perl_ithread_join(aTHX_ obj);
514 I32 len = AvFILL(params);
515 for (i = 0; i <= len; i++) {
516 XPUSHs(av_shift(params));
518 SvREFCNT_dec(params);
523 ithread_detach(ithread *thread)
526 ithread_DESTROY(SV *thread)
531 PL_perl_destruct_level = 2;
532 PERL_THREAD_ALLOC_SPECIFIC(self_key);
533 MUTEX_INIT(&create_mutex);
534 MUTEX_LOCK(&create_mutex);
535 thread = PerlMemShared_malloc(sizeof(ithread));
536 Zero(thread,1,ithread);
537 PL_perl_destruct_level = 2;
538 MUTEX_INIT(&thread->mutex);
540 thread->next = thread;
541 thread->prev = thread;
542 thread->interp = aTHX;
543 thread->count = 1; /* imortal */
544 thread->tid = tid_counter++;
545 thread->detached = 1;
547 thread->thr = GetCurrentThreadId();
549 thread->thr = pthread_self();
551 PERL_THREAD_SETSPECIFIC(self_key,thread);
552 MUTEX_UNLOCK(&create_mutex);