Support named closures

6 files changed, 38 insertions, 14 deletions

diff --git a/cv.h b/cv.h
index b08cf5c1d0..d94fb45b62 100644
--- a/cv.h
+++ b/cv.h
@@ -47,6 +47,7 @@ struct xpvcv {
 #define CVf_CLONED	0x02	/* a clone of one of those */
 #define CVf_ANON	0x04	/* CvGV() can't be trusted */
 #define CVf_OLDSTYLE	0x08
+#define CVf_UNIQUE	0x10	/* can't be cloned */
 
 #define CvCLONE(cv)		(CvFLAGS(cv) & CVf_CLONE)
 #define CvCLONE_on(cv)		(CvFLAGS(cv) |= CVf_CLONE)
@@ -63,3 +64,7 @@ struct xpvcv {
 #define CvOLDSTYLE(cv)		(CvFLAGS(cv) & CVf_OLDSTYLE)
 #define CvOLDSTYLE_on(cv)	(CvFLAGS(cv) |= CVf_OLDSTYLE)
 #define CvOLDSTYLE_off(cv)	(CvFLAGS(cv) &= ~CVf_OLDSTYLE)
+
+#define CvUNIQUE(cv)		(CvFLAGS(cv) & CVf_UNIQUE)
+#define CvUNIQUE_on(cv)		(CvFLAGS(cv) |= CVf_UNIQUE)
+#define CvUNIQUE_off(cv)	(CvFLAGS(cv) &= ~CVf_UNIQUE)
diff --git a/op.c b/op.c
index 3ab85b3545..eecde67660 100644
--- a/op.c
+++ b/op.c
@@ -195,7 +195,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 
 		depth = CvDEPTH(cv);
 		if (!depth) {
-		    if (newoff && (CvANON(cv) || CvGV(cv)))
+		    if (newoff && !CvUNIQUE(cv))
 			return 0; /* don't clone inactive sub's stack frame */
 		    depth = 1;
 		}
@@ -210,14 +210,16 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
 		    SvNVX(sv) = (double)curcop->cop_seq;
 		    SvIVX(sv) = 999999999;	/* A ref, intro immediately */
 		    SvFLAGS(sv) |= SVf_FAKE;
-		    /* "It's closures all the way down." */
-		    CvCLONE_on(compcv);
-		    if (cv != startcv) {
-			CV *bcv;
-			for (bcv = startcv;
-			     bcv && bcv != cv && !CvCLONE(bcv);
-			     bcv = CvOUTSIDE(bcv))
-			    CvCLONE_on(bcv);
+		    if (!CvUNIQUE(cv)) {
+			/* "It's closures all the way down." */
+			CvCLONE_on(compcv);
+			if (cv != startcv) {
+			    CV *bcv;
+			    for (bcv = startcv;
+				 bcv && bcv != cv && !CvCLONE(bcv);
+				 bcv = CvOUTSIDE(bcv))
+				CvCLONE_on(bcv);
+			}
 		    }
 		}
 		av_store(comppad, newoff, SvREFCNT_inc(oldsv));
@@ -2798,11 +2800,13 @@ CV* cv;
 		  cv,
 		  (CvANON(cv) ? "ANON"
 		   : (cv == main_cv) ? "MAIN"
+		   : CvUNIQUE(outside) ? "UNIQUE"
 		   : CvGV(cv) ? GvNAME(CvGV(cv)) : "?mystery?"),
 		  outside,
 		  (!outside ? "null"
 		   : CvANON(outside) ? "ANON"
 		   : (outside == main_cv) ? "MAIN"
+		   : CvUNIQUE(outside) ? "UNIQUE"
 		   : CvGV(outside) ? GvNAME(CvGV(outside)) : "?mystery?"));
 
     for (ix = 1; ix <= AvFILL(pad); ix++) {
@@ -2830,6 +2834,8 @@ CV* outside;
     AV* comppadlist;
     CV* cv;
 
+    assert(!CvUNIQUE(proto));
+
     ENTER;
     SAVESPTR(curpad);
     SAVESPTR(comppad);
diff --git a/perl.c b/perl.c
index d4c626c7f5..aa6a1a4d8b 100644
--- a/perl.c
+++ b/perl.c
@@ -562,6 +562,7 @@ setuid perl scripts securely.\n");
 
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     av_push(comppad, Nullsv);
diff --git a/pp.c b/pp.c
index e071ee3c07..db4276e5a1 100644
--- a/pp.c
+++ b/pp.c
@@ -248,8 +248,11 @@ PP(pp_rv2cv)
     /* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
     /* (But not in defined().) */
     CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
-
-    if (!cv)
+    if (cv) {
+	if (CvCLONE(cv))
+	    cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+    }
+    else
 	cv = (CV*)&sv_undef;
     SETs((SV*)cv);
     RETURN;
diff --git a/pp_ctl.c b/pp_ctl.c
index 332ae4831d..1350de4196 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1926,7 +1926,7 @@ int gimme;
     SAVESPTR(compcv);
     compcv = (CV*)NEWSV(1104,0);
     sv_upgrade((SV *)compcv, SVt_PVCV);
-    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+    CvUNIQUE_on(compcv);
 
     comppad = newAV();
     comppad_name = newAV();
@@ -1941,6 +1941,8 @@ int gimme;
     av_store(comppadlist, 0, (SV*)comppad_name);
     av_store(comppadlist, 1, (SV*)comppad);
     CvPADLIST(compcv) = comppadlist;
+    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
     SAVEFREESV(compcv);
 
     /* make sure we compile in the right package */
diff --git a/pp_hot.c b/pp_hot.c
index 41ad9f4893..9633d54e88 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1682,7 +1682,8 @@ PP(pp_entersub)
     register CV *cv;
     register CONTEXT *cx;
     I32 gimme;
-    I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
+    bool hasargs = (op->op_flags & OPf_STACKED) != 0;
+    bool may_clone = TRUE;
 
     if (!sv)
 	DIE("Not a CODE reference");
@@ -1702,14 +1703,17 @@ PP(pp_entersub)
 	    break;
 	}
 	cv = (CV*)SvRV(sv);
-	if (SvTYPE(cv) == SVt_PVCV)
+	if (SvTYPE(cv) == SVt_PVCV) {
+	    may_clone = FALSE;
 	    break;
+	}
 	/* FALL THROUGH */
     case SVt_PVHV:
     case SVt_PVAV:
 	DIE("Not a CODE reference");
     case SVt_PVCV:
 	cv = (CV*)sv;
+	may_clone = FALSE;
 	break;
     case SVt_PVGV:
 	if (!(cv = GvCV((GV*)sv)))
@@ -1720,6 +1724,9 @@ PP(pp_entersub)
     ENTER;
     SAVETMPS;
 
+    if (may_clone && cv && CvCLONE(cv))
+	cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+
   retry:
     if (!cv)
 	DIE("Not a CODE reference");