This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Some source files and documentation files need not to be executable
[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"
4dcb9e53
JH
5/* Workaround for XSUB.h bug under WIN32 */
6#ifdef WIN32
7# undef setjmp
c608f8c0
JH
8# if !defined(__BORLANDC__)
9# define setjmp(x) _setjmp(x)
10# endif
4dcb9e53 11#endif
0f1612a7 12#ifdef HAS_PPPORT_H
404aaa48 13# define NEED_PL_signals
0f1612a7 14# define NEED_newRV_noinc
dcefd27c 15# define NEED_sv_2pv_flags
0f1612a7
JH
16# include "ppport.h"
17# include "threads.h"
18#endif
68795e93 19
73e09c8f
JH
20#ifdef USE_ITHREADS
21
68795e93 22#ifdef WIN32
fc04eb16 23# include <windows.h>
514612b7
JH
24 /* Supposed to be in Winbase.h */
25# ifndef STACK_SIZE_PARAM_IS_A_RESERVATION
26# define STACK_SIZE_PARAM_IS_A_RESERVATION 0x00010000
27# endif
fc04eb16 28# include <win32thread.h>
68795e93 29#else
fc04eb16 30# ifdef OS2
5c728af0 31typedef perl_os_thread pthread_t;
fc04eb16
JH
32# else
33# include <pthread.h>
34# endif
35# include <thread.h>
36# define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
37# ifdef OLD_PTHREADS_API
38# define PERL_THREAD_DETACH(t) pthread_detach(&(t))
39# else
40# define PERL_THREAD_DETACH(t) pthread_detach((t))
41# endif
467f3f08 42#endif
d305c2c9
JH
43#if !defined(HAS_GETPAGESIZE) && defined(I_SYS_PARAM)
44# include <sys/param.h>
45#endif
68795e93 46
62375a60 47/* Values for 'state' member */
6ebc233e
RGS
48#define PERL_ITHR_DETACHED 1 /* Thread has been detached */
49#define PERL_ITHR_JOINED 2 /* Thread has been joined */
50#define PERL_ITHR_FINISHED 4 /* Thread has finished execution */
6158f8b3 51#define PERL_ITHR_THREAD_EXIT_ONLY 8 /* exit() only exits current thread */
6ebc233e
RGS
52#define PERL_ITHR_NONVIABLE 16 /* Thread creation failed */
53#define PERL_ITHR_DIED 32 /* Thread finished by dying */
6158f8b3
DM
54
55#define PERL_ITHR_UNCALLABLE (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)
56
fc04eb16
JH
57
58typedef struct _ithread {
59 struct _ithread *next; /* Next thread in the list */
60 struct _ithread *prev; /* Prev thread in the list */
61 PerlInterpreter *interp; /* The threads interpreter */
62 UV tid; /* Threads module's thread id */
63 perl_mutex mutex; /* Mutex for updating things in this struct */
6ebc233e 64 int count; /* Reference count. See S_ithread_create. */
fc04eb16
JH
65 int state; /* Detached, joined, finished, etc. */
66 int gimme; /* Context of create */
67 SV *init_function; /* Code to run */
68 SV *params; /* Args to pass function */
68795e93 69#ifdef WIN32
fc04eb16
JH
70 DWORD thr; /* OS's idea if thread id */
71 HANDLE handle; /* OS's waitable handle */
68795e93 72#else
fc04eb16 73 pthread_t thr; /* OS's handle for the thread */
68795e93 74#endif
514612b7 75 IV stack_size;
955c272e
JH
76 SV *err; /* Error from abnormally terminated thread */
77 char *err_class; /* Error object's classname if applicable */
68795e93
NIS
78} ithread;
79
fc04eb16 80
5c6ff896 81#define MY_CXT_KEY "threads::_cxt" XS_VERSION
628ab322
DM
82
83typedef struct {
861d5cbe
JH
84 /* Used by Perl interpreter for thread context switching */
85 ithread *context;
628ab322
DM
86} my_cxt_t;
87
88START_MY_CXT
89
68795e93 90
5c6ff896 91#define MY_POOL_KEY "threads::_pool" XS_VERSION
68795e93 92
5c6ff896
JH
93typedef struct {
94 /* Structure for 'main' thread
95 * Also forms the 'base' for the doubly-linked list of threads */
96 ithread main_thread;
97
98 /* Protects the creation and destruction of threads*/
99 perl_mutex create_destruct_mutex;
100
101 UV tid_counter;
102 IV joinable_threads;
103 IV running_threads;
104 IV detached_threads;
e9a908c9 105 IV total_threads;
5c6ff896
JH
106 IV default_stack_size;
107 IV page_size;
108} my_pool_t;
109
110#define dMY_POOL \
111 SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY, \
112 sizeof(MY_POOL_KEY)-1, TRUE); \
113 my_pool_t *my_poolp = INT2PTR(my_pool_t*, SvUV(my_pool_sv))
114
115#define MY_POOL (*my_poolp)
c05ae023
AB
116
117
fc04eb16 118/* Used by Perl interpreter for thread context switching */
861d5cbe 119STATIC void
fc04eb16 120S_ithread_set(pTHX_ ithread *thread)
c05ae023 121{
628ab322 122 dMY_CXT;
861d5cbe 123 MY_CXT.context = thread;
c05ae023
AB
124}
125
861d5cbe 126STATIC ithread *
fc04eb16
JH
127S_ithread_get(pTHX)
128{
628ab322 129 dMY_CXT;
861d5cbe 130 return (MY_CXT.context);
c05ae023
AB
131}
132
133
fc04eb16
JH
134/* Free any data (such as the Perl interpreter) attached to an ithread
135 * structure. This is a bit like undef on SVs, where the SV isn't freed,
6ebc233e
RGS
136 * but the PVX is. Must be called with thread->mutex already locked. Also,
137 * must be called with MY_POOL.create_destruct_mutex unlocked as destruction
138 * of the interpreter can lead to recursive destruction calls that could
139 * lead to a deadlock on that mutex.
2e676467 140 */
861d5cbe 141STATIC void
fc04eb16 142S_ithread_clear(pTHX_ ithread *thread)
2e676467
DM
143{
144 PerlInterpreter *interp;
fc04eb16 145
adc09a0e 146 assert(((thread->state & PERL_ITHR_FINISHED) &&
8718f9a1 147 (thread->state & PERL_ITHR_UNCALLABLE))
adc09a0e
JH
148 ||
149 (thread->state & PERL_ITHR_NONVIABLE));
2e676467
DM
150
151 interp = thread->interp;
152 if (interp) {
fc04eb16
JH
153 dTHXa(interp);
154
155 PERL_SET_CONTEXT(interp);
156 S_ithread_set(aTHX_ thread);
f2cba68d 157
fc04eb16
JH
158 SvREFCNT_dec(thread->params);
159 thread->params = Nullsv;
2e676467 160
955c272e
JH
161 if (thread->err) {
162 SvREFCNT_dec(thread->err);
163 thread->err = Nullsv;
164 }
165
fc04eb16 166 perl_destruct(interp);
9ca4d7fd 167 perl_free(interp);
fc04eb16 168 thread->interp = NULL;
2e676467 169 }
fc04eb16 170
2e676467
DM
171 PERL_SET_CONTEXT(aTHX);
172}
173
68795e93 174
6158f8b3
DM
175/* Decrement the refcount of an ithread, and if it reaches zero, free it.
176 * Must be called with the mutex held.
6ebc233e
RGS
177 * On return, mutex is released (or destroyed).
178 */
861d5cbe 179STATIC void
6158f8b3 180S_ithread_free(pTHX_ ithread *thread)
68795e93 181{
385d56e4 182#ifdef WIN32
fc04eb16 183 HANDLE handle;
385d56e4 184#endif
adc09a0e
JH
185 dMY_POOL;
186
6158f8b3
DM
187 if (! (thread->state & PERL_ITHR_NONVIABLE)) {
188 assert(thread->count > 0);
189 if (--thread->count > 0) {
190 MUTEX_UNLOCK(&thread->mutex);
191 return;
192 }
6ebc233e
RGS
193 assert((thread->state & PERL_ITHR_FINISHED) &&
194 (thread->state & PERL_ITHR_UNCALLABLE));
fc04eb16 195 }
adc09a0e 196 MUTEX_UNLOCK(&thread->mutex);
9feacc09 197
fc04eb16
JH
198 /* Main thread (0) is immortal and should never get here */
199 assert(thread->tid != 0);
200
201 /* Remove from circular list of threads */
5c6ff896 202 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
adc09a0e
JH
203 assert(thread->prev && thread->next);
204 thread->next->prev = thread->prev;
205 thread->prev->next = thread->next;
fc04eb16
JH
206 thread->next = NULL;
207 thread->prev = NULL;
5c6ff896 208 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
c2f2a82b 209
fc04eb16 210 /* Thread is now disowned */
9ca4d7fd 211 MUTEX_LOCK(&thread->mutex);
fc04eb16 212 S_ithread_clear(aTHX_ thread);
385d56e4
JH
213
214#ifdef WIN32
fc04eb16
JH
215 handle = thread->handle;
216 thread->handle = NULL;
385d56e4 217#endif
fc04eb16
JH
218 MUTEX_UNLOCK(&thread->mutex);
219 MUTEX_DESTROY(&thread->mutex);
385d56e4 220
c7667023 221#ifdef WIN32
fea7688c 222 if (handle) {
fc04eb16 223 CloseHandle(handle);
fea7688c 224 }
c7667023 225#endif
385d56e4 226
fc04eb16 227 PerlMemShared_free(thread);
ae3fba3d
DM
228
229 /* total_threads >= 1 is used to veto cleanup by the main thread,
230 * should it happen to exit while other threads still exist.
6ebc233e
RGS
231 * Decrement this as the very last thing in the thread's existence.
232 * Otherwise, MY_POOL and global state such as PL_op_mutex may get
233 * freed while we're still using it.
ae3fba3d
DM
234 */
235 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
236 MY_POOL.total_threads--;
237 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
68795e93
NIS
238}
239
fc04eb16 240
6158f8b3
DM
241static void
242S_ithread_count_inc(pTHX_ ithread *thread)
243{
244 MUTEX_LOCK(&thread->mutex);
245 thread->count++;
246 MUTEX_UNLOCK(&thread->mutex);
247}
248
249
69a9b4b8 250/* Warn if exiting with any unjoined threads */
861d5cbe 251STATIC int
69a9b4b8 252S_exit_warning(pTHX)
62375a60 253{
e9a908c9 254 int veto_cleanup, warn;
adc09a0e 255 dMY_POOL;
69a9b4b8 256
5c6ff896 257 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
e9a908c9
DM
258 veto_cleanup = (MY_POOL.total_threads > 0);
259 warn = (MY_POOL.running_threads || MY_POOL.joinable_threads);
5c6ff896 260 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
60bd5ef6 261
e9a908c9 262 if (warn) {
fc04eb16 263 if (ckWARN_d(WARN_THREADS)) {
4dcb9e53
JH
264 Perl_warn(aTHX_ "Perl exited with active threads:\n\t%"
265 IVdf " running and unjoined\n\t%"
266 IVdf " finished and unjoined\n\t%"
267 IVdf " running and detached\n",
5c6ff896
JH
268 MY_POOL.running_threads,
269 MY_POOL.joinable_threads,
270 MY_POOL.detached_threads);
fc04eb16 271 }
62375a60 272 }
69a9b4b8 273
fc04eb16 274 return (veto_cleanup);
62375a60
NIS
275}
276
ae3fba3d 277
6ebc233e
RGS
278/* Called from perl_destruct() in each thread. If it's the main thread,
279 * stop it from freeing everything if there are other threads still running.
280 */
69a9b4b8
RGS
281int
282Perl_ithread_hook(pTHX)
283{
5c6ff896 284 dMY_POOL;
b5c80a23 285 return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0);
69a9b4b8
RGS
286}
287
68795e93
NIS
288
289/* MAGIC (in mg.h sense) hooks */
290
291int
292ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
293{
fc04eb16 294 ithread *thread = (ithread *)mg->mg_ptr;
45977657 295 SvIV_set(sv, PTR2IV(thread));
68795e93 296 SvIOK_on(sv);
fc04eb16 297 return (0);
68795e93
NIS
298}
299
300int
301ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
302{
f2cba68d 303 ithread *thread = (ithread *)mg->mg_ptr;
68795e93 304 MUTEX_LOCK(&thread->mutex);
6ebc233e 305 S_ithread_free(aTHX_ thread); /* Releases MUTEX */
fc04eb16 306 return (0);
68795e93
NIS
307}
308
309int
310ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
311{
6158f8b3 312 S_ithread_count_inc(aTHX_ (ithread *)mg->mg_ptr);
fc04eb16 313 return (0);
68795e93
NIS
314}
315
316MGVTBL ithread_vtbl = {
fc04eb16
JH
317 ithread_mg_get, /* get */
318 0, /* set */
319 0, /* len */
320 0, /* clear */
321 ithread_mg_free, /* free */
322 0, /* copy */
323 ithread_mg_dup /* dup */
68795e93
NIS
324};
325
47ba8780 326
514612b7 327/* Provided default, minimum and rational stack sizes */
861d5cbe
JH
328STATIC IV
329S_good_stack_size(pTHX_ IV stack_size)
514612b7 330{
5c6ff896
JH
331 dMY_POOL;
332
514612b7 333 /* Use default stack size if no stack size specified */
fea7688c 334 if (! stack_size) {
5c6ff896 335 return (MY_POOL.default_stack_size);
fea7688c 336 }
514612b7
JH
337
338#ifdef PTHREAD_STACK_MIN
339 /* Can't use less than minimum */
340 if (stack_size < PTHREAD_STACK_MIN) {
4dcb9e53 341 if (ckWARN(WARN_THREADS)) {
514612b7
JH
342 Perl_warn(aTHX_ "Using minimum thread stack size of %" IVdf, (IV)PTHREAD_STACK_MIN);
343 }
344 return (PTHREAD_STACK_MIN);
345 }
346#endif
347
348 /* Round up to page size boundary */
5c6ff896 349 if (MY_POOL.page_size <= 0) {
d305c2c9 350#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
514612b7 351 SETERRNO(0, SS_NORMAL);
d305c2c9 352# ifdef _SC_PAGESIZE
5c6ff896 353 MY_POOL.page_size = sysconf(_SC_PAGESIZE);
d305c2c9 354# else
5c6ff896 355 MY_POOL.page_size = sysconf(_SC_MMAP_PAGE_SIZE);
d305c2c9 356# endif
5c6ff896 357 if ((long)MY_POOL.page_size < 0) {
514612b7
JH
358 if (errno) {
359 SV * const error = get_sv("@", FALSE);
360 (void)SvUPGRADE(error, SVt_PV);
361 Perl_croak(aTHX_ "PANIC: sysconf: %s", SvPV_nolen(error));
362 } else {
363 Perl_croak(aTHX_ "PANIC: sysconf: pagesize unknown");
364 }
365 }
d305c2c9
JH
366#else
367# ifdef HAS_GETPAGESIZE
5c6ff896 368 MY_POOL.page_size = getpagesize();
514612b7 369# else
d305c2c9 370# if defined(I_SYS_PARAM) && defined(PAGESIZE)
5c6ff896 371 MY_POOL.page_size = PAGESIZE;
d305c2c9 372# else
5c6ff896 373 MY_POOL.page_size = 8192; /* A conservative default */
d305c2c9 374# endif
514612b7 375# endif
5c6ff896
JH
376 if (MY_POOL.page_size <= 0) {
377 Perl_croak(aTHX_ "PANIC: bad pagesize %" IVdf, (IV)MY_POOL.page_size);
fea7688c 378 }
514612b7
JH
379#endif
380 }
5c6ff896 381 stack_size = ((stack_size + (MY_POOL.page_size - 1)) / MY_POOL.page_size) * MY_POOL.page_size;
514612b7
JH
382
383 return (stack_size);
384}
385
386
fc04eb16
JH
387/* Starts executing the thread.
388 * Passed as the C level function to run in the new thread.
b1edfb69 389 */
47ba8780 390#ifdef WIN32
861d5cbe 391STATIC THREAD_RET_TYPE
fc04eb16 392S_ithread_run(LPVOID arg)
47ba8780 393#else
861d5cbe 394STATIC void *
fc04eb16 395S_ithread_run(void * arg)
47ba8780 396#endif
fc04eb16
JH
397{
398 ithread *thread = (ithread *)arg;
69a9b4b8
RGS
399 int jmp_rc = 0;
400 I32 oldscope;
955c272e 401 int exit_app = 0; /* Thread terminated using 'exit' */
69a9b4b8 402 int exit_code = 0;
955c272e 403 int died = 0; /* Thread terminated abnormally */
f2cba68d 404
69a9b4b8
RGS
405 dJMPENV;
406
fc04eb16 407 dTHXa(thread->interp);
47ba8780 408
5c6ff896
JH
409 dMY_POOL;
410
9ca4d7fd 411 /* Blocked until ->create() call finishes */
fc04eb16 412 MUTEX_LOCK(&thread->mutex);
fc04eb16 413 MUTEX_UNLOCK(&thread->mutex);
9ca4d7fd
JH
414
415 PERL_SET_CONTEXT(thread->interp);
416 S_ithread_set(aTHX_ thread);
47ba8780 417
fc04eb16 418 PL_perl_destruct_level = 2;
f2cba68d 419
fc04eb16
JH
420 {
421 AV *params = (AV *)SvRV(thread->params);
422 int len = (int)av_len(params)+1;
423 int ii;
424
425 dSP;
426 ENTER;
427 SAVETMPS;
428
429 /* Put args on the stack */
430 PUSHMARK(SP);
431 for (ii=0; ii < len; ii++) {
432 XPUSHs(av_shift(params));
433 }
434 PUTBACK;
435
4dcb9e53
JH
436 oldscope = PL_scopestack_ix;
437 JMPENV_PUSH(jmp_rc);
438 if (jmp_rc == 0) {
439 /* Run the specified function */
440 len = (int)call_sv(thread->init_function, thread->gimme|G_EVAL);
441 } else if (jmp_rc == 2) {
69a9b4b8
RGS
442 /* Thread exited */
443 exit_app = 1;
444 exit_code = STATUS_CURRENT;
4dcb9e53
JH
445 while (PL_scopestack_ix > oldscope) {
446 LEAVE;
447 }
448 }
449 JMPENV_POP;
fc04eb16
JH
450
451 /* Remove args from stack and put back in params array */
452 SPAGAIN;
453 for (ii=len-1; ii >= 0; ii--) {
454 SV *sv = POPs;
7df0357e 455 if (jmp_rc == 0 && (thread->gimme & G_WANT) != G_VOID) {
4dcb9e53
JH
456 av_store(params, ii, SvREFCNT_inc(sv));
457 }
fc04eb16
JH
458 }
459
4dcb9e53
JH
460 FREETMPS;
461 LEAVE;
462
955c272e
JH
463 /* Check for abnormal termination */
464 if (SvTRUE(ERRSV)) {
465 died = PERL_ITHR_DIED;
466 thread->err = newSVsv(ERRSV);
467 /* If ERRSV is an object, remember the classname and then
468 * rebless into 'main' so it will survive 'cloning'
469 */
470 if (sv_isobject(thread->err)) {
471 thread->err_class = HvNAME(SvSTASH(SvRV(thread->err)));
472 sv_bless(thread->err, gv_stashpv("main", 0));
473 }
474
475 if (ckWARN_d(WARN_THREADS)) {
476 oldscope = PL_scopestack_ix;
477 JMPENV_PUSH(jmp_rc);
478 if (jmp_rc == 0) {
479 /* Warn that thread died */
480 Perl_warn(aTHX_ "Thread %" UVuf " terminated abnormally: %" SVf, thread->tid, ERRSV);
481 } else if (jmp_rc == 2) {
482 /* Warn handler exited */
483 exit_app = 1;
484 exit_code = STATUS_CURRENT;
485 while (PL_scopestack_ix > oldscope) {
486 LEAVE;
487 }
4dcb9e53 488 }
955c272e 489 JMPENV_POP;
4dcb9e53 490 }
fc04eb16
JH
491 }
492
fc04eb16
JH
493 /* Release function ref */
494 SvREFCNT_dec(thread->init_function);
495 thread->init_function = Nullsv;
496 }
62375a60 497
fc04eb16
JH
498 PerlIO_flush((PerlIO *)NULL);
499
5c6ff896 500 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
fc04eb16
JH
501 MUTEX_LOCK(&thread->mutex);
502 /* Mark as finished */
955c272e 503 thread->state |= (PERL_ITHR_FINISHED | died);
69a9b4b8 504 /* Clear exit flag if required */
fea7688c 505 if (thread->state & PERL_ITHR_THREAD_EXIT_ONLY) {
69a9b4b8 506 exit_app = 0;
fea7688c 507 }
fc04eb16 508
69a9b4b8 509 /* Adjust thread status counts */
adc09a0e 510 if (thread->state & PERL_ITHR_DETACHED) {
5c6ff896 511 MY_POOL.detached_threads--;
4dcb9e53 512 } else {
5c6ff896
JH
513 MY_POOL.running_threads--;
514 MY_POOL.joinable_threads++;
5168baf3 515 }
adc09a0e 516 MUTEX_UNLOCK(&thread->mutex);
5c6ff896 517 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
69a9b4b8
RGS
518
519 /* Exit application if required */
520 if (exit_app) {
521 oldscope = PL_scopestack_ix;
522 JMPENV_PUSH(jmp_rc);
523 if (jmp_rc == 0) {
524 /* Warn if there are unjoined threads */
525 S_exit_warning(aTHX);
526 } else if (jmp_rc == 2) {
527 /* Warn handler exited */
528 exit_code = STATUS_CURRENT;
529 while (PL_scopestack_ix > oldscope) {
530 LEAVE;
531 }
532 }
533 JMPENV_POP;
534
535 my_exit(exit_code);
536 }
537
6ebc233e
RGS
538 /* At this point, the interpreter may have been freed, so call
539 * free in the the context of of the 'main' interpreter which
540 * can't have been freed due to the veto_cleanup mechanism.
541 */
46c5d8f1
DM
542 aTHX = MY_POOL.main_thread.interp;
543
6158f8b3 544 MUTEX_LOCK(&thread->mutex);
6ebc233e 545 S_ithread_free(aTHX_ thread); /* Releases MUTEX */
91604d21 546
47ba8780 547#ifdef WIN32
fc04eb16 548 return ((DWORD)0);
e8f2bb9a 549#else
fc04eb16 550 return (0);
47ba8780 551#endif
68795e93
NIS
552}
553
fc04eb16
JH
554
555/* Type conversion helper functions */
fea7688c 556
861d5cbe
JH
557STATIC SV *
558S_ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
68795e93
NIS
559{
560 SV *sv;
561 MAGIC *mg;
fc04eb16 562
6158f8b3
DM
563 if (inc)
564 S_ithread_count_inc(aTHX_ thread);
fc04eb16
JH
565
566 if (! obj) {
567 obj = newSV(0);
68795e93 568 }
fc04eb16
JH
569
570 sv = newSVrv(obj, classname);
571 sv_setiv(sv, PTR2IV(thread));
572 mg = sv_magicext(sv, Nullsv, PERL_MAGIC_shared_scalar, &ithread_vtbl, (char *)thread, 0);
68795e93
NIS
573 mg->mg_flags |= MGf_DUP;
574 SvREADONLY_on(sv);
fc04eb16
JH
575
576 return (obj);
68795e93 577}
47ba8780 578
861d5cbe
JH
579STATIC ithread *
580S_SV_to_ithread(pTHX_ SV *sv)
68795e93 581{
fc04eb16
JH
582 /* Argument is a thread */
583 if (SvROK(sv)) {
584 return (INT2PTR(ithread *, SvIV(SvRV(sv))));
585 }
586 /* Argument is classname, therefore return current thread */
587 return (S_ithread_get(aTHX));
47ba8780
AB
588}
589
47ba8780 590
fc04eb16
JH
591/* threads->create()
592 * Called in context of parent thread.
5c6ff896 593 * Called with MY_POOL.create_destruct_mutex locked. (Unlocked on error.)
fc04eb16 594 */
861d5cbe 595STATIC ithread *
fc04eb16 596S_ithread_create(
9ca4d7fd 597 pTHX_ SV *init_function,
514612b7 598 IV stack_size,
9d9ff5b1 599 int gimme,
69a9b4b8 600 int exit_opt,
fc04eb16 601 SV *params)
68795e93 602{
fc04eb16 603 ithread *thread;
fc04eb16 604 ithread *current_thread = S_ithread_get(aTHX);
3b1c3273 605
fc04eb16
JH
606 SV **tmps_tmp = PL_tmps_stack;
607 IV tmps_ix = PL_tmps_ix;
d94006e8 608#ifndef WIN32
fc04eb16
JH
609 int rc_stack_size = 0;
610 int rc_thread_create = 0;
d94006e8 611#endif
adc09a0e 612 dMY_POOL;
3b1c3273 613
adc09a0e 614 /* Allocate thread structure in context of the main thread's interpreter */
5c6ff896
JH
615 {
616 PERL_SET_CONTEXT(MY_POOL.main_thread.interp);
617 thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
618 }
619 PERL_SET_CONTEXT(aTHX);
fc04eb16 620 if (!thread) {
5c6ff896 621 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
fc04eb16
JH
622 PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
623 my_exit(1);
624 }
625 Zero(thread, 1, ithread);
626
627 /* Add to threads list */
5c6ff896
JH
628 thread->next = &MY_POOL.main_thread;
629 thread->prev = MY_POOL.main_thread.prev;
630 MY_POOL.main_thread.prev = thread;
fc04eb16 631 thread->prev->next = thread;
e9a908c9 632 MY_POOL.total_threads++;
c05ae023 633
6ebc233e 634 /* 1 ref to be held by the local var 'thread' in S_ithread_run().
6158f8b3 635 * 1 ref to be held by the threads object that we assume we will
6ebc233e
RGS
636 * be embedded in upon our return.
637 * 1 ref to be the responsibility of join/detach, so we don't get
638 * freed until join/detach, even if no thread objects remain.
639 * This allows the following to work:
878090d5 640 * { threads->create(sub{...}); } threads->object(1)->join;
fc04eb16 641 */
6158f8b3 642 thread->count = 3;
fc04eb16 643
9ca4d7fd 644 /* Block new thread until ->create() call finishes */
fc04eb16 645 MUTEX_INIT(&thread->mutex);
9ca4d7fd
JH
646 MUTEX_LOCK(&thread->mutex);
647
5c6ff896 648 thread->tid = MY_POOL.tid_counter++;
861d5cbe 649 thread->stack_size = S_good_stack_size(aTHX_ stack_size);
9d9ff5b1 650 thread->gimme = gimme;
69a9b4b8 651 thread->state = exit_opt;
fc04eb16
JH
652
653 /* "Clone" our interpreter into the thread's interpreter.
654 * This gives thread access to "static data" and code.
655 */
656 PerlIO_flush((PerlIO *)NULL);
657 S_ithread_set(aTHX_ thread);
658
659 SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct value */
660 PL_srand_called = FALSE; /* Set it to false so we can detect if it gets
661 set during the clone */
3b1c3273 662
47ba8780 663#ifdef WIN32
fc04eb16 664 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
47ba8780 665#else
fc04eb16 666 thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
47ba8780 667#endif
47ba8780 668
fc04eb16
JH
669 /* perl_clone() leaves us in new interpreter's context. As it is tricky
670 * to spot an implicit aTHX, create a new scope with aTHX matching the
671 * context for the duration of our work for new interpreter.
672 */
673 {
894eec8b
JH
674 CLONE_PARAMS clone_param;
675
fc04eb16
JH
676 dTHXa(thread->interp);
677
678 MY_CXT_CLONE;
679
680 /* Here we remove END blocks since they should only run in the thread
681 * they are created
682 */
683 SvREFCNT_dec(PL_endav);
684 PL_endav = newAV();
404aaa48 685
894eec8b 686 clone_param.flags = 0;
f2e0bb91
JH
687 if (SvPOK(init_function)) {
688 thread->init_function = newSV(0);
689 sv_copypv(thread->init_function, init_function);
690 } else {
dd5ef8e0
DM
691 thread->init_function =
692 SvREFCNT_inc(sv_dup(init_function, &clone_param));
fc04eb16
JH
693 }
694
695 thread->params = sv_dup(params, &clone_param);
d4315dd6 696 SvREFCNT_inc_void(thread->params);
fc04eb16
JH
697
698 /* The code below checks that anything living on the tmps stack and
699 * has been cloned (so it lives in the ptr_table) has a refcount
700 * higher than 0.
701 *
702 * If the refcount is 0 it means that a something on the stack/context
703 * was holding a reference to it and since we init_stacks() in
704 * perl_clone that won't get cleaned and we will get a leaked scalar.
705 * The reason it was cloned was that it lived on the @_ stack.
706 *
707 * Example of this can be found in bugreport 15837 where calls in the
708 * parameter list end up as a temp.
709 *
710 * One could argue that this fix should be in perl_clone.
711 */
712 while (tmps_ix > 0) {
713 SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
714 tmps_ix--;
715 if (sv && SvREFCNT(sv) == 0) {
d4315dd6 716 SvREFCNT_inc_void(sv);
fc04eb16
JH
717 SvREFCNT_dec(sv);
718 }
719 }
720
721 SvTEMP_off(thread->init_function);
722 ptr_table_free(PL_ptr_table);
723 PL_ptr_table = NULL;
724 PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
725 }
726 S_ithread_set(aTHX_ current_thread);
727 PERL_SET_CONTEXT(aTHX);
728
729 /* Create/start the thread */
47ba8780 730#ifdef WIN32
fc04eb16 731 thread->handle = CreateThread(NULL,
514612b7 732 (DWORD)thread->stack_size,
fc04eb16
JH
733 S_ithread_run,
734 (LPVOID)thread,
514612b7 735 STACK_SIZE_PARAM_IS_A_RESERVATION,
fc04eb16 736 &thread->thr);
82c40bf6 737#else
fc04eb16 738 {
861d5cbe
JH
739 STATIC pthread_attr_t attr;
740 STATIC int attr_inited = 0;
741 STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE;
fc04eb16
JH
742 if (! attr_inited) {
743 pthread_attr_init(&attr);
744 attr_inited = 1;
745 }
746
fa26028c 747# ifdef PTHREAD_ATTR_SETDETACHSTATE
fc04eb16
JH
748 /* Threads start out joinable */
749 PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
fa26028c 750# endif
fc04eb16 751
514612b7 752# ifdef _POSIX_THREAD_ATTR_STACKSIZE
fc04eb16 753 /* Set thread's stack size */
514612b7
JH
754 if (thread->stack_size > 0) {
755 rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size);
756 }
3eb37d38
AB
757# endif
758
fc04eb16
JH
759 /* Create the thread */
760 if (! rc_stack_size) {
761# ifdef OLD_PTHREADS_API
762 rc_thread_create = pthread_create(&thread->thr,
763 attr,
764 S_ithread_run,
765 (void *)thread);
766# else
767# if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
768 pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
769# endif
770 rc_thread_create = pthread_create(&thread->thr,
771 &attr,
772 S_ithread_run,
773 (void *)thread);
19a077f6 774# endif
fc04eb16 775 }
514612b7
JH
776
777# ifdef _POSIX_THREAD_ATTR_STACKSIZE
778 /* Try to get thread's actual stack size */
779 {
780 size_t stacksize;
58a3a76c
JH
781#ifdef HPUX1020
782 stacksize = pthread_attr_getstacksize(attr);
783#else
784 if (! pthread_attr_getstacksize(&attr, &stacksize))
785#endif
786 if (stacksize > 0) {
514612b7
JH
787 thread->stack_size = (IV)stacksize;
788 }
514612b7
JH
789 }
790# endif
fc04eb16 791 }
82c40bf6 792#endif
bcd9ca9b 793
fc04eb16 794 /* Check for errors */
d94006e8 795#ifdef WIN32
fc04eb16 796 if (thread->handle == NULL) {
d94006e8 797#else
fc04eb16 798 if (rc_stack_size || rc_thread_create) {
d94006e8 799#endif
9ca4d7fd 800 /* Must unlock mutex for destruct call */
5c6ff896 801 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
fc04eb16 802 sv_2mortal(params);
adc09a0e 803 thread->state |= PERL_ITHR_NONVIABLE;
6ebc233e 804 S_ithread_free(aTHX_ thread); /* Releases MUTEX */
d94006e8 805#ifndef WIN32
514612b7 806 if (ckWARN_d(WARN_THREADS)) {
fea7688c 807 if (rc_stack_size) {
514612b7 808 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
fea7688c 809 } else {
514612b7 810 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
fea7688c 811 }
514612b7 812 }
d94006e8 813#endif
9ca4d7fd 814 return (NULL);
fc04eb16
JH
815 }
816
5c6ff896 817 MY_POOL.running_threads++;
fc04eb16 818 sv_2mortal(params);
9ca4d7fd 819 return (thread);
68795e93 820}
47ba8780 821
73e09c8f 822#endif /* USE_ITHREADS */
e1c44605 823
fcea4b7c 824
fc04eb16 825MODULE = threads PACKAGE = threads PREFIX = ithread_
68795e93 826PROTOTYPES: DISABLE
8222d950 827
73e09c8f
JH
828#ifdef USE_ITHREADS
829
68795e93 830void
f4cc38af
JH
831ithread_create(...)
832 PREINIT:
833 char *classname;
514612b7 834 ithread *thread;
f4cc38af
JH
835 SV *function_to_call;
836 AV *params;
514612b7
JH
837 HV *specs;
838 IV stack_size;
9d9ff5b1 839 int context;
69a9b4b8
RGS
840 int exit_opt;
841 SV *thread_exit_only;
9d9ff5b1 842 char *str;
514612b7 843 int idx;
f4cc38af 844 int ii;
5c6ff896 845 dMY_POOL;
f4cc38af 846 CODE:
514612b7 847 if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
fea7688c 848 if (--items < 2) {
18b9e6f5 849 Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)");
fea7688c 850 }
514612b7
JH
851 specs = (HV*)SvRV(ST(1));
852 idx = 1;
853 } else {
fea7688c 854 if (items < 2) {
514612b7 855 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
fea7688c 856 }
514612b7
JH
857 specs = NULL;
858 idx = 0;
859 }
f4cc38af 860
514612b7
JH
861 if (sv_isobject(ST(0))) {
862 /* $thr->create() */
863 classname = HvNAME(SvSTASH(SvRV(ST(0))));
864 thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
8718f9a1 865 MUTEX_LOCK(&thread->mutex);
514612b7 866 stack_size = thread->stack_size;
69a9b4b8 867 exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY;
8718f9a1 868 MUTEX_UNLOCK(&thread->mutex);
514612b7
JH
869 } else {
870 /* threads->create() */
871 classname = (char *)SvPV_nolen(ST(0));
5c6ff896 872 stack_size = MY_POOL.default_stack_size;
69a9b4b8
RGS
873 thread_exit_only = get_sv("threads::thread_exit_only", TRUE);
874 exit_opt = (SvTRUE(thread_exit_only))
875 ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
514612b7
JH
876 }
877
878 function_to_call = ST(idx+1);
879
9d9ff5b1 880 context = -1;
514612b7
JH
881 if (specs) {
882 /* stack_size */
883 if (hv_exists(specs, "stack", 5)) {
884 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
885 } else if (hv_exists(specs, "stacksize", 9)) {
886 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
887 } else if (hv_exists(specs, "stack_size", 10)) {
888 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
889 }
9d9ff5b1
JH
890
891 /* context */
892 if (hv_exists(specs, "context", 7)) {
893 str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
894 switch (*str) {
895 case 'a':
896 case 'A':
da140a40
JH
897 case 'l':
898 case 'L':
9d9ff5b1
JH
899 context = G_ARRAY;
900 break;
901 case 's':
902 case 'S':
903 context = G_SCALAR;
904 break;
905 case 'v':
906 case 'V':
907 context = G_VOID;
908 break;
909 default:
910 Perl_croak(aTHX_ "Invalid context: %s", str);
911 }
912 } else if (hv_exists(specs, "array", 5)) {
913 if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
914 context = G_ARRAY;
915 }
da140a40
JH
916 } else if (hv_exists(specs, "list", 4)) {
917 if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
918 context = G_ARRAY;
919 }
9d9ff5b1
JH
920 } else if (hv_exists(specs, "scalar", 6)) {
921 if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
922 context = G_SCALAR;
923 }
924 } else if (hv_exists(specs, "void", 4)) {
925 if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
926 context = G_VOID;
927 }
928 }
69a9b4b8
RGS
929
930 /* exit => thread_only */
931 if (hv_exists(specs, "exit", 4)) {
932 str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
933 exit_opt = (*str == 't' || *str == 'T')
934 ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
935 }
9d9ff5b1
JH
936 }
937 if (context == -1) {
938 context = GIMME_V; /* Implicit context */
939 } else {
940 context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
514612b7 941 }
f4cc38af
JH
942
943 /* Function args */
944 params = newAV();
945 if (items > 2) {
514612b7
JH
946 for (ii=2; ii < items ; ii++) {
947 av_push(params, SvREFCNT_inc(ST(idx+ii)));
f4cc38af
JH
948 }
949 }
950
951 /* Create thread */
5c6ff896 952 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
9ca4d7fd
JH
953 thread = S_ithread_create(aTHX_ function_to_call,
954 stack_size,
955 context,
956 exit_opt,
957 newRV_noinc((SV*)params));
958 if (! thread) {
959 XSRETURN_UNDEF; /* Mutex already unlocked */
960 }
861d5cbe 961 ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE));
adc09a0e 962 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
9ca4d7fd
JH
963
964 /* Let thread run */
965 MUTEX_UNLOCK(&thread->mutex);
9ca4d7fd 966
f4cc38af
JH
967 /* XSRETURN(1); - implied */
968
8222d950 969
68795e93 970void
f4cc38af
JH
971ithread_list(...)
972 PREINIT:
973 char *classname;
fc04eb16 974 ithread *thread;
f4cc38af
JH
975 int list_context;
976 IV count = 0;
11db694d 977 int want_running = 0;
8718f9a1 978 int state;
5c6ff896 979 dMY_POOL;
f4cc38af
JH
980 PPCODE:
981 /* Class method only */
fea7688c 982 if (SvROK(ST(0))) {
ead32952 983 Perl_croak(aTHX_ "Usage: threads->list(...)");
fea7688c 984 }
f4cc38af
JH
985 classname = (char *)SvPV_nolen(ST(0));
986
987 /* Calling context */
988 list_context = (GIMME_V == G_ARRAY);
989
ead32952
JH
990 /* Running or joinable parameter */
991 if (items > 1) {
992 want_running = SvTRUE(ST(1));
993 }
994
f4cc38af 995 /* Walk through threads list */
5c6ff896
JH
996 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
997 for (thread = MY_POOL.main_thread.next;
998 thread != &MY_POOL.main_thread;
fc04eb16 999 thread = thread->next)
f4cc38af 1000 {
8718f9a1
JH
1001 MUTEX_LOCK(&thread->mutex);
1002 state = thread->state;
1003 MUTEX_UNLOCK(&thread->mutex);
1004
f4cc38af 1005 /* Ignore detached or joined threads */
8718f9a1 1006 if (state & PERL_ITHR_UNCALLABLE) {
f4cc38af
JH
1007 continue;
1008 }
ead32952
JH
1009
1010 /* Filter per parameter */
1011 if (items > 1) {
1012 if (want_running) {
8718f9a1 1013 if (state & PERL_ITHR_FINISHED) {
ead32952
JH
1014 continue; /* Not running */
1015 }
1016 } else {
8718f9a1 1017 if (! (state & PERL_ITHR_FINISHED)) {
ead32952
JH
1018 continue; /* Still running - not joinable yet */
1019 }
1020 }
1021 }
1022
f4cc38af
JH
1023 /* Push object on stack if list context */
1024 if (list_context) {
861d5cbe 1025 XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
f4cc38af
JH
1026 }
1027 count++;
1028 }
5c6ff896 1029 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
f4cc38af
JH
1030 /* If scalar context, send back count */
1031 if (! list_context) {
1032 XSRETURN_IV(count);
1033 }
678a9b6c
AB
1034
1035
1036void
f4cc38af
JH
1037ithread_self(...)
1038 PREINIT:
1039 char *classname;
fcea4b7c 1040 ithread *thread;
f4cc38af
JH
1041 CODE:
1042 /* Class method only */
11db694d 1043 if ((items != 1) || SvROK(ST(0))) {
f4cc38af 1044 Perl_croak(aTHX_ "Usage: threads->self()");
fea7688c 1045 }
f4cc38af
JH
1046 classname = (char *)SvPV_nolen(ST(0));
1047
fcea4b7c
JH
1048 thread = S_ithread_get(aTHX);
1049
861d5cbe 1050 ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
f4cc38af 1051 /* XSRETURN(1); - implied */
47ba8780 1052
47ba8780
AB
1053
1054void
f4cc38af
JH
1055ithread_tid(...)
1056 PREINIT:
1057 ithread *thread;
1058 CODE:
11db694d 1059 PERL_UNUSED_VAR(items);
861d5cbe 1060 thread = S_SV_to_ithread(aTHX_ ST(0));
f4cc38af
JH
1061 XST_mUV(0, thread->tid);
1062 /* XSRETURN(1); - implied */
1063
e1c44605 1064
f9dff5f5 1065void
f4cc38af
JH
1066ithread_join(...)
1067 PREINIT:
fcea4b7c 1068 ithread *thread;
8718f9a1 1069 ithread *current_thread;
fcea4b7c 1070 int join_err;
6ebc233e 1071 AV *params = NULL;
f4cc38af
JH
1072 int len;
1073 int ii;
12701bb8 1074#ifndef WIN32
8718f9a1 1075 int rc_join;
fcea4b7c
JH
1076 void *retval;
1077#endif
5c6ff896 1078 dMY_POOL;
f4cc38af
JH
1079 PPCODE:
1080 /* Object method only */
11db694d 1081 if ((items != 1) || ! sv_isobject(ST(0))) {
f4cc38af 1082 Perl_croak(aTHX_ "Usage: $thr->join()");
fea7688c 1083 }
f4cc38af 1084
8718f9a1 1085 /* Check if the thread is joinable and not ourselves */
861d5cbe 1086 thread = S_SV_to_ithread(aTHX_ ST(0));
8718f9a1
JH
1087 current_thread = S_ithread_get(aTHX);
1088
1089 MUTEX_LOCK(&thread->mutex);
1090 if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1091 MUTEX_UNLOCK(&thread->mutex);
1092 Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED)
1093 ? "Cannot join a detached thread"
1094 : "Thread already joined");
1095 } else if (thread->tid == current_thread->tid) {
1096 MUTEX_UNLOCK(&thread->mutex);
1097 Perl_croak(aTHX_ "Cannot join self");
fcea4b7c
JH
1098 }
1099
8718f9a1
JH
1100 /* Mark as joined */
1101 thread->state |= PERL_ITHR_JOINED;
1102 MUTEX_UNLOCK(&thread->mutex);
1103
1104 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1105 MY_POOL.joinable_threads--;
1106 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1107
fcea4b7c
JH
1108 /* Join the thread */
1109#ifdef WIN32
8718f9a1
JH
1110 if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) {
1111 /* Timeout/abandonment unexpected here; check $^E */
1112 Perl_croak(aTHX_ "PANIC: underlying join failed");
1113 };
fcea4b7c 1114#else
8718f9a1
JH
1115 if ((rc_join = pthread_join(thread->thr, &retval)) != 0) {
1116 /* In progress/deadlock/unknown unexpected here; check $! */
1117 errno = rc_join;
1118 Perl_croak(aTHX_ "PANIC: underlying join failed");
1119 };
fcea4b7c
JH
1120#endif
1121
1122 MUTEX_LOCK(&thread->mutex);
fcea4b7c 1123 /* Get the return value from the call_sv */
955c272e 1124 /* Objects do not survive this process - FIXME */
7df0357e 1125 if ((thread->gimme & G_WANT) != G_VOID) {
fcea4b7c
JH
1126 AV *params_copy;
1127 PerlInterpreter *other_perl;
1128 CLONE_PARAMS clone_params;
fcea4b7c
JH
1129
1130 params_copy = (AV *)SvRV(thread->params);
1131 other_perl = thread->interp;
1132 clone_params.stashes = newAV();
1133 clone_params.flags = CLONEf_JOIN_IN;
1134 PL_ptr_table = ptr_table_new();
fcea4b7c
JH
1135 S_ithread_set(aTHX_ thread);
1136 /* Ensure 'meaningful' addresses retain their meaning */
1137 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1138 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1139 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1140 params = (AV *)sv_dup((SV*)params_copy, &clone_params);
1141 S_ithread_set(aTHX_ current_thread);
1142 SvREFCNT_dec(clone_params.stashes);
d4315dd6 1143 SvREFCNT_inc_void(params);
fcea4b7c
JH
1144 ptr_table_free(PL_ptr_table);
1145 PL_ptr_table = NULL;
1146 }
1147
955c272e
JH
1148 /* If thread didn't die, then we can free its interpreter */
1149 if (! (thread->state & PERL_ITHR_DIED)) {
1150 S_ithread_clear(aTHX_ thread);
1151 }
6ebc233e 1152 S_ithread_free(aTHX_ thread); /* Releases MUTEX */
955c272e 1153
fcea4b7c 1154 /* If no return values, then just return */
f4cc38af
JH
1155 if (! params) {
1156 XSRETURN_UNDEF;
1157 }
1158
1159 /* Put return values on stack */
1160 len = (int)AvFILL(params);
1161 for (ii=0; ii <= len; ii++) {
1162 SV* param = av_shift(params);
1163 XPUSHs(sv_2mortal(param));
1164 }
1165
1166 /* Free return value array */
1167 SvREFCNT_dec(params);
1168
1169
1170void
1171ithread_yield(...)
1172 CODE:
11db694d 1173 PERL_UNUSED_VAR(items);
f4cc38af
JH
1174 YIELD;
1175
1176
1177void
1178ithread_detach(...)
1179 PREINIT:
1180 ithread *thread;
fcea4b7c 1181 int detach_err;
5c6ff896 1182 dMY_POOL;
f4cc38af 1183 CODE:
11db694d
JH
1184 PERL_UNUSED_VAR(items);
1185
fcea4b7c 1186 /* Detach the thread */
8718f9a1 1187 thread = S_SV_to_ithread(aTHX_ ST(0));
5c6ff896 1188 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
9ca4d7fd 1189 MUTEX_LOCK(&thread->mutex);
8718f9a1
JH
1190 if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1191 /* Thread is detachable */
1192 thread->state |= PERL_ITHR_DETACHED;
fcea4b7c 1193#ifdef WIN32
8718f9a1 1194 /* Windows has no 'detach thread' function */
fcea4b7c 1195#else
8718f9a1 1196 PERL_THREAD_DETACH(thread->thr);
fcea4b7c 1197#endif
8718f9a1
JH
1198 if (thread->state & PERL_ITHR_FINISHED) {
1199 MY_POOL.joinable_threads--;
1200 } else {
1201 MY_POOL.running_threads--;
1202 MY_POOL.detached_threads++;
1203 }
4dcb9e53 1204 }
adc09a0e 1205 MUTEX_UNLOCK(&thread->mutex);
5c6ff896 1206 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
4dcb9e53 1207
8718f9a1
JH
1208 if (detach_err) {
1209 Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED)
1210 ? "Thread already detached"
1211 : "Cannot detach a joined thread");
1212 }
1213
955c272e
JH
1214 /* If thread is finished and didn't die,
1215 * then we can free its interpreter */
1216 MUTEX_LOCK(&thread->mutex);
1217 if ((thread->state & PERL_ITHR_FINISHED) &&
1218 ! (thread->state & PERL_ITHR_DIED))
1219 {
1220 S_ithread_clear(aTHX_ thread);
1221 }
6ebc233e 1222 S_ithread_free(aTHX_ thread); /* Releases MUTEX */
f4cc38af 1223
47ba8780
AB
1224
1225void
c0003851
JH
1226ithread_kill(...)
1227 PREINIT:
1228 ithread *thread;
1229 char *sig_name;
1230 IV signal;
1231 CODE:
1232 /* Must have safe signals */
fea7688c 1233 if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
4dcb9e53 1234 Perl_croak(aTHX_ "Cannot signal threads without safe signals");
fea7688c 1235 }
c0003851
JH
1236
1237 /* Object method only */
11db694d 1238 if ((items != 2) || ! sv_isobject(ST(0))) {
c0003851 1239 Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
fea7688c 1240 }
c0003851 1241
c0003851
JH
1242 /* Get signal */
1243 sig_name = SvPV_nolen(ST(1));
1244 if (isALPHA(*sig_name)) {
fea7688c 1245 if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') {
c0003851 1246 sig_name += 3;
fea7688c
JH
1247 }
1248 if ((signal = whichsig(sig_name)) < 0) {
c0003851 1249 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
fea7688c
JH
1250 }
1251 } else {
c0003851 1252 signal = SvIV(ST(1));
fea7688c 1253 }
c0003851
JH
1254
1255 /* Set the signal for the thread */
861d5cbe 1256 thread = S_SV_to_ithread(aTHX_ ST(0));
4dcb9e53 1257 MUTEX_LOCK(&thread->mutex);
3ceb02cd 1258 if (thread->interp) {
c0003851
JH
1259 dTHXa(thread->interp);
1260 PL_psig_pend[signal]++;
1261 PL_sig_pending = 1;
1262 }
4dcb9e53 1263 MUTEX_UNLOCK(&thread->mutex);
c0003851
JH
1264
1265 /* Return the thread to allow for method chaining */
1266 ST(0) = ST(0);
1267 /* XSRETURN(1); - implied */
1268
1269
1270void
f4cc38af
JH
1271ithread_DESTROY(...)
1272 CODE:
11db694d 1273 PERL_UNUSED_VAR(items);
fcea4b7c 1274 sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
f4cc38af
JH
1275
1276
1277void
1278ithread_equal(...)
fc04eb16
JH
1279 PREINIT:
1280 int are_equal = 0;
f4cc38af 1281 CODE:
11db694d
JH
1282 PERL_UNUSED_VAR(items);
1283
fc04eb16 1284 /* Compares TIDs to determine thread equality */
f4cc38af
JH
1285 if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1286 ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1287 ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
fc04eb16
JH
1288 are_equal = (thr1->tid == thr2->tid);
1289 }
1290 if (are_equal) {
1291 XST_mYES(0);
f4cc38af 1292 } else {
fc04eb16 1293 /* Return 0 on false for backward compatibility */
f4cc38af
JH
1294 XST_mIV(0, 0);
1295 }
1296 /* XSRETURN(1); - implied */
1297
47ba8780 1298
47ba8780 1299void
f4cc38af
JH
1300ithread_object(...)
1301 PREINIT:
1302 char *classname;
1303 UV tid;
fc04eb16 1304 ithread *thread;
8718f9a1 1305 int state;
9ca4d7fd 1306 int have_obj = 0;
5c6ff896 1307 dMY_POOL;
f4cc38af
JH
1308 CODE:
1309 /* Class method only */
fea7688c 1310 if (SvROK(ST(0))) {
f4cc38af 1311 Perl_croak(aTHX_ "Usage: threads->object($tid)");
fea7688c 1312 }
f4cc38af
JH
1313 classname = (char *)SvPV_nolen(ST(0));
1314
1315 if ((items < 2) || ! SvOK(ST(1))) {
1316 XSRETURN_UNDEF;
1317 }
1318
fc04eb16 1319 /* threads->object($tid) */
f4cc38af
JH
1320 tid = SvUV(ST(1));
1321
1322 /* Walk through threads list */
5c6ff896
JH
1323 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1324 for (thread = MY_POOL.main_thread.next;
1325 thread != &MY_POOL.main_thread;
fc04eb16 1326 thread = thread->next)
f4cc38af 1327 {
9ca4d7fd
JH
1328 /* Look for TID */
1329 if (thread->tid == tid) {
1330 /* Ignore if detached or joined */
8718f9a1
JH
1331 MUTEX_LOCK(&thread->mutex);
1332 state = thread->state;
1333 MUTEX_UNLOCK(&thread->mutex);
1334 if (! (state & PERL_ITHR_UNCALLABLE)) {
9ca4d7fd 1335 /* Put object on stack */
861d5cbe 1336 ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
9ca4d7fd
JH
1337 have_obj = 1;
1338 }
1339 break;
f4cc38af 1340 }
f4cc38af 1341 }
5c6ff896 1342 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
9ca4d7fd
JH
1343
1344 if (! have_obj) {
f4cc38af
JH
1345 XSRETURN_UNDEF;
1346 }
1347 /* XSRETURN(1); - implied */
1348
1349
1350void
1351ithread__handle(...);
1352 PREINIT:
1353 ithread *thread;
1354 CODE:
11db694d 1355 PERL_UNUSED_VAR(items);
861d5cbe 1356 thread = S_SV_to_ithread(aTHX_ ST(0));
f4cc38af 1357#ifdef WIN32
fcea4b7c 1358 XST_mUV(0, PTR2UV(&thread->handle));
f4cc38af 1359#else
75ba4ae2 1360 XST_mUV(0, PTR2UV(&thread->thr));
f4cc38af
JH
1361#endif
1362 /* XSRETURN(1); - implied */
68795e93 1363
514612b7
JH
1364
1365void
1366ithread_get_stack_size(...)
1367 PREINIT:
1368 IV stack_size;
5c6ff896 1369 dMY_POOL;
514612b7 1370 CODE:
11db694d 1371 PERL_UNUSED_VAR(items);
514612b7
JH
1372 if (sv_isobject(ST(0))) {
1373 /* $thr->get_stack_size() */
1374 ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1375 stack_size = thread->stack_size;
1376 } else {
1377 /* threads->get_stack_size() */
5c6ff896 1378 stack_size = MY_POOL.default_stack_size;
514612b7
JH
1379 }
1380 XST_mIV(0, stack_size);
1381 /* XSRETURN(1); - implied */
1382
1383
1384void
1385ithread_set_stack_size(...)
1386 PREINIT:
1387 IV old_size;
5c6ff896 1388 dMY_POOL;
514612b7 1389 CODE:
fea7688c 1390 if (items != 2) {
514612b7 1391 Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
fea7688c
JH
1392 }
1393 if (sv_isobject(ST(0))) {
514612b7 1394 Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
fea7688c 1395 }
6ebc233e
RGS
1396 if (! looks_like_number(ST(1))) {
1397 Perl_croak(aTHX_ "Stack size must be numeric");
1398 }
514612b7 1399
5c6ff896
JH
1400 old_size = MY_POOL.default_stack_size;
1401 MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1)));
514612b7
JH
1402 XST_mIV(0, old_size);
1403 /* XSRETURN(1); - implied */
1404
ead32952
JH
1405
1406void
1407ithread_is_running(...)
1408 PREINIT:
1409 ithread *thread;
1410 CODE:
1411 /* Object method only */
11db694d 1412 if ((items != 1) || ! sv_isobject(ST(0))) {
ead32952 1413 Perl_croak(aTHX_ "Usage: $thr->is_running()");
fea7688c 1414 }
ead32952
JH
1415
1416 thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
8718f9a1 1417 MUTEX_LOCK(&thread->mutex);
ead32952 1418 ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
8718f9a1 1419 MUTEX_UNLOCK(&thread->mutex);
ead32952
JH
1420 /* XSRETURN(1); - implied */
1421
1422
1423void
1424ithread_is_detached(...)
1425 PREINIT:
1426 ithread *thread;
1427 CODE:
11db694d 1428 PERL_UNUSED_VAR(items);
861d5cbe 1429 thread = S_SV_to_ithread(aTHX_ ST(0));
8718f9a1 1430 MUTEX_LOCK(&thread->mutex);
ead32952 1431 ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
8718f9a1 1432 MUTEX_UNLOCK(&thread->mutex);
ead32952
JH
1433 /* XSRETURN(1); - implied */
1434
1435
1436void
1437ithread_is_joinable(...)
1438 PREINIT:
1439 ithread *thread;
1440 CODE:
1441 /* Object method only */
11db694d 1442 if ((items != 1) || ! sv_isobject(ST(0))) {
ead32952 1443 Perl_croak(aTHX_ "Usage: $thr->is_joinable()");
fea7688c 1444 }
ead32952
JH
1445
1446 thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1447 MUTEX_LOCK(&thread->mutex);
1448 ST(0) = ((thread->state & PERL_ITHR_FINISHED) &&
8718f9a1 1449 ! (thread->state & PERL_ITHR_UNCALLABLE))
ead32952
JH
1450 ? &PL_sv_yes : &PL_sv_no;
1451 MUTEX_UNLOCK(&thread->mutex);
1452 /* XSRETURN(1); - implied */
1453
1454
1455void
1456ithread_wantarray(...)
1457 PREINIT:
1458 ithread *thread;
1459 CODE:
11db694d 1460 PERL_UNUSED_VAR(items);
861d5cbe 1461 thread = S_SV_to_ithread(aTHX_ ST(0));
7df0357e
NC
1462 ST(0) = ((thread->gimme & G_WANT) == G_ARRAY) ? &PL_sv_yes :
1463 ((thread->gimme & G_WANT) == G_VOID) ? &PL_sv_undef
7ef93cb2 1464 /* G_SCALAR */ : &PL_sv_no;
ead32952
JH
1465 /* XSRETURN(1); - implied */
1466
69a9b4b8
RGS
1467
1468void
1469ithread_set_thread_exit_only(...)
1470 PREINIT:
1471 ithread *thread;
1472 CODE:
fea7688c 1473 if (items != 2) {
69a9b4b8 1474 Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)");
fea7688c 1475 }
861d5cbe 1476 thread = S_SV_to_ithread(aTHX_ ST(0));
69a9b4b8
RGS
1477 MUTEX_LOCK(&thread->mutex);
1478 if (SvTRUE(ST(1))) {
1479 thread->state |= PERL_ITHR_THREAD_EXIT_ONLY;
1480 } else {
1481 thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY;
1482 }
1483 MUTEX_UNLOCK(&thread->mutex);
1484
955c272e
JH
1485
1486void
1487ithread_error(...)
1488 PREINIT:
1489 ithread *thread;
1490 SV *err = NULL;
1491 CODE:
1492 /* Object method only */
1493 if ((items != 1) || ! sv_isobject(ST(0))) {
1494 Perl_croak(aTHX_ "Usage: $thr->err()");
1495 }
1496
1497 thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1498 MUTEX_LOCK(&thread->mutex);
1499
1500 /* If thread died, then clone the error into the calling thread */
1501 if (thread->state & PERL_ITHR_DIED) {
1502 PerlInterpreter *other_perl;
1503 CLONE_PARAMS clone_params;
1504 ithread *current_thread;
1505
1506 other_perl = thread->interp;
1507 clone_params.stashes = newAV();
1508 clone_params.flags = CLONEf_JOIN_IN;
1509 PL_ptr_table = ptr_table_new();
1510 current_thread = S_ithread_get(aTHX);
1511 S_ithread_set(aTHX_ thread);
1512 /* Ensure 'meaningful' addresses retain their meaning */
1513 ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1514 ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1515 ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1516 err = sv_dup(thread->err, &clone_params);
1517 S_ithread_set(aTHX_ current_thread);
1518 SvREFCNT_dec(clone_params.stashes);
1519 SvREFCNT_inc_void(err);
1520 /* If error was an object, bless it into the correct class */
1521 if (thread->err_class) {
1522 sv_bless(err, gv_stashpv(thread->err_class, 1));
1523 }
1524 ptr_table_free(PL_ptr_table);
1525 PL_ptr_table = NULL;
1526 }
1527
1528 MUTEX_UNLOCK(&thread->mutex);
1529
1530 if (! err) {
1531 XSRETURN_UNDEF;
1532 }
1533
1534 ST(0) = sv_2mortal(err);
1535 /* XSRETURN(1); - implied */
1536
1537
73e09c8f
JH
1538#endif /* USE_ITHREADS */
1539
fc04eb16 1540
68795e93
NIS
1541BOOT:
1542{
73e09c8f 1543#ifdef USE_ITHREADS
5c6ff896
JH
1544 SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY,
1545 sizeof(MY_POOL_KEY)-1, TRUE);
1546 my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1));
1547
fc04eb16
JH
1548 MY_CXT_INIT;
1549
5c6ff896
JH
1550 Zero(my_poolp, 1, my_pool_t);
1551 sv_setuv(my_pool_sv, PTR2UV(my_poolp));
1552
fc04eb16 1553 PL_perl_destruct_level = 2;
5c6ff896
JH
1554 MUTEX_INIT(&MY_POOL.create_destruct_mutex);
1555 MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
fc04eb16
JH
1556
1557 PL_threadhook = &Perl_ithread_hook;
1558
5c6ff896
JH
1559 MY_POOL.tid_counter = 1;
1560# ifdef THREAD_CREATE_NEEDS_STACK
1561 MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK;
1562# endif
1563
c372d929
JH
1564 /* The 'main' thread is thread 0.
1565 * It is detached (unjoinable) and immortal.
1566 */
fc04eb16 1567
5c6ff896 1568 MUTEX_INIT(&MY_POOL.main_thread.mutex);
fc04eb16
JH
1569
1570 /* Head of the threads list */
5c6ff896
JH
1571 MY_POOL.main_thread.next = &MY_POOL.main_thread;
1572 MY_POOL.main_thread.prev = &MY_POOL.main_thread;
fc04eb16 1573
5c6ff896 1574 MY_POOL.main_thread.count = 1; /* Immortal */
fc04eb16 1575
5c6ff896
JH
1576 MY_POOL.main_thread.interp = aTHX;
1577 MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */
1578 MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size;
fc04eb16 1579# ifdef WIN32
5c6ff896 1580 MY_POOL.main_thread.thr = GetCurrentThreadId();
fc04eb16 1581# else
5c6ff896 1582 MY_POOL.main_thread.thr = pthread_self();
fc04eb16
JH
1583# endif
1584
5c6ff896
JH
1585 S_ithread_set(aTHX_ &MY_POOL.main_thread);
1586 MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
73e09c8f 1587#endif /* USE_ITHREADS */
68795e93 1588}