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