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