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