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