ext/threads/threads.xs

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