Move my sub prototype CVs to the pad names

my subs are cloned on scope entry.  To make closures work, a stub
stored in the pad (and closed over elsewhere) is cloned into.

But we need somewhere to store the prototype from which the clone is
made.  I was attaching the prototype via magic to the stub in the pad,
since the pad is available at run time, but not the pad names.

That leads to lots of little games all over the place to make sure
the prototype isn’t lost when the pad is swiped on scope exit
(SAVEt_CLEARSV in scope.c).  We also run the risk of losing it if an
XS module replaces the sub with another.

Instead, we should be storing it with the pad name.  The previous com-
mit made the pad names available at run time, so we can move it there
(still stuffed inside a magic box) and delete much code.

This does mean that newMYSUB cannot rely on the behaviour of non-clon-
able subs that close over variables (or subs) immediately.  Previ-
ously, we would dig through outer scopes to find the stub in cases
like this:

    sub y {
        my sub foo;
        sub x {
            sub {
                sub foo { ... }
            }
        }
    }

We would stop at x, which happens to have y’s stub in its pad, so
that’s no problem.

If we attach it to the pad name, we definitely have to dig past x to
get to the pad name in y’s pad.

Usually, immediate closures do not store the parent pad index, since
it will never be used.  But now we do need to use it, so we modify the
code in pad.c:S_pad_findlex to set it always for my/state.

diff --git a/op.c b/op.c
index 21f271e..ee5d7ee 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6981,12 +6981,9 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        cv = *spot;
     else {
        MAGIC *mg;
+       SvUPGRADE(name, SVt_PVMG);
+       mg = mg_find(name, PERL_MAGIC_proto);
        assert (SvTYPE(*spot) == SVt_PVCV);
-       if (CvROOT(*spot)) {
-           cv = *spot;
-           *svspot = newSV_type(SVt_PVCV);
-           SvPADMY_on(*spot);
-       }
        if (CvNAMED(*spot))
            hek = CvNAME_HEK(*spot);
        else {
@@ -6997,14 +6994,13 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                )
            );
        }
-       mg = mg_find(*svspot, PERL_MAGIC_proto);
        if (mg) {
            assert(mg->mg_obj);
            cv = (CV *)mg->mg_obj;
        }
        else {
-           sv_magic(*svspot, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
-           mg = mg_find(*svspot, PERL_MAGIC_proto);
+           sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+           mg = mg_find(name, PERL_MAGIC_proto);
        }
        spot = (CV **)(svspot = &mg->mg_obj);
     }
@@ -9888,23 +9884,22 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
        case OP_PADCV: {
            PADNAME *name = PAD_COMPNAME(rvop->op_targ);
            CV *compcv = PL_compcv;
-           SV *sv = PAD_SV(rvop->op_targ);
-           while (SvTYPE(sv) != SVt_PVCV) {
-               assert(PadnameOUTER(name));
+           PADOFFSET off = rvop->op_targ;
+           while (PadnameOUTER(name)) {
                assert(PARENT_PAD_INDEX(name));
                compcv = CvOUTSIDE(PL_compcv);
-               sv = AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])
-                       [PARENT_PAD_INDEX(name)];
                name = PadlistNAMESARRAY(CvPADLIST(compcv))
-                       [PARENT_PAD_INDEX(name)];
+                       [off = PARENT_PAD_INDEX(name)];
            }
-           if (!PadnameIsOUR(name) && !PadnameIsSTATE(name)) {
-               MAGIC * mg = mg_find(sv, PERL_MAGIC_proto);
+           assert(!PadnameIsOUR(name));
+           if (!PadnameIsSTATE(name)) {
+               MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
                assert(mg);
                assert(mg->mg_obj);
                cv = (CV *)mg->mg_obj;
            }
-           else cv = (CV *)sv;
+           else cv =
+                   (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
            gv = NULL;
        } break;
        default: {

diff --git a/pad.c b/pad.c
index 2d14810..e25d06d 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1383,6 +1383,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
        else {
            /* immediate creation - capture outer value right now */
            av_store(PL_comppad, new_offset, SvREFCNT_inc(*new_capturep));
+           /* But also note the offset, as newMYSUB needs it */
+           PARENT_PAD_INDEX_set(new_namesv, offset);
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                "Pad findlex cv=0x%"UVxf" saved captured sv 0x%"UVxf" at offset %ld\n",
                PTR2UV(cv), PTR2UV(*new_capturep), (long)new_offset));
@@ -2059,26 +2061,9 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                    else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
                    {
                        /* my sub */
-                     sv = newSV_type(SVt_PVCV);
-                     if (SvTYPE(ppad[ix]) == SVt_PVCV) {
-                       /* This is actually a stub with a proto CV attached
-                          to it by magic.  Since the stub itself is used
-                          when the proto is cloned, we need a new stub
-                          that nonetheless shares the same proto.
-                        */
-                       MAGIC * const mg =
-                           mg_find(ppad[ix], PERL_MAGIC_proto);
-                       assert(mg);
-                       assert(mg->mg_obj);
-                       assert(SvTYPE(ppad[ix]) == SVt_PVCV);
-                       assert(CvNAME_HEK((CV *)ppad[ix]));
-                       CvNAME_HEK_set(sv,
-                           share_hek_hek(CvNAME_HEK((CV *)ppad[ix])));
-                       sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0);
-                     }
-                     else {
-                       assert(SvTYPE(ppad[ix]) == SVt_NULL);
-                       /* Unavailable; just provide a stub, but name it */
+                       /* Just provide a stub, but name it.  It will be
+                          upgrade to the real thing on scope entry. */
+                       sv = newSV_type(SVt_PVCV);
                        CvNAME_HEK_set(
                            sv,
                            share_hek(SvPVX_const(namesv)+1,
@@ -2086,7 +2071,6 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
                                         * (SvUTF8(namesv) ? -1 : 1),
                                      0)
                        );
-                     }
                    }
                    else sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')

diff --git a/pp.c b/pp.c
index 6448462..e587f7d 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -162,13 +162,13 @@ PP(pp_introcv)
 PP(pp_clonecv)
 {
     dVAR; dTARGET;
-    MAGIC * const mg = mg_find(TARG, PERL_MAGIC_proto);
+    MAGIC * const mg =
+       mg_find(AvARRAY(PL_comppad_name)[ARGTARG], PERL_MAGIC_proto);
     assert(SvTYPE(TARG) == SVt_PVCV);
     assert(mg);
     assert(mg->mg_obj);
     if (CvISXSUB(mg->mg_obj)) { /* constant */
        /* XXX Should we clone it here? */
-       /* XXX Does this play nicely with pad_push? */
        /* If this changes to use SAVECLEARSV, we can move the SAVECLEARSV
           to introcv and remove the SvPADSTALE_off. */
        SAVEPADSVANDMORTALIZE(ARGTARG);

diff --git a/scope.c b/scope.c
index c3025f8..e3b4c79 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -955,8 +955,6 @@ Perl_leave_scope(pTHX_ I32 base)
                case SVt_PVCV:
                {
                    SV ** const svp = (SV **)ptr;
-                   MAGIC *mg = SvMAGIC(sv);
-                   MAGIC **tomg = &SvMAGIC(sv);
 
                    /* Create a stub */
                    *svp = newSV_type(SVt_PVCV);
@@ -965,18 +963,6 @@ Perl_leave_scope(pTHX_ I32 base)
                    assert(CvNAMED(sv));
                    CvNAME_HEK_set(*svp,
                        share_hek_hek(CvNAME_HEK((CV *)sv)));
-
-                   /* Steal magic */
-                   while (mg) {
-                       if (mg->mg_type == PERL_MAGIC_proto) break;
-                       mg = *(tomg = &mg->mg_moremagic);
-                   }
-                   assert(mg);
-                   *tomg = mg->mg_moremagic;
-                   mg->mg_moremagic = SvMAGIC(*svp);
-                   SvMAGIC(*svp) = mg;
-                   mg_magical(*svp);
-                   mg_magical(sv);
                    break;
                }
                default:        *(SV**)ptr = newSV(0);          break;