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     PPCODE:
 831         /* Class method only */
 832         if (SvROK(ST(0)))
 833             Perl_croak(aTHX_ "Usage: threads->list()");
 834         classname = (char *)SvPV_nolen(ST(0));
 835
 836         /* Calling context */
 837         list_context = (GIMME_V == G_ARRAY);
 838
 839         /* Walk through threads list */
 840         MUTEX_LOCK(&create_destruct_mutex);
 841         for (thread = threads->next;
 842              thread != threads;
 843              thread = thread->next)
 844         {
 845             /* Ignore detached or joined threads */
 846             if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
 847                 continue;
 848             }
 849             /* Push object on stack if list context */
 850             if (list_context) {
 851                 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
 852             }
 853             count++;
 854         }
 855         MUTEX_UNLOCK(&create_destruct_mutex);
 856         /* If scalar context, send back count */
 857         if (! list_context) {
 858             XSRETURN_IV(count);
 859         }
 860
 861
 862 void
 863 ithread_self(...)
 864     PREINIT:
 865         char *classname;
 866         ithread *thread;
 867     CODE:
 868         /* Class method only */
 869         if (SvROK(ST(0)))
 870             Perl_croak(aTHX_ "Usage: threads->self()");
 871         classname = (char *)SvPV_nolen(ST(0));
 872
 873         thread = S_ithread_get(aTHX);
 874
 875         ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
 876         /* XSRETURN(1); - implied */
 877
 878
 879 void
 880 ithread_tid(...)
 881     PREINIT:
 882         ithread *thread;
 883     CODE:
 884         thread = SV_to_ithread(aTHX_ ST(0));
 885         XST_mUV(0, thread->tid);
 886         /* XSRETURN(1); - implied */
 887
 888
 889 void
 890 ithread_join(...)
 891     PREINIT:
 892         ithread *thread;
 893         int join_err;
 894         AV *params;
 895         int len;
 896         int ii;
 897 #ifdef WIN32
 898         DWORD waitcode;
 899 #else
 900         void *retval;
 901 #endif
 902     PPCODE:
 903         /* Object method only */
 904         if (! sv_isobject(ST(0)))
 905             Perl_croak(aTHX_ "Usage: $thr->join()");
 906
 907         /* Check if the thread is joinable */
 908         thread = SV_to_ithread(aTHX_ ST(0));
 909         MUTEX_LOCK(&thread->mutex);
 910         join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
 911         MUTEX_UNLOCK(&thread->mutex);
 912         if (join_err) {
 913             if (join_err & PERL_ITHR_DETACHED) {
 914                 Perl_croak(aTHX_ "Cannot join a detached thread");
 915             } else {
 916                 Perl_croak(aTHX_ "Thread already joined");
 917             }
 918         }
 919
 920         /* Join the thread */
 921 #ifdef WIN32
 922         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 923 #else
 924         pthread_join(thread->thr, &retval);
 925 #endif
 926
 927         MUTEX_LOCK(&thread->mutex);
 928         /* Mark as joined */
 929         thread->state |= PERL_ITHR_JOINED;
 930
 931         /* Get the return value from the call_sv */
 932         {
 933             AV *params_copy;
 934             PerlInterpreter *other_perl;
 935             CLONE_PARAMS clone_params;
 936             ithread *current_thread;
 937
 938             params_copy = (AV *)SvRV(thread->params);
 939             other_perl = thread->interp;
 940             clone_params.stashes = newAV();
 941             clone_params.flags = CLONEf_JOIN_IN;
 942             PL_ptr_table = ptr_table_new();
 943             current_thread = S_ithread_get(aTHX);
 944             S_ithread_set(aTHX_ thread);
 945             /* Ensure 'meaningful' addresses retain their meaning */
 946             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
 947             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
 948             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
 949             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
 950             S_ithread_set(aTHX_ current_thread);
 951             SvREFCNT_dec(clone_params.stashes);
 952             SvREFCNT_inc(params);
 953             ptr_table_free(PL_ptr_table);
 954             PL_ptr_table = NULL;
 955         }
 956
 957         /* We are finished with the thread */
 958         S_ithread_clear(aTHX_ thread);
 959         MUTEX_UNLOCK(&thread->mutex);
 960
 961         MUTEX_LOCK(&create_destruct_mutex);
 962         joinable_threads--;
 963         MUTEX_UNLOCK(&create_destruct_mutex);
 964
 965         /* If no return values, then just return */
 966         if (! params) {
 967             XSRETURN_UNDEF;
 968         }
 969
 970         /* Put return values on stack */
 971         len = (int)AvFILL(params);
 972         for (ii=0; ii <= len; ii++) {
 973             SV* param = av_shift(params);
 974             XPUSHs(sv_2mortal(param));
 975         }
 976
 977         /* Free return value array */
 978         SvREFCNT_dec(params);
 979
 980
 981 void
 982 ithread_yield(...)
 983     CODE:
 984         YIELD;
 985
 986
 987 void
 988 ithread_detach(...)
 989     PREINIT:
 990         ithread *thread;
 991         int detach_err;
 992         int cleanup;
 993     CODE:
 994         thread = SV_to_ithread(aTHX_ ST(0));
 995         MUTEX_LOCK(&thread->mutex);
 996
 997         /* Check if the thread is detachable */
 998         if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
 999             MUTEX_UNLOCK(&thread->mutex);
1000             if (detach_err & PERL_ITHR_DETACHED) {
1001                 Perl_croak(aTHX_ "Thread already detached");
1002             } else {
1003                 Perl_croak(aTHX_ "Cannot detach a joined thread");
1004             }
1005         }
1006
1007         /* Detach the thread */
1008         thread->state |= PERL_ITHR_DETACHED;
1009 #ifdef WIN32
1010         /* Windows has no 'detach thread' function */
1011 #else
1012         PERL_THREAD_DETACH(thread->thr);
1013 #endif
1014         /* Cleanup if finished */
1015         cleanup = (thread->state & PERL_ITHR_FINISHED);
1016         MUTEX_UNLOCK(&thread->mutex);
1017
1018         MUTEX_LOCK(&create_destruct_mutex);
1019         if (cleanup) {
1020             joinable_threads--;
1021         } else {
1022             running_threads--;
1023             detached_threads++;
1024         }
1025         MUTEX_UNLOCK(&create_destruct_mutex);
1026
1027         if (cleanup) {
1028             S_ithread_destruct(aTHX_ thread);
1029         }
1030
1031
1032 void
1033 ithread_kill(...)
1034     PREINIT:
1035         ithread *thread;
1036         char *sig_name;
1037         IV signal;
1038     CODE:
1039         /* Must have safe signals */
1040         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
1041             Perl_croak(aTHX_ "Cannot signal threads without safe signals");
1042
1043         /* Object method only */
1044         if (! sv_isobject(ST(0)))
1045             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
1046
1047         /* Get signal */
1048         sig_name = SvPV_nolen(ST(1));
1049         if (isALPHA(*sig_name)) {
1050             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G')
1051                 sig_name += 3;
1052             if ((signal = whichsig(sig_name)) < 0)
1053                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
1054         } else
1055             signal = SvIV(ST(1));
1056
1057         /* Set the signal for the thread */
1058         thread = SV_to_ithread(aTHX_ ST(0));
1059         MUTEX_LOCK(&thread->mutex);
1060         {
1061             dTHXa(thread->interp);
1062             PL_psig_pend[signal]++;
1063             PL_sig_pending = 1;
1064         }
1065         MUTEX_UNLOCK(&thread->mutex);
1066
1067         /* Return the thread to allow for method chaining */
1068         ST(0) = ST(0);
1069         /* XSRETURN(1); - implied */
1070
1071
1072 void
1073 ithread_DESTROY(...)
1074     CODE:
1075         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
1076
1077
1078 void
1079 ithread_equal(...)
1080     PREINIT:
1081         int are_equal = 0;
1082     CODE:
1083         /* Compares TIDs to determine thread equality */
1084         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1085             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1086             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
1087             are_equal = (thr1->tid == thr2->tid);
1088         }
1089         if (are_equal) {
1090             XST_mYES(0);
1091         } else {
1092             /* Return 0 on false for backward compatibility */
1093             XST_mIV(0, 0);
1094         }
1095         /* XSRETURN(1); - implied */
1096
1097
1098 void
1099 ithread_object(...)
1100     PREINIT:
1101         char *classname;
1102         UV tid;
1103         ithread *thread;
1104         int found = 0;
1105     CODE:
1106         /* Class method only */
1107         if (SvROK(ST(0)))
1108             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1109         classname = (char *)SvPV_nolen(ST(0));
1110
1111         if ((items < 2) || ! SvOK(ST(1))) {
1112             XSRETURN_UNDEF;
1113         }
1114
1115         /* threads->object($tid) */
1116         tid = SvUV(ST(1));
1117
1118         /* Walk through threads list */
1119         MUTEX_LOCK(&create_destruct_mutex);
1120         for (thread = threads->next;
1121              thread != threads;
1122              thread = thread->next)
1123         {
1124             /* Look for TID, but ignore detached or joined threads */
1125             if ((thread->tid != tid) ||
1126                 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
1127             {
1128                 continue;
1129             }
1130             /* Put object on stack */
1131             ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1132             found = 1;
1133             break;
1134         }
1135         MUTEX_UNLOCK(&create_destruct_mutex);
1136         if (! found) {
1137             XSRETURN_UNDEF;
1138         }
1139         /* XSRETURN(1); - implied */
1140
1141
1142 void
1143 ithread__handle(...);
1144     PREINIT:
1145         ithread *thread;
1146     CODE:
1147         thread = SV_to_ithread(aTHX_ ST(0));
1148 #ifdef WIN32
1149         XST_mUV(0, PTR2UV(&thread->handle));
1150 #else
1151         XST_mUV(0, PTR2UV(&thread->thr));
1152 #endif
1153         /* XSRETURN(1); - implied */
1154
1155
1156 void
1157 ithread_get_stack_size(...)
1158     PREINIT:
1159         IV stack_size;
1160     CODE:
1161         if (sv_isobject(ST(0))) {
1162             /* $thr->get_stack_size() */
1163             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1164             stack_size = thread->stack_size;
1165         } else {
1166             /* threads->get_stack_size() */
1167             stack_size = default_stack_size;
1168         }
1169         XST_mIV(0, stack_size);
1170         /* XSRETURN(1); - implied */
1171
1172
1173 void
1174 ithread_set_stack_size(...)
1175     PREINIT:
1176         IV old_size;
1177     CODE:
1178         if (items != 2)
1179             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1180         if (sv_isobject(ST(0)))
1181             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1182
1183         old_size = default_stack_size;
1184         default_stack_size = good_stack_size(aTHX_ SvIV(ST(1)));
1185         XST_mIV(0, old_size);
1186         /* XSRETURN(1); - implied */
1187
1188 #endif /* USE_ITHREADS */
1189
1190
1191 BOOT:
1192 {
1193 #ifdef USE_ITHREADS
1194     /* The 'main' thread is thread 0.
1195      * It is detached (unjoinable) and immortal.
1196      */
1197
1198     ithread *thread;
1199     MY_CXT_INIT;
1200
1201     PL_perl_destruct_level = 2;
1202     MUTEX_INIT(&create_destruct_mutex);
1203     MUTEX_LOCK(&create_destruct_mutex);
1204
1205     PL_threadhook = &Perl_ithread_hook;
1206
1207     thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
1208     if (! thread) {
1209         PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
1210         my_exit(1);
1211     }
1212     Zero(thread, 1, ithread);
1213
1214     MUTEX_INIT(&thread->mutex);
1215
1216     thread->tid = tid_counter++;        /* Thread 0 */
1217
1218     /* Head of the threads list */
1219     threads = thread;
1220     thread->next = thread;
1221     thread->prev = thread;
1222
1223     thread->count = 1;                  /* Immortal */
1224
1225     thread->interp = aTHX;
1226     thread->state = PERL_ITHR_DETACHED; /* Detached */
1227     thread->stack_size = default_stack_size;
1228 #  ifdef WIN32
1229     thread->thr = GetCurrentThreadId();
1230 #  else
1231     thread->thr = pthread_self();
1232 #  endif
1233
1234     S_ithread_set(aTHX_ thread);
1235     MUTEX_UNLOCK(&create_destruct_mutex);
1236 #endif /* USE_ITHREADS */
1237 }