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