ext/threads/threads.xs

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