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