PL_malloc_mutex needs to be global, not per-interpreter

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 436fd88..23ece0f 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -47,16 +47,43 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
 #endif
 
 #ifdef PERL_OBJECT
-CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
-                    IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+CPerlObj*
+perl_alloc(struct IPerlMem* ipM, struct IPerlEnv* ipE,
+                struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
+                struct IPerlDir* ipD, struct IPerlSock* ipS,
+                struct IPerlProc* ipP)
 {
     CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
-    if(pPerl != NULL)
+    if (pPerl != NULL)
        pPerl->Init();
 
     return pPerl;
 }
 #else
+
+#ifdef PERL_IMPLICIT_SYS
+PerlInterpreter *
+perl_alloc_using(struct IPerlMem* ipM, struct IPerlEnv* ipE,
+                struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
+                struct IPerlDir* ipD, struct IPerlSock* ipS,
+                struct IPerlProc* ipP)
+{
+    PerlInterpreter *my_perl;
+
+    /* New() needs interpreter, so call malloc() instead */
+    my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
+    PERL_SET_INTERP(my_perl);
+    Zero(my_perl, 1, PerlInterpreter);
+    PL_Mem = ipM;
+    PL_Env = ipE;
+    PL_StdIO = ipStd;
+    PL_LIO = ipLIO;
+    PL_Dir = ipD;
+    PL_Sock = ipS;
+    PL_Proc = ipP;
+    return my_perl;
+}
+#else
 PerlInterpreter *
 perl_alloc(void)
 {
@@ -67,6 +94,7 @@ perl_alloc(void)
     PERL_SET_INTERP(my_perl);
     return my_perl;
 }
+#endif /* PERL_IMPLICIT_SYS */
 #endif /* PERL_OBJECT */
 
 void
@@ -75,15 +103,11 @@ perl_construct(pTHXx)
 #ifdef USE_THREADS
     int i;
 #ifndef FAKE_THREADS
-    struct perl_thread *thr;
+    struct perl_thread *thr = NULL;
 #endif /* FAKE_THREADS */
 #endif /* USE_THREADS */
     
 #ifdef MULTIPLICITY
-    Zero(my_perl, 1, PerlInterpreter);
-#endif
-
-#ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1; 
 #else
@@ -590,6 +614,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     dTHR;
     I32 oldscope;
     int ret;
+    dJMPENV;
 #ifdef USE_THREADS
     dTHX;
 #endif
@@ -638,7 +663,8 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body),
+               env, xsinit);
     switch (ret) {
     case 0:
        return 0;
@@ -651,7 +677,7 @@ setuid perl scripts securely.\n");
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_endav)
+       if (PL_endav && !PL_minus_c)
            call_list(oldscope, PL_endav);
        return STATUS_NATIVE_EXPORT;
     case 3:
@@ -785,7 +811,6 @@ S_parse_body(pTHX_ va_list args)
 #else
                sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
 #endif
-#if defined(DEBUGGING) || defined(MULTIPLICITY)
                sv_catpv(PL_Sv,"\"  Compile-time options:");
 #  ifdef DEBUGGING
                sv_catpv(PL_Sv," DEBUGGING");
@@ -793,8 +818,20 @@ S_parse_body(pTHX_ va_list args)
 #  ifdef MULTIPLICITY
                sv_catpv(PL_Sv," MULTIPLICITY");
 #  endif
+#  ifdef USE_THREADS
+               sv_catpv(PL_Sv," USE_THREADS");
+#  endif
+#  ifdef PERL_OBJECT
+               sv_catpv(PL_Sv," PERL_OBJECT");
+#  endif
+#  ifdef PERL_IMPLICIT_CONTEXT
+               sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
+#  endif
+#  ifdef PERL_IMPLICIT_SYS
+               sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
+#  endif
                sv_catpv(PL_Sv,"\\n\",");
-#endif
+
 #if defined(LOCAL_PATCH_COUNT)
                if (LOCAL_PATCH_COUNT > 0) {
                    int i;
@@ -1005,6 +1042,7 @@ perl_run(pTHXx)
     dTHR;
     I32 oldscope;
     int ret;
+    dJMPENV;
 #ifdef USE_THREADS
     dTHX;
 #endif
@@ -1012,7 +1050,7 @@ perl_run(pTHXx)
     oldscope = PL_scopestack_ix;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope);
     switch (ret) {
     case 1:
        cxstack_ix = -1;                /* start context stack again */
@@ -1023,7 +1061,7 @@ perl_run(pTHXx)
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_endav)
+       if (PL_endav && !PL_minus_c)
            call_list(oldscope, PL_endav);
 #ifdef MYMALLOC
        if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
@@ -1206,6 +1244,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     bool oldcatch = CATCH_GET;
     int ret;
     OP* oldop = PL_op;
+    dJMPENV;
 
     if (flags & G_DISCARD) {
        ENTER;
@@ -1237,16 +1276,10 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        PL_op->op_private |= OPpENTERSUB_DB;
 
     if (!(flags & G_EVAL)) {
-        /* G_NOCATCH is a hack for perl_vdie using this path to call
-          a __DIE__ handler */
-        if (!(flags & G_NOCATCH)) {
-           CATCH_SET(TRUE);
-       }
+       CATCH_SET(TRUE);
        call_xbody((OP*)&myop, FALSE);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
-        if (!(flags & G_NOCATCH)) {
-           CATCH_SET(FALSE);
-       }
+       CATCH_SET(oldcatch);
     }
     else {
        cLOGOP->op_other = PL_op;
@@ -1273,7 +1306,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        PL_markstack_ptr++;
 
   redo_body:
-       CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE);
+       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+                   (OP*)&myop, FALSE);
        switch (ret) {
        case 0:
            retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -1371,6 +1405,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     I32 oldscope;
     int ret;
     OP* oldop = PL_op;
+    dJMPENV;
 
     if (flags & G_DISCARD) {
        ENTER;
@@ -1395,7 +1430,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
        myop.op_flags |= OPf_SPECIAL;
 
  redo_body:
-    CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE);
+    CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body),
+               (OP*)&myop, TRUE);
     switch (ret) {
     case 0:
        retval = PL_stack_sp - (PL_stack_base + oldmark);
@@ -2920,7 +2956,6 @@ S_init_main_thread(pTHX)
     thr->threadsv = newAV();
     /* thr->threadsvp is set when find_threadsv is called */
     thr->specific = newAV();
-    thr->errhv = newHV();
     thr->flags = THRf_R_JOINABLE;
     MUTEX_INIT(&thr->mutex);
     /* Handcraft thrsv similarly to mess_sv */
@@ -2991,11 +3026,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     CV *cv;
     STRLEN len;
     int ret;
+    dJMPENV;
 
     while (AvFILL(paramList) >= 0) {
        cv = (CV*)av_shift(paramList);
        SAVEFREESV(cv);
-       CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
+       CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
        switch (ret) {
        case 0:
            (void)SvPV(atsv, len);
@@ -3020,7 +3056,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                LEAVE;
            FREETMPS;
            PL_curstash = PL_defstash;
-           if (PL_endav)
+           if (PL_endav && !PL_minus_c)
                call_list(oldscope, PL_endav);
            PL_curcop = &PL_compiling;
            PL_curcop->cop_line = oldline;