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