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