make die/warn and other diagnostics go to wherever STDERR happens

[perl5.git] / ext / Thread / Thread.xs

diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index c3b4683..09d063a 100644 (file)
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -1,3 +1,4 @@
+#define PERL_NO_GET_CONTEXT
 #include "EXTERN.h"
 #include "perl.h"
 #include "XSUB.h"
@@ -20,10 +21,10 @@ static int sig_pipe[2];
 #endif
 
 static void
-remove_thread(struct perl_thread *t)
+remove_thread(pTHX_ struct perl_thread *t)
 {
 #ifdef USE_THREADS
-    DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(),
+    DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
                                   "%p: remove_thread %p\n", thr, t)));
     MUTEX_LOCK(&PL_threads_mutex);
     MUTEX_DESTROY(&t->mutex);
@@ -48,7 +49,7 @@ threadstart(void *arg)
     AV *av;
     int i;
 
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
                          thr, SvPEEK(TOPs)));
     thr = (Thread) arg;
     savemark = TOPMARK;
@@ -68,7 +69,7 @@ threadstart(void *arg)
     myop.op_flags |= OPf_WANT_LIST;
     PL_op = pp_entersub(ARGS);
     DEBUG_S(if (!PL_op)
-           PerlIO_printf(PerlIO_stderr(), "thread starts at Nullop\n"));
+           PerlIO_printf(Perl_debug_log, "thread starts at Nullop\n"));
     /*
      * When this thread is next scheduled, we start in the right
      * place. When the thread runs off the end of the sub, perl.c
@@ -85,10 +86,15 @@ threadstart(void *arg)
     I32 oldscope = PL_scopestack_ix;
     I32 retval;
     SV *sv;
-    AV *av = newAV();
+    AV *av;
     int i, ret;
     dJMPENV;
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p waiting to start\n",
+
+#if defined(MULTIPLICITY)
+    PERL_SET_INTERP(thr->interp);
+#endif
+
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p waiting to start\n",
                          thr));
 
     /* Don't call *anything* requiring dTHR until after SET_THR() */
@@ -110,9 +116,10 @@ threadstart(void *arg)
     SET_THR(thr);
 
     /* Only now can we use SvPEEK (which calls sv_newmortal which does dTHR) */
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new thread %p starting at %s\n",
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "new thread %p starting at %s\n",
                          thr, SvPEEK(TOPs)));
 
+    av = newAV();
     sv = POPs;
     PUTBACK;
     ENTER;
@@ -127,12 +134,12 @@ threadstart(void *arg)
        MUTEX_UNLOCK(&thr->mutex);
        av_store(av, 0, &PL_sv_no);
        av_store(av, 1, newSVsv(thr->errsv));
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p died: %s\n",
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p died: %s\n",
                              thr, SvPV(thr->errsv, PL_na)));
     } else {
        DEBUG_S(STMT_START {
            for (i = 1; i <= retval; i++) {
-               PerlIO_printf(PerlIO_stderr(), "%p return[%d] = %s\n",
+               PerlIO_printf(Perl_debug_log, "%p return[%d] = %s\n",
                                thr, i, SvPEEK(SP[i - 1]));
            }
        } STMT_END);
@@ -174,37 +181,39 @@ threadstart(void *arg)
     SvREFCNT_dec(PL_rs);
     SvREFCNT_dec(PL_nrs);
     SvREFCNT_dec(PL_statname);
+    SvREFCNT_dec(PL_errors);
     Safefree(PL_screamfirst);
     Safefree(PL_screamnext);
     Safefree(PL_reg_start_tmp);
     SvREFCNT_dec(PL_lastscream);
     SvREFCNT_dec(PL_defoutgv);
+    Safefree(PL_reg_poscache);
 
     MUTEX_LOCK(&thr->mutex);
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: threadstart finishing: state is %u\n",
                          thr, ThrSTATE(thr)));
     switch (ThrSTATE(thr)) {
     case THRf_R_JOINABLE:
        ThrSETSTATE(thr, THRf_ZOMBIE);
        MUTEX_UNLOCK(&thr->mutex);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+       DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "%p: R_JOINABLE thread finished\n", thr));
        break;
     case THRf_R_JOINED:
        ThrSETSTATE(thr, THRf_DEAD);
        MUTEX_UNLOCK(&thr->mutex);
-       remove_thread(thr);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+       remove_thread(aTHX_ thr);
+       DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "%p: R_JOINED thread finished\n", thr));
        break;
     case THRf_R_DETACHED:
        ThrSETSTATE(thr, THRf_DEAD);
        MUTEX_UNLOCK(&thr->mutex);
        SvREFCNT_dec(av);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+       DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "%p: DETACHED thread finished\n", thr));
-       remove_thread(thr);     /* This might trigger main thread to finish */
+       remove_thread(aTHX_ thr);       /* This might trigger main thread to finish */
        break;
     default:
        MUTEX_UNLOCK(&thr->mutex);
@@ -221,7 +230,7 @@ threadstart(void *arg)
 }
 
 static SV *
-newthread (SV *startsv, AV *initargs, char *classname)
+newthread (pTHX_ SV *startsv, AV *initargs, char *classname)
 {
 #ifdef USE_THREADS
     dSP;
@@ -244,7 +253,7 @@ newthread (SV *startsv, AV *initargs, char *classname)
      * are the only ones who know about it */
     SET_THR(thr);
     SPAGAIN;
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "%p: newthread (%p), tid is %u, preparing stack\n",
                          savethread, thr, thr->tid));
     /* The following pushes the arg list and startsv onto the *new* stack */
@@ -284,12 +293,12 @@ newthread (SV *startsv, AV *initargs, char *classname)
 
     if (err) {
        MUTEX_UNLOCK(&thr->mutex);
-        DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+        DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "%p: create of %p failed %d\n",
                              savethread, thr, err));
        /* Thread creation failed--clean up */
        SvREFCNT_dec(thr->cvcache);
-       remove_thread(thr);
+       remove_thread(aTHX_ thr);
        MUTEX_DESTROY(&thr->mutex);
        for (i = 0; i <= AvFILL(initargs); i++)
            SvREFCNT_dec(*av_fetch(initargs, i, FALSE));
@@ -319,18 +328,19 @@ newthread (SV *startsv, AV *initargs, char *classname)
 #endif
 }
 
-static Signal_t handle_thread_signal _((int sig));
+static Signal_t handle_thread_signal (int sig);
 
 static Signal_t
 handle_thread_signal(int sig)
 {
+    dTHXo;
     unsigned char c = (unsigned char) sig;
     /*
      * We're not really allowed to call fprintf in a signal handler
      * so don't be surprised if this isn't robust while debugging
      * with -DL.
      */
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
            "handle_thread_signal: got signal %d\n", sig););
     write(sig_pipe[1], &c, 1);
 }
@@ -344,7 +354,7 @@ new(classname, startsv, ...)
        SV *            startsv
        AV *            av = av_make(items - 2, &ST(2));
     PPCODE:
-       XPUSHs(sv_2mortal(newthread(startsv, av, classname)));
+       XPUSHs(sv_2mortal(newthread(aTHX_ startsv, av, classname)));
 
 void
 join(t)
@@ -353,7 +363,9 @@ join(t)
        int     i = NO_INIT
     PPCODE:
 #ifdef USE_THREADS
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: joining %p (state %u)\n",
+       if (t == thr)
+           croak("Attempt to join self");
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: joining %p (state %u)\n",
                              thr, t, ThrSTATE(t)););
        MUTEX_LOCK(&t->mutex);
        switch (ThrSTATE(t)) {
@@ -365,7 +377,7 @@ join(t)
        case THRf_ZOMBIE:
            ThrSETSTATE(t, THRf_DEAD);
            MUTEX_UNLOCK(&t->mutex);
-           remove_thread(t);
+           remove_thread(aTHX_ t);
            break;
        default:
            MUTEX_UNLOCK(&t->mutex);
@@ -381,7 +393,7 @@ join(t)
        } else {
            STRLEN n_a;
            char *mess = SvPV(*av_fetch(av, 1, FALSE), n_a);
-           DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+           DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "%p: join propagating die message: %s\n",
                                  thr, mess));
            croak(mess);
@@ -393,7 +405,7 @@ detach(t)
        Thread  t
     CODE:
 #ifdef USE_THREADS
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: detaching %p (state %u)\n",
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: detaching %p (state %u)\n",
                              thr, t, ThrSTATE(t)););
        MUTEX_LOCK(&t->mutex);
        switch (ThrSTATE(t)) {
@@ -408,7 +420,7 @@ detach(t)
            ThrSETSTATE(t, THRf_DEAD);
            DETACH(t);
            MUTEX_UNLOCK(&t->mutex);
-           remove_thread(t);
+           remove_thread(aTHX_ t);
            break;
        default:
            MUTEX_UNLOCK(&t->mutex);
@@ -485,7 +497,7 @@ CODE:
            sv = SvRV(sv);
 
        mg = condpair_magic(sv);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_wait %p\n", thr, sv));
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_wait %p\n", thr, sv));
        MUTEX_LOCK(MgMUTEXP(mg));
        if (MgOWNER(mg) != thr) {
            MUTEX_UNLOCK(MgMUTEXP(mg));
@@ -510,7 +522,7 @@ CODE:
            sv = SvRV(sv);
 
        mg = condpair_magic(sv);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_signal %p\n",thr,sv));
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_signal %p\n",thr,sv));
        MUTEX_LOCK(MgMUTEXP(mg));
        if (MgOWNER(mg) != thr) {
            MUTEX_UNLOCK(MgMUTEXP(mg));
@@ -530,7 +542,7 @@ CODE:
            sv = SvRV(sv);
 
        mg = condpair_magic(sv);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: cond_broadcast %p\n",
+       DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: cond_broadcast %p\n",
                              thr, sv));
        MUTEX_LOCK(MgMUTEXP(mg));
        if (MgOWNER(mg) != thr) {
@@ -633,7 +645,7 @@ await_signal()
        ST(0) = sv_newmortal();
        if (ret)
            sv_setsv(ST(0), c ? PL_psig_ptr[c] : &PL_sv_no);
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+       DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "await_signal returning %s\n", SvPEEK(ST(0))););
 
 MODULE = Thread                PACKAGE = Thread::Specific