ext/threads/threads.xs

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