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