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