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