patch for syslog
[p5sagit/p5-mst-13.2.git] / ext / threads / threads.xs
CommitLineData
68795e93 1#define PERL_NO_GET_CONTEXT
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6#ifdef WIN32
7#include <windows.h>
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) \
12STMT_START {\
13 if((k = TlsAlloc()) == TLS_OUT_OF_INDEXES) {\
14 PerlIO_printf(PerlIO_stderr(),"panic threads.h: TlsAlloc");\
15 exit(1);\
16 }\
17} STMT_END
18#else
19#include <pthread.h>
20#include <thread.h>
21
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");\
29 exit(1);\
30 }\
31} STMT_END
32#else
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");\
38 exit(1);\
39 }\
40} STMT_END
41#endif
42#endif
43
44typedef 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 ? */
a446a88f 52 int gimme; /* Context of create */
68795e93 53 SV* init_function; /* Code to run */
54 SV* params; /* args to pass function */
55#ifdef WIN32
56 DWORD thr; /* OS's idea if thread id */
57 HANDLE handle; /* OS's waitable handle */
58#else
59 pthread_t thr; /* OS's handle for the thread */
60#endif
61} ithread;
62
63ithread *threads;
64
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)
71
419d29dc 72static perl_mutex create_destruct_mutex; /* protects the creation and destruction of threads*/
68795e93 73
74I32 tid_counter = 0;
149bd5a9 75I32 active_threads = 0;
68795e93 76perl_key self_key;
77
78/*
79 * Clear up after thread is done with
80 */
81void
82Perl_ithread_destruct (pTHX_ ithread* thread)
83{
84 MUTEX_LOCK(&thread->mutex);
68795e93 85 if (thread->count != 0) {
86 MUTEX_UNLOCK(&thread->mutex);
d1400e48 87 return;
68795e93 88 }
419d29dc 89 MUTEX_LOCK(&create_destruct_mutex);
68795e93 90 /* Remove from circular list of threads */
91 if (thread->next == thread) {
92 /* last one should never get here ? */
93 threads = NULL;
94 }
95 else {
96 thread->next->prev = thread->prev->next;
97 thread->prev->next = thread->next->prev;
98 if (threads == thread) {
99 threads = thread->next;
100 }
101 }
149bd5a9 102 active_threads--;
419d29dc 103 MUTEX_UNLOCK(&create_destruct_mutex);
68795e93 104 /* Thread is now disowned */
ba14dd9a 105#if 0
106 Perl_warn(aTHX_ "destruct %d @ %p by %p",
107 thread->tid,thread->interp,aTHX);
108#endif
68795e93 109 if (thread->interp) {
110 dTHXa(thread->interp);
111 PERL_SET_CONTEXT(thread->interp);
112 perl_destruct(thread->interp);
113 perl_free(thread->interp);
114 thread->interp = NULL;
115 }
116 PERL_SET_CONTEXT(aTHX);
d1400e48 117 MUTEX_UNLOCK(&thread->mutex);
68795e93 118}
119
120
121/* MAGIC (in mg.h sense) hooks */
122
123int
124ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
125{
126 ithread *thread = (ithread *) mg->mg_ptr;
127 SvIVX(sv) = PTR2IV(thread);
128 SvIOK_on(sv);
129 return 0;
130}
131
132int
133ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
134{
135 ithread *thread = (ithread *) mg->mg_ptr;
136 MUTEX_LOCK(&thread->mutex);
68795e93 137 thread->count--;
138 MUTEX_UNLOCK(&thread->mutex);
139 /* This is safe as it re-checks count */
140 Perl_ithread_destruct(aTHX_ thread);
141 return 0;
142}
143
144int
145ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
146{
147 ithread *thread = (ithread *) mg->mg_ptr;
148 MUTEX_LOCK(&thread->mutex);
68795e93 149 thread->count++;
150 MUTEX_UNLOCK(&thread->mutex);
151 return 0;
152}
153
154MGVTBL ithread_vtbl = {
155 ithread_mg_get, /* get */
156 0, /* set */
157 0, /* len */
158 0, /* clear */
159 ithread_mg_free, /* free */
160 0, /* copy */
161 ithread_mg_dup /* dup */
162};
163
47ba8780 164
47ba8780 165/*
b1edfb69 166 * Starts executing the thread. Needs to clean up memory a tad better.
68795e93 167 * Passed as the C level function to run in the new thread
b1edfb69 168 */
47ba8780 169
170#ifdef WIN32
68795e93 171THREAD_RET_TYPE
172Perl_ithread_run(LPVOID arg) {
47ba8780 173#else
68795e93 174void*
175Perl_ithread_run(void * arg) {
47ba8780 176#endif
5b414d21 177 ithread* thread = (ithread*) arg;
47ba8780 178 dTHXa(thread->interp);
47ba8780 179 PERL_SET_CONTEXT(thread->interp);
68795e93 180 PERL_THREAD_SETSPECIFIC(self_key,thread);
47ba8780 181
68795e93 182#if 0
183 /* Far from clear messing with ->thr child-side is a good idea */
184 MUTEX_LOCK(&thread->mutex);
47ba8780 185#ifdef WIN32
186 thread->thr = GetCurrentThreadId();
187#else
188 thread->thr = pthread_self();
189#endif
68795e93 190 MUTEX_UNLOCK(&thread->mutex);
191#endif
47ba8780 192
47ba8780 193 PL_perl_destruct_level = 2;
4f896ddc 194
47ba8780 195 {
68795e93 196 AV* params = (AV*) SvRV(thread->params);
197 I32 len = av_len(params)+1;
47ba8780 198 int i;
199 dSP;
47ba8780 200 ENTER;
201 SAVETMPS;
202 PUSHMARK(SP);
68795e93 203 for(i = 0; i < len; i++) {
204 XPUSHs(av_shift(params));
47ba8780 205 }
206 PUTBACK;
a446a88f 207 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
68795e93 208 SPAGAIN;
a446a88f 209 for (i=len-1; i >= 0; i--) {
e1c44605 210 SV *sv = POPs;
211 av_store(params, i, SvREFCNT_inc(sv));
a446a88f 212 }
213 PUTBACK;
214 if (SvTRUE(ERRSV)) {
215 Perl_warn(aTHX_ "Died:%_",ERRSV);
216 }
47ba8780 217 FREETMPS;
218 LEAVE;
68795e93 219 SvREFCNT_dec(thread->init_function);
47ba8780 220 }
221
fd58862f 222 PerlIO_flush((PerlIO*)NULL);
68795e93 223 MUTEX_LOCK(&thread->mutex);
a446a88f 224 if (thread->detached & 1) {
47ba8780 225 MUTEX_UNLOCK(&thread->mutex);
a446a88f 226 SvREFCNT_dec(thread->params);
227 thread->params = Nullsv;
68795e93 228 Perl_ithread_destruct(aTHX_ thread);
47ba8780 229 } else {
a446a88f 230 thread->detached |= 4;
47ba8780 231 MUTEX_UNLOCK(&thread->mutex);
232 }
233#ifdef WIN32
234 return (DWORD)0;
e8f2bb9a 235#else
236 return 0;
47ba8780 237#endif
68795e93 238}
239
240SV *
241ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
242{
243 SV *sv;
244 MAGIC *mg;
245 if (inc) {
246 MUTEX_LOCK(&thread->mutex);
247 thread->count++;
68795e93 248 MUTEX_UNLOCK(&thread->mutex);
249 }
250 if (!obj)
251 obj = newSV(0);
252 sv = newSVrv(obj,classname);
253 sv_setiv(sv,PTR2IV(thread));
254 mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
255 mg->mg_flags |= MGf_DUP;
256 SvREADONLY_on(sv);
257 return obj;
258}
47ba8780 259
68795e93 260ithread *
261SV_to_ithread(pTHX_ SV *sv)
262{
263 ithread *thread;
264 if (SvROK(sv))
265 {
266 thread = INT2PTR(ithread*, SvIV(SvRV(sv)));
267 }
268 else
269 {
270 PERL_THREAD_GETSPECIFIC(self_key,thread);
271 }
272 return thread;
47ba8780 273}
274
47ba8780 275/*
68795e93 276 * iThread->create(); ( aka iThread->new() )
277 * Called in context of parent thread
b1edfb69 278 */
47ba8780 279
68795e93 280SV *
281Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
282{
283 ithread* thread;
284 CLONE_PARAMS clone_param;
285
419d29dc 286 MUTEX_LOCK(&create_destruct_mutex);
68795e93 287 thread = PerlMemShared_malloc(sizeof(ithread));
288 Zero(thread,1,ithread);
289 thread->next = threads;
290 thread->prev = threads->prev;
291 thread->prev->next = thread;
292 /* Set count to 1 immediately in case thread exits before
293 * we return to caller !
294 */
295 thread->count = 1;
296 MUTEX_INIT(&thread->mutex);
297 thread->tid = tid_counter++;
a446a88f 298 thread->gimme = GIMME_V;
299 thread->detached = (thread->gimme == G_VOID) ? 1 : 0;
4f896ddc 300
68795e93 301 /* "Clone" our interpreter into the thread's interpreter
302 * This gives thread access to "static data" and code.
303 */
47ba8780 304
68795e93 305 PerlIO_flush((PerlIO*)NULL);
cd8c9bf8 306
47ba8780 307#ifdef WIN32
68795e93 308 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 309#else
68795e93 310 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780 311#endif
ba14dd9a 312 /* perl_clone leaves us in new interpreter's context.
313 As it is tricky to spot implcit aTHX create a new scope
a446a88f 314 with aTHX matching the context for the duration of
ba14dd9a 315 our work for new interpreter.
316 */
317 {
318 dTHXa(thread->interp);
4e00007d 319 /* Here we remove END blocks since they should only run
320 in the thread they are created
321 */
322 SvREFCNT_dec(PL_endav);
323 PL_endav = newAV();
d1400e48 324 clone_param.flags = 0;
ba14dd9a 325 thread->init_function = sv_dup(init_function, &clone_param);
326 if (SvREFCNT(thread->init_function) == 0) {
327 SvREFCNT_inc(thread->init_function);
d1400e48 328 }
ba14dd9a 329
330 thread->params = sv_dup(params, &clone_param);
331 SvREFCNT_inc(thread->params);
332 SvTEMP_off(thread->init_function);
333 ptr_table_free(PL_ptr_table);
334 PL_ptr_table = NULL;
335 }
d1400e48 336
68795e93 337 PERL_SET_CONTEXT(aTHX);
47ba8780 338
68795e93 339 /* Start the thread */
47ba8780 340
341#ifdef WIN32
342
68795e93 343 thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
47ba8780 344 (LPVOID)thread, 0, &thread->thr);
345
82c40bf6 346#else
fa26028c 347 {
348 static pthread_attr_t attr;
349 static int attr_inited = 0;
350 sigset_t fullmask, oldmask;
351 static int attr_joinable = PTHREAD_CREATE_JOINABLE;
352 if (!attr_inited) {
353 attr_inited = 1;
354 pthread_attr_init(&attr);
355 }
356# ifdef PTHREAD_ATTR_SETDETACHSTATE
357 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
358# endif
3eb37d38 359# ifdef THREAD_CREATE_NEEDS_STACK
360 if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
361 croak("panic: pthread_attr_setstacksize failed");
362# endif
363
3ad0b7d6 364#ifdef OLD_PTHREADS_API
68795e93 365 pthread_create( &thread->thr, attr, Perl_ithread_run, (void *)thread);
47ba8780 366#else
68795e93 367 pthread_create( &thread->thr, &attr, Perl_ithread_run, (void *)thread);
47ba8780 368#endif
3ad0b7d6 369 }
82c40bf6 370#endif
149bd5a9 371 active_threads++;
419d29dc 372 MUTEX_UNLOCK(&create_destruct_mutex);
68795e93 373 return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
374}
47ba8780 375
68795e93 376SV*
377Perl_ithread_self (pTHX_ SV *obj, char* Class)
378{
379 ithread *thread;
380 PERL_THREAD_GETSPECIFIC(self_key,thread);
381 return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
47ba8780 382}
383
384/*
e1c44605 385 * Joins the thread this code needs to take the returnvalue from the
68795e93 386 * call_sv and send it back
b1edfb69 387 */
47ba8780 388
68795e93 389void
390Perl_ithread_CLONE(pTHX_ SV *obj)
391{
392 if (SvROK(obj))
393 {
394 ithread *thread = SV_to_ithread(aTHX_ obj);
395 }
396 else
397 {
398 Perl_warn(aTHX_ "CLONE %_",obj);
399 }
47ba8780 400}
401
e1c44605 402AV*
68795e93 403Perl_ithread_join(pTHX_ SV *obj)
404{
405 ithread *thread = SV_to_ithread(aTHX_ obj);
406 MUTEX_LOCK(&thread->mutex);
a446a88f 407 if (thread->detached & 1) {
408 MUTEX_UNLOCK(&thread->mutex);
409 Perl_croak(aTHX_ "Cannot join a detached thread");
410 }
411 else if (thread->detached & 2) {
412 MUTEX_UNLOCK(&thread->mutex);
413 Perl_croak(aTHX_ "Thread already joined");
414 }
415 else {
e1c44605 416 AV* retparam;
47ba8780 417#ifdef WIN32
418 DWORD waitcode;
47ba8780 419#else
420 void *retval;
47ba8780 421#endif
47ba8780 422 MUTEX_UNLOCK(&thread->mutex);
68795e93 423#ifdef WIN32
424 waitcode = WaitForSingleObject(thread->handle, INFINITE);
425#else
426 pthread_join(thread->thr,&retval);
427#endif
47ba8780 428 MUTEX_LOCK(&thread->mutex);
e1c44605 429
430 {
431 AV* params = (AV*) SvRV(thread->params);
432 CLONE_PARAMS clone_params;
3275ba96 433 clone_params.stashes = newAV();
e1c44605 434 PL_ptr_table = ptr_table_new();
435 retparam = (AV*) sv_dup((SV*)params, &clone_params);
3275ba96 436 SvREFCNT_dec(clone_params.stashes);
e1c44605 437 SvREFCNT_inc(retparam);
438 ptr_table_free(PL_ptr_table);
439 PL_ptr_table = NULL;
440
441 }
a446a88f 442 /* sv_dup over the args */
443 /* We have finished with it */
444 thread->detached |= 2;
47ba8780 445 MUTEX_UNLOCK(&thread->mutex);
68795e93 446 sv_unmagic(SvRV(obj),PERL_MAGIC_shared_scalar);
e1c44605 447 Perl_ithread_destruct(aTHX_ thread);
448 return retparam;
68795e93 449 }
e1c44605 450 return (AV*)NULL;
47ba8780 451}
452
68795e93 453void
454Perl_ithread_detach(pTHX_ ithread *thread)
455{
456 MUTEX_LOCK(&thread->mutex);
457 if (!thread->detached) {
458 thread->detached = 1;
47ba8780 459#ifdef WIN32
68795e93 460 CloseHandle(thread->handle);
461 thread->handle = 0;
47ba8780 462#else
68795e93 463 PERL_THREAD_DETACH(thread->thr);
47ba8780 464#endif
68795e93 465 }
466 MUTEX_UNLOCK(&thread->mutex);
467}
47ba8780 468
47ba8780 469
68795e93 470void
471Perl_ithread_DESTROY(pTHX_ SV *sv)
472{
473 ithread *thread = SV_to_ithread(aTHX_ sv);
68795e93 474 sv_unmagic(SvRV(sv),PERL_MAGIC_shared_scalar);
475}
8222d950 476
e1c44605 477
478
68795e93 479MODULE = threads PACKAGE = threads PREFIX = ithread_
480PROTOTYPES: DISABLE
8222d950 481
68795e93 482void
483ithread_new (classname, function_to_call, ...)
484char * classname
485SV * function_to_call
486CODE:
487{
488 AV* params = newAV();
489 if (items > 2) {
490 int i;
491 for(i = 2; i < items ; i++) {
492 av_push(params, ST(i));
493 }
494 }
495 ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
496 XSRETURN(1);
497}
8222d950 498
68795e93 499void
500ithread_self(char *classname)
501CODE:
502{
503 ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
504 XSRETURN(1);
505}
47ba8780 506
507int
68795e93 508ithread_tid(ithread *thread)
47ba8780 509
510void
68795e93 511ithread_join(SV *obj)
e1c44605 512PPCODE:
513{
514 AV* params = Perl_ithread_join(aTHX_ obj);
515 int i;
516 I32 len = AvFILL(params);
517 for (i = 0; i <= len; i++) {
518 XPUSHs(av_shift(params));
519 }
520 SvREFCNT_dec(params);
521}
522
47ba8780 523
524void
68795e93 525ithread_detach(ithread *thread)
47ba8780 526
47ba8780 527void
68795e93 528ithread_DESTROY(SV *thread)
529
68795e93 530BOOT:
531{
532 ithread* thread;
e1c44605 533 PL_perl_destruct_level = 2;
68795e93 534 PERL_THREAD_ALLOC_SPECIFIC(self_key);
419d29dc 535 MUTEX_INIT(&create_destruct_mutex);
536 MUTEX_LOCK(&create_destruct_mutex);
68795e93 537 thread = PerlMemShared_malloc(sizeof(ithread));
538 Zero(thread,1,ithread);
539 PL_perl_destruct_level = 2;
540 MUTEX_INIT(&thread->mutex);
541 threads = thread;
542 thread->next = thread;
543 thread->prev = thread;
544 thread->interp = aTHX;
545 thread->count = 1; /* imortal */
546 thread->tid = tid_counter++;
149bd5a9 547 active_threads++;
68795e93 548 thread->detached = 1;
549#ifdef WIN32
550 thread->thr = GetCurrentThreadId();
551#else
552 thread->thr = pthread_self();
553#endif
554 PERL_THREAD_SETSPECIFIC(self_key,thread);
419d29dc 555 MUTEX_UNLOCK(&create_destruct_mutex);
68795e93 556}
557