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