ext/threads/threads.xs

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