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