home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / Thread / Thread.xs < prev    next >
Text File  |  2000-02-28  |  16KB  |  667 lines
  1. #define PERL_NO_GET_CONTEXT
  2. #include "EXTERN.h"
  3. #include "perl.h"
  4. #include "XSUB.h"
  5.  
  6. /* Magic signature for Thread's mg_private is "Th" */ 
  7. #define Thread_MAGIC_SIGNATURE 0x5468
  8.  
  9. #ifdef __cplusplus
  10. #ifdef I_UNISTD
  11. #include <unistd.h>
  12. #endif
  13. #endif
  14. #include <fcntl.h>
  15.                         
  16. static int sig_pipe[2];
  17.             
  18. #ifndef THREAD_RET_TYPE
  19. #define THREAD_RET_TYPE void *
  20. #define THREAD_RET_CAST(x) ((THREAD_RET_TYPE) x)
  21. #endif
  22.  
  23. static void
  24. remove_thread(pTHX_ struct perl_thread *t)
  25. {
  26. #ifdef USE_THREADS
  27.     DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
  28.                    "%p: remove_thread %p\n", thr, t)));
  29.     MUTEX_LOCK(&PL_threads_mutex);
  30.     MUTEX_DESTROY(&t->mutex);
  31.     PL_nthreads--;
  32.     t->prev->next = t->next;
  33.     t->next->prev = t->prev;
  34.     SvREFCNT_dec(t->oursv);
  35.     COND_BROADCAST(&PL_nthreads_cond);
  36.     MUTEX_UNLOCK(&PL_threads_mutex);
  37. #endif
  38. }
  39.  
  40. static THREAD_RET_TYPE
  41. threadstart(void *arg)
  42. {
  43. #ifdef USE_THREADS
  44. #ifdef FAKE_THREADS
  45.     Thread savethread = thr;
  46.     LOGOP myop;
  47.     dSP;
  48.     I32 oldscope = PL_scopestack_ix;
  49.     I32 retval;
  50.     AV *av;
  51.     int i;
  52.  
  53.     DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
  54.               thr, SvPEEK(TOPs)));
  55.     thr = (Thread) arg;
  56.     savemark = TOPMARK;
  57.     thr->prev = thr->prev_run = savethread;
  58.     thr->next = savethread->next;
  59.     thr->next_run = savethread->next_run;
  60.     savethread->next = savethread->next_run = thr;
  61.     thr->wait_queue = 0;
  62.     thr->private = 0;
  63.  
  64.     /* Now duplicate most of perl_call_sv but with a few twists */
  65.     PL_op = (OP*)&myop;
  66.     Zero(PL_op, 1, LOGOP);
  67.     myop.op_flags = OPf_STACKED;
  68.     myop.op_next = Nullop;
  69.     myop.op_flags |= OPf_KNOW;
  70.     myop.op_flags |= OPf_WANT_LIST;
  71.     PL_op = pp_entersub(ARGS);
  72.     DEBUG_S(if (!PL_op)
  73.         PerlIO_printf(Perl_debug_log, "thread starts at Nullop\n"));
  74.     /*
  75.      * When this thread is next scheduled, we start in the right
  76.      * place. When the thread runs off the end of the sub, perl.c
  77.      * handles things, using savemark to figure out how much of the
  78.      * stack is the return value for any join.
  79.      */
  80.     thr = savethread;        /* back to the old thread */
  81.     return 0;
  82. #else
  83.     Thread thr = (Thread) arg;
  84.     LOGOP myop;
  85.     djSP;
  86.     I32 oldmark = TOPMARK;
  87.     I32 oldscope = PL_scopestack_ix;
  88.     I32 retval;
  89.     SV *sv;
  90.     AV *av;
  91.     int i, ret;
  92.     dJMPENV;
  93.  
  94. #if defined(MULTIPLICITY)
  95.     PERL_SET_INTERP(thr->interp);
  96. #endif
  97.  
  98.     DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n",
  99.               thr));
  100.  
  101.     /* Don't call *anything* requiring dTHR until after PERL_SET_THX() */
  102.     /*
  103.      * Wait until our creator releases us. If we didn't do this, then
  104.      * it would be potentially possible for out thread to carry on and
  105.      * do stuff before our creator fills in our "self" field. For example,
  106.      * if we went and created another thread which tried to JOIN with us,
  107.      * then we'd be in a mess.
  108.      */
  109.     MUTEX_LOCK(&thr->mutex);
  110.     MUTEX_UNLOCK(&thr->mutex);
  111.  
  112.     /*
  113.      * It's safe to wait until now to set the thread-specific pointer
  114.      * from our pthread_t structure to our struct perl_thread, since
  115.      * we're the only thread who can get at it anyway.
  116.      */
  117.     PERL_SET_THX(thr);
  118.  
  119.     /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
  120.     DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
  121.               thr, SvPEEK(TOPs)));
  122.  
  123.     av = newAV();
  124.     sv = POPs;
  125.     PUTBACK;
  126.     ENTER;
  127.     SAVETMPS;
  128.     perl_call_sv(sv, G_ARRAY|G_EVAL);
  129.     SPAGAIN;
  130.     retval = SP - (PL_stack_base + oldmark);
  131.     SP = PL_stack_base + oldmark + 1;
  132.     if (SvCUR(thr->errsv)) {
  133.     MUTEX_LOCK(&thr->mutex);
  134.     thr->flags |= THRf_DID_DIE;
  135.     MUTEX_UNLOCK(&thr->mutex);
  136.     av_store(av, 0, &PL_sv_no);
  137.     av_store(av, 1, newSVsv(thr->errsv));
  138.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p died: %s\n",
  139.                   thr, SvPV(thr->errsv, PL_na)));
  140.     }
  141.     else {
  142.     DEBUG_S(STMT_START {
  143.         for (i = 1; i <= retval; i++) {
  144.         PerlIO_printf(Perl_debug_log, "%p return[%d] = %s\n",
  145.                 thr, i, SvPEEK(SP[i - 1]));
  146.         }
  147.     } STMT_END);
  148.     av_store(av, 0, &PL_sv_yes);
  149.     for (i = 1; i <= retval; i++, SP++)
  150.         sv_setsv(*av_fetch(av, i, TRUE), SvREFCNT_inc(*SP));
  151.     }
  152.     FREETMPS;
  153.     LEAVE;
  154.  
  155.   finishoff:
  156. #if 0    
  157.     /* removed for debug */
  158.     SvREFCNT_dec(PL_curstack);
  159. #endif
  160.     SvREFCNT_dec(thr->cvcache);
  161.     SvREFCNT_dec(thr->threadsv);
  162.     SvREFCNT_dec(thr->specific);
  163.     SvREFCNT_dec(thr->errsv);
  164.  
  165.     /*Safefree(cxstack);*/
  166.     while (PL_curstackinfo->si_next)
  167.     PL_curstackinfo = PL_curstackinfo->si_next;
  168.     while (PL_curstackinfo) {
  169.     PERL_SI *p = PL_curstackinfo->si_prev;
  170.     SvREFCNT_dec(PL_curstackinfo->si_stack);
  171.     Safefree(PL_curstackinfo->si_cxstack);
  172.     Safefree(PL_curstackinfo);
  173.     PL_curstackinfo = p;
  174.     }    
  175.     Safefree(PL_markstack);
  176.     Safefree(PL_scopestack);
  177.     Safefree(PL_savestack);
  178.     Safefree(PL_retstack);
  179.     Safefree(PL_tmps_stack);
  180.     Safefree(PL_ofs);
  181.  
  182.     SvREFCNT_dec(PL_rs);
  183.     SvREFCNT_dec(PL_nrs);
  184.     SvREFCNT_dec(PL_statname);
  185.     SvREFCNT_dec(PL_errors);
  186.     Safefree(PL_screamfirst);
  187.     Safefree(PL_screamnext);
  188.     Safefree(PL_reg_start_tmp);
  189.     SvREFCNT_dec(PL_lastscream);
  190.     SvREFCNT_dec(PL_defoutgv);
  191.     Safefree(PL_reg_poscache);
  192.  
  193.     MUTEX_LOCK(&thr->mutex);
  194.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  195.               "%p: threadstart finishing: state is %u\n",
  196.               thr, ThrSTATE(thr)));
  197.     switch (ThrSTATE(thr)) {
  198.     case THRf_R_JOINABLE:
  199.     ThrSETSTATE(thr, THRf_ZOMBIE);
  200.     MUTEX_UNLOCK(&thr->mutex);
  201.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  202.                   "%p: R_JOINABLE thread finished\n", thr));
  203.     break;
  204.     case THRf_R_JOINED:
  205.     ThrSETSTATE(thr, THRf_DEAD);
  206.     MUTEX_UNLOCK(&thr->mutex);
  207.     remove_thread(aTHX_ thr);
  208.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  209.                   "%p: R_JOINED thread finished\n", thr));
  210.     break;
  211.     case THRf_R_DETACHED:
  212.     ThrSETSTATE(thr, THRf_DEAD);
  213.     MUTEX_UNLOCK(&thr->mutex);
  214.     SvREFCNT_dec(av);
  215.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  216.                   "%p: DETACHED thread finished\n", thr));
  217.     remove_thread(aTHX_ thr);    /* This might trigger main thread to finish */
  218.     break;
  219.     default:
  220.     MUTEX_UNLOCK(&thr->mutex);
  221.     croak("panic: illegal state %u at end of threadstart", ThrSTATE(thr));
  222.     /* NOTREACHED */
  223.     }
  224.     return THREAD_RET_CAST(av);    /* Available for anyone to join with */
  225.                     /* us unless we're detached, in which */
  226.                     /* case noone sees the value anyway. */
  227. #endif    
  228. #else
  229.     return THREAD_RET_CAST(NULL);
  230. #endif
  231. }
  232.  
  233. static SV *
  234. newthread (pTHX_ SV *startsv, AV *initargs, char *classname)
  235. {
  236. #ifdef USE_THREADS
  237.     dSP;
  238.     Thread savethread;
  239.     int i;
  240.     SV *sv;
  241.     int err;
  242. #ifndef THREAD_CREATE
  243.     static pthread_attr_t attr;
  244.     static int attr_inited = 0;
  245.     sigset_t fullmask, oldmask;
  246.     static int attr_joinable = PTHREAD_CREATE_JOINABLE;
  247. #endif
  248.  
  249.     savethread = thr;
  250.     thr = new_struct_thread(thr);
  251.     /* temporarily pretend to be the child thread in case the
  252.      * XPUSHs() below want to grow the child's stack.  This is
  253.      * safe, since the other thread is not yet created, and we
  254.      * are the only ones who know about it */
  255.     PERL_SET_THX(thr);
  256.     SPAGAIN;
  257.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  258.               "%p: newthread (%p), tid is %u, preparing stack\n",
  259.               savethread, thr, thr->tid));
  260.     /* The following pushes the arg list and startsv onto the *new* stack */
  261.     PUSHMARK(SP);
  262.     /* Could easily speed up the following greatly */
  263.     for (i = 0; i <= AvFILL(initargs); i++)
  264.     XPUSHs(SvREFCNT_inc(*av_fetch(initargs, i, FALSE)));
  265.     XPUSHs(SvREFCNT_inc(startsv));
  266.     PUTBACK;
  267.  
  268.     /* On your marks... */
  269.     PERL_SET_THX(savethread);
  270.     MUTEX_LOCK(&thr->mutex);
  271.  
  272. #ifdef THREAD_CREATE
  273.     err = THREAD_CREATE(thr, threadstart);
  274. #else    
  275.     /* Get set...  */
  276.     sigfillset(&fullmask);
  277.     if (sigprocmask(SIG_SETMASK, &fullmask, &oldmask) == -1)
  278.     croak("panic: sigprocmask");
  279.     err = 0;
  280.     if (!attr_inited) {
  281.     attr_inited = 1;
  282.     err = pthread_attr_init(&attr);
  283. #  ifdef PTHREAD_ATTR_SETDETACHSTATE
  284.     if (err == 0)
  285.         err = PTHREAD_ATTR_SETDETACHSTATE(&attr, attr_joinable);
  286.  
  287. #  else
  288.     croak("panic: can't pthread_attr_setdetachstate");
  289. #  endif
  290.     }
  291.     if (err == 0)
  292.     err = PTHREAD_CREATE(&thr->self, attr, threadstart, (void*) thr);
  293. #endif
  294.  
  295.     if (err) {
  296.     MUTEX_UNLOCK(&thr->mutex);
  297.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  298.                   "%p: create of %p failed %d\n",
  299.                   savethread, thr, err));
  300.     /* Thread creation failed--clean up */
  301.     SvREFCNT_dec(thr->cvcache);
  302.     remove_thread(aTHX_ thr);
  303.     for (i = 0; i <= AvFILL(initargs); i++)
  304.         SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
  305.     SvREFCNT_dec(startsv);
  306.     return NULL;
  307.     }
  308.  
  309. #ifdef THREAD_POST_CREATE
  310.     THREAD_POST_CREATE(thr);
  311. #else
  312.     if (sigprocmask(SIG_SETMASK, &oldmask, 0))
  313.     croak("panic: sigprocmask");
  314. #endif
  315.  
  316.     sv = newSViv(thr->tid);
  317.     sv_magic(sv, thr->oursv, '~', 0, 0);
  318.     SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
  319.     sv = sv_bless(newRV_noinc(sv), gv_stashpv(classname, TRUE));
  320.  
  321.     /* Go */
  322.     MUTEX_UNLOCK(&thr->mutex);
  323.  
  324.     return sv;
  325. #else
  326.     croak("No threads in this perl");
  327.     return &PL_sv_undef;
  328. #endif
  329. }
  330.  
  331. static Signal_t handle_thread_signal (int sig);
  332.  
  333. static Signal_t
  334. handle_thread_signal(int sig)
  335. {
  336.     dTHXo;
  337.     unsigned char c = (unsigned char) sig;
  338.     /*
  339.      * We're not really allowed to call fprintf in a signal handler
  340.      * so don't be surprised if this isn't robust while debugging
  341.      * with -DL.
  342.      */
  343.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  344.         "handle_thread_signal: got signal %d\n", sig););
  345.     write(sig_pipe[1], &c, 1);
  346. }
  347.  
  348. MODULE = Thread        PACKAGE = Thread
  349. PROTOTYPES: DISABLE
  350.  
  351. void
  352. new(classname, startsv, ...)
  353.     char *        classname
  354.     SV *        startsv
  355.     AV *        av = av_make(items - 2, &ST(2));
  356.     PPCODE:
  357.     XPUSHs(sv_2mortal(newthread(aTHX_ startsv, av, classname)));
  358.  
  359. void
  360. join(t)
  361.     Thread    t
  362.     AV *    av = NO_INIT
  363.     int    i = NO_INIT
  364.     PPCODE:
  365. #ifdef USE_THREADS
  366.     if (t == thr)
  367.         croak("Attempt to join self");
  368.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n",
  369.                   thr, t, ThrSTATE(t)););
  370.         MUTEX_LOCK(&t->mutex);
  371.     switch (ThrSTATE(t)) {
  372.     case THRf_R_JOINABLE:
  373.     case THRf_R_JOINED:
  374.         ThrSETSTATE(t, THRf_R_JOINED);
  375.         MUTEX_UNLOCK(&t->mutex);
  376.         break;
  377.     case THRf_ZOMBIE:
  378.         ThrSETSTATE(t, THRf_DEAD);
  379.         MUTEX_UNLOCK(&t->mutex);
  380.         remove_thread(aTHX_ t);
  381.         break;
  382.     default:
  383.         MUTEX_UNLOCK(&t->mutex);
  384.         croak("can't join with thread");
  385.         /* NOTREACHED */
  386.     }
  387.     JOIN(t, &av);
  388.  
  389.     sv_2mortal((SV*)av);
  390.  
  391.     if (SvTRUE(*av_fetch(av, 0, FALSE))) {
  392.         /* Could easily speed up the following if necessary */
  393.         for (i = 1; i <= AvFILL(av); i++)
  394.         XPUSHs(*av_fetch(av, i, FALSE));
  395.     }
  396.     else {
  397.         STRLEN n_a;
  398.         char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a);
  399.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  400.                   "%p: join propagating die message: %s\n",
  401.                   thr, mess));
  402.         croak(mess);
  403.     }
  404. #endif
  405.  
  406. void
  407. detach(t)
  408.     Thread    t
  409.     CODE:
  410. #ifdef USE_THREADS
  411.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n",
  412.                   thr, t, ThrSTATE(t)););
  413.         MUTEX_LOCK(&t->mutex);
  414.     switch (ThrSTATE(t)) {
  415.     case THRf_R_JOINABLE:
  416.         ThrSETSTATE(t, THRf_R_DETACHED);
  417.         /* fall through */
  418.     case THRf_R_DETACHED:
  419.         DETACH(t);
  420.         MUTEX_UNLOCK(&t->mutex);
  421.         break;
  422.     case THRf_ZOMBIE:
  423.         ThrSETSTATE(t, THRf_DEAD);
  424.         DETACH(t);
  425.         MUTEX_UNLOCK(&t->mutex);
  426.         remove_thread(aTHX_ t);
  427.         break;
  428.     default:
  429.         MUTEX_UNLOCK(&t->mutex);
  430.         croak("can't detach thread");
  431.         /* NOTREACHED */
  432.     }
  433. #endif
  434.  
  435. void
  436. equal(t1, t2)
  437.     Thread    t1
  438.     Thread    t2
  439.     PPCODE:
  440.     PUSHs((t1 == t2) ? &PL_sv_yes : &PL_sv_no);
  441.  
  442. void
  443. flags(t)
  444.     Thread    t
  445.     PPCODE:
  446. #ifdef USE_THREADS
  447.     PUSHs(sv_2mortal(newSViv(t->flags)));
  448. #endif
  449.  
  450. void
  451. self(classname)
  452.     char *    classname
  453.     PREINIT:
  454.     SV *sv;
  455.     PPCODE:        
  456. #ifdef USE_THREADS
  457.     sv = newSViv(thr->tid);
  458.     sv_magic(sv, thr->oursv, '~', 0, 0);
  459.     SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
  460.     PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv),
  461.                   gv_stashpv(classname, TRUE))));
  462. #endif
  463.  
  464. U32
  465. tid(t)
  466.     Thread    t
  467.     CODE:
  468. #ifdef USE_THREADS
  469.         MUTEX_LOCK(&t->mutex);
  470.     RETVAL = t->tid;
  471.         MUTEX_UNLOCK(&t->mutex);
  472. #else 
  473.     RETVAL = 0;
  474. #endif
  475.     OUTPUT:
  476.     RETVAL
  477.  
  478. void
  479. DESTROY(t)
  480.     SV *    t
  481.     PPCODE:
  482.     PUSHs(&PL_sv_yes);
  483.  
  484. void
  485. yield()
  486.     CODE:
  487. {
  488. #ifdef USE_THREADS
  489.     YIELD;
  490. #endif
  491. }
  492.  
  493. void
  494. cond_wait(sv)
  495.     SV *    sv
  496.     MAGIC *    mg = NO_INIT
  497. CODE:                       
  498. #ifdef USE_THREADS
  499.     if (SvROK(sv))
  500.         sv = SvRV(sv);
  501.  
  502.     mg = condpair_magic(sv);
  503.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_wait %p\n", thr, sv));
  504.     MUTEX_LOCK(MgMUTEXP(mg));
  505.     if (MgOWNER(mg) != thr) {
  506.         MUTEX_UNLOCK(MgMUTEXP(mg));
  507.         croak("cond_wait for lock that we don't own\n");
  508.     }
  509.     MgOWNER(mg) = 0;
  510.     COND_SIGNAL(MgOWNERCONDP(mg));
  511.     COND_WAIT(MgCONDP(mg), MgMUTEXP(mg));
  512.     while (MgOWNER(mg))
  513.         COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
  514.     MgOWNER(mg) = thr;
  515.     MUTEX_UNLOCK(MgMUTEXP(mg));
  516. #endif
  517.  
  518. void
  519. cond_signal(sv)
  520.     SV *    sv
  521.     MAGIC *    mg = NO_INIT
  522. CODE:
  523. #ifdef USE_THREADS
  524.     if (SvROK(sv))
  525.         sv = SvRV(sv);
  526.  
  527.     mg = condpair_magic(sv);
  528.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_signal %p\n",thr,sv));
  529.     MUTEX_LOCK(MgMUTEXP(mg));
  530.     if (MgOWNER(mg) != thr) {
  531.         MUTEX_UNLOCK(MgMUTEXP(mg));
  532.         croak("cond_signal for lock that we don't own\n");
  533.     }
  534.     COND_SIGNAL(MgCONDP(mg));
  535.     MUTEX_UNLOCK(MgMUTEXP(mg));
  536. #endif
  537.  
  538. void
  539. cond_broadcast(sv)
  540.     SV *    sv
  541.     MAGIC *    mg = NO_INIT
  542. CODE: 
  543. #ifdef USE_THREADS
  544.     if (SvROK(sv))
  545.         sv = SvRV(sv);
  546.  
  547.     mg = condpair_magic(sv);
  548.     DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_broadcast %p\n",
  549.                   thr, sv));
  550.     MUTEX_LOCK(MgMUTEXP(mg));
  551.     if (MgOWNER(mg) != thr) {
  552.         MUTEX_UNLOCK(MgMUTEXP(mg));
  553.         croak("cond_broadcast for lock that we don't own\n");
  554.     }
  555.     COND_BROADCAST(MgCONDP(mg));
  556.     MUTEX_UNLOCK(MgMUTEXP(mg));
  557. #endif
  558.  
  559. void
  560. list(classname)
  561.     char *    classname
  562.     PREINIT:
  563.     Thread    t;
  564.     AV *    av;
  565.     SV **    svp;
  566.     int    n = 0;
  567.     PPCODE:
  568. #ifdef USE_THREADS
  569.     av = newAV();
  570.     /*
  571.      * Iterate until we have enough dynamic storage for all threads.
  572.      * We mustn't do any allocation while holding threads_mutex though.
  573.      */
  574.     MUTEX_LOCK(&PL_threads_mutex);
  575.     do {
  576.         n = PL_nthreads;
  577.         MUTEX_UNLOCK(&PL_threads_mutex);
  578.         if (AvFILL(av) < n - 1) {
  579.         int i = AvFILL(av);
  580.         for (i = AvFILL(av); i < n - 1; i++) {
  581.             SV *sv = newSViv(0);    /* fill in tid later */
  582.             sv_magic(sv, 0, '~', 0, 0);    /* fill in other magic later */
  583.             av_push(av, sv_bless(newRV_noinc(sv),
  584.                      gv_stashpv(classname, TRUE)));
  585.     
  586.         }
  587.         }
  588.         MUTEX_LOCK(&PL_threads_mutex);
  589.     } while (n < PL_nthreads);
  590.     n = PL_nthreads;    /* Get the final correct value */
  591.  
  592.     /*
  593.      * At this point, there's enough room to fill in av.
  594.      * Note that we are holding threads_mutex so the list
  595.      * won't change out from under us but all the remaining
  596.      * processing is "fast" (no blocking, malloc etc.)
  597.      */
  598.     t = thr;
  599.     svp = AvARRAY(av);
  600.     do {
  601.         SV *sv = (SV*)SvRV(*svp);
  602.         sv_setiv(sv, t->tid);
  603.         SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
  604.         SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
  605.         SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
  606.         t = t->next;
  607.         svp++;
  608.     } while (t != thr);
  609.     /*  */
  610.     MUTEX_UNLOCK(&PL_threads_mutex);
  611.     /* Truncate any unneeded slots in av */
  612.     av_fill(av, n - 1);
  613.     /* Finally, push all the new objects onto the stack and drop av */
  614.     EXTEND(SP, n);
  615.     for (svp = AvARRAY(av); n > 0; n--, svp++)
  616.         PUSHs(*svp);
  617.     (void)sv_2mortal((SV*)av);
  618. #endif
  619.  
  620.  
  621. MODULE = Thread        PACKAGE = Thread::Signal
  622.  
  623. void
  624. kill_sighandler_thread()
  625.     PPCODE:
  626.     write(sig_pipe[1], "\0", 1);
  627.     PUSHs(&PL_sv_yes);
  628.  
  629. void
  630. init_thread_signals()
  631.     PPCODE:
  632.     PL_sighandlerp = handle_thread_signal;
  633.     if (pipe(sig_pipe) == -1)
  634.         XSRETURN_UNDEF;
  635.     PUSHs(&PL_sv_yes);
  636.  
  637. void
  638. await_signal()
  639.     PREINIT:
  640.     unsigned char c;
  641.     SSize_t ret;
  642.     CODE:
  643.     do {
  644.         ret = read(sig_pipe[0], &c, 1);
  645.     } while (ret == -1 && errno == EINTR);
  646.     if (ret == -1)
  647.         croak("panic: await_signal");
  648.     ST(0) = sv_newmortal();
  649.     if (ret)
  650.         sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no);
  651.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  652.                   "await_signal returning %s\n", SvPEEK(ST(0))););
  653.  
  654. MODULE = Thread        PACKAGE = Thread::Specific
  655.  
  656. void
  657. data(classname = "Thread::Specific")
  658.     char *    classname
  659.     PPCODE:
  660. #ifdef USE_THREADS
  661.     if (AvFILL(thr->specific) == -1) {
  662.         GV *gv = gv_fetchpv("Thread::Specific::FIELDS", TRUE, SVt_PVHV);
  663.         av_store(thr->specific, 0, newRV((SV*)GvHV(gv)));
  664.     }
  665.     XPUSHs(sv_bless(newRV((SV*)thr->specific),gv_stashpv(classname,TRUE)));
  666. #endif
  667.