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