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             if (! pthread_attr_getstacksize(&attr, &stacksize)) {
 624                 if (stacksize) {
 625                     thread->stack_size = (IV)stacksize;
 626                 }
 627             }
 628         }
 629 #  endif
 630     }
 631 #endif
 632
 633     /* Check for errors */
 634 #ifdef WIN32
 635     if (thread->handle == NULL) {
 636 #else
 637     if (rc_stack_size || rc_thread_create) {
 638 #endif
 639         MUTEX_UNLOCK(&create_destruct_mutex);
 640         sv_2mortal(params);
 641         S_ithread_destruct(aTHX_ thread);
 642 #ifndef WIN32
 643         if (ckWARN_d(WARN_THREADS)) {
 644             if (rc_stack_size)
 645                 Perl_warn(aTHX_ "Thread creation failed: pthread_attr_setstacksize(%" IVdf ") returned %d", thread->stack_size, rc_stack_size);
 646             else
 647                 Perl_warn(aTHX_ "Thread creation failed: pthread_create returned %d", rc_thread_create);
 648         }
 649 #endif
 650         return (&PL_sv_undef);
 651     }
 652
 653     active_threads++;
 654     MUTEX_UNLOCK(&create_destruct_mutex);
 655
 656     sv_2mortal(params);
 657
 658     return (ithread_to_SV(aTHX_ obj, thread, classname, FALSE));
 659 }
 660
 661 #endif /* USE_ITHREADS */
 662
 663
 664 MODULE = threads    PACKAGE = threads    PREFIX = ithread_
 665 PROTOTYPES: DISABLE
 666
 667 #ifdef USE_ITHREADS
 668
 669 void
 670 ithread_create(...)
 671     PREINIT:
 672         char *classname;
 673         ithread *thread;
 674         SV *function_to_call;
 675         AV *params;
 676         HV *specs;
 677         IV stack_size;
 678         int context;
 679         char *str;
 680         char ch;
 681         int idx;
 682         int ii;
 683     CODE:
 684         if ((items >= 2) && SvROK(ST(1)) && SvTYPE(SvRV(ST(1)))==SVt_PVHV) {
 685             if (--items < 2)
 686                 Perl_croak(aTHX_ "Usage: threads->create(\\%specs, function, ...)");
 687             specs = (HV*)SvRV(ST(1));
 688             idx = 1;
 689         } else {
 690             if (items < 2)
 691                 Perl_croak(aTHX_ "Usage: threads->create(function, ...)");
 692             specs = NULL;
 693             idx = 0;
 694         }
 695
 696         if (sv_isobject(ST(0))) {
 697             /* $thr->create() */
 698             classname = HvNAME(SvSTASH(SvRV(ST(0))));
 699             thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
 700             stack_size = thread->stack_size;
 701         } else {
 702             /* threads->create() */
 703             classname = (char *)SvPV_nolen(ST(0));
 704             stack_size = default_stack_size;
 705         }
 706
 707         function_to_call = ST(idx+1);
 708
 709         context = -1;
 710         if (specs) {
 711             /* stack_size */
 712             if (hv_exists(specs, "stack", 5)) {
 713                 stack_size = SvIV(*hv_fetch(specs, "stack", 5, 0));
 714             } else if (hv_exists(specs, "stacksize", 9)) {
 715                 stack_size = SvIV(*hv_fetch(specs, "stacksize", 9, 0));
 716             } else if (hv_exists(specs, "stack_size", 10)) {
 717                 stack_size = SvIV(*hv_fetch(specs, "stack_size", 10, 0));
 718             }
 719
 720             /* context */
 721             if (hv_exists(specs, "context", 7)) {
 722                 str = (char *)SvPV_nolen(*hv_fetch(specs, "context", 7, 0));
 723                 switch (*str) {
 724                     case 'a':
 725                     case 'A':
 726                         context = G_ARRAY;
 727                         break;
 728                     case 's':
 729                     case 'S':
 730                         context = G_SCALAR;
 731                         break;
 732                     case 'v':
 733                     case 'V':
 734                         context = G_VOID;
 735                         break;
 736                     default:
 737                         Perl_croak(aTHX_ "Invalid context: %s", str);
 738                 }
 739             } else if (hv_exists(specs, "array", 5)) {
 740                 if (SvTRUE(*hv_fetch(specs, "array", 5, 0))) {
 741                     context = G_ARRAY;
 742                 }
 743             } else if (hv_exists(specs, "scalar", 6)) {
 744                 if (SvTRUE(*hv_fetch(specs, "scalar", 6, 0))) {
 745                     context = G_SCALAR;
 746                 }
 747             } else if (hv_exists(specs, "void", 4)) {
 748                 if (SvTRUE(*hv_fetch(specs, "void", 4, 0))) {
 749                     context = G_VOID;
 750                 }
 751             }
 752         }
 753         if (context == -1) {
 754             context = GIMME_V;  /* Implicit context */
 755         } else {
 756             context |= (GIMME_V & (~(G_ARRAY|G_SCALAR|G_VOID)));
 757         }
 758
 759         /* Function args */
 760         params = newAV();
 761         if (items > 2) {
 762             for (ii=2; ii < items ; ii++) {
 763                 av_push(params, SvREFCNT_inc(ST(idx+ii)));
 764             }
 765         }
 766
 767         /* Create thread */
 768         ST(0) = sv_2mortal(S_ithread_create(aTHX_ Nullsv,
 769                                             classname,
 770                                             function_to_call,
 771                                             stack_size,
 772                                             context,
 773                                             newRV_noinc((SV*)params)));
 774         /* XSRETURN(1); - implied */
 775
 776
 777 void
 778 ithread_list(...)
 779     PREINIT:
 780         char *classname;
 781         ithread *thread;
 782         int list_context;
 783         IV count = 0;
 784     PPCODE:
 785         /* Class method only */
 786         if (SvROK(ST(0)))
 787             Perl_croak(aTHX_ "Usage: threads->list()");
 788         classname = (char *)SvPV_nolen(ST(0));
 789
 790         /* Calling context */
 791         list_context = (GIMME_V == G_ARRAY);
 792
 793         /* Walk through threads list */
 794         MUTEX_LOCK(&create_destruct_mutex);
 795         for (thread = threads->next;
 796              thread != threads;
 797              thread = thread->next)
 798         {
 799             /* Ignore detached or joined threads */
 800             if (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)) {
 801                 continue;
 802             }
 803             /* Push object on stack if list context */
 804             if (list_context) {
 805                 XPUSHs(sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE)));
 806             }
 807             count++;
 808         }
 809         MUTEX_UNLOCK(&create_destruct_mutex);
 810         /* If scalar context, send back count */
 811         if (! list_context) {
 812             XSRETURN_IV(count);
 813         }
 814
 815
 816 void
 817 ithread_self(...)
 818     PREINIT:
 819         char *classname;
 820         ithread *thread;
 821     CODE:
 822         /* Class method only */
 823         if (SvROK(ST(0)))
 824             Perl_croak(aTHX_ "Usage: threads->self()");
 825         classname = (char *)SvPV_nolen(ST(0));
 826
 827         thread = S_ithread_get(aTHX);
 828
 829         ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
 830         /* XSRETURN(1); - implied */
 831
 832
 833 void
 834 ithread_tid(...)
 835     PREINIT:
 836         ithread *thread;
 837     CODE:
 838         thread = SV_to_ithread(aTHX_ ST(0));
 839         XST_mUV(0, thread->tid);
 840         /* XSRETURN(1); - implied */
 841
 842
 843 void
 844 ithread_join(...)
 845     PREINIT:
 846         ithread *thread;
 847         int join_err;
 848         AV *params;
 849         int len;
 850         int ii;
 851 #ifdef WIN32
 852         DWORD waitcode;
 853 #else
 854         void *retval;
 855 #endif
 856     PPCODE:
 857         /* Object method only */
 858         if (! sv_isobject(ST(0)))
 859             Perl_croak(aTHX_ "Usage: $thr->join()");
 860
 861         /* Check if the thread is joinable */
 862         thread = SV_to_ithread(aTHX_ ST(0));
 863         MUTEX_LOCK(&thread->mutex);
 864         join_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED));
 865         MUTEX_UNLOCK(&thread->mutex);
 866         if (join_err) {
 867             if (join_err & PERL_ITHR_DETACHED) {
 868                 Perl_croak(aTHX_ "Cannot join a detached thread");
 869             } else {
 870                 Perl_croak(aTHX_ "Thread already joined");
 871             }
 872         }
 873
 874         /* Join the thread */
 875 #ifdef WIN32
 876         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 877 #else
 878         pthread_join(thread->thr, &retval);
 879 #endif
 880
 881         MUTEX_LOCK(&thread->mutex);
 882         /* Mark as joined */
 883         thread->state |= PERL_ITHR_JOINED;
 884
 885         /* Get the return value from the call_sv */
 886         {
 887             AV *params_copy;
 888             PerlInterpreter *other_perl;
 889             CLONE_PARAMS clone_params;
 890             ithread *current_thread;
 891
 892             params_copy = (AV *)SvRV(thread->params);
 893             other_perl = thread->interp;
 894             clone_params.stashes = newAV();
 895             clone_params.flags = CLONEf_JOIN_IN;
 896             PL_ptr_table = ptr_table_new();
 897             current_thread = S_ithread_get(aTHX);
 898             S_ithread_set(aTHX_ thread);
 899             /* Ensure 'meaningful' addresses retain their meaning */
 900             ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
 901             ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
 902             ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
 903             params = (AV *)sv_dup((SV*)params_copy, &clone_params);
 904             S_ithread_set(aTHX_ current_thread);
 905             SvREFCNT_dec(clone_params.stashes);
 906             SvREFCNT_inc(params);
 907             ptr_table_free(PL_ptr_table);
 908             PL_ptr_table = NULL;
 909         }
 910
 911         /* We are finished with the thread */
 912         S_ithread_clear(aTHX_ thread);
 913         MUTEX_UNLOCK(&thread->mutex);
 914
 915         /* If no return values, then just return */
 916         if (! params) {
 917             XSRETURN_UNDEF;
 918         }
 919
 920         /* Put return values on stack */
 921         len = (int)AvFILL(params);
 922         for (ii=0; ii <= len; ii++) {
 923             SV* param = av_shift(params);
 924             XPUSHs(sv_2mortal(param));
 925         }
 926
 927         /* Free return value array */
 928         SvREFCNT_dec(params);
 929
 930
 931 void
 932 ithread_yield(...)
 933     CODE:
 934         YIELD;
 935
 936
 937 void
 938 ithread_detach(...)
 939     PREINIT:
 940         ithread *thread;
 941         int detach_err;
 942         int cleanup;
 943     CODE:
 944         thread = SV_to_ithread(aTHX_ ST(0));
 945         MUTEX_LOCK(&thread->mutex);
 946
 947         /* Check if the thread is detachable */
 948         if ((detach_err = (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))) {
 949             MUTEX_UNLOCK(&thread->mutex);
 950             if (detach_err & PERL_ITHR_DETACHED) {
 951                 Perl_croak(aTHX_ "Thread already detached");
 952             } else {
 953                 Perl_croak(aTHX_ "Cannot detach a joined thread");
 954             }
 955         }
 956
 957         /* Detach the thread */
 958         thread->state |= PERL_ITHR_DETACHED;
 959 #ifdef WIN32
 960         /* Windows has no 'detach thread' function */
 961 #else
 962         PERL_THREAD_DETACH(thread->thr);
 963 #endif
 964         /* Cleanup if finished */
 965         cleanup = (thread->state & PERL_ITHR_FINISHED);
 966         MUTEX_UNLOCK(&thread->mutex);
 967
 968         if (cleanup)
 969             S_ithread_destruct(aTHX_ thread);
 970
 971
 972 void
 973 ithread_kill(...)
 974     PREINIT:
 975         ithread *thread;
 976         char *sig_name;
 977         IV signal;
 978     CODE:
 979         /* Must have safe signals */
 980         if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
 981             Perl_croak(aTHX_ "Cannot signal other threads without safe signals");
 982
 983         /* Object method only */
 984         if (! sv_isobject(ST(0)))
 985             Perl_croak(aTHX_ "Usage: $thr->kill('SIG...')");
 986
 987         /* Get thread */
 988         thread = SV_to_ithread(aTHX_ ST(0));
 989
 990         /* Get signal */
 991         sig_name = SvPV_nolen(ST(1));
 992         if (isALPHA(*sig_name)) {
 993             if (*sig_name == 'S' && sig_name[1] == 'I' && sig_name[2] == 'G')
 994                 sig_name += 3;
 995             if ((signal = whichsig(sig_name)) < 0)
 996                 Perl_croak(aTHX_ "Unrecognized signal name: %s", sig_name);
 997         } else
 998             signal = SvIV(ST(1));
 999
1000         /* Set the signal for the thread */
1001         {
1002             dTHXa(thread->interp);
1003             PL_psig_pend[signal]++;
1004             PL_sig_pending = 1;
1005         }
1006
1007         /* Return the thread to allow for method chaining */
1008         ST(0) = ST(0);
1009         /* XSRETURN(1); - implied */
1010
1011
1012 void
1013 ithread_DESTROY(...)
1014     CODE:
1015         sv_unmagic(SvRV(ST(0)), PERL_MAGIC_shared_scalar);
1016
1017
1018 void
1019 ithread_equal(...)
1020     PREINIT:
1021         int are_equal = 0;
1022     CODE:
1023         /* Compares TIDs to determine thread equality */
1024         if (sv_isobject(ST(0)) && sv_isobject(ST(1))) {
1025             ithread *thr1 = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1026             ithread *thr2 = INT2PTR(ithread *, SvIV(SvRV(ST(1))));
1027             are_equal = (thr1->tid == thr2->tid);
1028         }
1029         if (are_equal) {
1030             XST_mYES(0);
1031         } else {
1032             /* Return 0 on false for backward compatibility */
1033             XST_mIV(0, 0);
1034         }
1035         /* XSRETURN(1); - implied */
1036
1037
1038 void
1039 ithread_object(...)
1040     PREINIT:
1041         char *classname;
1042         UV tid;
1043         ithread *thread;
1044         int found = 0;
1045     CODE:
1046         /* Class method only */
1047         if (SvROK(ST(0)))
1048             Perl_croak(aTHX_ "Usage: threads->object($tid)");
1049         classname = (char *)SvPV_nolen(ST(0));
1050
1051         if ((items < 2) || ! SvOK(ST(1))) {
1052             XSRETURN_UNDEF;
1053         }
1054
1055         /* threads->object($tid) */
1056         tid = SvUV(ST(1));
1057
1058         /* Walk through threads list */
1059         MUTEX_LOCK(&create_destruct_mutex);
1060         for (thread = threads->next;
1061              thread != threads;
1062              thread = thread->next)
1063         {
1064             /* Look for TID, but ignore detached or joined threads */
1065             if ((thread->tid != tid) ||
1066                 (thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED)))
1067             {
1068                 continue;
1069             }
1070             /* Put object on stack */
1071             ST(0) = sv_2mortal(ithread_to_SV(aTHX_ Nullsv, thread, classname, TRUE));
1072             found = 1;
1073             break;
1074         }
1075         MUTEX_UNLOCK(&create_destruct_mutex);
1076         if (! found) {
1077             XSRETURN_UNDEF;
1078         }
1079         /* XSRETURN(1); - implied */
1080
1081
1082 void
1083 ithread__handle(...);
1084     PREINIT:
1085         ithread *thread;
1086     CODE:
1087         thread = SV_to_ithread(aTHX_ ST(0));
1088 #ifdef WIN32
1089         XST_mUV(0, PTR2UV(&thread->handle));
1090 #else
1091         XST_mUV(0, PTR2UV(&thread->thr));
1092 #endif
1093         /* XSRETURN(1); - implied */
1094
1095
1096 void
1097 ithread_get_stack_size(...)
1098     PREINIT:
1099         IV stack_size;
1100     CODE:
1101         if (sv_isobject(ST(0))) {
1102             /* $thr->get_stack_size() */
1103             ithread *thread = INT2PTR(ithread *, SvIV(SvRV(ST(0))));
1104             stack_size = thread->stack_size;
1105         } else {
1106             /* threads->get_stack_size() */
1107             stack_size = default_stack_size;
1108         }
1109         XST_mIV(0, stack_size);
1110         /* XSRETURN(1); - implied */
1111
1112
1113 void
1114 ithread_set_stack_size(...)
1115     PREINIT:
1116         IV old_size;
1117     CODE:
1118         if (items != 2)
1119             Perl_croak(aTHX_ "Usage: threads->set_stack_size($size)");
1120         if (sv_isobject(ST(0)))
1121             Perl_croak(aTHX_ "Cannot change stack size of an existing thread");
1122
1123         old_size = default_stack_size;
1124         default_stack_size = good_stack_size(aTHX_ SvIV(ST(1)));
1125         XST_mIV(0, old_size);
1126         /* XSRETURN(1); - implied */
1127
1128 #endif /* USE_ITHREADS */
1129
1130
1131 BOOT:
1132 {
1133 #ifdef USE_ITHREADS
1134     /* The 'main' thread is thread 0.
1135      * It is detached (unjoinable) and immortal.
1136      */
1137
1138     ithread *thread;
1139     MY_CXT_INIT;
1140
1141     PL_perl_destruct_level = 2;
1142     MUTEX_INIT(&create_destruct_mutex);
1143     MUTEX_LOCK(&create_destruct_mutex);
1144
1145     PL_threadhook = &Perl_ithread_hook;
1146
1147     thread = (ithread *)PerlMemShared_malloc(sizeof(ithread));
1148     if (! thread) {
1149         PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem));
1150         my_exit(1);
1151     }
1152     Zero(thread, 1, ithread);
1153
1154     PL_perl_destruct_level = 2;
1155     MUTEX_INIT(&thread->mutex);
1156
1157     thread->tid = tid_counter++;        /* Thread 0 */
1158
1159     /* Head of the threads list */
1160     threads = thread;
1161     thread->next = thread;
1162     thread->prev = thread;
1163
1164     thread->count = 1;                  /* Immortal */
1165
1166     thread->interp = aTHX;
1167     thread->state = PERL_ITHR_DETACHED; /* Detached */
1168     thread->stack_size = default_stack_size;
1169 #  ifdef WIN32
1170     thread->thr = GetCurrentThreadId();
1171 #  else
1172     thread->thr = pthread_self();
1173 #  endif
1174
1175     active_threads++;
1176
1177     S_ithread_set(aTHX_ thread);
1178     MUTEX_UNLOCK(&create_destruct_mutex);
1179 #endif /* USE_ITHREADS */
1180 }