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