ext/threads/threads.xs

   1 #define PERL_NO_GET_CONTEXT
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 #ifdef USE_ITHREADS
   7
   8
   9 #ifdef WIN32
  10 #include <windows.h>
  11 #include <win32thread.h>
  12 #else
  13 #ifdef OS2
  14 typedef perl_os_thread pthread_t;
  15 #else
  16 #include <pthread.h>
  17 #endif
  18 #include <thread.h>
  19 #define PERL_THREAD_SETSPECIFIC(k,v) pthread_setspecific(k,v)
  20 #ifdef OLD_PTHREADS_API
  21 #define PERL_THREAD_DETACH(t) pthread_detach(&(t))
  22 #else
  23 #define PERL_THREAD_DETACH(t) pthread_detach((t))
  24 #endif  /* OLD_PTHREADS_API */
  25 #endif
  26
  27
  28
  29
  30 /* Values for 'state' member */
  31 #define PERL_ITHR_JOINABLE              0
  32 #define PERL_ITHR_DETACHED              1
  33 #define PERL_ITHR_FINISHED              4
  34 #define PERL_ITHR_JOINED                2
  35
  36 typedef struct ithread_s {
  37     struct ithread_s *next;     /* Next thread in the list */
  38     struct ithread_s *prev;     /* Prev thread in the list */
  39     PerlInterpreter *interp;    /* The threads interpreter */
  40     I32 tid;                    /* Threads module's thread id */
  41     perl_mutex mutex;           /* Mutex for updating things in this struct */
  42     I32 count;                  /* How many SVs have a reference to us */
  43     signed char state;          /* Are we detached ? */
  44     int gimme;                  /* Context of create */
  45     SV* init_function;          /* Code to run */
  46     SV* params;                 /* Args to pass function */
  47 #ifdef WIN32
  48         DWORD   thr;            /* OS's idea if thread id */
  49         HANDLE handle;          /* OS's waitable handle */
  50 #else
  51         pthread_t thr;          /* OS's handle for the thread */
  52 #endif
  53 } ithread;
  54
  55 ithread *threads;
  56
  57 /* Macros to supply the aTHX_ in an embed.h like manner */
  58 #define ithread_join(thread)            Perl_ithread_join(aTHX_ thread)
  59 #define ithread_DESTROY(thread)         Perl_ithread_DESTROY(aTHX_ thread)
  60 #define ithread_CLONE(thread)           Perl_ithread_CLONE(aTHX_ thread)
  61 #define ithread_detach(thread)          Perl_ithread_detach(aTHX_ thread)
  62 #define ithread_tid(thread)             ((thread)->tid)
  63 #define ithread_yield(thread)           (YIELD);
  64
  65 static perl_mutex create_destruct_mutex;  /* protects the creation and destruction of threads*/
  66
  67 I32 tid_counter = 0;
  68 I32 known_threads = 0;
  69 I32 active_threads = 0;
  70
  71
  72 void Perl_ithread_set (pTHX_ ithread* thread)
  73 {
  74   SV* thread_sv = newSViv(PTR2IV(thread));
  75   if(!hv_store(PL_modglobal, "threads::self", 12, thread_sv,0)) {
  76     croak("%s\n","Internal error, couldn't set TLS");
  77   }
  78 }
  79
  80 ithread* Perl_ithread_get (pTHX) {
  81   SV** thread_sv = hv_fetch(PL_modglobal, "threads::self",12,0);
  82   if(!thread_sv) {
  83     croak("%s\n","Internal error, couldn't get TLS");
  84   }
  85   return INT2PTR(ithread*,SvIV(*thread_sv));
  86 }
  87
  88
  89
  90 /*
  91  *  Clear up after thread is done with
  92  */
  93 void
  94 Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
  95 {
  96         PerlInterpreter *freeperl = NULL;
  97         MUTEX_LOCK(&thread->mutex);
  98         if (!thread->next) {
  99             MUTEX_UNLOCK(&thread->mutex);
 100             Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
 101         }
 102         if (thread->count != 0) {
 103                 MUTEX_UNLOCK(&thread->mutex);
 104                 return;
 105         }
 106         MUTEX_LOCK(&create_destruct_mutex);
 107         /* Remove from circular list of threads */
 108         if (thread->next == thread) {
 109             /* last one should never get here ? */
 110             threads = NULL;
 111         }
 112         else {
 113             thread->next->prev = thread->prev;
 114             thread->prev->next = thread->next;
 115             if (threads == thread) {
 116                 threads = thread->next;
 117             }
 118             thread->next = NULL;
 119             thread->prev = NULL;
 120         }
 121         known_threads--;
 122         assert( known_threads >= 0 );
 123 #if 0
 124         Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
 125                   thread->tid,thread->interp,aTHX, known_threads);
 126 #endif
 127         MUTEX_UNLOCK(&create_destruct_mutex);
 128         /* Thread is now disowned */
 129
 130         if(thread->interp) {
 131             dTHXa(thread->interp);
 132             ithread*        current_thread;
 133 #ifdef OEMVS
 134             void *ptr;
 135 #endif
 136             PERL_SET_CONTEXT(thread->interp);
 137             current_thread = Perl_ithread_get(aTHX);
 138             Perl_ithread_set(aTHX_ thread);
 139
 140
 141
 142
 143             SvREFCNT_dec(thread->params);
 144
 145
 146
 147             thread->params = Nullsv;
 148             perl_destruct(thread->interp);
 149             freeperl = thread->interp;
 150             thread->interp = NULL;
 151         }
 152         MUTEX_UNLOCK(&thread->mutex);
 153         MUTEX_DESTROY(&thread->mutex);
 154 #ifdef WIN32
 155         if (thread->handle)
 156             CloseHandle(thread->handle);
 157         thread->handle = 0;
 158 #endif
 159         PerlMemShared_free(thread);
 160         if (freeperl)
 161             perl_free(freeperl);
 162
 163         PERL_SET_CONTEXT(aTHX);
 164 }
 165
 166 int
 167 Perl_ithread_hook(pTHX)
 168 {
 169     int veto_cleanup = 0;
 170     MUTEX_LOCK(&create_destruct_mutex);
 171     if (aTHX == PL_curinterp && active_threads != 1) {
 172         if (ckWARN_d(WARN_THREADS))
 173             Perl_warn(aTHX_ "A thread exited while %" IVdf " threads were running",
 174                                                       (IV)active_threads);
 175         veto_cleanup = 1;
 176     }
 177     MUTEX_UNLOCK(&create_destruct_mutex);
 178     return veto_cleanup;
 179 }
 180
 181 void
 182 Perl_ithread_detach(pTHX_ ithread *thread)
 183 {
 184     MUTEX_LOCK(&thread->mutex);
 185     if (!(thread->state & (PERL_ITHR_DETACHED|PERL_ITHR_JOINED))) {
 186         thread->state |= PERL_ITHR_DETACHED;
 187 #ifdef WIN32
 188         CloseHandle(thread->handle);
 189         thread->handle = 0;
 190 #else
 191         PERL_THREAD_DETACH(thread->thr);
 192 #endif
 193     }
 194     if ((thread->state & PERL_ITHR_FINISHED) &&
 195         (thread->state & PERL_ITHR_DETACHED)) {
 196         MUTEX_UNLOCK(&thread->mutex);
 197         Perl_ithread_destruct(aTHX_ thread, "detach");
 198     }
 199     else {
 200         MUTEX_UNLOCK(&thread->mutex);
 201     }
 202 }
 203
 204 /* MAGIC (in mg.h sense) hooks */
 205
 206 int
 207 ithread_mg_get(pTHX_ SV *sv, MAGIC *mg)
 208 {
 209     ithread *thread = (ithread *) mg->mg_ptr;
 210     SvIV_set(sv, PTR2IV(thread));
 211     SvIOK_on(sv);
 212     return 0;
 213 }
 214
 215 int
 216 ithread_mg_free(pTHX_ SV *sv, MAGIC *mg)
 217 {
 218     ithread *thread = (ithread *) mg->mg_ptr;
 219     MUTEX_LOCK(&thread->mutex);
 220     thread->count--;
 221     if (thread->count == 0) {
 222        if(thread->state & PERL_ITHR_FINISHED &&
 223           (thread->state & PERL_ITHR_DETACHED ||
 224            thread->state & PERL_ITHR_JOINED))
 225        {
 226             MUTEX_UNLOCK(&thread->mutex);
 227             Perl_ithread_destruct(aTHX_ thread, "no reference");
 228        }
 229        else {
 230             MUTEX_UNLOCK(&thread->mutex);
 231        }
 232     }
 233     else {
 234         MUTEX_UNLOCK(&thread->mutex);
 235     }
 236     return 0;
 237 }
 238
 239 int
 240 ithread_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *param)
 241 {
 242     ithread *thread = (ithread *) mg->mg_ptr;
 243     MUTEX_LOCK(&thread->mutex);
 244     thread->count++;
 245     MUTEX_UNLOCK(&thread->mutex);
 246     return 0;
 247 }
 248
 249 MGVTBL ithread_vtbl = {
 250  ithread_mg_get,        /* get */
 251  0,                     /* set */
 252  0,                     /* len */
 253  0,                     /* clear */
 254  ithread_mg_free,       /* free */
 255  0,                     /* copy */
 256  ithread_mg_dup         /* dup */
 257 };
 258
 259
 260 /*
 261  *      Starts executing the thread. Needs to clean up memory a tad better.
 262  *      Passed as the C level function to run in the new thread
 263  */
 264
 265 #ifdef WIN32
 266 THREAD_RET_TYPE
 267 Perl_ithread_run(LPVOID arg) {
 268 #else
 269 void*
 270 Perl_ithread_run(void * arg) {
 271 #endif
 272         ithread* thread = (ithread*) arg;
 273         dTHXa(thread->interp);
 274         PERL_SET_CONTEXT(thread->interp);
 275         Perl_ithread_set(aTHX_ thread);
 276
 277 #if 0
 278         /* Far from clear messing with ->thr child-side is a good idea */
 279         MUTEX_LOCK(&thread->mutex);
 280 #ifdef WIN32
 281         thread->thr = GetCurrentThreadId();
 282 #else
 283         thread->thr = pthread_self();
 284 #endif
 285         MUTEX_UNLOCK(&thread->mutex);
 286 #endif
 287
 288         PL_perl_destruct_level = 2;
 289
 290         {
 291                 AV* params = (AV*) SvRV(thread->params);
 292                 I32 len = av_len(params)+1;
 293                 int i;
 294                 dSP;
 295                 ENTER;
 296                 SAVETMPS;
 297                 PUSHMARK(SP);
 298                 for(i = 0; i < len; i++) {
 299                     XPUSHs(av_shift(params));
 300                 }
 301                 PUTBACK;
 302                 len = call_sv(thread->init_function, thread->gimme|G_EVAL);
 303
 304                 SPAGAIN;
 305                 for (i=len-1; i >= 0; i--) {
 306                   SV *sv = POPs;
 307                   av_store(params, i, SvREFCNT_inc(sv));
 308                 }
 309                 if (SvTRUE(ERRSV) && ckWARN_d(WARN_THREADS)) {
 310                     Perl_warn(aTHX_ "thread failed to start: %" SVf, ERRSV);
 311                 }
 312                 FREETMPS;
 313                 LEAVE;
 314                 SvREFCNT_dec(thread->init_function);
 315         }
 316
 317         PerlIO_flush((PerlIO*)NULL);
 318         MUTEX_LOCK(&thread->mutex);
 319         thread->state |= PERL_ITHR_FINISHED;
 320
 321         if (thread->state & PERL_ITHR_DETACHED) {
 322                 MUTEX_UNLOCK(&thread->mutex);
 323                 Perl_ithread_destruct(aTHX_ thread, "detached finish");
 324         } else {
 325                 MUTEX_UNLOCK(&thread->mutex);
 326         }
 327         MUTEX_LOCK(&create_destruct_mutex);
 328         active_threads--;
 329         assert( active_threads >= 0 );
 330         MUTEX_UNLOCK(&create_destruct_mutex);
 331
 332 #ifdef WIN32
 333         return (DWORD)0;
 334 #else
 335         return 0;
 336 #endif
 337 }
 338
 339 SV *
 340 ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc)
 341 {
 342     SV *sv;
 343     MAGIC *mg;
 344     if (inc) {
 345         MUTEX_LOCK(&thread->mutex);
 346         thread->count++;
 347         MUTEX_UNLOCK(&thread->mutex);
 348     }
 349     if (!obj)
 350      obj = newSV(0);
 351     sv = newSVrv(obj,classname);
 352     sv_setiv(sv,PTR2IV(thread));
 353     mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0);
 354     mg->mg_flags |= MGf_DUP;
 355     SvREADONLY_on(sv);
 356     return obj;
 357 }
 358
 359 ithread *
 360 SV_to_ithread(pTHX_ SV *sv)
 361 {
 362     if (SvROK(sv))
 363      {
 364       return INT2PTR(ithread*, SvIV(SvRV(sv)));
 365      }
 366     else
 367      {
 368       return Perl_ithread_get(aTHX);
 369      }
 370 }
 371
 372 /*
 373  * ithread->create(); ( aka ithread->new() )
 374  * Called in context of parent thread
 375  */
 376
 377 SV *
 378 Perl_ithread_create(pTHX_ SV *obj, char* classname, SV* init_function, SV* params)
 379 {
 380         ithread*        thread;
 381         CLONE_PARAMS    clone_param;
 382         ithread*        current_thread = Perl_ithread_get(aTHX);
 383
 384         SV**            tmps_tmp = PL_tmps_stack;
 385         I32             tmps_ix  = PL_tmps_ix;
 386 #ifndef WIN32
 387         int             failure;
 388         const char*     panic = NULL;
 389 #endif
 390
 391
 392         MUTEX_LOCK(&create_destruct_mutex);
 393         thread = (ithread *) PerlMemShared_malloc(sizeof(ithread));
 394         if (!thread) {
 395             MUTEX_UNLOCK(&create_destruct_mutex);
 396             PerlLIO_write(PerlIO_fileno(Perl_error_log),
 397                           PL_no_mem, strlen(PL_no_mem));
 398             my_exit(1);
 399         }
 400         Zero(thread,1,ithread);
 401         thread->next = threads;
 402         thread->prev = threads->prev;
 403         threads->prev = thread;
 404         thread->prev->next = thread;
 405         /* Set count to 1 immediately in case thread exits before
 406          * we return to caller !
 407          */
 408         thread->count = 1;
 409         MUTEX_INIT(&thread->mutex);
 410         thread->tid = tid_counter++;
 411         thread->gimme = GIMME_V;
 412
 413         /* "Clone" our interpreter into the thread's interpreter
 414          * This gives thread access to "static data" and code.
 415          */
 416
 417         PerlIO_flush((PerlIO*)NULL);
 418         Perl_ithread_set(aTHX_ thread);
 419
 420         SAVEBOOL(PL_srand_called); /* Save this so it becomes the correct
 421                                       value */
 422         PL_srand_called = FALSE; /* Set it to false so we can detect
 423                                     if it gets set during the clone */
 424
 425 #ifdef WIN32
 426         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE | CLONEf_CLONE_HOST);
 427 #else
 428         thread->interp = perl_clone(aTHX, CLONEf_KEEP_PTR_TABLE);
 429 #endif
 430         /* perl_clone leaves us in new interpreter's context.
 431            As it is tricky to spot an implicit aTHX, create a new scope
 432            with aTHX matching the context for the duration of
 433            our work for new interpreter.
 434          */
 435         {
 436             dTHXa(thread->interp);
 437
 438             /* Here we remove END blocks since they should only run
 439                in the thread they are created
 440             */
 441             SvREFCNT_dec(PL_endav);
 442             PL_endav = newAV();
 443             clone_param.flags = 0;
 444             thread->init_function = sv_dup(init_function, &clone_param);
 445             if (SvREFCNT(thread->init_function) == 0) {
 446                 SvREFCNT_inc(thread->init_function);
 447             }
 448
 449
 450
 451             thread->params = sv_dup(params, &clone_param);
 452             SvREFCNT_inc(thread->params);
 453
 454
 455             /* The code below checks that anything living on
 456                the tmps stack and has been cloned (so it lives in the
 457                ptr_table) has a refcount higher than 0
 458
 459                If the refcount is 0 it means that a something on the
 460                stack/context was holding a reference to it and
 461                since we init_stacks() in perl_clone that won't get
 462                cleaned and we will get a leaked scalar.
 463                The reason it was cloned was that it lived on the
 464                @_ stack.
 465
 466                Example of this can be found in bugreport 15837
 467                where calls in the parameter list end up as a temp
 468
 469                One could argue that this fix should be in perl_clone
 470             */
 471
 472
 473             while (tmps_ix > 0) {
 474               SV* sv = (SV*)ptr_table_fetch(PL_ptr_table, tmps_tmp[tmps_ix]);
 475               tmps_ix--;
 476               if (sv && SvREFCNT(sv) == 0) {
 477                 SvREFCNT_inc(sv);
 478                 SvREFCNT_dec(sv);
 479               }
 480             }
 481
 482
 483
 484             SvTEMP_off(thread->init_function);
 485             ptr_table_free(PL_ptr_table);
 486             PL_ptr_table = NULL;
 487             PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
 488         }
 489         Perl_ithread_set(aTHX_ current_thread);
 490         PERL_SET_CONTEXT(aTHX);
 491
 492         /* Start the thread */
 493
 494 #ifdef WIN32
 495         thread->handle = CreateThread(NULL, 0, Perl_ithread_run,
 496                         (LPVOID)thread, 0, &thread->thr);
 497 #else
 498         {
 499           static pthread_attr_t attr;
 500           static int attr_inited = 0;
 501           static int attr_joinable = PTHREAD_CREATE_JOINABLE;
 502           if (!attr_inited) {
 503             attr_inited = 1;
 504             pthread_attr_init(&attr);
 505           }
 506 #  ifdef PTHREAD_ATTR_SETDETACHSTATE
 507             PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
 508 #  endif
 509 #  ifdef THREAD_CREATE_NEEDS_STACK
 510             if(pthread_attr_setstacksize(&attr, THREAD_CREATE_NEEDS_STACK))
 511               panic = "panic: pthread_attr_setstacksize failed";
 512 #  endif
 513
 514 #ifdef OLD_PTHREADS_API
 515             failure
 516               = panic ? 1 : pthread_create( &thread->thr, attr,
 517                                             Perl_ithread_run, (void *)thread);
 518 #else
 519 #  if defined(HAS_PTHREAD_ATTR_SETSCOPE) && defined(PTHREAD_SCOPE_SYSTEM)
 520           pthread_attr_setscope( &attr, PTHREAD_SCOPE_SYSTEM );
 521 #  endif
 522           failure
 523             = panic ? 1 : pthread_create( &thread->thr, &attr,
 524                                           Perl_ithread_run, (void *)thread);
 525 #endif
 526         }
 527 #endif
 528         known_threads++;
 529         if (
 530 #ifdef WIN32
 531             thread->handle == NULL
 532 #else
 533             failure
 534 #endif
 535             ) {
 536           MUTEX_UNLOCK(&create_destruct_mutex);
 537           sv_2mortal(params);
 538           Perl_ithread_destruct(aTHX_ thread, "create failed");
 539 #ifndef WIN32
 540           if (panic)
 541             Perl_croak(aTHX_ panic);
 542 #endif
 543           return &PL_sv_undef;
 544         }
 545         active_threads++;
 546         MUTEX_UNLOCK(&create_destruct_mutex);
 547         sv_2mortal(params);
 548
 549         return ithread_to_SV(aTHX_ obj, thread, classname, FALSE);
 550 }
 551
 552 SV*
 553 Perl_ithread_self (pTHX_ SV *obj, char* Class)
 554 {
 555    ithread *thread = Perl_ithread_get(aTHX);
 556    if (thread)
 557         return ithread_to_SV(aTHX_ obj, thread, Class, TRUE);
 558    else
 559         Perl_croak(aTHX_ "panic: cannot find thread data");
 560    return NULL; /* silence compiler warning */
 561 }
 562
 563 /*
 564  * Joins the thread this code needs to take the returnvalue from the
 565  * call_sv and send it back
 566  */
 567
 568 void
 569 Perl_ithread_CLONE(pTHX_ SV *obj)
 570 {
 571     if (SvROK(obj)) {
 572         ithread *thread = SV_to_ithread(aTHX_ obj);
 573     }
 574     else if (ckWARN_d(WARN_THREADS)) {
 575         Perl_warn(aTHX_ "CLONE %" SVf,obj);
 576     }
 577 }
 578
 579 AV*
 580 Perl_ithread_join(pTHX_ SV *obj)
 581 {
 582     ithread *thread = SV_to_ithread(aTHX_ obj);
 583     MUTEX_LOCK(&thread->mutex);
 584     if (thread->state & PERL_ITHR_DETACHED) {
 585         MUTEX_UNLOCK(&thread->mutex);
 586         Perl_croak(aTHX_ "Cannot join a detached thread");
 587     }
 588     else if (thread->state & PERL_ITHR_JOINED) {
 589         MUTEX_UNLOCK(&thread->mutex);
 590         Perl_croak(aTHX_ "Thread already joined");
 591     }
 592     else {
 593         AV* retparam;
 594 #ifdef WIN32
 595         DWORD waitcode;
 596 #else
 597         void *retval;
 598 #endif
 599         MUTEX_UNLOCK(&thread->mutex);
 600 #ifdef WIN32
 601         waitcode = WaitForSingleObject(thread->handle, INFINITE);
 602         CloseHandle(thread->handle);
 603         thread->handle = 0;
 604 #else
 605         pthread_join(thread->thr,&retval);
 606 #endif
 607         MUTEX_LOCK(&thread->mutex);
 608
 609         /* sv_dup over the args */
 610         {
 611           ithread*        current_thread;
 612           AV* params = (AV*) SvRV(thread->params);
 613           PerlInterpreter *other_perl = thread->interp;
 614           CLONE_PARAMS clone_params;
 615           clone_params.stashes = newAV();
 616           clone_params.flags |= CLONEf_JOIN_IN;
 617           PL_ptr_table = ptr_table_new();
 618           current_thread = Perl_ithread_get(aTHX);
 619           Perl_ithread_set(aTHX_ thread);
 620           /* ensure 'meaningful' addresses retain their meaning */
 621           ptr_table_store(PL_ptr_table, &other_perl->Isv_undef, &PL_sv_undef);
 622           ptr_table_store(PL_ptr_table, &other_perl->Isv_no, &PL_sv_no);
 623           ptr_table_store(PL_ptr_table, &other_perl->Isv_yes, &PL_sv_yes);
 624
 625 #if 0
 626           {
 627             I32 len = av_len(params)+1;
 628             I32 i;
 629             for(i = 0; i < len; i++) {
 630               sv_dump(SvRV(AvARRAY(params)[i]));
 631             }
 632           }
 633 #endif
 634           retparam = (AV*) sv_dup((SV*)params, &clone_params);
 635 #if 0
 636           {
 637             I32 len = av_len(retparam)+1;
 638             I32 i;
 639             for(i = 0; i < len; i++) {
 640                 sv_dump(SvRV(AvARRAY(retparam)[i]));
 641             }
 642           }
 643 #endif
 644           Perl_ithread_set(aTHX_ current_thread);
 645           SvREFCNT_dec(clone_params.stashes);
 646           SvREFCNT_inc(retparam);
 647           ptr_table_free(PL_ptr_table);
 648           PL_ptr_table = NULL;
 649
 650         }
 651         /* We are finished with it */
 652         thread->state |= PERL_ITHR_JOINED;
 653         MUTEX_UNLOCK(&thread->mutex);
 654
 655         return retparam;
 656     }
 657     return (AV*)NULL;
 658 }
 659
 660 void
 661 Perl_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_new (classname, function_to_call, ...)
 676 char *  classname
 677 SV *    function_to_call
 678 CODE:
 679 {
 680     AV* params = newAV();
 681     if (items > 2) {
 682         int i;
 683         for(i = 2; i < items ; i++) {
 684             av_push(params, SvREFCNT_inc(ST(i)));
 685         }
 686     }
 687     ST(0) = sv_2mortal(Perl_ithread_create(aTHX_ Nullsv, classname, function_to_call, newRV_noinc((SV*) params)));
 688     XSRETURN(1);
 689 }
 690
 691 void
 692 ithread_list(char *classname)
 693 PPCODE:
 694 {
 695   ithread *curr_thread;
 696   MUTEX_LOCK(&create_destruct_mutex);
 697   curr_thread = threads;
 698   if(curr_thread->tid != 0)
 699     XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
 700   while(curr_thread) {
 701     curr_thread = curr_thread->next;
 702     if(curr_thread == threads)
 703       break;
 704     if(curr_thread->state & PERL_ITHR_DETACHED ||
 705        curr_thread->state & PERL_ITHR_JOINED)
 706          continue;
 707      XPUSHs( sv_2mortal(ithread_to_SV(aTHX_ NULL, curr_thread, classname, TRUE)));
 708   }
 709   MUTEX_UNLOCK(&create_destruct_mutex);
 710 }
 711
 712
 713 void
 714 ithread_self(char *classname)
 715 CODE:
 716 {
 717         ST(0) = sv_2mortal(Perl_ithread_self(aTHX_ Nullsv,classname));
 718         XSRETURN(1);
 719 }
 720
 721 int
 722 ithread_tid(ithread *thread)
 723
 724 void
 725 ithread_join(SV *obj)
 726 PPCODE:
 727 {
 728   AV* params = Perl_ithread_join(aTHX_ obj);
 729   int i;
 730   I32 len = AvFILL(params);
 731   for (i = 0; i <= len; i++) {
 732     SV* tmp = av_shift(params);
 733     XPUSHs(tmp);
 734     sv_2mortal(tmp);
 735   }
 736   SvREFCNT_dec(params);
 737 }
 738
 739 void
 740 yield(...)
 741 CODE:
 742 {
 743     YIELD;
 744 }
 745
 746
 747 void
 748 ithread_detach(ithread *thread)
 749
 750 void
 751 ithread_DESTROY(SV *thread)
 752
 753 #endif /* USE_ITHREADS */
 754
 755 BOOT:
 756 {
 757 #ifdef USE_ITHREADS
 758         ithread* thread;
 759         PL_perl_destruct_level = 2;
 760         MUTEX_INIT(&create_destruct_mutex);
 761         MUTEX_LOCK(&create_destruct_mutex);
 762         PL_threadhook = &Perl_ithread_hook;
 763         thread  = (ithread *) PerlMemShared_malloc(sizeof(ithread));
 764         if (!thread) {
 765             PerlLIO_write(PerlIO_fileno(Perl_error_log),
 766                           PL_no_mem, strlen(PL_no_mem));
 767             my_exit(1);
 768         }
 769         Zero(thread,1,ithread);
 770         PL_perl_destruct_level = 2;
 771         MUTEX_INIT(&thread->mutex);
 772         threads = thread;
 773         thread->next = thread;
 774         thread->prev = thread;
 775         thread->interp = aTHX;
 776         thread->count  = 1;  /* Immortal. */
 777         thread->tid = tid_counter++;
 778         known_threads++;
 779         active_threads++;
 780         thread->state = PERL_ITHR_DETACHED;
 781 #ifdef WIN32
 782         thread->thr = GetCurrentThreadId();
 783 #else
 784         thread->thr = pthread_self();
 785 #endif
 786
 787         Perl_ithread_set(aTHX_ thread);
 788         MUTEX_UNLOCK(&create_destruct_mutex);
 789 #endif /* USE_ITHREADS */
 790 }
 791