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 SV* init_function; /* Code to run */
53 SV* params; /* args to pass function */
55 DWORD thr; /* OS's idea if thread id */
56 HANDLE handle; /* OS's waitable handle */
58 pthread_t thr; /* OS's handle for the thread */
64 /* Macros to supply the aTHX_ in an embed.h like manner */
65 #define ithread_join(thread) Perl_ithread_join(aTHX_ thread)
66 #define ithread_DESTROY(thread) Perl_ithread_DESTROY(aTHX_ thread)
67 #define ithread_CLONE(thread) Perl_ithread_CLONE(aTHX_ thread)
68 #define ithread_detach(thread) Perl_ithread_detach(aTHX_ thread)
69 #define ithread_tid(thread) ((thread)->tid)
71 static perl_mutex create_mutex; /* protects the creation of threads ??? */
78 * Clear up after thread is done with
81 Perl_ithread_destruct (pTHX_ ithread* thread)
83 MUTEX_LOCK(&thread->mutex);
84 Perl_warn(aTHX_ "destruct %d with count=%d",thread->tid,thread->count);
85 if (thread->count != 0) {
86 MUTEX_UNLOCK(&thread->mutex);
89 MUTEX_UNLOCK(&thread->mutex);
90 MUTEX_LOCK(&create_mutex);
91 /* Remove from circular list of threads */
92 if (thread->next == thread) {
93 /* last one should never get here ? */
97 thread->next->prev = thread->prev->next;
98 thread->prev->next = thread->next->prev;
99 if (threads == thread) {
100 threads = thread->next;
103 MUTEX_UNLOCK(&create_mutex);
104 /* Thread is now disowned */
105 if (thread->interp) {
106 dTHXa(thread->interp);
107 PERL_SET_CONTEXT(thread->interp);
108 perl_destruct(thread->interp);
109 perl_free(thread->interp);
110 thread->interp = NULL;
112 PERL_SET_CONTEXT(aTHX);
116 /* MAGIC (in mg.h sense) hooks */
119 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
121 ithread *thread = (ithread *) mg->mg_ptr;
122 SvIVX(sv) = PTR2IV(thread);
128 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
130 ithread *thread = (ithread *) mg->mg_ptr;
131 MUTEX_LOCK(&thread->mutex);
132 Perl_warn(aTHX_ "Unmagic %d with count=%d",thread->tid,thread->count);
134 MUTEX_UNLOCK(&thread->mutex);
135 /* This is safe as it re-checks count */
136 Perl_ithread_destruct(aTHX_ thread);
141 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
143 ithread *thread = (ithread *) mg->mg_ptr;
144 MUTEX_LOCK(&thread->mutex);
145 Perl_warn(aTHX_ "DUP %d with count=%d",thread->tid,thread->count);
147 MUTEX_UNLOCK(&thread->mutex);
151 MGVTBL ithread_vtbl = {
152 ithread_mg_get, /* get */
156 ithread_mg_free, /* free */
158 ithread_mg_dup /* dup */
163 * Starts executing the thread. Needs to clean up memory a tad better.
164 * Passed as the C level function to run in the new thread
169 Perl_ithread_run(LPVOID arg) {
172 Perl_ithread_run(void * arg) {
174 ithread* thread = (ithread*) arg;
175 dTHXa(thread->interp);
176 PERL_SET_CONTEXT(thread->interp);
177 PERL_THREAD_SETSPECIFIC(self_key,thread);
180 /* Far from clear messing with ->thr child-side is a good idea */
181 MUTEX_LOCK(&thread->mutex);
183 thread->thr = GetCurrentThreadId();
185 thread->thr = pthread_self();
187 MUTEX_UNLOCK(&thread->mutex);
190 PL_perl_destruct_level = 2;
193 AV* params = (AV*) SvRV(thread->params);
194 I32 len = av_len(params)+1;
200 for(i = 0; i < len; i++) {
201 XPUSHs(av_shift(params));
204 call_sv(thread->init_function, G_DISCARD|G_EVAL);
208 SvREFCNT_dec(thread->params);
209 SvREFCNT_dec(thread->init_function);
212 PerlIO_flush((PerlIO*)NULL);
213 MUTEX_LOCK(&thread->mutex);
214 Perl_warn(aTHX_ "finished %d with count=%d",thread->tid,thread->count);
215 if (thread->detached == 1) {
216 MUTEX_UNLOCK(&thread->mutex);
217 Perl_ithread_destruct(aTHX_ thread);
219 MUTEX_UNLOCK(&thread->mutex);
229 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
234 MUTEX_LOCK(&thread->mutex);
236 Perl_warn(aTHX_ "SV for %d with count=%d",thread->tid,thread->count);
237 MUTEX_UNLOCK(&thread->mutex);
241 sv = newSVrv(obj,classname);
242 sv_setiv(sv,PTR2IV(thread));
243 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
244 mg->mg_flags |= MGf_DUP;
250 SV_to_ithread(pTHX_ SV *sv)
255 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
259 PERL_THREAD_GETSPECIFIC(self_key,thread);
265 * iThread->create(); ( aka iThread->new() )
266 * Called in context of parent thread
270 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
273 CLONE_PARAMS clone_param;
275 MUTEX_LOCK(&create_mutex);
276 thread = PerlMemShared_malloc(sizeof(ithread));
277 Zero(thread,1,ithread);
278 thread->next = threads;
279 thread->prev = threads->prev;
280 thread->prev->next = thread;
281 /* Set count to 1 immediately in case thread exits before
282 * we return to caller !
285 MUTEX_INIT(&thread->mutex);
286 thread->tid = tid_counter++;
287 thread->detached = 0;
289 /* "Clone" our interpreter into the thread's interpreter
290 * This gives thread access to "static data" and code.
293 PerlIO_flush((PerlIO*)NULL);
296 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
298 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
301 clone_param.flags = 0;
302 thread->init_function = Perl_sv_dup(thread->interp, init_function, &clone_param);
303 if (SvREFCNT(thread->init_function) == 0) {
304 SvREFCNT_inc(thread->init_function);
307 thread->params = Perl_sv_dup(thread->interp,params, &clone_param);
308 SvREFCNT_inc(thread->params);
309 SvTEMP_off(thread->init_function);
310 ptr_table_free(PL_ptr_table);
313 PERL_SET_CONTEXT(aTHX);
315 /* Start the thread */
319 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
320 (LPVOID)thread, 0, &thread->thr);
324 static pthread_attr_t attr;
325 static int attr_inited = 0;
326 sigset_t fullmask, oldmask;
327 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
330 pthread_attr_init(&attr);
332 # ifdef PTHREAD_ATTR_SETDETACHSTATE
333 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
335 # ifdef THREAD_CREATE_NEEDS_STACK
336 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
337 croak("panic: pthread_attr_setstacksize failed");
340 #ifdef OLD_PTHREADS_API
341 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
343 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
347 MUTEX_UNLOCK(&create_mutex);
348 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
352 Perl_ithread_self (pTHX_ SV *obj, char* Class)
355 PERL_THREAD_GETSPECIFIC(self_key,thread);
356 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
360 * joins the thread this code needs to take the returnvalue from the
361 * call_sv and send it back
365 Perl_ithread_CLONE(pTHX_ SV *obj)
369 ithread *thread = SV_to_ithread(aTHX_ obj);
373 Perl_warn(aTHX_ "CLONE %_",obj);
378 Perl_ithread_join(pTHX_ SV *obj)
380 ithread *thread = SV_to_ithread(aTHX_ obj);
381 MUTEX_LOCK(&thread->mutex);
382 Perl_warn(aTHX_ "joining %d with count=%d",thread->tid,thread->count);
383 if (!thread->detached) {
389 MUTEX_UNLOCK(&thread->mutex);
391 waitcode = WaitForSingleObject(thread->handle, INFINITE);
393 pthread_join(thread->thr,&retval);
395 Perl_warn(aTHX_ "joined %d with count=%d",thread->tid,thread->count);
396 /* We have finished with it */
397 MUTEX_LOCK(&thread->mutex);
398 thread->detached = 2;
399 MUTEX_UNLOCK(&thread->mutex);
400 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
403 MUTEX_UNLOCK(&thread->mutex);
404 Perl_croak(aTHX_ "Cannot join a detached thread");
409 Perl_ithread_detach(pTHX_ ithread *thread)
411 MUTEX_LOCK(&thread->mutex);
412 if (!thread->detached) {
413 thread->detached = 1;
415 CloseHandle(thread->handle);
418 PERL_THREAD_DETACH(thread->thr);
421 MUTEX_UNLOCK(&thread->mutex);
426 Perl_ithread_DESTROY(pTHX_ SV *sv)
428 ithread *thread = SV_to_ithread(aTHX_ sv);
429 Perl_warn(aTHX_ "DESTROY %d with count=%d",thread->tid,thread->count);
430 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
433 MODULE = threads PACKAGE = threads PREFIX = ithread_
437 ithread_new (classname, function_to_call, ...)
439 SV * function_to_call
442 AV* params = newAV();
445 for(i = 2; i < items ; i++) {
446 av_push(params, ST(i));
449 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
454 ithread_self(char *classname)
457 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
462 ithread_tid(ithread *thread)
465 ithread_join(SV *obj)
468 ithread_detach(ithread *thread)
471 ithread_DESTROY(SV *thread)
474 ithread_CLONE(SV *sv)
479 PERL_THREAD_ALLOC_SPECIFIC(self_key);
480 MUTEX_INIT(&create_mutex);
481 MUTEX_LOCK(&create_mutex);
482 thread = PerlMemShared_malloc(sizeof(ithread));
483 Zero(thread,1,ithread);
484 PL_perl_destruct_level = 2;
485 MUTEX_INIT(&thread->mutex);
487 thread->next = thread;
488 thread->prev = thread;
489 thread->interp = aTHX;
490 thread->count = 1; /* imortal */
491 thread->tid = tid_counter++;
492 thread->detached = 1;
494 thread->thr = GetCurrentThreadId();
496 thread->thr = pthread_self();
498 PERL_THREAD_SETSPECIFIC(self_key,thread);
499 MUTEX_UNLOCK(&create_mutex);