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