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