Clone my subs on scope entry

The pad slot for a my sub now holds a stub with a prototype CV
attached to it by proto magic.

The prototype is cloned on scope entry.  The stub in the pad is used
when cloning, so any code that references the sub before scope entry
will be able to see that stub become defined, making these behave
similarly:

    our $x;
    BEGIN { $x = \&foo }
    sub foo { }

    our $x;
    my sub foo { }
    BEGIN { $x = \&foo }

Constants are currently not cloned, but that may cause bugs in
pad_push.  I’ll have to look into that.

On scope exit, lexical CVs go through leave_scope’s SAVEt_CLEARSV sec-
tion, like lexical variables.  If the sub is referenced elsewhere, it
is abandoned, and its proto magic is stolen and attached to a new stub
stored in the pad.  If the sub is not referenced elsewhere, it is
undefined via cv_undef.

To clone my subs on scope entry, we create a sequence of introcv and
clonecv ops.  See the huge comment in block_end that explains why we
need two separate ops for each CV.

To allow my subs to be defined in inner subs (my sub foo; sub { sub
foo {} }), pad_add_name_pvn and S_pad_findlex now upgrade the entry
for a my sub to a CV to begin with, so that fake entries added to pads
(fake entries are those that reference outer pads) can share the same
CV.  Otherwise newMYSUB would have to add the CV to every pad that
closes over the ‘my sub’ declaration.  newMYSUB no longer throws away
the initial value replacing it with a new one.

Prototypes are not currently visible to sub calls at compile time,
because the lexer sees the empty stub.  A future commit will
solve that.

When I added name heks to CV’s I made mistakes in a few places, by not
turning on the CVf_NAMED flag, or by not clearing the field when free-
ing the hek.  Those code paths were not exercised enough by state
subs, so the problems did not show up till now.  So this commit fixes
those, too.

One of the tests in lexsub.t, involving foreach loops, was incorrect,
and has been fixed.  Another test has been added to the end for a par-
ticular case of state subs closing over my subs that I broke when ini-
tially trying to get sibling my subs to close over each other, before
I had separate introcv and clonecv ops.

1 files changed, 54 insertions, 6 deletions

diff --git a/pad.c b/pad.c
index d3200049f2..7a3fad4f66 100644
--- a/pad.c
+++ b/pad.c
@@ -381,7 +381,8 @@ Perl_cv_undef(pTHX_ CV *cv)
 #endif
     SvPOK_off(MUTABLE_SV(cv));		/* forget prototype */
     sv_unmagic((SV *)cv, PERL_MAGIC_checkcall);
-    if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv));
+    if (CvNAMED(cv)) unshare_hek(CvNAME_HEK(cv)),
+		     SvANY(cv)->xcv_gv_u.xcv_hek = NULL;
     else	     CvGV_set(cv, NULL);
 
     /* This statement and the subsequence if block was pad_undef().  */
@@ -646,6 +647,8 @@ Perl_pad_add_name_pvn(pTHX_ const char *namepv, STRLEN namelen,
 	sv_upgrade(PL_curpad[offset], SVt_PVAV);
     else if (namelen != 0 && *namepv == '%')
 	sv_upgrade(PL_curpad[offset], SVt_PVHV);
+    else if (namelen != 0 && *namepv == '&')
+	sv_upgrade(PL_curpad[offset], SVt_PVCV);
     assert(SvPADMY(PL_curpad[offset]));
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 			   "Pad addname: %ld \"%s\" new lex=0x%"UVxf"\n",
@@ -1298,6 +1301,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen, U32 flags, const CV* cv,
 			*out_capture = sv_2mortal(MUTABLE_SV(newAV()));
 		    else if (namelen != 0 && *namepv == '%')
 			*out_capture = sv_2mortal(MUTABLE_SV(newHV()));
+		    else if (namelen != 0 && *namepv == '&')
+			*out_capture = sv_2mortal(newSV_type(SVt_PVCV));
 		    else
 			*out_capture = sv_newmortal();
 		}
@@ -1531,11 +1536,12 @@ lexicals in this scope and warn of any lexicals that never got introduced.
 =cut
 */
 
-void
+OP *
 Perl_pad_leavemy(pTHX)
 {
     dVAR;
     I32 off;
+    OP *o = NULL;
     SV * const * const svp = AvARRAY(PL_comppad_name);
 
     PL_pad_reset_pending = FALSE;
@@ -1552,7 +1558,7 @@ Perl_pad_leavemy(pTHX)
     }
     /* "Deintroduce" my variables that are leaving with this scope. */
     for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_fill; off--) {
-	const SV * const sv = svp[off];
+	SV * const sv = svp[off];
 	if (sv && sv != &PL_sv_undef && !SvFAKE(sv)
 	    && COP_SEQ_RANGE_HIGH(sv) == PERL_PADSEQ_INTRO)
 	{
@@ -1563,6 +1569,12 @@ Perl_pad_leavemy(pTHX)
 		(unsigned long)COP_SEQ_RANGE_LOW(sv),
 		(unsigned long)COP_SEQ_RANGE_HIGH(sv))
 	    );
+	    if (!PadnameIsSTATE(sv) && !PadnameIsOUR(sv)
+	     && *PadnamePV(sv) == '&' && PadnameLEN(sv) > 1) {
+		OP *kid = newOP(OP_INTROCV, 0);
+		kid->op_targ = off;
+		o = op_prepend_elem(OP_LINESEQ, kid, o);
+	    }
 	}
     }
     PL_cop_seqmax++;
@@ -1570,6 +1582,7 @@ Perl_pad_leavemy(pTHX)
 	PL_cop_seqmax++;
     DEBUG_Xv(PerlIO_printf(Perl_debug_log,
 	    "Pad leavemy: seq = %ld\n", (long)PL_cop_seqmax));
+    return o;
 }
 
 /*
@@ -2038,9 +2051,32 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside)
 		       ing over other state subs’ entries, so we have
 		       to put a stub here and then clone into it on the
 		       second pass. */
-		    sv = SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])
-			? (subclones = 1, newSV_type(SVt_PVCV))
-			: SvREFCNT_inc(ppad[ix]);
+		    if (SvPAD_STATE(namesv) && !CvCLONED(ppad[ix])) {
+			assert(SvTYPE(ppad[ix]) == SVt_PVCV);
+			subclones = 1;
+			sv = newSV_type(SVt_PVCV);
+		    }
+		    else if (PadnameLEN(namesv)>1 && !PadnameIsOUR(namesv))
+		    {
+			/* my sub */
+			/* 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]));
+			sv = newSV_type(SVt_PVCV);
+			SvANY((CV *)sv)->xcv_gv_u.xcv_hek =
+			    share_hek_hek(CvNAME_HEK((CV *)ppad[ix]));
+			CvNAMED_on(sv);
+			sv_magic(sv,mg->mg_obj,PERL_MAGIC_proto,NULL,0);
+		    }
+		    else sv = SvREFCNT_inc(ppad[ix]);
                 else if (sigil == '@')
 		    sv = MUTABLE_SV(newAV());
                 else if (sigil == '%')
@@ -2087,7 +2123,10 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
     CvFILE(cv)		= CvDYNFILE(proto) ? savepv(CvFILE(proto))
 					   : CvFILE(proto);
     if (CvNAMED(proto))
+    {
 	 SvANY(cv)->xcv_gv_u.xcv_hek = share_hek_hek(CvNAME_HEK(proto));
+	 CvNAMED_on(cv);
+    }
     else CvGV_set(cv,CvGV(proto));
     CvSTASH_set(cv, CvSTASH(proto));
     OP_REFCNT_LOCK;
@@ -2141,6 +2180,15 @@ Perl_cv_clone(pTHX_ CV *proto)
     return S_cv_clone(aTHX_ proto, NULL, NULL);
 }
 
+/* Called only by pp_clonecv */
+CV *
+Perl_cv_clone_into(pTHX_ CV *proto, CV *target)
+{
+    PERL_ARGS_ASSERT_CV_CLONE_INTO;
+    cv_undef(target);
+    return S_cv_clone(aTHX_ proto, target, NULL);
+}
+
 /*
 =for apidoc m|void|pad_fixup_inner_anons|PADLIST *padlist|CV *old_cv|CV *new_cv