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         if (SvPOK(init_function)) {
 526             thread->init_function = newSV(0);
 527             sv_copypv(thread->init_function, init_function);
 528         } else {
 529             clone_param.flags = 0;
 530             thread->init_function = sv_dup(init_function, &clone_param);
 531             if (SvREFCNT(thread->init_function) == 0) {
 532                 SvREFCNT_inc(thread->init_function);
 533             }
 534         }
 535
 536         thread->params = sv_dup(params, &clone_param);
 537         SvREFCNT_inc(thread->params);
 538
 539         /* The code below checks that anything living on the tmps stack and
 540          * has been cloned (so it lives in the ptr_table) has a refcount
 541          * higher than 0.
 542          *
 543          * If the refcount is 0 it means that a something on the stack/context
 544          * was holding a reference to it and since we init_stacks() in
 545          * perl_clone that won't get cleaned and we will get a leaked scalar.
 546          * The reason it was cloned was that it lived on the @_ stack.
 547          *
 548          * Example of this can be found in bugreport 15837 where calls in the
 549          * parameter list end up as a temp.
 550          *
 551          * One could argue that this fix should be in perl_clone.
 552          */
 553         while (tmps_ix > 0) {
 554             SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
 555             tmps_ix--;
 556             if (sv && SvREFCNT(sv) == 0) {
 557                 SvREFCNT_inc(sv);
 558                 SvREFCNT_dec(sv);
 559             }
 560         }
 561
 562         SvTEMP_off(thread->init_function);
 563         ptr_table_free(PL_ptr_table);
 564         PL_ptr_table = NULL;
 565         PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 566     }
 567     S_ithread_set(aTHX_ current_thread);
 568     PERL_SET_CONTEXT(aTHX);
 569
 570     /* Create/start the thread */
 571 #ifdef WIN32
 572     thread->handle = CreateThread(NULL,
 573                                   (DWORD)thread->stack_size,
 574                                   S_ithread_run,
 575                                   (LPVOID)thread,
 576                                   STACK_SIZE_PARAM_IS_A_RESERVATION,
 577                                   &thread->thr);
 578 #else
 579     {
 580         static pthread_attr_t attr;
 581         static int attr_inited = 0;
 582         static int attr_joinable = PTHREAD_CREATE_JOINABLE;
 583         if (! attr_inited) {
 584             pthread_attr_init(&attr);
 585             attr_inited = 1;
 586         }
 587
 588 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
 589         /* Threads start out joinable */
 590         PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 591 #  endif
 592
 593 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
 594         /* Set thread's stack size */
 595         if (thread->stack_size > 0) {
 596             rc_stack_size = pthread_attr_setstacksize(&attr, (size_t)thread->stack_size);
 597         }
 598 #  endif
 599
 600         /* Create the thread */
 601         if (! rc_stack_size) {
 602 #  ifdef OLD_PTHREADS_API
 603             rc_thread_create = pthread_create(&thread->thr,
 604                                               attr,
 605                                               S_ithread_run,
 606                                               (void *)thread);
 607 #  else
 608 #    if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
 609             pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
 610 #    endif
 611             rc_thread_create = pthread_create(&thread->thr,
 612                                               &attr,
 613                                               S_ithread_run,
 614                                               (void *)thread);
 615 #  endif
 616         }
 617
 618 #  ifdef _POSIX_THREAD_ATTR_STACKSIZE
 619         /* Try to get thread's actual stack size */
 620         {
 621             size_t stacksize;
 622             if (! pthread_attr_getstacksize(&attr, &stacksize)) {
 623                 if (stacksize) {
 624                     thread->stack_size = (IV)stacksize;
 625                 }
 626             }
 627         }
 628 #  endif
 629     }
 630 #endif
 631
 632     /* Check for errors */
 633 #ifdef WIN32
 634     if (thread->handle == NULL) {
 635 #else
 636     if (rc_stack_size || rc_thread_create) {
 637 #endif
 638         MUTEX_UNLOCK(&create_destruct_mutex);
 639         sv_2mortal(params);
 640         S_ithread_destruct(aTHX_ thread);
 641 #ifndef WIN32
 642         if (ckWARN_d(WARN_THREADS)) {
 643             if (rc_stack_size)
 644                 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
 645             else
 646                 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
 647         }
 648 #endif
 649         return (&PL_sv_undef);
 650     }
 651
 652     active_threads++;
 653     MUTEX_UNLOCK(&create_destruct_mutex);
 654
 655     sv_2mortal(params);
 656
 657     return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
 658 }
 659
 660 #endif /* USE_ITHREADS */
 661
 662
 663 MODULE = threads    PACKAGE = threads    PREFIX = ithread_
 664 PROTOTYPES: DISABLE
 665
 666 #ifdef USE_ITHREADS
 667
 668 void
 669 ithread_create(...)
 670     PREINIT:
 671         char *classname;
 672         ithread *thread;
 673         SV *function_to_call;
 674         AV *params;
 675         HV *specs;
 676         IV stack_size;
 677         int idx;
 678         int ii;
 679     CODE:
 680         if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
 681             if (--items < 2)
 682                 Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
 683             specs = (HV*)SvRV(ST(1));
 684             idx = 1;
 685         } else {
 686             if (items < 2)
 687                 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
 688             specs = NULL;
 689             idx = 0;
 690         }
 691
 692         if (sv_isobject(ST(0))) {
 693             /* $thr->create() */
 694             classname = HvNAME(SvSTASH(SvRV(ST(0))));
 695             thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
 696             stack_size = thread->stack_size;
 697         } else {
 698             /* threads->create() */
 699             classname = (char *)SvPV_nolen(ST(0));
 700             stack_size = default_stack_size;
 701         }
 702
 703         function_to_call = ST(idx+1);
 704
 705         if (specs) {
 706             /* stack_size */
 707             if (hv_exists(specs, "stack", 5)) {
 708                 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
 709             } else if (hv_exists(specs, "stacksize", 9)) {
 710                 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
 711             } else if (hv_exists(specs, "stack_size", 10)) {
 712                 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
 713             }
 714         }
 715
 716         /* Function args */
 717         params = newAV();
 718         if (items > 2) {
 719             for (ii=2; ii < items ; ii++) {
 720                 av_push(params, SvREFCNT_inc(ST(idx+ii)));
 721             }
 722         }
 723
 724         /* Create thread */
 725         ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
 726                                             classname,
 727                                             function_to_call,
 728                                             stack_size,
 729                                             newRV_noinc((SV*)params)));
 730         /* XSRETURN(1); - implied */
 731
 732
 733 void
 734 ithread_list(...)
 735     PREINIT:
 736         char *classname;
 737         ithread *thread;
 738         int list_context;
 739         IV count = 0;
 740     PPCODE:
 741         /* Class method only */
 742         if (SvROK(ST(0)))
 743             Perl_croak(aTHX_ "Usage: threads->list()");
 744         classname = (char *)SvPV_nolen(ST(0));
 745
 746         /* Calling context */
 747         list_context = (GIMME_V == G_ARRAY);
 748
 749         /* Walk through threads list */
 750         MUTEX_LOCK(&create_destruct_mutex);
 751         for (thread = threads->next;
 752              thread != threads;
 753              thread = thread->next)
 754         {
 755             /* Ignore detached or joined threads */
 756             if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
 757                 continue;
 758             }
 759             /* Push object on stack if list context */
 760             if (list_context) {
 761                 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
 762             }
 763             count++;
 764         }
 765         MUTEX_UNLOCK(&create_destruct_mutex);
 766         /* If scalar context, send back count */
 767         if (! list_context) {
 768             XSRETURN_IV(count);
 769         }
 770
 771
 772 void
 773 ithread_self(...)
 774     PREINIT:
 775         char *classname;
 776         ithread *thread;
 777     CODE:
 778         /* Class method only */
 779         if (SvROK(ST(0)))
 780             Perl_croak(aTHX_ "Usage: threads->self()");
 781         classname = (char *)SvPV_nolen(ST(0));
 782
 783         thread = S_ithread_get(aTHX);
 784
 785         ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
 786         /* XSRETURN(1); - implied */
 787
 788
 789 void
 790 ithread_tid(...)
 791     PREINIT:
 792         ithread *thread;
 793     CODE:
 794         thread = SV_to_ithread(aTHX_ ST(0));
 795         XST_mUV(0, thread->tid);
 796         /* XSRETURN(1); - implied */
 797
 798
 799 void
 800 ithread_join(...)
 801     PREINIT:
 802         ithread *thread;
 803         int join_err;
 804         AV *params;
 805         int len;
 806         int ii;
 807 #ifdef WIN32
 808         DWORD waitcode;
 809 #else
 810         void *retval;
 811 #endif
 812     PPCODE:
 813         /* Object method only */
 814         if (! sv_isobject(ST(0)))
 815             Perl_croak(aTHX_ "Usage: $thr->join()");
 816
 817         /* Check if the thread is joinable */
 818         thread = SV_to_ithread(aTHX_ ST(0));
 819         MUTEX_LOCK(&thread->mutex);
 820         join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
 821         MUTEX_UNLOCK(&thread->mutex);
 822         if (join_err) {
 823             if (join_err & PERL_ITHR_DETACHED) {
 824                 Perl_croak(aTHX_ "Cannot join a detached thread");
 825             } else {
 826                 Perl_croak(aTHX_ "Thread already joined");
 827             }
 828         }
 829
 830         /* Join the thread */
 831 #ifdef WIN32
 832         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 833 #else
 834         pthread_join(thread->thr, &retval);
 835 #endif
 836
 837         MUTEX_LOCK(&thread->mutex);
 838         /* Mark as joined */
 839         thread->state |= PERL_ITHR_JOINED;
 840
 841         /* Get the return value from the call_sv */
 842         {
 843             AV *params_copy;
 844             PerlInterpreter *other_perl;
 845             CLONE_PARAMS clone_params;
 846             ithread *current_thread;
 847
 848             params_copy = (AV *)SvRV(thread->params);
 849             other_perl = thread->interp;
 850             clone_params.stashes = newAV();
 851             clone_params.flags = CLONEf_JOIN_IN;
 852             PL_ptr_table = ptr_table_new();
 853             current_thread = S_ithread_get(aTHX);
 854             S_ithread_set(aTHX_ thread);
 855             /* Ensure 'meaningful' addresses retain their meaning */
 856             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
 857             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
 858             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
 859             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
 860             S_ithread_set(aTHX_ current_thread);
 861             SvREFCNT_dec(clone_params.stashes);
 862             SvREFCNT_inc(params);
 863             ptr_table_free(PL_ptr_table);
 864             PL_ptr_table = NULL;
 865         }
 866
 867         /* We are finished with the thread */
 868         S_ithread_clear(aTHX_ thread);
 869         MUTEX_UNLOCK(&thread->mutex);
 870
 871         /* If no return values, then just return */
 872         if (! params) {
 873             XSRETURN_UNDEF;
 874         }
 875
 876         /* Put return values on stack */
 877         len = (int)AvFILL(params);
 878         for (ii=0; ii <= len; ii++) {
 879             SV* param = av_shift(params);
 880             XPUSHs(sv_2mortal(param));
 881         }
 882
 883         /* Free return value array */
 884         SvREFCNT_dec(params);
 885
 886
 887 void
 888 ithread_yield(...)
 889     CODE:
 890         YIELD;
 891
 892
 893 void
 894 ithread_detach(...)
 895     PREINIT:
 896         ithread *thread;
 897         int detach_err;
 898         int cleanup;
 899     CODE:
 900         thread = SV_to_ithread(aTHX_ ST(0));
 901         MUTEX_LOCK(&thread->mutex);
 902
 903         /* Check if the thread is detachable */
 904         if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
 905             MUTEX_UNLOCK(&thread->mutex);
 906             if (detach_err & PERL_ITHR_DETACHED) {
 907                 Perl_croak(aTHX_ "Thread already detached");
 908             } else {
 909                 Perl_croak(aTHX_ "Cannot detach a joined thread");
 910             }
 911         }
 912
 913         /* Detach the thread */
 914         thread->state |= PERL_ITHR_DETACHED;
 915 #ifdef WIN32
 916         /* Windows has no 'detach thread' function */
 917 #else
 918         PERL_THREAD_DETACH(thread->thr);
 919 #endif
 920         /* Cleanup if finished */
 921         cleanup = (thread->state & PERL_ITHR_FINISHED);
 922         MUTEX_UNLOCK(&thread->mutex);
 923
 924         if (cleanup)
 925             S_ithread_destruct(aTHX_ thread);
 926
 927
 928 void
 929 ithread_kill(...)
 930     PREINIT:
 931         ithread *thread;
 932         char *sig_name;
 933         IV signal;
 934     CODE:
 935         /* Must have safe signals */
 936         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
 937             Perl_croak(aTHX_ "Cannot signal other threads without safe signals");
 938
 939         /* Object method only */
 940         if (! sv_isobject(ST(0)))
 941             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
 942
 943         /* Get thread */
 944         thread = SV_to_ithread(aTHX_ ST(0));
 945
 946         /* Get signal */
 947         sig_name = SvPV_nolen(ST(1));
 948         if (isALPHA(*sig_name)) {
 949             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G')
 950                 sig_name += 3;
 951             if ((signal = whichsig(sig_name)) < 0)
 952                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
 953         } else
 954             signal = SvIV(ST(1));
 955
 956         /* Set the signal for the thread */
 957         {
 958             dTHXa(thread->interp);
 959             PL_psig_pend[signal]++;
 960             PL_sig_pending = 1;
 961         }
 962
 963         /* Return the thread to allow for method chaining */
 964         ST(0) = ST(0);
 965         /* XSRETURN(1); - implied */
 966
 967
 968 void
 969 ithread_DESTROY(...)
 970     CODE:
 971         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
 972
 973
 974 void
 975 ithread_equal(...)
 976     PREINIT:
 977         int are_equal = 0;
 978     CODE:
 979         /* Compares TIDs to determine thread equality */
 980         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
 981             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
 982             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
 983             are_equal = (thr1->tid == thr2->tid);
 984         }
 985         if (are_equal) {
 986             XST_mYES(0);
 987         } else {
 988             /* Return 0 on false for backward compatibility */
 989             XST_mIV(0, 0);
 990         }
 991         /* XSRETURN(1); - implied */
 992
 993
 994 void
 995 ithread_object(...)
 996     PREINIT:
 997         char *classname;
 998         UV tid;
 999         ithread *thread;
1000         int found = 0;
1001     CODE:
1002         /* Class method only */
1003         if (SvROK(ST(0)))
1004             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1005         classname = (char *)SvPV_nolen(ST(0));
1006
1007         if ((items < 2) || ! SvOK(ST(1))) {
1008             XSRETURN_UNDEF;
1009         }
1010
1011         /* threads->object($tid) */
1012         tid = SvUV(ST(1));
1013
1014         /* Walk through threads list */
1015         MUTEX_LOCK(&create_destruct_mutex);
1016         for (thread = threads->next;
1017              thread != threads;
1018              thread = thread->next)
1019         {
1020             /* Look for TID, but ignore detached or joined threads */
1021             if ((thread->tid != tid) ||
1022                 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
1023             {
1024                 continue;
1025             }
1026             /* Put object on stack */
1027             ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1028             found = 1;
1029             break;
1030         }
1031         MUTEX_UNLOCK(&create_destruct_mutex);
1032         if (! found) {
1033             XSRETURN_UNDEF;
1034         }
1035         /* XSRETURN(1); - implied */
1036
1037
1038 void
1039 ithread__handle(...);
1040     PREINIT:
1041         ithread *thread;
1042     CODE:
1043         thread = SV_to_ithread(aTHX_ ST(0));
1044 #ifdef WIN32
1045         XST_mUV(0, PTR2UV(&thread->handle));
1046 #else
1047         XST_mUV(0, PTR2UV(&thread->thr));
1048 #endif
1049         /* XSRETURN(1); - implied */
1050
1051
1052 void
1053 ithread_get_stack_size(...)
1054     PREINIT:
1055         IV stack_size;
1056     CODE:
1057         if (sv_isobject(ST(0))) {
1058             /* $thr->get_stack_size() */
1059             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1060             stack_size = thread->stack_size;
1061         } else {
1062             /* threads->get_stack_size() */
1063             stack_size = default_stack_size;
1064         }
1065         XST_mIV(0, stack_size);
1066         /* XSRETURN(1); - implied */
1067
1068
1069 void
1070 ithread_set_stack_size(...)
1071     PREINIT:
1072         IV old_size;
1073     CODE:
1074         if (items != 2)
1075             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1076         if (sv_isobject(ST(0)))
1077             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1078
1079         old_size = default_stack_size;
1080         default_stack_size = good_stack_size(aTHX_ SvIV(ST(1)));
1081         XST_mIV(0, old_size);
1082         /* XSRETURN(1); - implied */
1083
1084 #endif /* USE_ITHREADS */
1085
1086
1087 BOOT:
1088 {
1089 #ifdef USE_ITHREADS
1090     /* The 'main' thread is thread 0.
1091      * It is detached (unjoinable) and immortal.
1092      */
1093
1094     ithread *thread;
1095     MY_CXT_INIT;
1096
1097     PL_perl_destruct_level = 2;
1098     MUTEX_INIT(&create_destruct_mutex);
1099     MUTEX_LOCK(&create_destruct_mutex);
1100
1101     PL_threadhook = &Perl_ithread_hook;
1102
1103     thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
1104     if (! thread) {
1105         PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
1106         my_exit(1);
1107     }
1108     Zero(thread, 1, ithread);
1109
1110     PL_perl_destruct_level = 2;
1111     MUTEX_INIT(&thread->mutex);
1112
1113     thread->tid = tid_counter++;        /* Thread 0 */
1114
1115     /* Head of the threads list */
1116     threads = thread;
1117     thread->next = thread;
1118     thread->prev = thread;
1119
1120     thread->count = 1;                  /* Immortal */
1121
1122     thread->interp = aTHX;
1123     thread->state = PERL_ITHR_DETACHED; /* Detached */
1124     thread->stack_size = default_stack_size;
1125 #  ifdef WIN32
1126     thread->thr = GetCurrentThreadId();
1127 #  else
1128     thread->thr = pthread_self();
1129 #  endif
1130
1131     active_threads++;
1132
1133     S_ithread_set(aTHX_ thread);
1134     MUTEX_UNLOCK(&create_destruct_mutex);
1135 #endif /* USE_ITHREADS */
1136 }