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_flags
  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 && (! (thread->gimme & G_VOID))) {
 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 =
 692                 SvREFCNT_inc(sv_dup(init_function, &clone_param));
 693         }
 694
 695         thread->params = sv_dup(params, &clone_param);
 696         SvREFCNT_inc_void(thread->params);
 697
 698         /* The code below checks that anything living on the tmps stack and
 699          * has been cloned (so it lives in the ptr_table) has a refcount
 700          * higher than 0.
 701          *
 702          * If the refcount is 0 it means that a something on the stack/context
 703          * was holding a reference to it and since we init_stacks() in
 704          * perl_clone that won't get cleaned and we will get a leaked scalar.
 705          * The reason it was cloned was that it lived on the @_ stack.
 706          *
 707          * Example of this can be found in bugreport 15837 where calls in the
 708          * parameter list end up as a temp.
 709          *
 710          * One could argue that this fix should be in perl_clone.
 711          */
 712         while (tmps_ix > 0) {
 713             SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
 714             tmps_ix--;
 715             if (sv && SvREFCNT(sv) == 0) {
 716                 SvREFCNT_inc_void(sv);
 717                 SvREFCNT_dec(sv);
 718             }
 719         }
 720
 721         SvTEMP_off(thread->init_function);
 722         ptr_table_free(PL_ptr_table);
 723         PL_ptr_table = NULL;
 724         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 725     }
 726     S_ithread_set(aTHX_ current_thread);
 727     PERL_SET_CONTEXT(aTHX);
 728
 729     /* Create/start the thread */
 730 #ifdef WIN32
 731     thread->handle = CreateThread(NULL,
 732                                   (DWORD)thread->stack_size,
 733                                   S_ithread_run,
 734                                   (LPVOID)thread,
 735                                   STACK_SIZE_PARAM_IS_A_RESERVATION,
 736                                   &thread->thr);
 737 #else
 738     {
 739         STATIC pthread_attr_t attr;
 740         STATIC int attr_inited = 0;
 741         STATIC int attr_joinable = PTHREAD_CREATE_JOINABLE;
 742         if (! attr_inited) {
 743             pthread_attr_init(&attr);
 744             attr_inited = 1;
 745         }
 746
 747 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
 748         /* Threads start out joinable */
 749         PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 750 #  endif
 751
 752 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
 753         /* Set thread's stack size */
 754         if (thread->stack_size > 0) {
 755             rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size);
 756         }
 757 #  endif
 758
 759         /* Create the thread */
 760         if (! rc_stack_size) {
 761 #  ifdef OLD_PTHREADS_API
 762             rc_thread_create = pthread_create(&thread->thr,
 763                                               attr,
 764                                               S_ithread_run,
 765                                               (void *)thread);
 766 #  else
 767 #    if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
 768             pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
 769 #    endif
 770             rc_thread_create = pthread_create(&thread->thr,
 771                                               &attr,
 772                                               S_ithread_run,
 773                                               (void *)thread);
 774 #  endif
 775         }
 776
 777 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
 778         /* Try to get thread's actual stack size */
 779         {
 780             size_t stacksize;
 781 #ifdef HPUX1020
 782             stacksize = pthread_attr_getstacksize(attr);
 783 #else
 784             if (! pthread_attr_getstacksize(&attr, &stacksize))
 785 #endif
 786                 if (stacksize > 0) {
 787                     thread->stack_size = (IV)stacksize;
 788                 }
 789         }
 790 #  endif
 791     }
 792 #endif
 793
 794     /* Check for errors */
 795 #ifdef WIN32
 796     if (thread->handle == NULL) {
 797 #else
 798     if (rc_stack_size || rc_thread_create) {
 799 #endif
 800         /* Must unlock mutex for destruct call */
 801         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 802         sv_2mortal(params);
 803         thread->state |= PERL_ITHR_NONVIABLE;
 804         S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
 805 #ifndef WIN32
 806         if (ckWARN_d(WARN_THREADS)) {
 807             if (rc_stack_size) {
 808                 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
 809             } else {
 810                 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
 811             }
 812         }
 813 #endif
 814         return (NULL);
 815     }
 816
 817     MY_POOL.running_threads++;
 818     sv_2mortal(params);
 819     return (thread);
 820 }
 821
 822 #endif /* USE_ITHREADS */
 823
 824
 825 MODULE = threads    PACKAGE = threads    PREFIX = ithread_
 826 PROTOTYPES: DISABLE
 827
 828 #ifdef USE_ITHREADS
 829
 830 void
 831 ithread_create(...)
 832     PREINIT:
 833         char *classname;
 834         ithread *thread;
 835         SV *function_to_call;
 836         AV *params;
 837         HV *specs;
 838         IV stack_size;
 839         int context;
 840         int exit_opt;
 841         SV *thread_exit_only;
 842         char *str;
 843         int idx;
 844         int ii;
 845         dMY_POOL;
 846     CODE:
 847         if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
 848             if (--items < 2) {
 849                 Perl_croak(aTHX_ "Usage: threads->create(\\%%specs, function, ...)");
 850             }
 851             specs = (HV*)SvRV(ST(1));
 852             idx = 1;
 853         } else {
 854             if (items < 2) {
 855                 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
 856             }
 857             specs = NULL;
 858             idx = 0;
 859         }
 860
 861         if (sv_isobject(ST(0))) {
 862             /* $thr->create() */
 863             classname = HvNAME(SvSTASH(SvRV(ST(0))));
 864             thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
 865             MUTEX_LOCK(&thread->mutex);
 866             stack_size = thread->stack_size;
 867             exit_opt = thread->state & PERL_ITHR_THREAD_EXIT_ONLY;
 868             MUTEX_UNLOCK(&thread->mutex);
 869         } else {
 870             /* threads->create() */
 871             classname = (char *)SvPV_nolen(ST(0));
 872             stack_size = MY_POOL.default_stack_size;
 873             thread_exit_only = get_sv("threads::thread_exit_only", TRUE);
 874             exit_opt = (SvTRUE(thread_exit_only))
 875                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
 876         }
 877
 878         function_to_call = ST(idx+1);
 879
 880         context = -1;
 881         if (specs) {
 882             /* stack_size */
 883             if (hv_exists(specs, "stack", 5)) {
 884                 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
 885             } else if (hv_exists(specs, "stacksize", 9)) {
 886                 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
 887             } else if (hv_exists(specs, "stack_size", 10)) {
 888                 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
 889             }
 890
 891             /* context */
 892             if (hv_exists(specs, "context", 7)) {
 893                 str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
 894                 switch (*str) {
 895                     case 'a':
 896                     case 'A':
 897                     case 'l':
 898                     case 'L':
 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, "list", 4)) {
 917                 if (SvTRUE(*hv_fetch(specs, "list", 4, 0))) {
 918                     context = G_ARRAY;
 919                 }
 920             } else if (hv_exists(specs, "scalar", 6)) {
 921                 if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
 922                     context = G_SCALAR;
 923                 }
 924             } else if (hv_exists(specs, "void", 4)) {
 925                 if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
 926                     context = G_VOID;
 927                 }
 928             }
 929
 930             /* exit => thread_only */
 931             if (hv_exists(specs, "exit", 4)) {
 932                 str = (char *)SvPV_nolen(*hv_fetch(specs, "exit", 4, 0));
 933                 exit_opt = (*str == 't' || *str == 'T')
 934                                     ? PERL_ITHR_THREAD_EXIT_ONLY : 0;
 935             }
 936         }
 937         if (context == -1) {
 938             context = GIMME_V;  /* Implicit context */
 939         } else {
 940             context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
 941         }
 942
 943         /* Function args */
 944         params = newAV();
 945         if (items > 2) {
 946             for (ii=2; ii < items ; ii++) {
 947                 av_push(params, SvREFCNT_inc(ST(idx+ii)));
 948             }
 949         }
 950
 951         /* Create thread */
 952         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 953         thread = S_ithread_create(aTHX_ function_to_call,
 954                                         stack_size,
 955                                         context,
 956                                         exit_opt,
 957                                         newRV_noinc((SV*)params));
 958         if (! thread) {
 959             XSRETURN_UNDEF;     /* Mutex already unlocked */
 960         }
 961         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, FALSE));
 962         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 963
 964         /* Let thread run */
 965         MUTEX_UNLOCK(&thread->mutex);
 966
 967         /* XSRETURN(1); - implied */
 968
 969
 970 void
 971 ithread_list(...)
 972     PREINIT:
 973         char *classname;
 974         ithread *thread;
 975         int list_context;
 976         IV count = 0;
 977         int want_running = 0;
 978         int state;
 979         dMY_POOL;
 980     PPCODE:
 981         /* Class method only */
 982         if (SvROK(ST(0))) {
 983             Perl_croak(aTHX_ "Usage: threads->list(...)");
 984         }
 985         classname = (char *)SvPV_nolen(ST(0));
 986
 987         /* Calling context */
 988         list_context = (GIMME_V == G_ARRAY);
 989
 990         /* Running or joinable parameter */
 991         if (items > 1) {
 992             want_running = SvTRUE(ST(1));
 993         }
 994
 995         /* Walk through threads list */
 996         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
 997         for (thread = MY_POOL.main_thread.next;
 998              thread != &MY_POOL.main_thread;
 999              thread = thread->next)
1000         {
1001             MUTEX_LOCK(&thread->mutex);
1002             state = thread->state;
1003             MUTEX_UNLOCK(&thread->mutex);
1004
1005             /* Ignore detached or joined threads */
1006             if (state & PERL_ITHR_UNCALLABLE) {
1007                 continue;
1008             }
1009
1010             /* Filter per parameter */
1011             if (items > 1) {
1012                 if (want_running) {
1013                     if (state & PERL_ITHR_FINISHED) {
1014                         continue;   /* Not running */
1015                     }
1016                 } else {
1017                     if (! (state & PERL_ITHR_FINISHED)) {
1018                         continue;   /* Still running - not joinable yet */
1019                     }
1020                 }
1021             }
1022
1023             /* Push object on stack if list context */
1024             if (list_context) {
1025                 XPUSHs(sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
1026             }
1027             count++;
1028         }
1029         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1030         /* If scalar context, send back count */
1031         if (! list_context) {
1032             XSRETURN_IV(count);
1033         }
1034
1035
1036 void
1037 ithread_self(...)
1038     PREINIT:
1039         char *classname;
1040         ithread *thread;
1041     CODE:
1042         /* Class method only */
1043         if ((items != 1) || SvROK(ST(0))) {
1044             Perl_croak(aTHX_ "Usage: threads->self()");
1045         }
1046         classname = (char *)SvPV_nolen(ST(0));
1047
1048         thread = S_ithread_get(aTHX);
1049
1050         ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1051         /* XSRETURN(1); - implied */
1052
1053
1054 void
1055 ithread_tid(...)
1056     PREINIT:
1057         ithread *thread;
1058     CODE:
1059         PERL_UNUSED_VAR(items);
1060         thread = S_SV_to_ithread(aTHX_ ST(0));
1061         XST_mUV(0, thread->tid);
1062         /* XSRETURN(1); - implied */
1063
1064
1065 void
1066 ithread_join(...)
1067     PREINIT:
1068         ithread *thread;
1069         ithread *current_thread;
1070         int join_err;
1071         AV *params = NULL;
1072         int len;
1073         int ii;
1074 #ifndef WIN32
1075         int rc_join;
1076         void *retval;
1077 #endif
1078         dMY_POOL;
1079     PPCODE:
1080         /* Object method only */
1081         if ((items != 1) || ! sv_isobject(ST(0))) {
1082             Perl_croak(aTHX_ "Usage: $thr->join()");
1083         }
1084
1085         /* Check if the thread is joinable and not ourselves */
1086         thread = S_SV_to_ithread(aTHX_ ST(0));
1087         current_thread = S_ithread_get(aTHX);
1088
1089         MUTEX_LOCK(&thread->mutex);
1090         if ((join_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1091             MUTEX_UNLOCK(&thread->mutex);
1092             Perl_croak(aTHX_ (join_err & PERL_ITHR_DETACHED)
1093                                 ? "Cannot join a detached thread"
1094                                 : "Thread already joined");
1095         } else if (thread->tid == current_thread->tid) {
1096             MUTEX_UNLOCK(&thread->mutex);
1097             Perl_croak(aTHX_ "Cannot join self");
1098         }
1099
1100         /* Mark as joined */
1101         thread->state |= PERL_ITHR_JOINED;
1102         MUTEX_UNLOCK(&thread->mutex);
1103
1104         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1105         MY_POOL.joinable_threads--;
1106         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1107
1108         /* Join the thread */
1109 #ifdef WIN32
1110         if (WaitForSingleObject(thread->handle, INFINITE) != WAIT_OBJECT_0) {
1111             /* Timeout/abandonment unexpected here; check $^E */
1112             Perl_croak(aTHX_ "PANIC: underlying join failed");
1113         };
1114 #else
1115         if ((rc_join = pthread_join(thread->thr, &retval)) != 0) {
1116             /* In progress/deadlock/unknown unexpected here; check $! */
1117             errno = rc_join;
1118             Perl_croak(aTHX_ "PANIC: underlying join failed");
1119         };
1120 #endif
1121
1122         MUTEX_LOCK(&thread->mutex);
1123         /* Get the return value from the call_sv */
1124         /* Objects do not survive this process - FIXME */
1125         if (! (thread->gimme & G_VOID)) {
1126             AV *params_copy;
1127             PerlInterpreter *other_perl;
1128             CLONE_PARAMS clone_params;
1129
1130             params_copy = (AV *)SvRV(thread->params);
1131             other_perl = thread->interp;
1132             clone_params.stashes = newAV();
1133             clone_params.flags = CLONEf_JOIN_IN;
1134             PL_ptr_table = ptr_table_new();
1135             S_ithread_set(aTHX_ thread);
1136             /* Ensure 'meaningful' addresses retain their meaning */
1137             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1138             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1139             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1140             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
1141             S_ithread_set(aTHX_ current_thread);
1142             SvREFCNT_dec(clone_params.stashes);
1143             SvREFCNT_inc_void(params);
1144             ptr_table_free(PL_ptr_table);
1145             PL_ptr_table = NULL;
1146         }
1147
1148         /* If thread didn't die, then we can free its interpreter */
1149         if (! (thread->state & PERL_ITHR_DIED)) {
1150             S_ithread_clear(aTHX_ thread);
1151         }
1152         S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
1153
1154         /* If no return values, then just return */
1155         if (! params) {
1156             XSRETURN_UNDEF;
1157         }
1158
1159         /* Put return values on stack */
1160         len = (int)AvFILL(params);
1161         for (ii=0; ii <= len; ii++) {
1162             SV* param = av_shift(params);
1163             XPUSHs(sv_2mortal(param));
1164         }
1165
1166         /* Free return value array */
1167         SvREFCNT_dec(params);
1168
1169
1170 void
1171 ithread_yield(...)
1172     CODE:
1173         PERL_UNUSED_VAR(items);
1174         YIELD;
1175
1176
1177 void
1178 ithread_detach(...)
1179     PREINIT:
1180         ithread *thread;
1181         int detach_err;
1182         dMY_POOL;
1183     CODE:
1184         PERL_UNUSED_VAR(items);
1185
1186         /* Detach the thread */
1187         thread = S_SV_to_ithread(aTHX_ ST(0));
1188         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1189         MUTEX_LOCK(&thread->mutex);
1190         if (! (detach_err = (thread->state & PERL_ITHR_UNCALLABLE))) {
1191             /* Thread is detachable */
1192             thread->state |= PERL_ITHR_DETACHED;
1193 #ifdef WIN32
1194             /* Windows has no 'detach thread' function */
1195 #else
1196             PERL_THREAD_DETACH(thread->thr);
1197 #endif
1198             if (thread->state & PERL_ITHR_FINISHED) {
1199                 MY_POOL.joinable_threads--;
1200             } else {
1201                 MY_POOL.running_threads--;
1202                 MY_POOL.detached_threads++;
1203             }
1204         }
1205         MUTEX_UNLOCK(&thread->mutex);
1206         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1207
1208         if (detach_err) {
1209             Perl_croak(aTHX_ (detach_err & PERL_ITHR_DETACHED)
1210                                 ? "Thread already detached"
1211                                 : "Cannot detach a joined thread");
1212         }
1213
1214         /* If thread is finished and didn't die,
1215          * then we can free its interpreter */
1216         MUTEX_LOCK(&thread->mutex);
1217         if ((thread->state & PERL_ITHR_FINISHED) &&
1218             ! (thread->state & PERL_ITHR_DIED))
1219         {
1220             S_ithread_clear(aTHX_ thread);
1221         }
1222         S_ithread_free(aTHX_ thread);   /* Releases MUTEX */
1223
1224
1225 void
1226 ithread_kill(...)
1227     PREINIT:
1228         ithread *thread;
1229         char *sig_name;
1230         IV signal;
1231     CODE:
1232         /* Must have safe signals */
1233         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) {
1234             Perl_croak(aTHX_ "Cannot signal threads without safe signals");
1235         }
1236
1237         /* Object method only */
1238         if ((items != 2) || ! sv_isobject(ST(0))) {
1239             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
1240         }
1241
1242         /* Get signal */
1243         sig_name = SvPV_nolen(ST(1));
1244         if (isALPHA(*sig_name)) {
1245             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G') {
1246                 sig_name += 3;
1247             }
1248             if ((signal = whichsig(sig_name)) < 0) {
1249                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
1250             }
1251         } else {
1252             signal = SvIV(ST(1));
1253         }
1254
1255         /* Set the signal for the thread */
1256         thread = S_SV_to_ithread(aTHX_ ST(0));
1257         MUTEX_LOCK(&thread->mutex);
1258         if (thread->interp) {
1259             dTHXa(thread->interp);
1260             PL_psig_pend[signal]++;
1261             PL_sig_pending = 1;
1262         }
1263         MUTEX_UNLOCK(&thread->mutex);
1264
1265         /* Return the thread to allow for method chaining */
1266         ST(0) = ST(0);
1267         /* XSRETURN(1); - implied */
1268
1269
1270 void
1271 ithread_DESTROY(...)
1272     CODE:
1273         PERL_UNUSED_VAR(items);
1274         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
1275
1276
1277 void
1278 ithread_equal(...)
1279     PREINIT:
1280         int are_equal = 0;
1281     CODE:
1282         PERL_UNUSED_VAR(items);
1283
1284         /* Compares TIDs to determine thread equality */
1285         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1286             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1287             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
1288             are_equal = (thr1->tid == thr2->tid);
1289         }
1290         if (are_equal) {
1291             XST_mYES(0);
1292         } else {
1293             /* Return 0 on false for backward compatibility */
1294             XST_mIV(0, 0);
1295         }
1296         /* XSRETURN(1); - implied */
1297
1298
1299 void
1300 ithread_object(...)
1301     PREINIT:
1302         char *classname;
1303         UV tid;
1304         ithread *thread;
1305         int state;
1306         int have_obj = 0;
1307         dMY_POOL;
1308     CODE:
1309         /* Class method only */
1310         if (SvROK(ST(0))) {
1311             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1312         }
1313         classname = (char *)SvPV_nolen(ST(0));
1314
1315         if ((items < 2) || ! SvOK(ST(1))) {
1316             XSRETURN_UNDEF;
1317         }
1318
1319         /* threads->object($tid) */
1320         tid = SvUV(ST(1));
1321
1322         /* Walk through threads list */
1323         MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1324         for (thread = MY_POOL.main_thread.next;
1325              thread != &MY_POOL.main_thread;
1326              thread = thread->next)
1327         {
1328             /* Look for TID */
1329             if (thread->tid == tid) {
1330                 /* Ignore if detached or joined */
1331                 MUTEX_LOCK(&thread->mutex);
1332                 state = thread->state;
1333                 MUTEX_UNLOCK(&thread->mutex);
1334                 if (! (state & PERL_ITHR_UNCALLABLE)) {
1335                     /* Put object on stack */
1336                     ST(0) = sv_2mortal(S_ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1337                     have_obj = 1;
1338                 }
1339                 break;
1340             }
1341         }
1342         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1343
1344         if (! have_obj) {
1345             XSRETURN_UNDEF;
1346         }
1347         /* XSRETURN(1); - implied */
1348
1349
1350 void
1351 ithread__handle(...);
1352     PREINIT:
1353         ithread *thread;
1354     CODE:
1355         PERL_UNUSED_VAR(items);
1356         thread = S_SV_to_ithread(aTHX_ ST(0));
1357 #ifdef WIN32
1358         XST_mUV(0, PTR2UV(&thread->handle));
1359 #else
1360         XST_mUV(0, PTR2UV(&thread->thr));
1361 #endif
1362         /* XSRETURN(1); - implied */
1363
1364
1365 void
1366 ithread_get_stack_size(...)
1367     PREINIT:
1368         IV stack_size;
1369         dMY_POOL;
1370     CODE:
1371         PERL_UNUSED_VAR(items);
1372         if (sv_isobject(ST(0))) {
1373             /* $thr->get_stack_size() */
1374             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1375             stack_size = thread->stack_size;
1376         } else {
1377             /* threads->get_stack_size() */
1378             stack_size = MY_POOL.default_stack_size;
1379         }
1380         XST_mIV(0, stack_size);
1381         /* XSRETURN(1); - implied */
1382
1383
1384 void
1385 ithread_set_stack_size(...)
1386     PREINIT:
1387         IV old_size;
1388         dMY_POOL;
1389     CODE:
1390         if (items != 2) {
1391             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1392         }
1393         if (sv_isobject(ST(0))) {
1394             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1395         }
1396         if (! looks_like_number(ST(1))) {
1397             Perl_croak(aTHX_ "Stack size must be numeric");
1398         }
1399
1400         old_size = MY_POOL.default_stack_size;
1401         MY_POOL.default_stack_size = S_good_stack_size(aTHX_ SvIV(ST(1)));
1402         XST_mIV(0, old_size);
1403         /* XSRETURN(1); - implied */
1404
1405
1406 void
1407 ithread_is_running(...)
1408     PREINIT:
1409         ithread *thread;
1410     CODE:
1411         /* Object method only */
1412         if ((items != 1) || ! sv_isobject(ST(0))) {
1413             Perl_croak(aTHX_ "Usage: $thr->is_running()");
1414         }
1415
1416         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1417         MUTEX_LOCK(&thread->mutex);
1418         ST(0) = (thread->state & PERL_ITHR_FINISHED) ? &PL_sv_no : &PL_sv_yes;
1419         MUTEX_UNLOCK(&thread->mutex);
1420         /* XSRETURN(1); - implied */
1421
1422
1423 void
1424 ithread_is_detached(...)
1425     PREINIT:
1426         ithread *thread;
1427     CODE:
1428         PERL_UNUSED_VAR(items);
1429         thread = S_SV_to_ithread(aTHX_ ST(0));
1430         MUTEX_LOCK(&thread->mutex);
1431         ST(0) = (thread->state & PERL_ITHR_DETACHED) ? &PL_sv_yes : &PL_sv_no;
1432         MUTEX_UNLOCK(&thread->mutex);
1433         /* XSRETURN(1); - implied */
1434
1435
1436 void
1437 ithread_is_joinable(...)
1438     PREINIT:
1439         ithread *thread;
1440     CODE:
1441         /* Object method only */
1442         if ((items != 1) || ! sv_isobject(ST(0))) {
1443             Perl_croak(aTHX_ "Usage: $thr->is_joinable()");
1444         }
1445
1446         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1447         MUTEX_LOCK(&thread->mutex);
1448         ST(0) = ((thread->state & PERL_ITHR_FINISHED) &&
1449                  ! (thread->state & PERL_ITHR_UNCALLABLE))
1450             ? &PL_sv_yes : &PL_sv_no;
1451         MUTEX_UNLOCK(&thread->mutex);
1452         /* XSRETURN(1); - implied */
1453
1454
1455 void
1456 ithread_wantarray(...)
1457     PREINIT:
1458         ithread *thread;
1459     CODE:
1460         PERL_UNUSED_VAR(items);
1461         thread = S_SV_to_ithread(aTHX_ ST(0));
1462         ST(0) = (thread->gimme & G_ARRAY) ? &PL_sv_yes :
1463                 (thread->gimme & G_VOID)  ? &PL_sv_undef
1464                            /* G_SCALAR */ : &PL_sv_no;
1465         /* XSRETURN(1); - implied */
1466
1467
1468 void
1469 ithread_set_thread_exit_only(...)
1470     PREINIT:
1471         ithread *thread;
1472     CODE:
1473         if (items != 2) {
1474             Perl_croak(aTHX_ "Usage: ->set_thread_exit_only(boolean)");
1475         }
1476         thread = S_SV_to_ithread(aTHX_ ST(0));
1477         MUTEX_LOCK(&thread->mutex);
1478         if (SvTRUE(ST(1))) {
1479             thread->state |= PERL_ITHR_THREAD_EXIT_ONLY;
1480         } else {
1481             thread->state &= ~PERL_ITHR_THREAD_EXIT_ONLY;
1482         }
1483         MUTEX_UNLOCK(&thread->mutex);
1484
1485
1486 void
1487 ithread_error(...)
1488     PREINIT:
1489         ithread *thread;
1490         SV *err = NULL;
1491     CODE:
1492         /* Object method only */
1493         if ((items != 1) || ! sv_isobject(ST(0))) {
1494             Perl_croak(aTHX_ "Usage: $thr->err()");
1495         }
1496
1497         thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1498         MUTEX_LOCK(&thread->mutex);
1499
1500         /* If thread died, then clone the error into the calling thread */
1501         if (thread->state & PERL_ITHR_DIED) {
1502             PerlInterpreter *other_perl;
1503             CLONE_PARAMS clone_params;
1504             ithread *current_thread;
1505
1506             other_perl = thread->interp;
1507             clone_params.stashes = newAV();
1508             clone_params.flags = CLONEf_JOIN_IN;
1509             PL_ptr_table = ptr_table_new();
1510             current_thread = S_ithread_get(aTHX);
1511             S_ithread_set(aTHX_ thread);
1512             /* Ensure 'meaningful' addresses retain their meaning */
1513             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
1514             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
1515             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
1516             err = sv_dup(thread->err, &clone_params);
1517             S_ithread_set(aTHX_ current_thread);
1518             SvREFCNT_dec(clone_params.stashes);
1519             SvREFCNT_inc_void(err);
1520             /* If error was an object, bless it into the correct class */
1521             if (thread->err_class) {
1522                 sv_bless(err, gv_stashpv(thread->err_class, 1));
1523             }
1524             ptr_table_free(PL_ptr_table);
1525             PL_ptr_table = NULL;
1526         }
1527
1528         MUTEX_UNLOCK(&thread->mutex);
1529
1530         if (! err) {
1531             XSRETURN_UNDEF;
1532         }
1533
1534         ST(0) = sv_2mortal(err);
1535         /* XSRETURN(1); - implied */
1536
1537
1538 #endif /* USE_ITHREADS */
1539
1540
1541 BOOT:
1542 {
1543 #ifdef USE_ITHREADS
1544     SV *my_pool_sv = *hv_fetch(PL_modglobal, MY_POOL_KEY,
1545                                sizeof(MY_POOL_KEY)-1, TRUE);
1546     my_pool_t *my_poolp = (my_pool_t*)SvPVX(newSV(sizeof(my_pool_t)-1));
1547
1548     MY_CXT_INIT;
1549
1550     Zero(my_poolp, 1, my_pool_t);
1551     sv_setuv(my_pool_sv, PTR2UV(my_poolp));
1552
1553     PL_perl_destruct_level = 2;
1554     MUTEX_INIT(&MY_POOL.create_destruct_mutex);
1555     MUTEX_LOCK(&MY_POOL.create_destruct_mutex);
1556
1557     PL_threadhook = &Perl_ithread_hook;
1558
1559     MY_POOL.tid_counter = 1;
1560 #  ifdef THREAD_CREATE_NEEDS_STACK
1561     MY_POOL.default_stack_size = THREAD_CREATE_NEEDS_STACK;
1562 #  endif
1563
1564     /* The 'main' thread is thread 0.
1565      * It is detached (unjoinable) and immortal.
1566      */
1567
1568     MUTEX_INIT(&MY_POOL.main_thread.mutex);
1569
1570     /* Head of the threads list */
1571     MY_POOL.main_thread.next = &MY_POOL.main_thread;
1572     MY_POOL.main_thread.prev = &MY_POOL.main_thread;
1573
1574     MY_POOL.main_thread.count = 1;                  /* Immortal */
1575
1576     MY_POOL.main_thread.interp = aTHX;
1577     MY_POOL.main_thread.state = PERL_ITHR_DETACHED; /* Detached */
1578     MY_POOL.main_thread.stack_size = MY_POOL.default_stack_size;
1579 #  ifdef WIN32
1580     MY_POOL.main_thread.thr = GetCurrentThreadId();
1581 #  else
1582     MY_POOL.main_thread.thr = pthread_self();
1583 #  endif
1584
1585     S_ithread_set(aTHX_ &MY_POOL.main_thread);
1586     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
1587 #endif /* USE_ITHREADS */
1588 }