summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--embed.fnc2
-rw-r--r--embed.h2
-rw-r--r--op.c57
-rw-r--r--pad.c19
-rw-r--r--proto.h2
-rw-r--r--t/op/sub.t12
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