Revert "[perl #79908] Stop sub inlining from breaking closures"

This reverts commit 137da2b05b4b7628115049f343163bdaf2c30dbb. See the
"How about having a recommended way to add constant subs dynamically?"
thread on perl5-porters, specifically while it sucks that we have this
bug, it's been documented to work this way since 5.003 in "Constant
Functions" in perlsub:

    If the result after optimization and constant folding is either a
    constant or a lexically-scoped scalar which has no other references,
    then it will be used in place of function calls made without C<&>

    -- http://perldoc.perl.org/perlsub.html#Constant-Functions

Since we've had this documented bug for a long time we should introduce
this fix in a deprecation cycle rather than silently slowing down code
that assumes it's going to be optimized by constant folding.

I didn't revert the tests it t/op/sub.t, but turned them into TODO tests
instead.

Conflicts:
	t/op/sub.t

6 files changed, 85 insertions, 9 deletions

diff --git a/embed.fnc b/embed.fnc
index 1545bd2caf..c78f345723 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -310,7 +310,7 @@ ApdR	|SV*	|gv_const_sv	|NN GV* gv
 ApdR	|SV*	|cv_const_sv	|NULLOK const CV *const cv
 pR	|SV*	|cv_const_sv_or_av|NULLOK const CV *const cv
 : Used in pad.c
-pR	|SV*	|op_const_sv	|NULLOK const OP* o
+pR	|SV*	|op_const_sv	|NULLOK const OP* o|NULLOK CV* cv
 Apd	|void	|cv_undef	|NN CV* cv
 p	|void	|cv_forget_slab	|NN CV *cv
 Ap	|void	|cx_dump	|NN PERL_CONTEXT* cx
diff --git a/embed.h b/embed.h
index d4b175225c..a6e3b9d182 100644
--- a/embed.h
+++ b/embed.h
@@ -1206,7 +1206,7 @@
 #define nextargv(a)		Perl_nextargv(aTHX_ a)
 #define oopsAV(a)		Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)		Perl_oopsHV(aTHX_ a)
-#define op_const_sv(a)		Perl_op_const_sv(aTHX_ a)
+#define op_const_sv(a,b)	Perl_op_const_sv(aTHX_ a,b)
 #define op_unscope(a)		Perl_op_unscope(aTHX_ a)
 #define package_version(a)	Perl_package_version(aTHX_ a)
 #define pad_block_start(a)	Perl_pad_block_start(aTHX_ a)
diff --git a/op.c b/op.c
index 716c684ccc..796cb0346c 100644
--- a/op.c
+++ b/op.c
@@ -7248,10 +7248,28 @@ Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
 }
 
 /* op_const_sv:  examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * 	look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ * 	examine the clone prototype, and if contains only a single
+ * 	OP_CONST referencing a pad const, or a single PADSV referencing
+ * 	an outer lexical, return a non-zero value to indicate the CV is
+ * 	a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ *	We have just cloned an anon prototype that was marked as a const
+ *	candidate. Try to grab the current value, and in the case of
+ *	PADSV, ignore it if it has multiple references. In this case we
+ *	return a newly created *copy* of the value.
  */
 
 SV *
-Perl_op_const_sv(pTHX_ const OP *o)
+Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
 {
     dVAR;
     SV *sv = NULL;
@@ -7284,6 +7302,27 @@ Perl_op_const_sv(pTHX_ const OP *o)
 	    return NULL;
 	if (type == OP_CONST && cSVOPo->op_sv)
 	    sv = cSVOPo->op_sv;
+	else if (cv && type == OP_CONST) {
+	    sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+	    if (!sv)
+		return NULL;
+	}
+	else if (cv && type == OP_PADSV) {
+	    if (CvCONST(cv)) { /* newly cloned anon */
+		sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+		/* the candidate should have 1 ref from this pad and 1 ref
+		 * from the parent */
+		if (!sv || SvREFCNT(sv) != 2)
+		    return NULL;
+		sv = newSVsv(sv);
+		SvREADONLY_on(sv);
+		return sv;
+	    }
+	    else {
+		if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+		    sv = &PL_sv_undef; /* an arbitrary non-null value */
+	    }
+	}
 	else {
 	    return NULL;
 	}
@@ -7455,7 +7494,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	)
 	const_sv = NULL;
     else
-	const_sv = op_const_sv(block);
+	const_sv = op_const_sv(block, NULL);
 
     if (cv) {
         const bool exists = CvROOT(cv) || CvXSUB(cv);
@@ -7628,6 +7667,12 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 
     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
 
+    if (CvCLONE(cv)) {
+	assert(!CvCONST(cv));
+	if (ps && !*ps && op_const_sv(block, cv))
+	    CvCONST_on(cv);
+    }
+
   attrs:
     if (attrs) {
 	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
@@ -7822,7 +7867,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 	)
 	const_sv = NULL;
     else
-	const_sv = op_const_sv(block);
+	const_sv = op_const_sv(block, NULL);
 
     if (cv) {
         const bool exists = CvROOT(cv) || CvXSUB(cv);
@@ -7984,6 +8029,12 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs,
 
     pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
 
+    if (CvCLONE(cv)) {
+	assert(!CvCONST(cv));
+	if (ps && !*ps && op_const_sv(block, cv))
+	    CvCONST_on(cv);
+    }
+
   attrs:
     if (attrs) {
 	/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
diff --git a/pad.c b/pad.c
index 419b40338d..31282d157d 100644
--- a/pad.c
+++ b/pad.c
@@ -2197,6 +2197,25 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
 	cv_dump(cv,	 "To");
     );
 
+    if (CvCONST(cv)) {
+	/* Constant sub () { $x } closing over $x - see lib/constant.pm:
+	 * The prototype was marked as a candiate for const-ization,
+	 * so try to grab the current const value, and if successful,
+	 * turn into a const sub:
+	 */
+	SV* const const_sv = op_const_sv(CvSTART(cv), cv);
+	if (const_sv) {
+	    SvREFCNT_dec_NN(cv);
+            /* For this calling case, op_const_sv returns a *copy*, which we
+               donate to newCONSTSUB. Yes, this is ugly, and should be killed.
+               Need to fix how lib/constant.pm works to eliminate this.  */
+	    cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+	}
+	else {
+	    CvCONST_off(cv);
+	}
+    }
+
     return cv;
 }
 
diff --git a/proto.h b/proto.h
index a553202f81..a6ee09aa85 100644
--- a/proto.h
+++ b/proto.h
@@ -3064,7 +3064,7 @@ PERL_CALLCONV void	Perl_op_clear(pTHX_ OP* o)
 #define PERL_ARGS_ASSERT_OP_CLEAR	\
 	assert(o)
 
-PERL_CALLCONV SV*	Perl_op_const_sv(pTHX_ const OP* o)
+PERL_CALLCONV SV*	Perl_op_const_sv(pTHX_ const OP* o, CV* cv)
 			__attribute__warn_unused_result__;
 
 PERL_CALLCONV OP*	Perl_op_contextualize(pTHX_ OP* o, I32 context)
diff --git a/t/op/sub.t b/t/op/sub.t
index a0860636d8..7df8f49aab 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -152,7 +152,10 @@ is eval {
     my $x = 5;
     *_79908 = sub (){$x};
     $x = 7;
-    is eval "_79908", 7, 'sub(){$x} does not break closures';
+    TODO: {
+        local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
+        is eval "_79908", 7, 'sub(){$x} does not break closures';
+    }
     isnt eval '\_79908', \$x, 'sub(){$x} returns a copy';
 
     # Test another thing that was broken by $x inlinement
@@ -162,8 +165,11 @@ is eval {
     my $w;
     local $SIG{__WARN__} = sub { $w .= shift };
     eval "()=time";
-    is $w, undef,
-      '*keyword = sub():method{$y} does not cause ambiguity warnings';
+    TODO: {
+        local $TODO = "Should be fixed with a deprecation cycle, see 'How about having a recommended way to add constant subs dynamically?' on p5p";
+        is $w, undef,
+          '*keyword = sub():method{$y} does not cause ambiguity warnings';
+    }
 }
 
 # &xsub when @_ has nonexistent elements