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