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 locked.  Also,
 137  * must be called with MY_POOL.create_destruct_mutex unlocked as destruction
 138  * of the interpreter can lead to recursive destruction calls that could
 139  * lead to a deadlock on that mutex.
 140  */
 141 STATIC void
 142 S_ithread_clear(pTHX_ ithread *thread)
 143 {
 144     PerlInterpreter *interp;
 145
 146     assert(((thread->state & PERL_ITHR_FINISHED) &&
 147             (thread->state & PERL_ITHR_UNCALLABLE))
 148                 ||
 149            (thread->state & PERL_ITHR_NONVIABLE));
 150
 151     interp = thread->interp;
 152     if (interp) {
 153         dTHXa(interp);
 154
 155         PERL_SET_CONTEXT(interp);
 156         S_ithread_set(aTHX_ thread);
 157
 158         SvREFCNT_dec(thread->params);
 159         thread->params = Nullsv;
 160
 161         if (thread->err) {
 162             SvREFCNT_dec(thread->err);
 163             thread->err = Nullsv;
 164         }
 165
 166         perl_destruct(interp);
 167         perl_free(interp);
 168         thread->interp = NULL;
 169     }
 170
 171     PERL_SET_CONTEXT(aTHX);
 172 }
 173
 174
 175 /* Decrement the refcount of an ithread, and if it reaches zero, free it.
 176  * Must be called with the mutex held.
 177  * On return, mutex is released (or destroyed).
 178  */
 179 STATIC void
 180 S_ithread_free(pTHX_ ithread *thread)
 181 {
 182 #ifdef WIN32
 183     HANDLE handle;
 184 #endif
 185     dMY_POOL;
 186
 187     if (! (thread->state & PERL_ITHR_NONVIABLE)) {
 188         assert(thread->count > 0);
 189         if (--thread->count > 0) {
 190             MUTEX_UNLOCK(&thread->mutex);
 191             return;
 192         }
 193         assert((thread->state & PERL_ITHR_FINISHED) &&
 194                (thread->state & PERL_ITHR_UNCALLABLE));
 195     }
 196     MUTEX_UNLOCK(&thread->mutex);
 197
 198     /* Main thread (0) is immortal and should never get here */
 199     assert(thread->tid != 0);
 200
 201     /* Remove from circular list of threads */
 202     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 203     assert(thread->prev && thread->next);
 204     thread->next->prev = thread->prev;
 205     thread->prev->next = thread->next;
 206     thread->next = NULL;
 207     thread->prev = NULL;
 208     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 209
 210     /* Thread is now disowned */
 211     MUTEX_LOCK(&thread->mutex);
 212     S_ithread_clear(aTHX_ thread);
 213
 214 #ifdef WIN32
 215     handle = thread->handle;
 216     thread->handle = NULL;
 217 #endif
 218     MUTEX_UNLOCK(&thread->mutex);
 219     MUTEX_DESTROY(&thread->mutex);
 220
 221 #ifdef WIN32
 222     if (handle) {
 223         CloseHandle(handle);
 224     }
 225 #endif
 226
 227     PerlMemShared_free(thread);
 228
 229     /* total_threads >= 1 is used to veto cleanup by the main thread,
 230      * should it happen to exit while other threads still exist.
 231      * Decrement this as the very last thing in the thread's existence.
 232      * Otherwise, MY_POOL and global state such as PL_op_mutex may get
 233      * freed while we're still using it.
 234      */
 235     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 236     MY_POOL.total_threads--;
 237     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 238 }
 239
 240
 241 static void
 242 S_ithread_count_inc(pTHX_ ithread *thread)
 243 {
 244     MUTEX_LOCK(&thread->mutex);
 245     thread->count++;
 246     MUTEX_UNLOCK(&thread->mutex);
 247 }
 248
 249
 250 /* Warn if exiting with any unjoined threads */
 251 STATIC int
 252 S_exit_warning(pTHX)
 253 {
 254     int veto_cleanup, warn;
 255     dMY_POOL;
 256
 257     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 258     veto_cleanup = (MY_POOL.total_threads > 0);
 259     warn         = (MY_POOL.running_threads || MY_POOL.joinable_threads);
 260     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 261
 262     if (warn) {
 263         if (ckWARN_d(WARN_THREADS)) {
 264             Perl_warn(aTHX_ "Perl exited with active threads:\n\t%"
 265                             IVdf " running and unjoined\n\t%"
 266                             IVdf " finished and unjoined\n\t%"
 267                             IVdf " running and detached\n",
 268                             MY_POOL.running_threads,
 269                             MY_POOL.joinable_threads,
 270                             MY_POOL.detached_threads);
 271         }
 272     }
 273
 274     return (veto_cleanup);
 275 }
 276
 277
 278 /* Called from perl_destruct() in each thread.  If it's the main thread,
 279  * stop it from freeing everything if there are other threads still running.
 280  */
 281 int
 282 Perl_ithread_hook(pTHX)
 283 {
 284     dMY_POOL;
 285     return ((aTHX == MY_POOL.main_thread.interp) ? S_exit_warning(aTHX) : 0);
 286 }
 287
 288
 289 /* MAGIC (in mg.h sense) hooks */
 290
 291 int
 292 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
 293 {
 294     ithread *thread = (ithread *)mg->mg_ptr;
 295     SvIV_set(sv, PTR2IV(thread));
 296     SvIOK_on(sv);
 297     return (0);
 298 }
 299
 300 int
 301 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
 302 {
 303     ithread *thread = (ithread *)mg->mg_ptr;
 304     MUTEX_LOCK(&thread->mutex);
 305     S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
 306     return (0);
 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 the context of of the 'main' interpreter which
 540      * can't have 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
 638      *      freed until join/detach, even if no thread objects remain.
 639      *      This allows the following to work:
 640      *          { threads->create(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                     case 'l':
 900                     case 'L':
 901                         context = G_ARRAY;
 902                         break;
 903                     case 's':
 904                     case 'S':
 905                         context = G_SCALAR;
 906                         break;
 907                     case 'v':
 908                     case 'V':
 909                         context = G_VOID;
 910                         break;
 911                     default:
 912                         Perl_croak(aTHX_ "Invalid context: %s", str);
 913                 }
 914             } else if (hv_exists(specs, "array", 5)) {
 915                 if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
 916                     context = G_ARRAY;
 917                 }
 918             } else if (hv_exists(specs, "list", 4)) {
 919                 if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
 920                     context = G_ARRAY;
 921                 }
 922             } else if (hv_exists(specs, "scalar", 6)) {
 923                 if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
 924                     context = G_SCALAR;
 925                 }
 926             } else if (hv_exists(specs, "void", 4)) {
 927                 if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
 928                     context = G_VOID;
 929                 }
 930             }
 931
 932             /* exit => thread_only */
 933             if (hv_exists(specs, "exit", 4)) {
 934                 str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
 935                 exit_opt = (*str == 't' || *str == 'T')
 936                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
 937             }
 938         }
 939         if (context == -1) {
 940             context = GIMME_V;  /* Implicit context */
 941         } else {
 942             context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
 943         }
 944
 945         /* Function args */
 946         params = newAV();
 947         if (items > 2) {
 948             for (ii=2; ii < items ; ii++) {
 949                 av_push(params, SvREFCNT_inc(ST(idx+ii)));
 950             }
 951         }
 952
 953         /* Create thread */
 954         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 955         thread = S_ithread_create(aTHX_ function_to_call,
 956                                         stack_size,
 957                                         context,
 958                                         exit_opt,
 959                                         newRV_noinc((SV*)params));
 960         if (! thread) {
 961             XSRETURN_UNDEF;     /* Mutex already unlocked */
 962         }
 963         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE));
 964         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 965
 966         /* Let thread run */
 967         MUTEX_UNLOCK(&thread->mutex);
 968
 969         /* XSRETURN(1); - implied */
 970
 971
 972 void
 973 ithread_list(...)
 974     PREINIT:
 975         char *classname;
 976         ithread *thread;
 977         int list_context;
 978         IV count = 0;
 979         int want_running = 0;
 980         int state;
 981         dMY_POOL;
 982     PPCODE:
 983         /* Class method only */
 984         if (SvROK(ST(0))) {
 985             Perl_croak(aTHX_ "Usage: threads->list(...)");
 986         }
 987         classname = (char *)SvPV_nolen(ST(0));
 988
 989         /* Calling context */
 990         list_context = (GIMME_V == G_ARRAY);
 991
 992         /* Running or joinable parameter */
 993         if (items > 1) {
 994             want_running = SvTRUE(ST(1));
 995         }
 996
 997         /* Walk through threads list */
 998         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 999         for (thread = MY_POOL.main_thread.next;
1000              thread != &MY_POOL.main_thread;
1001              thread = thread->next)
1002         {
1003             MUTEX_LOCK(&thread->mutex);
1004             state = thread->state;
1005             MUTEX_UNLOCK(&thread->mutex);
1006
1007             /* Ignore detached or joined threads */
1008             if (state & PERL_ITHR_UNCALLABLE) {
1009                 continue;
1010             }
1011
1012             /* Filter per parameter */
1013             if (items > 1) {
1014                 if (want_running) {
1015                     if (state & PERL_ITHR_FINISHED) {
1016                         continue;   /* Not running */
1017                     }
1018                 } else {
1019                     if (! (state & PERL_ITHR_FINISHED)) {
1020                         continue;   /* Still running - not joinable yet */
1021                     }
1022                 }
1023             }
1024
1025             /* Push object on stack if list context */
1026             if (list_context) {
1027                 XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
1028             }
1029             count++;
1030         }
1031         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1032         /* If scalar context, send back count */
1033         if (! list_context) {
1034             XSRETURN_IV(count);
1035         }
1036
1037
1038 void
1039 ithread_self(...)
1040     PREINIT:
1041         char *classname;
1042         ithread *thread;
1043     CODE:
1044         /* Class method only */
1045         if ((items != 1) || SvROK(ST(0))) {
1046             Perl_croak(aTHX_ "Usage: threads->self()");
1047         }
1048         classname = (char *)SvPV_nolen(ST(0));
1049
1050         thread = S_ithread_get(aTHX);
1051
1052         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1053         /* XSRETURN(1); - implied */
1054
1055
1056 void
1057 ithread_tid(...)
1058     PREINIT:
1059         ithread *thread;
1060     CODE:
1061         PERL_UNUSED_VAR(items);
1062         thread = S_SV_to_ithread(aTHX_ ST(0));
1063         XST_mUV(0, thread->tid);
1064         /* XSRETURN(1); - implied */
1065
1066
1067 void
1068 ithread_join(...)
1069     PREINIT:
1070         ithread *thread;
1071         ithread *current_thread;
1072         int join_err;
1073         AV *params = NULL;
1074         int len;
1075         int ii;
1076 #ifndef WIN32
1077         int rc_join;
1078         void *retval;
1079 #endif
1080         dMY_POOL;
1081     PPCODE:
1082         /* Object method only */
1083         if ((items != 1) || ! sv_isobject(ST(0))) {
1084             Perl_croak(aTHX_ "Usage: $thr->join()");
1085         }
1086
1087         /* Check if the thread is joinable and not ourselves */
1088         thread = S_SV_to_ithread(aTHX_ ST(0));
1089         current_thread = S_ithread_get(aTHX);
1090
1091         MUTEX_LOCK(&thread->mutex);
1092         if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1093             MUTEX_UNLOCK(&thread->mutex);
1094             Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED)
1095                                 ? "Cannot join a detached thread"
1096                                 : "Thread already joined");
1097         } else if (thread->tid == current_thread->tid) {
1098             MUTEX_UNLOCK(&thread->mutex);
1099             Perl_croak(aTHX_ "Cannot join self");
1100         }
1101
1102         /* Mark as joined */
1103         thread->state |= PERL_ITHR_JOINED;
1104         MUTEX_UNLOCK(&thread->mutex);
1105
1106         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1107         MY_POOL.joinable_threads--;
1108         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1109
1110         /* Join the thread */
1111 #ifdef WIN32
1112         if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) {
1113             /* Timeout/abandonment unexpected here; check $^E */
1114             Perl_croak(aTHX_ "PANIC: underlying join failed");
1115         };
1116 #else
1117         if ((rc_join = pthread_join(thread->thr, &retval)) != 0) {
1118             /* In progress/deadlock/unknown unexpected here; check $! */
1119             errno = rc_join;
1120             Perl_croak(aTHX_ "PANIC: underlying join failed");
1121         };
1122 #endif
1123
1124         MUTEX_LOCK(&thread->mutex);
1125         /* Get the return value from the call_sv */
1126         /* Objects do not survive this process - FIXME */
1127         if (! (thread->gimme & G_VOID)) {
1128             AV *params_copy;
1129             PerlInterpreter *other_perl;
1130             CLONE_PARAMS clone_params;
1131
1132             params_copy = (AV *)SvRV(thread->params);
1133             other_perl = thread->interp;
1134             clone_params.stashes = newAV();
1135             clone_params.flags = CLONEf_JOIN_IN;
1136             PL_ptr_table = ptr_table_new();
1137             S_ithread_set(aTHX_ thread);
1138             /* Ensure 'meaningful' addresses retain their meaning */
1139             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1140             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1141             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1142             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
1143             S_ithread_set(aTHX_ current_thread);
1144             SvREFCNT_dec(clone_params.stashes);
1145             SvREFCNT_inc_void(params);
1146             ptr_table_free(PL_ptr_table);
1147             PL_ptr_table = NULL;
1148         }
1149
1150         /* If thread didn't die, then we can free its interpreter */
1151         if (! (thread->state & PERL_ITHR_DIED)) {
1152             S_ithread_clear(aTHX_ thread);
1153         }
1154         S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
1155
1156         /* If no return values, then just return */
1157         if (! params) {
1158             XSRETURN_UNDEF;
1159         }
1160
1161         /* Put return values on stack */
1162         len = (int)AvFILL(params);
1163         for (ii=0; ii <= len; ii++) {
1164             SV* param = av_shift(params);
1165             XPUSHs(sv_2mortal(param));
1166         }
1167
1168         /* Free return value array */
1169         SvREFCNT_dec(params);
1170
1171
1172 void
1173 ithread_yield(...)
1174     CODE:
1175         PERL_UNUSED_VAR(items);
1176         YIELD;
1177
1178
1179 void
1180 ithread_detach(...)
1181     PREINIT:
1182         ithread *thread;
1183         int detach_err;
1184         dMY_POOL;
1185     CODE:
1186         PERL_UNUSED_VAR(items);
1187
1188         /* Detach the thread */
1189         thread = S_SV_to_ithread(aTHX_ ST(0));
1190         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1191         MUTEX_LOCK(&thread->mutex);
1192         if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1193             /* Thread is detachable */
1194             thread->state |= PERL_ITHR_DETACHED;
1195 #ifdef WIN32
1196             /* Windows has no 'detach thread' function */
1197 #else
1198             PERL_THREAD_DETACH(thread->thr);
1199 #endif
1200             if (thread->state & PERL_ITHR_FINISHED) {
1201                 MY_POOL.joinable_threads--;
1202             } else {
1203                 MY_POOL.running_threads--;
1204                 MY_POOL.detached_threads++;
1205             }
1206         }
1207         MUTEX_UNLOCK(&thread->mutex);
1208         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1209
1210         if (detach_err) {
1211             Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED)
1212                                 ? "Thread already detached"
1213                                 : "Cannot detach a joined thread");
1214         }
1215
1216         /* If thread is finished and didn't die,
1217          * then we can free its interpreter */
1218         MUTEX_LOCK(&thread->mutex);
1219         if ((thread->state & PERL_ITHR_FINISHED) &&
1220             ! (thread->state & PERL_ITHR_DIED))
1221         {
1222             S_ithread_clear(aTHX_ thread);
1223         }
1224         S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
1225
1226
1227 void
1228 ithread_kill(...)
1229     PREINIT:
1230         ithread *thread;
1231         char *sig_name;
1232         IV signal;
1233     CODE:
1234         /* Must have safe signals */
1235         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
1236             Perl_croak(aTHX_ "Cannot signal threads without safe signals");
1237         }
1238
1239         /* Object method only */
1240         if ((items != 2) || ! sv_isobject(ST(0))) {
1241             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
1242         }
1243
1244         /* Get signal */
1245         sig_name = SvPV_nolen(ST(1));
1246         if (isALPHA(*sig_name)) {
1247             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') {
1248                 sig_name += 3;
1249             }
1250             if ((signal = whichsig(sig_name)) < 0) {
1251                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
1252             }
1253         } else {
1254             signal = SvIV(ST(1));
1255         }
1256
1257         /* Set the signal for the thread */
1258         thread = S_SV_to_ithread(aTHX_ ST(0));
1259         MUTEX_LOCK(&thread->mutex);
1260         if (thread->interp) {
1261             dTHXa(thread->interp);
1262             PL_psig_pend[signal]++;
1263             PL_sig_pending = 1;
1264         }
1265         MUTEX_UNLOCK(&thread->mutex);
1266
1267         /* Return the thread to allow for method chaining */
1268         ST(0) = ST(0);
1269         /* XSRETURN(1); - implied */
1270
1271
1272 void
1273 ithread_DESTROY(...)
1274     CODE:
1275         PERL_UNUSED_VAR(items);
1276         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
1277
1278
1279 void
1280 ithread_equal(...)
1281     PREINIT:
1282         int are_equal = 0;
1283     CODE:
1284         PERL_UNUSED_VAR(items);
1285
1286         /* Compares TIDs to determine thread equality */
1287         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1288             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1289             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
1290             are_equal = (thr1->tid == thr2->tid);
1291         }
1292         if (are_equal) {
1293             XST_mYES(0);
1294         } else {
1295             /* Return 0 on false for backward compatibility */
1296             XST_mIV(0, 0);
1297         }
1298         /* XSRETURN(1); - implied */
1299
1300
1301 void
1302 ithread_object(...)
1303     PREINIT:
1304         char *classname;
1305         UV tid;
1306         ithread *thread;
1307         int state;
1308         int have_obj = 0;
1309         dMY_POOL;
1310     CODE:
1311         /* Class method only */
1312         if (SvROK(ST(0))) {
1313             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1314         }
1315         classname = (char *)SvPV_nolen(ST(0));
1316
1317         if ((items < 2) || ! SvOK(ST(1))) {
1318             XSRETURN_UNDEF;
1319         }
1320
1321         /* threads->object($tid) */
1322         tid = SvUV(ST(1));
1323
1324         /* Walk through threads list */
1325         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1326         for (thread = MY_POOL.main_thread.next;
1327              thread != &MY_POOL.main_thread;
1328              thread = thread->next)
1329         {
1330             /* Look for TID */
1331             if (thread->tid == tid) {
1332                 /* Ignore if detached or joined */
1333                 MUTEX_LOCK(&thread->mutex);
1334                 state = thread->state;
1335                 MUTEX_UNLOCK(&thread->mutex);
1336                 if (! (state & PERL_ITHR_UNCALLABLE)) {
1337                     /* Put object on stack */
1338                     ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1339                     have_obj = 1;
1340                 }
1341                 break;
1342             }
1343         }
1344         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1345
1346         if (! have_obj) {
1347             XSRETURN_UNDEF;
1348         }
1349         /* XSRETURN(1); - implied */
1350
1351
1352 void
1353 ithread__handle(...);
1354     PREINIT:
1355         ithread *thread;
1356     CODE:
1357         PERL_UNUSED_VAR(items);
1358         thread = S_SV_to_ithread(aTHX_ ST(0));
1359 #ifdef WIN32
1360         XST_mUV(0, PTR2UV(&thread->handle));
1361 #else
1362         XST_mUV(0, PTR2UV(&thread->thr));
1363 #endif
1364         /* XSRETURN(1); - implied */
1365
1366
1367 void
1368 ithread_get_stack_size(...)
1369     PREINIT:
1370         IV stack_size;
1371         dMY_POOL;
1372     CODE:
1373         PERL_UNUSED_VAR(items);
1374         if (sv_isobject(ST(0))) {
1375             /* $thr->get_stack_size() */
1376             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1377             stack_size = thread->stack_size;
1378         } else {
1379             /* threads->get_stack_size() */
1380             stack_size = MY_POOL.default_stack_size;
1381         }
1382         XST_mIV(0, stack_size);
1383         /* XSRETURN(1); - implied */
1384
1385
1386 void
1387 ithread_set_stack_size(...)
1388     PREINIT:
1389         IV old_size;
1390         dMY_POOL;
1391     CODE:
1392         if (items != 2) {
1393             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1394         }
1395         if (sv_isobject(ST(0))) {
1396             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1397         }
1398         if (! looks_like_number(ST(1))) {
1399             Perl_croak(aTHX_ "Stack size must be numeric");
1400         }
1401
1402         old_size = MY_POOL.default_stack_size;
1403         MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1)));
1404         XST_mIV(0, old_size);
1405         /* XSRETURN(1); - implied */
1406
1407
1408 void
1409 ithread_is_running(...)
1410     PREINIT:
1411         ithread *thread;
1412     CODE:
1413         /* Object method only */
1414         if ((items != 1) || ! sv_isobject(ST(0))) {
1415             Perl_croak(aTHX_ "Usage: $thr->is_running()");
1416         }
1417
1418         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1419         MUTEX_LOCK(&thread->mutex);
1420         ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
1421         MUTEX_UNLOCK(&thread->mutex);
1422         /* XSRETURN(1); - implied */
1423
1424
1425 void
1426 ithread_is_detached(...)
1427     PREINIT:
1428         ithread *thread;
1429     CODE:
1430         PERL_UNUSED_VAR(items);
1431         thread = S_SV_to_ithread(aTHX_ ST(0));
1432         MUTEX_LOCK(&thread->mutex);
1433         ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
1434         MUTEX_UNLOCK(&thread->mutex);
1435         /* XSRETURN(1); - implied */
1436
1437
1438 void
1439 ithread_is_joinable(...)
1440     PREINIT:
1441         ithread *thread;
1442     CODE:
1443         /* Object method only */
1444         if ((items != 1) || ! sv_isobject(ST(0))) {
1445             Perl_croak(aTHX_ "Usage: $thr->is_joinable()");
1446         }
1447
1448         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1449         MUTEX_LOCK(&thread->mutex);
1450         ST(0) = ((thread->state & PERL_ITHR_FINISHED) &&
1451                  ! (thread->state & PERL_ITHR_UNCALLABLE))
1452             ? &PL_sv_yes : &PL_sv_no;
1453         MUTEX_UNLOCK(&thread->mutex);
1454         /* XSRETURN(1); - implied */
1455
1456
1457 void
1458 ithread_wantarray(...)
1459     PREINIT:
1460         ithread *thread;
1461     CODE:
1462         PERL_UNUSED_VAR(items);
1463         thread = S_SV_to_ithread(aTHX_ ST(0));
1464         ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
1465                 (thread->gimme & G_VOID)  ? &PL_sv_undef
1466                            /* G_SCALAR */ : &PL_sv_no;
1467         /* XSRETURN(1); - implied */
1468
1469
1470 void
1471 ithread_set_thread_exit_only(...)
1472     PREINIT:
1473         ithread *thread;
1474     CODE:
1475         if (items != 2) {
1476             Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)");
1477         }
1478         thread = S_SV_to_ithread(aTHX_ ST(0));
1479         MUTEX_LOCK(&thread->mutex);
1480         if (SvTRUE(ST(1))) {
1481             thread->state |= PERL_ITHR_THREAD_EXIT_ONLY;
1482         } else {
1483             thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY;
1484         }
1485         MUTEX_UNLOCK(&thread->mutex);
1486
1487
1488 void
1489 ithread_error(...)
1490     PREINIT:
1491         ithread *thread;
1492         SV *err = NULL;
1493     CODE:
1494         /* Object method only */
1495         if ((items != 1) || ! sv_isobject(ST(0))) {
1496             Perl_croak(aTHX_ "Usage: $thr->err()");
1497         }
1498
1499         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1500         MUTEX_LOCK(&thread->mutex);
1501
1502         /* If thread died, then clone the error into the calling thread */
1503         if (thread->state & PERL_ITHR_DIED) {
1504             PerlInterpreter *other_perl;
1505             CLONE_PARAMS clone_params;
1506             ithread *current_thread;
1507
1508             other_perl = thread->interp;
1509             clone_params.stashes = newAV();
1510             clone_params.flags = CLONEf_JOIN_IN;
1511             PL_ptr_table = ptr_table_new();
1512             current_thread = S_ithread_get(aTHX);
1513             S_ithread_set(aTHX_ thread);
1514             /* Ensure 'meaningful' addresses retain their meaning */
1515             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1516             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1517             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1518             err = sv_dup(thread->err, &clone_params);
1519             S_ithread_set(aTHX_ current_thread);
1520             SvREFCNT_dec(clone_params.stashes);
1521             SvREFCNT_inc_void(err);
1522             /* If error was an object, bless it into the correct class */
1523             if (thread->err_class) {
1524                 sv_bless(err, gv_stashpv(thread->err_class, 1));
1525             }
1526             ptr_table_free(PL_ptr_table);
1527             PL_ptr_table = NULL;
1528         }
1529
1530         MUTEX_UNLOCK(&thread->mutex);
1531
1532         if (! err) {
1533             XSRETURN_UNDEF;
1534         }
1535
1536         ST(0) = sv_2mortal(err);
1537         /* XSRETURN(1); - implied */
1538
1539
1540 #endif /* USE_ITHREADS */
1541
1542
1543 BOOT:
1544 {
1545 #ifdef USE_ITHREADS
1546     SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY,
1547                                sizeof(MY_POOL_KEY)-1, TRUE);
1548     my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1));
1549
1550     MY_CXT_INIT;
1551
1552     Zero(my_poolp, 1, my_pool_t);
1553     sv_setuv(my_pool_sv, PTR2UV(my_poolp));
1554
1555     PL_perl_destruct_level = 2;
1556     MUTEX_INIT(&MY_POOL.create_destruct_mutex);
1557     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1558
1559     PL_threadhook = &Perl_ithread_hook;
1560
1561     MY_POOL.tid_counter = 1;
1562 #  ifdef THREAD_CREATE_NEEDS_STACK
1563     MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK;
1564 #  endif
1565
1566     /* The 'main' thread is thread 0.
1567      * It is detached (unjoinable) and immortal.
1568      */
1569
1570     MUTEX_INIT(&MY_POOL.main_thread.mutex);
1571
1572     /* Head of the threads list */
1573     MY_POOL.main_thread.next = &MY_POOL.main_thread;
1574     MY_POOL.main_thread.prev = &MY_POOL.main_thread;
1575
1576     MY_POOL.main_thread.count = 1;                  /* Immortal */
1577
1578     MY_POOL.main_thread.interp = aTHX;
1579     MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */
1580     MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size;
1581 #  ifdef WIN32
1582     MY_POOL.main_thread.thr = GetCurrentThreadId();
1583 #  else
1584     MY_POOL.main_thread.thr = pthread_self();
1585 #  endif
1586
1587     S_ithread_set(aTHX_ &MY_POOL.main_thread);
1588     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1589 #endif /* USE_ITHREADS */
1590 }