cloned interpreters now actually run and pass all but 55/10386

subtests; various subtle bugs, new and old, observed when running
cloned interpreters have been fixed

still to do:
|  * dup psig_ptr table
|  * merge PADOP GVs support with "our" SVs (existing PADOPs are too
|    simple-minded and grab one pad entry each, heavily bloating
|    the pad by not avoiding dups)
|  * overloaded constants are not really immutable--they need to
|    be PADOPs
|  * allocator for constants and OPs need to be spelled differently
|    (shared vs interpreter-local allocations)
|  * optree refcounting is still missing locking (macros are in place)
|  * curstackinfo, {mark,scope,save,ret}stack need to be cloned so
|    perl_clone() can be called from within runops*()

p4raw-id: //depot/perl@4553

diff --git a/dump.c b/dump.c
index 41116b8..bb8adf2 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -510,18 +510,23 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
     }
 
     switch (o->op_type) {
+    case OP_AELEMFAST:
     case OP_GVSV:
     case OP_GV:
-       if (cGVOPo) {
+#ifdef USE_ITHREADS
+       Perl_dump_indent(aTHX_ level, file, "PADIX = %d\n", cPADOPo->op_padix);
+#else
+       if (cSVOPo->op_sv) {
            SV *tmpsv = NEWSV(0,0);
            ENTER;
            SAVEFREESV(tmpsv);
-           gv_fullname3(tmpsv, (GV*)cGVOPo, Nullch);
+           gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
            Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
            LEAVE;
        }
        else
            Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
+#endif
        break;
     case OP_CONST:
     case OP_METHOD_NAMED:

diff --git a/ext/Devel/DProf/DProf.xs b/ext/Devel/DProf/DProf.xs
index c751127..381919f 100644 (file)
--- a/ext/Devel/DProf/DProf.xs
+++ b/ext/Devel/DProf/DProf.xs
@@ -106,7 +106,6 @@ dprof_times(struct tms *t)
 
 XS(XS_Devel__DProf_END);        /* used by prof_mark() */
 
-static SV * Sub;        /* pointer to $DB::sub */
 static PerlIO *fp;      /* pointer to tmon.out file */
 
 /* Added -JH */
@@ -255,6 +254,7 @@ prof_mark( opcode ptype )
         STRLEN len;
         SV *sv;
        U32 id;
+       SV *Sub = GvSV(DBsub);       /* name of current sub */
 
         if( SAVE_STACK ){
                 if( profstack_ix + 5 > profstack_max ){
@@ -552,6 +552,7 @@ XS(XS_DB_sub)
         dXSARGS;
         dORIGMARK;
         HV *oldstash = curstash;
+       SV *Sub = GvSV(DBsub);       /* name of current sub */
 
         SP -= items;
 
@@ -605,6 +606,7 @@ XS(XS_DB_goto)
 
                 dORIGMARK;
                 HV *oldstash = curstash;
+               SV *Sub = GvSV(DBsub);       /* name of current sub */
                 /* SP -= items;  added by xsubpp */
                 DBG_SUB_NOTIFY( "XS DBsub(%s)\n", SvPV(Sub, na) );
 
@@ -662,7 +664,6 @@ BOOT:
                 dowarn = warn_tmp;
         }
 
-        Sub = GvSV(DBsub);       /* name of current sub */
         sv_setiv( DBsingle, 0 ); /* disable DB single-stepping */
 
        {

diff --git a/gv.c b/gv.c
index b662141..25e5b36 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -929,6 +929,8 @@ Perl_newGVgen(pTHX_ char *pack)
 GP*
 Perl_gp_ref(pTHX_ GP *gp)
 {
+    if (!gp)
+       return (GP*)NULL;
     gp->gp_refcnt++;
     if (gp->gp_cv) {
        if (gp->gp_cvgen) {

diff --git a/mg.c b/mg.c
index bb69f5c..a0fee46 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1640,7 +1640,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
                        PL_dowarn |= G_WARN_ONCE ;
                }
            }
-       }    
+       }
        break;
     case '.':
        if (PL_localizing) {

diff --git a/op.c b/op.c
index bd8f652..806dee3 100644 (file)
--- a/op.c
+++ b/op.c
@@ -26,7 +26,7 @@
 #define OP_REFCNT_LOCK         NOOP
 #define OP_REFCNT_UNLOCK       NOOP
 #define OpREFCNT_set(o,n)      NOOP
-#define OpREFCNT_dec(o)                0
+#define OpREFCNT_dec(o)                ((o)->op_targ--)
 
 #ifdef PL_OP_SLAB_ALLOC 
 #define SLAB_SIZE 8192
@@ -659,6 +659,7 @@ Perl_op_free(pTHX_ OP *o)
                OP_REFCNT_UNLOCK;
                return;
            }
+           o->op_targ = 0;             /* XXXXXX */
            OP_REFCNT_UNLOCK;
            break;
        default:
@@ -718,16 +719,18 @@ S_op_clear(pTHX_ OP *o)
     case OP_GV:
     case OP_AELEMFAST:
 #ifdef USE_ITHREADS
-       if (PL_curpad) {
-           GV *gv = cGVOPo;
-           pad_swipe(cPADOPo->op_padix);
-           /* No GvIN_PAD_off(gv) here, because other references may still
-            * exist on the pad */
-           SvREFCNT_dec(gv);
-       }
-       cPADOPo->op_padix = 0;
+       if (cPADOPo->op_padix > 0) {
+           if (PL_curpad) {
+               GV *gv = cGVOPo;
+               pad_swipe(cPADOPo->op_padix);
+               /* No GvIN_PAD_off(gv) here, because other references may still
+                * exist on the pad */
+               SvREFCNT_dec(gv);
+           }
+           cPADOPo->op_padix = 0;
+       }
 #else
-       SvREFCNT_dec(cGVOPo);
+       SvREFCNT_dec(cSVOPo->op_sv);
        cSVOPo->op_sv = Nullsv;
 #endif
        break;
@@ -754,11 +757,26 @@ S_op_clear(pTHX_ OP *o)
        break;
     case OP_SUBST:
        op_free(cPMOPo->op_pmreplroot);
-       cPMOPo->op_pmreplroot = Nullop;
-       /* FALL THROUGH */
+       goto clear_pmop;
     case OP_PUSHRE:
+#ifdef USE_ITHREADS
+       if ((PADOFFSET)cPMOPo->op_pmreplroot) {
+           if (PL_curpad) {
+               GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
+               pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
+               /* No GvIN_PAD_off(gv) here, because other references may still
+                * exist on the pad */
+               SvREFCNT_dec(gv);
+           }
+       }
+#else
+       SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
+#endif
+       /* FALL THROUGH */
     case OP_MATCH:
     case OP_QR:
+clear_pmop:
+       cPMOPo->op_pmreplroot = Nullop;
        ReREFCNT_dec(cPMOPo->op_pmregexp);
        cPMOPo->op_pmregexp = (REGEXP*)NULL;
        break;
@@ -3240,7 +3258,13 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
                {
                    tmpop = ((UNOP*)left)->op_first;
                    if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
-                       pm->op_pmreplroot = (OP*)cGVOPx(tmpop);
+#ifdef USE_ITHREADS
+                       pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
+                       cPADOPx(tmpop)->op_padix = 0;   /* steal it */
+#else
+                       pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
+                       cSVOPx(tmpop)->op_sv = Nullsv;  /* steal it */
+#endif
                        pm->op_pmflags |= PMf_ONCE;
                        tmpop = cUNOPo->op_first;       /* to list (nulled) */
                        tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
@@ -3339,7 +3363,12 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
        if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
            (void)SvIOK_on(*svp);
            SvIVX(*svp) = 1;
+#ifndef USE_ITHREADS
+           /* XXX This nameless kludge interferes with cloning SVs. :-(
+            * What's more, it seems entirely redundant when considering
+            * PL_DBsingle exists to do the same thing */
            SvSTASH(*svp) = (HV*)cop;
+#endif
        }
     }
 

diff --git a/perl.c b/perl.c
index 11a06bd..5eb8338 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -512,7 +512,8 @@ perl_destruct(pTHXx)
     PL_utf8_totitle    = Nullsv;
     PL_utf8_tolower    = Nullsv;
 
-    SvREFCNT_dec(PL_compiling.cop_warnings);
+    if (!specialWARN(PL_compiling.cop_warnings))
+       SvREFCNT_dec(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = Nullsv;
 
     /* Prepare to destruct main symbol table.  */
@@ -3121,7 +3122,7 @@ void
 Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
 {
     dTHR;
-    SV *atsv = ERRSV;
+    SV *atsv;
     line_t oldline = CopLINE(PL_curcop);
     CV *cv;
     STRLEN len;
@@ -3134,8 +3135,10 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
        CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv);
        switch (ret) {
        case 0:
+           atsv = ERRSV;
            (void)SvPV(atsv, len);
            if (len) {
+               STRLEN n_a;
                PL_curcop = &PL_compiling;
                CopLINE_set(PL_curcop, oldline);
                if (paramList == PL_beginav)
@@ -3148,7 +3151,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                                   : "END");
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
-               Perl_croak(aTHX_ "%s", SvPVX(atsv));
+               Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
            }
            break;
        case 1:

diff --git a/pp.c b/pp.c
index 1fb26c3..443eed0 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4938,8 +4938,13 @@ PP(pp_split)
     TAINT_IF((pm->op_pmflags & PMf_LOCALE) &&
             (pm->op_pmflags & (PMf_WHITE | PMf_SKIPWHITE)));
 
-    if (pm->op_pmreplroot)
+    if (pm->op_pmreplroot) {
+#ifdef USE_ITHREADS
+       ary = GvAVn((GV*)PL_curpad[(PADOFFSET)pm->op_pmreplroot]);
+#else
        ary = GvAVn((GV*)pm->op_pmreplroot);
+#endif
+    }
     else if (gimme != G_ARRAY)
 #ifdef USE_THREADS
        ary = (AV*)PL_curpad[0];

diff --git a/sv.c b/sv.c
index 6e96590..1351265 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -5604,9 +5604,14 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
 #endif
 
 #ifndef OpREFCNT_inc
-#  define OpREFCNT_inc(o)      o
+#  define OpREFCNT_inc(o)      ((o) ? (++(o)->op_targ, (o)) : Nullop)
 #endif
 
+#ifndef GpREFCNT_inc
+#  define GpREFCNT_inc(gp)     ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
+#endif
+
+
 #define sv_dup_inc(s)  SvREFCNT_inc(sv_dup(s))
 #define av_dup(s)      (AV*)sv_dup((SV*)s)
 #define av_dup_inc(s)  (AV*)SvREFCNT_inc(sv_dup((SV*)s))
@@ -5653,13 +5658,22 @@ Perl_gp_dup(pTHX_ GP *gp)
     GP *ret;
     if (!gp)
        return (GP*)NULL;
+    /* look for it in the table first */
+    ret = (GP*)sv_table_fetch(PL_sv_table, (SV*)gp);
+    if (ret)
+       return ret;
+
+    /* create anew and remember what it is */
     Newz(0, ret, 1, GP);
+    sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret);
+
+    /* clone */
     ret->gp_sv         = sv_dup_inc(gp->gp_sv);
     ret->gp_io         = io_dup_inc(gp->gp_io);
     ret->gp_form       = cv_dup_inc(gp->gp_form);
     ret->gp_av         = av_dup_inc(gp->gp_av);
     ret->gp_hv         = hv_dup_inc(gp->gp_hv);
-    ret->gp_egv                = gv_dup_inc(gp->gp_egv);
+    ret->gp_egv                = 0;
     ret->gp_cv         = cv_dup_inc(gp->gp_cv);
     ret->gp_cvgen      = gp->gp_cvgen;
     ret->gp_flags      = gp->gp_flags;
@@ -5676,6 +5690,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg)
     MAGIC *mgprev;
     if (!mg)
        return (MAGIC*)NULL;
+    /* XXX need to handle aliases here? */
+
     for (; mg; mg = mg->mg_moremagic) {
        MAGIC *nmg;
        Newz(0, nmg, 1, MAGIC);
@@ -5698,8 +5714,17 @@ Perl_mg_dup(pTHX_ MAGIC *mg)
        nmg->mg_len     = mg->mg_len;
        nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
        if (mg->mg_ptr && mg->mg_type != 'g') {
-           if (mg->mg_len >= 0)
+           if (mg->mg_len >= 0) {
                nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
+               if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
+                   AMT *amtp = (AMT*)mg->mg_ptr;
+                   AMT *namtp = (AMT*)nmg->mg_ptr;
+                   I32 i;
+                   for (i = 1; i < NofAMmeth; i++) {
+                       namtp->table[i] = cv_dup_inc(amtp->table[i]);
+                   }
+               }
+           }
            else if (mg->mg_len == HEf_SVKEY)
                nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr);
        }
@@ -5788,6 +5813,10 @@ Perl_sv_table_split(pTHX_ SVTBL *tbl)
     }
 }
 
+#ifdef DEBUGGING
+DllExport char *PL_watch_pvx;
+#endif
+
 SV *
 Perl_sv_dup(pTHX_ SV *sstr)
 {
@@ -5796,7 +5825,7 @@ Perl_sv_dup(pTHX_ SV *sstr)
     int stype;
     SV *dstr;
 
-    if (!sstr)
+    if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
        return Nullsv;
     /* look for it in the table first */
     dstr = sv_table_fetch(PL_sv_table, sstr);
@@ -5814,6 +5843,12 @@ Perl_sv_dup(pTHX_ SV *sstr)
     SvFLAGS(dstr)      &= ~SVf_OOK;            /* don't propagate OOK hack */
     SvREFCNT(dstr)     = 0;
 
+#ifdef DEBUGGING
+    if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
+       PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
+                     PL_watch_pvx, SvPVX(sstr));
+#endif
+
     switch (SvTYPE(sstr)) {
     case SVt_NULL:
        SvANY(dstr)     = NULL;
@@ -5834,8 +5869,10 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvANY(dstr)     = new_XPV();
        SvCUR(dstr)     = SvCUR(sstr);
        SvLEN(dstr)     = SvLEN(sstr);
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        break;
@@ -5844,8 +5881,10 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvCUR(dstr)     = SvCUR(sstr);
        SvLEN(dstr)     = SvLEN(sstr);
        SvIVX(dstr)     = SvIVX(sstr);
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        break;
@@ -5855,8 +5894,10 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvLEN(dstr)     = SvLEN(sstr);
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        break;
@@ -5867,12 +5908,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        break;
@@ -5883,11 +5923,10 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
            SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
@@ -5902,12 +5941,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        LvTARGOFF(dstr) = LvTARGOFF(sstr);      /* XXX sometimes holds PMOP* when DEBUGGING */
@@ -5922,12 +5960,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        GvNAMELEN(dstr) = GvNAMELEN(sstr);
@@ -5935,7 +5972,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
        GvSTASH(dstr)   = hv_dup_inc(GvSTASH(sstr));
        GvFLAGS(dstr)   = GvFLAGS(sstr);
        GvGP(dstr)      = gp_dup(GvGP(sstr));
-       GvGP(dstr)->gp_refcnt++;
+       (void)GpREFCNT_inc(GvGP(dstr));
+       if (GvEGV(sstr) == (GV*)sstr)
+           GvEGV(dstr) = (GV*)dstr;
+       else
+           GvEGV(dstr) = gv_dup_inc(GvEGV(sstr));
        break;
     case SVt_PVIO:
        SvANY(dstr)     = new_XPVIO();
@@ -5944,12 +5985,11 @@ Perl_sv_dup(pTHX_ SV *sstr)
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvROK(sstr))
+           SvRV(dstr)  = sv_dup_inc(SvRV(sstr));
+       else if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        IoIFP(dstr)             = fp_dup(IoIFP(sstr), IoTYPE(sstr));
@@ -6050,8 +6090,10 @@ Perl_sv_dup(pTHX_ SV *sstr)
            else
                dxhv->xhv_eiter = (HE*)NULL;
        }
-       else
+       else {
            SvPVX(dstr)         = Nullch;
+           HvEITER((HV*)dstr)  = (HE*)NULL;
+       }
        HvPMROOT((HV*)dstr)     = HvPMROOT((HV*)sstr);          /* XXX */
        HvNAME((HV*)dstr)       = SAVEPV(HvNAME((HV*)sstr));
        break;
@@ -6067,12 +6109,9 @@ dup_pvcv:
        SvIVX(dstr)     = SvIVX(sstr);
        SvNVX(dstr)     = SvNVX(sstr);
        SvMAGIC(dstr)   = mg_dup(SvMAGIC(sstr));
-       if (SvSMAGICAL(sstr) && mg_find(sstr, 'l'))
-           SvSTASH(dstr)       = SvSTASH(sstr);        /* COP* in disguise */
-       else
-           SvSTASH(dstr)       = hv_dup_inc(SvSTASH(sstr));
-       if (SvPOKp(sstr) && SvLEN(sstr))
-           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+       SvSTASH(dstr)   = hv_dup_inc(SvSTASH(sstr));
+       if (SvPVX(sstr) && SvLEN(sstr))
+           SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
        else
            SvPVX(dstr) = SvPVX(sstr);          /* XXX shared string/random ptr? */
        CvSTASH(dstr)   = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
@@ -6082,7 +6121,15 @@ dup_pvcv:
        CvXSUBANY(dstr) = CvXSUBANY(sstr);
        CvGV(dstr)      = gv_dup_inc(CvGV(sstr));
        CvDEPTH(dstr)   = CvDEPTH(sstr);
-       CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
+       if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
+           /* XXX padlists are real, but pretend to be not */
+           AvREAL_on(CvPADLIST(sstr));
+           CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
+           AvREAL_off(CvPADLIST(sstr));
+           AvREAL_off(CvPADLIST(dstr));
+       }
+       else
+           CvPADLIST(dstr)     = av_dup_inc(CvPADLIST(sstr));
        CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
        CvFLAGS(dstr)   = CvFLAGS(sstr);
        break;
@@ -6111,7 +6158,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags,
     PERL_SET_INTERP(my_perl);
 
 #ifdef DEBUGGING
-    memset(my_perl, 0xab, sizeof(PerlInterpreter));
+    memset(my_perl, 0x0, sizeof(PerlInterpreter));
     PL_markstack = 0;
     PL_scopestack = 0;
     PL_savestack = 0;
@@ -6195,7 +6242,8 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags,
     PL_compiling               = proto_perl->Icompiling;
     PL_compiling.cop_stashpv   = SAVEPV(PL_compiling.cop_stashpv);
     PL_compiling.cop_file      = SAVEPV(PL_compiling.cop_file);
-    PL_compiling.cop_warnings  = sv_dup_inc(PL_compiling.cop_warnings);
+    if (!specialWARN(PL_compiling.cop_warnings))
+       PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
     if (proto_perl->Tcurcop == &proto_perl->Icompiling)
        PL_curcop       = &PL_compiling;
     else
@@ -6291,7 +6339,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags,
     PL_forkprocess     = proto_perl->Iforkprocess;
 
     /* subprocess state */
-    PL_fdpid           = av_dup(proto_perl->Ifdpid);
+    PL_fdpid           = av_dup_inc(proto_perl->Ifdpid);
 
     /* internal state */
     PL_tainting                = proto_perl->Itainting;
@@ -6336,19 +6384,19 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags,
     }
     else
        PL_exitlist     = (PerlExitListEntry*)NULL;
-    PL_modglobal       = hv_dup(proto_perl->Imodglobal);
+    PL_modglobal       = hv_dup_inc(proto_perl->Imodglobal);
 
     PL_profiledata     = NULL;                 /* XXX */
     PL_rsfp            = fp_dup(proto_perl->Irsfp, '<');
     /* XXX PL_rsfp_filters entries have fake IoDIRP() */
-    PL_rsfp_filters    = av_dup(proto_perl->Irsfp_filters);
+    PL_rsfp_filters    = av_dup_inc(proto_perl->Irsfp_filters);
 
     PL_compcv                  = cv_dup(proto_perl->Icompcv);
     PL_comppad                 = av_dup(proto_perl->Icomppad);
     PL_comppad_name            = av_dup(proto_perl->Icomppad_name);
     PL_comppad_name_fill       = proto_perl->Icomppad_name_fill;
     PL_comppad_name_floor      = proto_perl->Icomppad_name_floor;
-    PL_curpad                  = AvARRAY(PL_comppad);  /* XXX */
+    PL_curpad                  = PL_comppad ? AvARRAY(PL_comppad) : (SV**)NULL;
 
 #ifdef HAVE_INTERP_INTERN
     sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
@@ -6523,7 +6571,7 @@ perl_clone_using(PerlInterpreter *proto_perl, IV flags,
     PL_statbuf         = proto_perl->Tstatbuf;
     PL_statcache       = proto_perl->Tstatcache;
     PL_statgv          = gv_dup(proto_perl->Tstatgv);
-    PL_statname                = sv_dup(proto_perl->Tstatname);
+    PL_statname                = sv_dup_inc(proto_perl->Tstatname);
 #ifdef HAS_TIMES
     PL_timesbuf                = proto_perl->Ttimesbuf;
 #endif

diff --git a/warnings.h b/warnings.h
index a5d50bf..8c1bbf7 100644 (file)
--- a/warnings.h
+++ b/warnings.h
@@ -17,8 +17,8 @@
 #define G_WARN_ALL_MASK                (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define WARN_STD               Nullsv
-#define WARN_ALL               (&PL_sv_yes)    /* use warnings 'all' */
-#define WARN_NONE              (&PL_sv_no)     /* no  warnings 'all' */
+#define WARN_ALL               (Nullsv+1)      /* use warnings 'all' */
+#define WARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 
 #define specialWARN(x)         ((x) == WARN_STD || (x) == WARN_ALL ||  \
                                 (x) == WARN_NONE)

diff --git a/warnings.pl b/warnings.pl
index 9ff4197..72d19af 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -150,8 +150,8 @@ print WARN <<'EOM' ;
 #define G_WARN_ALL_MASK                (G_WARN_ALL_ON|G_WARN_ALL_OFF)
 
 #define WARN_STD               Nullsv
-#define WARN_ALL               (&PL_sv_yes)    /* use warnings 'all' */
-#define WARN_NONE              (&PL_sv_no)     /* no  warnings 'all' */
+#define WARN_ALL               (Nullsv+1)      /* use warnings 'all' */
+#define WARN_NONE              (Nullsv+2)      /* no  warnings 'all' */
 
 #define specialWARN(x)         ((x) == WARN_STD || (x) == WARN_ALL ||  \
                                 (x) == WARN_NONE)

diff --git a/win32/Makefile b/win32/Makefile
index 654643a..c4bb568 100644 (file)
--- a/win32/Makefile
+++ b/win32/Makefile
@@ -145,7 +145,11 @@ CCLIBDIR   = $(CCHOME)\lib
 #
 #BUILDOPT      = $(BUILDOPT) -DPERL_INTERNAL_GLOB
 
+# Beginnings of interpreter cloning/threads: still rather rough, fails
+# many tests.  Do not enable unless you know what you're doing!
 #
+#BUILDOPT      = $(BUILDOPT) -DUSE_ITHREADS
+
 # specify semicolon-separated list of extra directories that modules will
 # look for libraries (spaces in path names need not be quoted)
 #

diff --git a/win32/perllib.c b/win32/perllib.c
index 61798fa..0cf21cb 100644 (file)
--- a/win32/perllib.c
+++ b/win32/perllib.c
@@ -1556,12 +1556,14 @@ RunPerl(int argc, char **argv, char **env)
 
     exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
     if (!exitstatus) {
-#if 0 /* def USE_ITHREADS */           /* XXXXXX testing */
+#ifdef USE_ITHREADS            /* XXXXXX testing */
 extern PerlInterpreter * perl_clone(pTHXx_ IV flags);
 
        PerlInterpreter *new_perl = perl_clone(my_perl, 0);
+       Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */
        exitstatus = perl_run( new_perl );
-       /* perl_destruct(new_perl); perl_free(new_perl); */
+       perl_destruct(new_perl); perl_free(new_perl);
+       SetPerlInterpreter(my_perl);
 #else
        exitstatus = perl_run( my_perl );
 #endif