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