In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/c74d82e0fe4dd71d3b113d1a8a651b6f48184019?hp=9a18979311347ab1c45e2ef16113bb5abe4cbd26>
- Log -----------------------------------------------------------------
commit c74d82e0fe4dd71d3b113d1a8a651b6f48184019
Merge: 8915ba3 d3c633b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Nov 13 04:52:55 2014 -0800
[Merge] Constant inlining clean-up
This branch makes perl more consistent in how it turns sub(){...} into
a constant.
Previously, it did not behave as documented, or at least not all the
time. And whether an anonymous sub was clonable made a difference to
the behaviour. Clonable subs are usually closures, but they could
also be anonymous subs containing state declarations or string evals,
or any anonymous subs under the debugger. âClosuresâ below includes
any clonable subs.
⢠Explicit return never makes a constant (as promised in the docs).
⢠Statements optimised away are ignored (not just with closures).
⢠Lvalue and custom attributes now prevent constants with closures,
as they have already done for non-closures.
⢠Method attributes no longer prevent constants with non-closures.
⢠Closing over a variable potentially modified elsewhere will con-
tinue to make a constant as before, but is detected and deprecated.
⢠More complex cases than sub(){$x}, such as sub(){foo() if 0; $x}
just follow the new behaviour, which is not to make a constant if
$x is modifiable elsewhere.
And a few other bug fixes.
commit d3c633bad10e97654c0903dcb92dcebbee444ce6
Author: Father Chrysostomos <spr...@cpan.org>
Date: Wed Nov 12 22:29:27 2014 -0800
Document sub inlining changes
Most of the changes do not need to be documented, because the previous
behaviour did not match the documentation or was just plain buggy.
M pod/perlsub.pod
commit 04472a849792297300059ba880a7ad59900aa5b8
Author: Father Chrysostomos <spr...@cpan.org>
Date: Tue Nov 4 13:25:49 2014 -0800
pad.c:cv_clone_pad: Avoid copying sv
When we capture the lexical variable in order to make sub () {$x}
constant, we donât have to copy it if it is not modified or referenced
elsewhere.
M pad.c
M scope.c
commit e4211fee6f4152b99074ac26f85747ac3fba448b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Nov 3 22:28:08 2014 -0800
Account for state vars when const-izing sub(){$x}
If the only lvalue use of a lexical âmyâ variable is its declaration,
then it is fine to turn a sub that closes over it into a constant.
But with state variables we have to be a little more careful.
This is fine:
state $x = something();
sub () { $x }
because the variable is only assigned to once. But this modifies the
same variable every time the enclosing sub is called:
state $x++;
sub () { $x }
So that closure must remain a closure, and not become a constant.
(However, for a simple lexical scalar in the sub like that, we still
make it a constant, but deprecate the usage.)
M op.c
M t/op/const-optree.t
commit 03414f05f41ecc10f644b53e455358ae8125d158
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Nov 3 22:18:11 2014 -0800
Account for string eval when const-izing sub(){$x}
If we have a string eval in the same scope as the variable, it is
potentially in value context.
M inline.h
M op.c
M pad.c
M t/op/const-optree.t
commit 7a2b740ab541f1d6fadd7282391ae3fda8c1c3af
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Nov 3 17:56:11 2014 -0800
Make op.c:op_const_sv static
It is no longer called from any other file.
M embed.fnc
M embed.h
M op.c
M proto.h
commit d8d6ddf8b51240f0ea81626a66b88b172ca30364
Author: Father Chrysostomos <spr...@cpan.org>
Date: Mon Nov 3 17:53:01 2014 -0800
Inline op_const_sv into cv_clone
op_const_sv is actually two functions in one. This particular calling
convention (CvCONST) was used only by cv_clone.
Half the code was not even necessary for cv_cloneâs use (the other
half only for its use), so this reduces the total number of lines.
M embed.fnc
M embed.h
M op.c
M pad.c
M proto.h
commit 73c13e16ff95b775e0d9b3a78dc422b3c96aa086
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 22:24:32 2014 -0800
Make sub () { 0; 3 } inlinable once more
It probably stopped being inlinable in commit beab0874143b.
Following op_next pointers to see whether a subâs execution chain con-
sists of a constant followed by sub exit does not make sense if the
op_next pointers have not been set up yet.
So call LINKLIST earlier, so that we can merge the two calls to
op_const_sv in newATTRSUB (no need to search for constants twice).
That will allow sub () { 0; 3 } to be inlined once more, as it was in
perl 5.005 (I checked) and probably in 5.6, too (I didnât check).
This also allows us to remove initial the OP_LINESEQ check, which
was added to help this function into the block when we have no
op_next pointers.
op_const_sv is now called only before the peephole optimiser and
finalize_op, which removes the need for the special explicit return
check (it hasnât been optimised out of the execution chain yet) and
the need to account for constants that have been relocated to the pad
by finalize_op.
M embed.fnc
M embed.h
M op.c
M pad.c
M proto.h
M t/op/const-optree.t
commit 7a3e5b7e7f731d44ac601c08cb38bb6c5bc900c4
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 21:54:22 2014 -0800
Allow sub():method{CONSTANT} to be inlined
This brings non-closure subs into conformity with closures.
M op.c
M t/op/const-optree.t
commit a642da7263dec18aa73cc82297c22867e050a28c
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 21:34:23 2014 -0800
First arg to op_const_sv is never null
M embed.fnc
M op.c
M proto.h
commit d0a32af375ac806258a97cce0091ce4b3636f8dc
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 16:50:40 2014 -0800
Remove SvREADONLY_on from op.c:op_const_sv
If we turn on the padtmp flag, then this this SV will never be seen in
lvalue context, so whether it is read-only is irrelevant. Donât even
bother making it so.
M op.c
commit b4fbc73e81381ab07b6809659ad3b9efccaff2c0
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 16:46:57 2014 -0800
op.c:Start the search for const vars at CvSTART
When we search an op tree to see whether it could become a constant
closure, we search the op execution chain, but we donât necessarily
start at the beginning. We start at the outermost op of the first
statementâs contents. That means that for sub {$a+$b} we begin the
search at the + (add), even though the full execution chain is next-
state, gvsv, gvsv, add, leavesub.
It was this oddity that led to bug #63540. Originally (before
beab0874143b), the search through the op chain started at CvSTART
(the start of the execution chain), but was accidentally changed
in beab0874143b. (That was also when sub(){return 2} stopped
being inlined.)
Changing this back to the way it used to be allows use to remove the
check to see whether a null op has kids, which was added to handle op
trees like
b leavesub
- lineseq
1 nextstate
- null ->9
3 and
2 padsv
8 leave
4 enter
5 nextstate
7 die
6 pushmark
9 nextstate
a const
which is the result of sub { if($x){ die }; 0 }.
If we begin the search at the null op, and if nulls are skipped, we
end up missing the entire âifâ block and seeing just null, nextstate,
const, leavesub, which looks constant.
M op.c
commit f1603422ae0a192fdd8f8245e90bd3f082dd0c62
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 16:31:27 2014 -0800
Handle multiple closures in sub(){$x} const-izing
Till now, we were checking the reference count of the variable that we
have just closed over, to see whether the newly-cloned sub can become
a constant. A reference count of 2 would indicate that only the outer
pad and the pad of the newly-cloned sub held references.
Recent commits also checked whether the variable is used in lvalue
context in the outer sub in places other than its declaration.
This is insufficient to detect cases like:
my $x = 43;
my $const_closure = sub () { $x };
my $other_closure = sub {$x++};
Although it does work if the $other_closure comes first (because it
holds a refcount by the time the $const_closure is created).
Extending the check for lvalue uses to inner subs as well (the changes
this commit makes to op_lvalue_flags) fixes that issue. It does not
allows cases like
my $x = 43;
my $other_closure = sub { $x };
my $const_closure = sub () { $x };
to create a constant, because the reference count check still prevents
it. I tried removing the reference count check, but it fails for
cases like \(my $x = 1), which allows $x to be referenced elsewhere,
even though the only lvalue use of it is its declaration.
As with the commits leading up to this, we allow a simple sub(){$x} to
create constants erroneously where it would have done so before, but
with a deprecation warning.
The deprecation warning had to be moved, because it could trigger even
in those cases where the refcount check fails and we donât create a
constant, which is just wrong.
This commit does not account for string eval within the scope of
the variable.
M op.c
M t/op/const-optree.t
commit a41f70ad015230573fe0128d7bc385d4aa0bfc9f
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 06:20:09 2014 -0800
const-optree.t: Correct comment
M t/op/const-optree.t
commit 9d391755a062145d74c79dabcfd610dda7e9c441
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sun Nov 2 06:02:18 2014 -0800
Donât inline sub(){ 0; return $x }
If return occurs at the end of a sub, it is optimised out of the
execution, chain, so we have to look at the op tree structure to
detect it.
M op.c
M t/op/const-optree.t
commit 3c37c25ad7cb92aee523edcbedcb46950479df92
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 22:17:39 2014 -0700
Donât inline sub(){ 0; return $x; ... }
We document that explicit return prevents subs from being inlined.
But if that explicit return comes after a statement optimised away,
then it does not prevent inlining.
Originally, explicit return did not prevent inlining, and the way
constant subs were detected was to search through the op chain in
execution order, looking for padsv followed by return or leavesub.
Later, things were accidentally changed, such that the search began,
not at the beginning of the execution chain, but at the outer-
most op of the first statementâs contents. That means that, with
sub () { $a + $b }, we begin the search at the + (add), even though
the execution order is nextstate, gvsv, gvsv, add, leavesub. So for
sub () { return $x } we begin the search at return, and miss the padsv
that precedes it.
Even though it was accidental that âreturnâ inlining was broken, it
ended up becoming a documented feature, and has been so for over a
decade. So I am just making things consistent with that.
This commit only affects those cases where the return is not at the
end of the sub. At the end of the sub, the return is optimised out of
the execution chain, so it requires a little more work, which the next
commit will do.
M op.c
M t/op/const-optree.t
commit cb12c7ef455562eb196a81a76e8968794ce8f455
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 22:01:54 2014 -0700
const-optree.t: More tests
Test explicit return with variable (single statement) and simple scalar
not modified elsewhere.
M t/op/const-optree.t
commit 4a99178023fe6cfaff9f88827dfc81bfb8c6f1f0
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 21:52:08 2014 -0700
Donât inline sub(){my $x; state sub z {$x} $outer}
The code that determines whether a closure prototype is potentially eligi-
ble for inlining when cloned iterates through the op chain in the order it
is executed. It looks for padsv (or const) followed by sub exit. Cer-
tain ops with no side effects, like nextstate and null, are skipped over.
There is a flaw in the logic handling padsv ops. If the padsv op closes
over a variable from outside, we record that we have seen an SV, so
another padsv or const prevents inlining. If the first padsv op does
not close over a variable from outside, but belongs to this sub itself,
then we just ignore it and skip over it as we would a null op. So that
means sub () { my $x; $outer_var } is marked as potentially eligible
for inlining.
Now, when cloning happens (i.e., when the âsubâ expression is
evaluated),
we search through the op chain (once more) of subs marked as potentially
inlinable and find the first padsv op, which we assume is the one that
closes over the outer sub. So we get the value of the wrong variable.
Now, there is a reference count check that usually saves the day. The
reference count must be exactly 2, one reference held by the newly-cloned
closure and the other by the outer sub. Usually âmy $xâ will have a
ref-
erence count of 1 when the sub is cloned, so it does not become inlina-
ble, but behaves as expected.
With state subs, however, which are cloned when the enclosing sub is
cloned, we can make that inner lexical have a reference count of 2.
So the sub becomes inlinable, using the undefined value taken from the
wrong variable:
$ ./perl -Ilib -MO=Concise -Mfeature=:all -e 'BEGIN { my $x = 43; *foo =
sub :prototype(){my $y; state sub z { $y } $x}} print foo()'
The lexical_subs feature is experimental at -e line 1.
6 <@> leave[1 ref] vKP/REFC ->(end)
1 <0> enter ->2
2 <;> nextstate(main 53 -e:1) v:%,{,469764096 ->3
5 <@> print vK ->6
3 <0> pushmark s ->4
4 <$> const[NULL ] s*/FOLD ->5
-e syntax OK
Notice the const[NULL ], which indicates undef.
At least thatâs what we get if we are lucky enough not to crash in the
padname-handling code added recently to op.c:op_const_sv. Sometimes
this results:
$ ./perl -Ilib -MO=Concise -Mfeature=:all -e 'BEGIN { my $x = 43; *foo =
sub :prototype(){my $y; state sub z { $y } $x}} print foo()'
The lexical_subs feature is experimental at -e line 1.
Segmentation fault: 11
M op.c
M t/op/const-optree.t
commit 7f08c641e557e7ea5657578f33a3430437642ffc
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 19:08:46 2014 -0700
Donât inline sub(){0; $x} if $x changes elsewhere
Some op trees will turn a sub into a constant even if they
are more than just a simple constant or lexical variable. In
particular, a statement optimised away followed by a lexi-
cal variable is eligible for inlining. As discussed in
<20141101170924.17763.qm...@lists-nntp.develooper.com>, make these
more complex op trees follow closure rules properly. If the outer
lexical is used in lvalue context in places other than its declara-
tion, then we should forego inlining.
M op.c
M t/op/const-optree.t
commit bbd7756c2420ed595497f5969770114617b5abb2
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 18:45:37 2014 -0700
Restructure const-optree.t
This new layout (it is completely rewritten) allows endless variations
to be tested more easily.
M t/op/const-optree.t
commit 0f44b2a5b802e59ad05c2cce937079ade2abace7
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 16:41:23 2014 -0700
Use âbehaviorâ consistently in perldiag
âBehaviorâ is used many times; âbehaviourâ only three.
M pod/perldiag.pod
commit 0ac016fc68a8b6f210ddacb62494e53da203c571
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 07:07:36 2014 -0700
Deprecate inlining sub(){$x} if $x is changed elsewhere
With the new PadnameLVALUE flag, we can detect cases where an outer
lexical is used multiple times in lvalue context. If the subroutine
contains just a lexical variable and nothing else, deprecate this
behaviour, so we can change it not to break the closure pattern at
some future date.
Future commits will fix those cases where the subroutine contains more
than just a lexical variable, without a deprecation cycle.
Adding this code to op_const_sv doesnât really make sense. More to
the point, having S_cv_clone_pad call op_const_sv doesnât make sense,
but changing that (moving this code directly to S_cv_clone_pad) will
require other refactorings to avoid breaking some cases of constant
(real constant) inlining, such as sub(){$x++ if 0; 3}, which cur-
rently gets inlined.
M embed.fnc
M embed.h
M op.c
M pad.c
M pod/perldiag.pod
M proto.h
M t/op/const-optree.t
commit 0b2df18fd3736ebdac552d596b8976109f9f4643
Author: Father Chrysostomos <spr...@cpan.org>
Date: Sat Nov 1 14:33:35 2014 -0700
Put sub(){ ... } constant tests in a new file
M MANIFEST
M t/op/closure.t
A t/op/const-optree.t
M t/op/sub.t
commit 1567c65ac069266bfe65959430c185babd476538
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 22:08:52 2014 -0700
pad.c: Move constant closure code
S_cv_clone normally calls S_cv_clone_pad, which takes care of cloning
the pad, surprisingly enough. Then S_cv_clone checks whether it can
turn a closure into a constant. That code needs to be moved into
S_cv_clone_pad, because, not only is it pad-related, but to work cor-
rectly it needs to access the outer sub (which S_cv_clone_pad already
fetches for its own use), which future commits will make it do.
M pad.c
commit 21195f4d7c569ffbbfc383cb731fb11abd237028
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 22:04:21 2014 -0700
pad.c: Have S_cv_clone_pad return the CV
Currently it is a void function, because it modifies the CV in place.
Shortly it will sometimes return a different CV from the one it was
passed.
M pad.c
commit 50ce6708accb814cda9d2e6c5be4d84c90c7f059
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 21:59:39 2014 -0700
pad.c:S_cv_clone: Add assertion
This code cannot handle the case where cloning uses an existing
stub, because it creates a new CV via newCONSTSUB. Cloning into
an existing stub only happens for lexical subs, and the previous
commit prevented them from reaching this code. Before that we
would have had assertion failures in pp_padcv.
M pad.c
commit 04bae31374e4aa02ef4389cc3484ac2558056857
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 21:57:28 2014 -0700
Donât attempt to inline my sub (){$outer_var}
$ perl5.18.2 -Ilib -Mfeature=lexical_subs -e ' my $x; my sub a(){$x};
print a'
The lexical_subs feature is experimental at -e line 1.
Segmentation fault: 11
Same in blead.
When calls to the sub are compiled (the âaâ in âprint aâ) the value
of the lexical variable cannot possibly known, because the sub hasnât
been cloned yet, and all we have is the closure prototype.
A potentially constant closure prototype is marked CvCONST and
cv_const_sv_or_av (called by the code in toke.c that handles bare-
words) thinks that CvCONST means we have a constant XSUB. Only lexi-
cal subs allow a closure prototype to reach that function.
We shouldnât mark the closure prototype as CvCONST to begin with.
Because when we do, the âconstantâ is retrieved from CvXUBANY, which
is a union shared by CvSTART. Then toke.c does SvREFCNT_inc on
CvSTART, and screws up the op tree.
M op.c
M t/op/lexsub.t
commit a63556160924a497d8ad70cda2f162316ff10cfc
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 15:54:39 2014 -0700
op.c: Record lvalue use of lexicals
other than where the variable is declared.
This will be used to determine whether my $x; sub(){$x} can make a
constant. Currently, this becomes a constant even if $x is subse-
quently modified, breaking the closure behaviour (bug #79908).
M op.c
commit 72af0f205aa343252ed7cdba3f48ad1dad170ff6
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Oct 31 14:54:20 2014 -0700
Add new LVALUE flag for pad names
This will be used to record whether a pad entry is used as an lvalue
multiple times. If so, it cannot be used as a constant.
M pad.h
M sv.c
M sv.h
commit f928b3395fa5dd08d171fbedbbe170f38de76272
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Oct 30 08:56:44 2014 -0700
Update comments about sub(){$x} consting
It no longer has anything to do with constant.pm.
M pad.c
commit 2575a0050170c409bc123a30901f3a711bd1802d
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Oct 30 08:52:56 2014 -0700
Donât turn sub:CustomAttr(){$outer_lex} into a const
We canât know what the attributes are for, and turning it into a con-
stant discards the attributes.
M ext/XS-APItest/t/call_checker.t
M op.c
commit 129e2d056c165dc78638cf280d0b324975e918a4
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Oct 30 08:46:00 2014 -0700
Preserve :method in sub:method(){$outer_lex}
When we turn such a sub into a constant, we need to preserve the
attribute, since it changes behaviour.
M pad.c
M t/op/sub.t
commit 5543332d9f6e4a5bc0a246a13645c56cb9fb9092
Author: Father Chrysostomos <spr...@cpan.org>
Date: Thu Oct 30 05:08:19 2014 -0700
Make sub(){$outer_lexical} return a copy each time
We donât actually stop in from being inlined, but simply mark the
inlined value as PADTMP, so it gets copied in lvalue context.
M op.c
M t/op/sub.t
commit 8915ba3d0a86145ad54f5a92fc334bd8e79a531d
Author: Father Chrysostomos <spr...@cpan.org>
Date: Wed Nov 12 21:56:37 2014 -0800
sub(){__SUB__} under -d, sub{eval"";__SUB__}
The peephole optimiser changes __SUB__ to a constant if the sub is not
clonable. All anonymous subs are clonable under the debugger, but
they are not marked as such until after the peephole optimiser runs.
If a sub is clonable, then it undergoes a second search through the
op tree (op_const_sv) to see if it is inlinable. Trying to make
sub(){__SUB__} inlinable results in some sort of memory corruption,
in which it presumably points to a freed SV that get reused for some-
thing else:
$ PERL5DB='sub DB::DB{}' ./perl -dIlib -lE 'BEGIN{*f = sub(){__SUB__}};
print f; print \&f'
*IO::File::AUTOLOAD
CODE(0x7fef62035760)
(Both lines should show the same thing.)
The same clonability applies to subs containing a string eval. The
sub is not marked clonable yet when __SUB__ becomes a constant, so it
ends up referring to the closure prototype:
$ ./perl -Ilib -lE 'BEGIN{*f = sub(){eval""; __SUB__}}; print f; print
\&f; f->()'
CODE(0x7fe8c2036fe8)
CODE(0x7fe8c2031730)
Closure prototype called at -e line 1.
When turning __SUB__ into a constant, we need to check the same con-
dition (PL_cv_has_eval || PL_perldb; see pad_tidy) that would make a
sub clonable.
M op.c
M t/op/current_sub.t
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
embed.fnc | 2 -
embed.h | 1 -
ext/XS-APItest/t/call_checker.t | 8 +-
inline.h | 35 +++
op.c | 212 ++++++++++--------
pad.c | 136 ++++++++----
pad.h | 3 +
pod/perldiag.pod | 46 +++-
pod/perlsub.pod | 33 ++-
proto.h | 3 -
scope.c | 1 -
sv.c | 14 +-
sv.h | 2 +
t/op/closure.t | 14 --
t/op/const-optree.t | 478 ++++++++++++++++++++++++++++++++++++++++
t/op/current_sub.t | 14 +-
t/op/lexsub.t | 7 +-
t/op/sub.t | 27 +--
19 files changed, 833 insertions(+), 204 deletions(-)
create mode 100644 t/op/const-optree.t
diff --git a/MANIFEST b/MANIFEST
index 36add9b..cb992f1 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5179,6 +5179,7 @@ t/op/closure.t See if closures work
t/op/closure_test.pl Extra file for closure.t
t/op/concat2.t Tests too complex for concat.t
t/op/cond.t See if conditional expressions work
+t/op/const-optree.t Tests for sub(){...} becoming constant
t/op/context.t See if context propagation works
t/op/coreamp.t Test &foo() calls for CORE subs
t/op/coresubs.t Generic tests for CORE subs
diff --git a/embed.fnc b/embed.fnc
index 9d209b7..7de7d84 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -315,8 +315,6 @@ EMXp |void |cv_ckproto_len_flags |NN const CV*
cv|NULLOK const GV* gv\
ApdR |SV* |gv_const_sv |NN GV* gv
ApdRn |SV* |cv_const_sv |NULLOK const CV *const cv
pRn |SV* |cv_const_sv_or_av|NULLOK const CV *const cv
-: Used in pad.c
-pR |SV* |op_const_sv |NULLOK const OP* o|NULLOK CV* cv
Apd |SV * |cv_name |NN CV *cv|NULLOK SV *sv|U32 flags
Apd |void |cv_undef |NN CV* cv
p |void |cv_undef_flags |NN CV* cv|U32 flags
diff --git a/embed.h b/embed.h
index 938d7d3..0f53421 100644
--- a/embed.h
+++ b/embed.h
@@ -1261,7 +1261,6 @@
#define noperl_die Perl_noperl_die
#define oopsAV(a) Perl_oopsAV(aTHX_ a)
#define oopsHV(a) Perl_oopsHV(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(a) Perl_package(aTHX_ a)
#define package_version(a) Perl_package_version(aTHX_ a)
diff --git a/ext/XS-APItest/t/call_checker.t b/ext/XS-APItest/t/call_checker.t
index a9ad1c7..9367096 100644
--- a/ext/XS-APItest/t/call_checker.t
+++ b/ext/XS-APItest/t/call_checker.t
@@ -1,6 +1,6 @@
use warnings;
use strict;
-use Test::More tests => 76;
+use Test::More tests => 78;
use XS::APItest;
@@ -164,6 +164,8 @@ is $foo_ret, 9;
sub MODIFY_CODE_ATTRIBUTES { cv_set_call_checker_lists($_[1]); () }
BEGIN {
*foo2 = sub($$) :Attr { $foo_got = [ @_ ]; return "z"; };
+ my $foo = 3;
+ *foo3 = sub() :Attr { $foo };
}
$foo_got = undef;
@@ -172,6 +174,10 @@ is $@, "";
is_deeply $foo_got, [ qw(a b), qw(a b c) ];
is $foo_ret, "z";
+eval q{$foo_ret = foo3(@b, @c);};
+is $@, "";
+is $foo_ret, 3;
+
cv_set_call_checker_lists(\&foo);
undef &foo;
$foo_got = undef;
diff --git a/inline.h b/inline.h
index 1092474..cde2c54 100644
--- a/inline.h
+++ b/inline.h
@@ -90,6 +90,41 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN
len)
}
#endif
+/* ------------------------------- pad.h ------------------------------ */
+
+#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
+PERL_STATIC_INLINE bool
+PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
+{
+ /* is seq within the range _LOW to _HIGH ?
+ * This is complicated by the fact that PL_cop_seqmax
+ * may have wrapped around at some point */
+ if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
+ return FALSE; /* not yet introduced */
+
+ if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
+ /* in compiling scope */
+ if (
+ (seq > COP_SEQ_RANGE_LOW(pn))
+ ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
+ : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
+ )
+ return TRUE;
+ }
+ else if (
+ (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
+ ?
+ ( seq > COP_SEQ_RANGE_LOW(pn)
+ || seq <= COP_SEQ_RANGE_HIGH(pn))
+
+ : ( seq > COP_SEQ_RANGE_LOW(pn)
+ && seq <= COP_SEQ_RANGE_HIGH(pn))
+ )
+ return TRUE;
+ return FALSE;
+}
+#endif
+
/* ----------------------------- regexp.h ----------------------------- */
PERL_STATIC_INLINE struct regexp *
diff --git a/op.c b/op.c
index d14bdc9..8a0c7fa 100644
--- a/op.c
+++ b/op.c
@@ -2422,6 +2422,22 @@ such as C<$$x = 5> which might have to vivify a
reference in C<$x>.
=cut
*/
+static void
+S_mark_padname_lvalue(pTHX_ PADNAME *pn)
+{
+ CV *cv = PL_compcv;
+ PadnameLVALUE_on(pn);
+ while (PadnameOUTER(pn) && PARENT_PAD_INDEX(pn)) {
+ cv = CvOUTSIDE(cv);
+ assert(cv);
+ assert(CvPADLIST(cv));
+ pn =
+ PadlistNAMESARRAY(CvPADLIST(cv))[PARENT_PAD_INDEX(pn)];
+ assert(PadnameLEN(pn));
+ PadnameLVALUE_on(pn);
+ }
+}
+
static bool
S_vivifies(const OPCODE type)
{
@@ -2792,6 +2808,10 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %"SVf,
PAD_COMPNAME_SV(o->op_targ));
+ if (!(o->op_private & OPpLVAL_INTRO)
+ || ( type != OP_SASSIGN && type != OP_AASSIGN
+ && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
+ S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
break;
case OP_PUSHMARK:
@@ -5164,6 +5184,21 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
return CHECKOP(type, pmop);
}
+static void
+S_set_haseval(pTHX)
+{
+ PADOFFSET i = 1;
+ PL_cv_has_eval = 1;
+ /* Any pad names in scope are potentially lvalues. */
+ for (; i < PadnamelistMAXNAMED(PL_comppad_name); i++) {
+ PADNAME *pn = PAD_COMPNAME_SV(i);
+ if (!pn || !PadnameLEN(pn))
+ continue;
+ if (PadnameOUTER(pn) || PadnameIN_SCOPE(pn, PL_cop_seqmax))
+ S_mark_padname_lvalue(aTHX_ pn);
+ }
+}
+
/* Given some sort of match op o, and an expression expr containing a
* pattern, either compile expr into a regex and attach it to o (if it's
* constant), or convert expr into a runtime regcomp op sequence (if it's
@@ -5456,7 +5491,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32
floor)
rcop->op_targ = cv_targ;
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL)
+ S_set_haseval(aTHX);
/* establish postfix order */
if (expr->op_type == OP_REGCRESET || expr->op_type == OP_REGCMAYBE) {
@@ -7673,51 +7709,38 @@ Perl_cv_const_sv_or_av(const CV * const cv)
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
+ * Can be called in 2 ways:
*
- * !cv
+ * !allow_lex
* look for a single OP_CONST with attached value: return the value
*
- * cv && CvCLONE(cv) && !CvCONST(cv)
+ * allow_lex && !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.
+ * OP_CONST, return the value; or if it contains a single PADSV ref-
+ * erencing an outer lexical, turn on CvCONST to indicate the CV is
+ * a candidate for "constizing" at clone time, and return NULL.
*/
-SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+static SV *
+S_op_const_sv(pTHX_ const OP *o, CV *cv, bool allow_lex)
{
SV *sv = NULL;
+ bool padsv = FALSE;
- if (!o)
- return NULL;
-
- if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
- o = OP_SIBLING(cLISTOPo->op_first);
+ assert(o);
+ assert(cv);
for (; o; o = o->op_next) {
const OPCODE type = o->op_type;
- if (sv && o->op_next == o)
- return sv;
- if (o->op_next != o) {
- if (type == OP_NEXTSTATE
- || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ if (type == OP_NEXTSTATE || type == OP_LINESEQ
+ || type == OP_NULL
|| type == OP_PUSHMARK)
continue;
- if (type == OP_DBSTATE)
+ if (type == OP_DBSTATE)
continue;
- }
- if (type == OP_LEAVESUB || type == OP_RETURN)
+ if (type == OP_LEAVESUB)
break;
if (sv)
return NULL;
@@ -7727,31 +7750,23 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
sv = newSV(0);
SAVEFREESV(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 {
+ else if (allow_lex && type == OP_PADSV) {
if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+ {
sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
+ padsv = TRUE;
+ }
+ else
+ return NULL;
}
else {
return NULL;
}
}
+ if (padsv) {
+ CvCONST_on(cv);
+ return NULL;
+ }
return sv;
}
@@ -7821,6 +7836,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
CV *clonee = NULL;
HEK *hek = NULL;
bool reusable = FALSE;
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
#endif
@@ -7906,12 +7922,29 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
spot = (CV **)(svspot = &mg->mg_obj);
}
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
+
if (!block || !ps || *ps || attrs
- || (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = S_op_const_sv(aTHX_ start, compcv, FALSE);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
@@ -7957,6 +7990,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(compcv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
@@ -8053,16 +8087,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
@@ -8072,9 +8097,8 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs, OP *block)
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
@@ -8082,12 +8106,6 @@ 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>. */
@@ -8186,6 +8204,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
o ? SvPV_const(o_is_gv ? (SV *)o : cSVOPo->op_sv, namlen) : NULL;
bool has_name;
bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv);
+ OP *start;
#ifdef PERL_DEBUG_READONLY_OPS
OPSLAB *slab = NULL;
bool special = FALSE;
@@ -8306,13 +8325,31 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
? (CV *)SvRV(gv)
: NULL;
+ if (block) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
+ const line_t l = PL_parser->copline;
+ op_free(block);
+ block = newSTATEOP(0, NULL, 0);
+ PL_parser->copline = l;
+ }
+ block = CvLVALUE(PL_compcv)
+ || (cv && CvLVALUE(cv) && !CvROOT(cv) && !CvXSUB(cv)
+ && (!isGV(gv) || !GvASSUMECV(gv)))
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ start = LINKLIST(block);
+ block->op_next = 0;
+ }
if (!block || !ps || *ps || attrs
- || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
+ || CvLVALUE(PL_compcv)
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv =
+ S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv));
if (SvPOK(gv) || (SvROK(gv) && SvTYPE(SvRV(gv)) != SVt_PVCV)) {
assert (block);
@@ -8379,14 +8416,17 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
CvCONST_on(cv);
CvISXSUB_on(cv);
PoisonPADLIST(cv);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
- if (isGV(gv)) {
- if (name) GvCV_set(gv, NULL);
+ if (isGV(gv) || CvMETHOD(PL_compcv)) {
+ if (name && isGV(gv))
+ GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
);
+ CvFLAGS(cv) |= CvMETHOD(PL_compcv);
}
else {
if (!SvROK(gv)) {
@@ -8512,16 +8552,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
exit. */
PL_breakable_sub_gen++;
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
- OP* const newblock = newSTATEOP(0, NULL, 0);
- op_free(block);
- block = newblock;
- }
- CvROOT(cv) = CvLVALUE(cv)
- ? newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV))
- : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
+ CvROOT(cv) = block;
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
/* The cv no longer needs to hold a refcount on the slab, as CvROOT
@@ -8531,9 +8562,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP
*attrs,
#ifdef PERL_DEBUG_READONLY_OPS
slab = (OPSLAB *)CvSTART(cv);
#endif
- CvSTART(cv) = LINKLIST(CvROOT(cv));
- CvROOT(cv)->op_next = 0;
- CALL_PEEP(CvSTART(cv));
+ CvSTART(cv) = start;
+ CALL_PEEP(start);
finalize_optree(CvROOT(cv));
S_prune_chain_head(&CvSTART(cv));
@@ -8541,12 +8571,6 @@ 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>. */
@@ -9427,7 +9451,7 @@ Perl_ck_eval(pTHX_ OP *o)
}
else {
scalar((OP*)kid);
- PL_cv_has_eval = 1;
+ S_set_haseval(aTHX);
}
}
else {
@@ -12741,7 +12765,9 @@ Perl_rpeep(pTHX_ OP *o)
break;
case OP_RUNCV:
- if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)) {
+ if (!(o->op_private & OPpOFFBYONE) && !CvCLONE(PL_compcv)
+ && (!CvANON(PL_compcv) || (!PL_cv_has_eval && !PL_perldb)))
+ {
SV *sv;
if (CvEVAL(PL_compcv)) sv = &PL_sv_undef;
else {
diff --git a/pad.c b/pad.c
index 6e38f13..0775a42 100644
--- a/pad.c
+++ b/pad.c
@@ -1233,31 +1233,8 @@ S_pad_findlex(pTHX_ const char *namepv, STRLEN namelen,
U32 flags, const CV* cv,
fake_offset = offset; /* in case we don't find a real one */
continue;
}
- /* is seq within the range _LOW to _HIGH ?
- * This is complicated by the fact that PL_cop_seqmax
- * may have wrapped around at some point */
- if (COP_SEQ_RANGE_LOW(namesv) == PERL_PADSEQ_INTRO)
- continue; /* not yet introduced */
-
- if (COP_SEQ_RANGE_HIGH(namesv) == PERL_PADSEQ_INTRO) {
- /* in compiling scope */
- if (
- (seq > COP_SEQ_RANGE_LOW(namesv))
- ? (seq - COP_SEQ_RANGE_LOW(namesv) < (U32_MAX >> 1))
- : (COP_SEQ_RANGE_LOW(namesv) - seq > (U32_MAX >> 1))
- )
- break;
- }
- else if (
- (COP_SEQ_RANGE_LOW(namesv) > COP_SEQ_RANGE_HIGH(namesv))
- ?
- ( seq > COP_SEQ_RANGE_LOW(namesv)
- || seq <= COP_SEQ_RANGE_HIGH(namesv))
-
- : ( seq > COP_SEQ_RANGE_LOW(namesv)
- && seq <= COP_SEQ_RANGE_HIGH(namesv))
- )
- break;
+ if (PadnameIN_SCOPE(namesv, seq))
+ break;
}
}
@@ -2037,7 +2014,7 @@ the immediately surrounding code.
static CV *S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside);
-static void
+static CV *
S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside, bool newcv)
{
I32 ix;
@@ -2194,6 +2171,91 @@ S_cv_clone_pad(pTHX_ CV *proto, CV *cv, CV *outside,
bool newcv)
if (newcv) SvREFCNT_inc_simple_void_NN(cv);
LEAVE;
+
+ if (CvCONST(cv)) {
+ /* Constant sub () { $x } closing over $x:
+ * 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_sv;
+ OP *o = CvSTART(cv);
+ assert(newcv);
+ for (; o; o = o->op_next)
+ if (o->op_type == OP_PADSV)
+ break;
+ ASSUME(o->op_type == OP_PADSV);
+ const_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 (const_sv && SvREFCNT(const_sv) == 2) {
+ const bool was_method = cBOOL(CvMETHOD(cv));
+ bool copied = FALSE;
+ if (outside) {
+ PADNAME * const pn =
+ PadlistNAMESARRAY(CvPADLIST(outside))
+ [PARENT_PAD_INDEX(PadlistNAMESARRAY(
+ CvPADLIST(cv))[o->op_targ])];
+ assert(PadnameOUTER(PadlistNAMESARRAY(CvPADLIST(cv))
+ [o->op_targ]));
+ if (PadnameLVALUE(pn)) {
+ /* We have a lexical that is potentially modifiable
+ elsewhere, so making a constant will break clo-
+ sure behaviour. If this is a âsimple lexical
+ op treeâ, i.e., sub(){$x}, emit a deprecation
+ warning, but continue to exhibit the old behav-
+ iour of making it a constant based on the ref-
+ count of the candidate variable.
+
+ A simple lexical op tree looks like this:
+
+ leavesub
+ lineseq
+ nextstate
+ padsv
+ */
+ if (OP_SIBLING(
+ cUNOPx(cUNOPx(CvROOT(cv))->op_first)->op_first
+ ) == o
+ && !OP_SIBLING(o))
+ {
+ Perl_ck_warner_d(aTHX_
+ packWARN(WARN_DEPRECATED),
+ "Constants from lexical "
+ "variables potentially "
+ "modified elsewhere are "
+ "deprecated");
+ /* We *copy* the lexical variable, and donate the
+ copy to newCONSTSUB. Yes, this is ugly, and
+ should be killed. We need to do this for the
+ time being, however, because turning on SvPADTMP
+ on a lexical will have observable effects
+ elsewhere. */
+ const_sv = newSVsv(const_sv);
+ copied = TRUE;
+ }
+ else
+ goto constoff;
+ }
+ }
+ if (!copied)
+ SvREFCNT_inc_simple_void_NN(const_sv);
+ /* If the lexical is not used elsewhere, it is safe to turn on
+ SvPADTMP, since it is only when it is used in lvalue con-
+ text that the difference is observable. */
+ SvPADTMP_on(const_sv);
+ SvREFCNT_dec_NN(cv);
+ cv = newCONSTSUB(CvSTASH(proto), NULL, const_sv);
+ if (was_method)
+ CvMETHOD_on(cv);
+ }
+ else {
+ constoff:
+ CvCONST_off(cv);
+ }
+ }
+
+ return cv;
}
static CV *
@@ -2231,7 +2293,8 @@ S_cv_clone(pTHX_ CV *proto, CV *cv, CV *outside)
if (SvMAGIC(proto))
mg_copy((SV *)proto, (SV *)cv, 0, 0);
- if (CvPADLIST(proto)) S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
+ if (CvPADLIST(proto))
+ cv = S_cv_clone_pad(aTHX_ proto, cv, outside, newcv);
DEBUG_Xv(
PerlIO_printf(Perl_debug_log, "\nPad CV clone\n");
@@ -2240,25 +2303,6 @@ 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/pad.h b/pad.h
index d800b19..3ca79d3 100644
--- a/pad.h
+++ b/pad.h
@@ -301,7 +301,10 @@ Restore the old pad saved into the local variable opad by
PAD_SAVE_LOCAL()
#define PadnameOUTER(pn) !!SvFAKE(pn)
#define PadnameIsSTATE(pn) !!SvPAD_STATE(pn)
#define PadnameTYPE(pn) (SvPAD_TYPED(pn) ? SvSTASH(pn) : NULL)
+#define PadnameLVALUE(pn) \
+ ((SvFLAGS(pn) & (SVpad_NAME|SVpad_LVALUE))==(SVpad_NAME|SVpad_LVALUE))
+#define PadnameLVALUE_on(pn) (SvFLAGS(pn) |= SVpad_NAME|SVpad_LVALUE)
#ifdef DEBUGGING
# define PAD_SV(po) pad_sv(po)
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index ef29b3a..6df69d9 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1620,6 +1620,42 @@ The message indicates the type of reference that was
expected. This
usually indicates a syntax error in dereferencing the constant value.
See L<perlsub/"Constant Functions"> and L<constant>.
+=item Constants from lexical variables potentially modified elsewhere are
+deprecated
+
+(D deprecated) You wrote something like
+
+ my $var;
+ $sub = sub () { $var };
+
+but $var is referenced elsewhere and could be modified after the C<sub>
+expression is evaluated. Either it is explicitly modified elsewhere
+(C<$var = 3>) or it is passed to a subroutine or to an operator like
+C<printf> or C<map>, which may or may not modify the variable.
+
+Traditionally, Perl has captured the value of the variable at that
+point and turned the subroutine into a constant eligible for inlining.
+In those cases where the variable can be modified elsewhere, this
+breaks the behavior of closures, in which the subroutine captures
+the variable itself, rather than its value, so future changes to the
+variable are reflected in the subroutine's return value.
+
+This usage is deprecated, because the behavior is likely to change
+in a future version of Perl.
+
+If you intended for the subroutine to be eligible for inlining, then
+make sure the variable is not referenced elsewhere, possibly by
+copying it:
+
+ my $var2 = $var;
+ $sub = sub () { $var2 };
+
+If you do want this subroutine to be a closure that reflects future
+changes to the variable that it closes over, add an explicit C<return>:
+
+ my $var;
+ $sub = sub () { return $var };
+
=item Constant subroutine %s redefined
(W redefine)(S) You redefined a subroutine which had previously
@@ -2338,9 +2374,9 @@ of Perl are likely to eliminate these arbitrary
limitations.
S<<-- HERE> in m/%s/
(W regexp) Named Unicode character escapes (C<\N{...}>) may return a
-zero-length sequence. When such an escape is used in a character class
-its behaviour is not well defined. Check that the correct escape has
-been used, and the correct charname handler is in scope.
+zero-length sequence. When such an escape is used in a character
+class its behavior is not well defined. Check that the correct
+escape has been used, and the correct charname handler is in scope.
=item Illegal binary digit %s
@@ -3852,7 +3888,7 @@ with an offset pointing outside the buffer. This is
difficult to
imagine. The sole exceptions to this are that zero padding will
take place when going past the end of the string when either
C<sysread()>ing a file, or when seeking past the end of a scalar opened
-for I/O (in anticipation of future reads and to imitate the behaviour
+for I/O (in anticipation of future reads and to imitate the behavior
with real files).
=item %s() on unopened %s
@@ -6624,7 +6660,7 @@ of the returned sequence, which is not likely what you
want.
=item Using !~ with %s doesn't make sense
(F) Using the C<!~> operator with C<s///r>, C<tr///r> or C<y///r> is
-currently reserved for future use, as the exact behaviour has not
+currently reserved for future use, as the exact behavior has not
been decided. (Simply returning the boolean opposite of the
modified string is usually not particularly useful.)
diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index 3146037..10eedf5 100644
--- a/pod/perlsub.pod
+++ b/pod/perlsub.pod
@@ -1639,11 +1639,12 @@ The following functions would all be inlined:
sub N () { int(OPT_BAZ) / 3 }
sub FOO_SET () { 1 if FLAG_MASK & FLAG_FOO }
+ sub FOO_SET2 () { if (FLAG_MASK & FLAG_FOO) { 1 } }
-Be aware that these will not be inlined; as they contain inner scopes,
-the constant folding doesn't reduce them to a single constant:
-
- sub foo_set () { if (FLAG_MASK & FLAG_FOO) { 1 } }
+(Be aware that the last example was not always inlined in Perl 5.20 and
+earlier, which did not behave consistently with subroutines containing
+inner scopes.) You can countermand inlining by using an explicit
+C<return>:
sub baz_val () {
if (OPT_BAZ) {
@@ -1653,6 +1654,7 @@ the constant folding doesn't reduce them to a single
constant:
return 42;
}
}
+ sub bonk_val () { return 12345 }
As alluded to earlier you can also declare inlined subs dynamically at
BEGIN time if their body consists of a lexically-scoped scalar which
@@ -1682,6 +1684,24 @@ normal lexical variable, e.g. this will print C<79907>,
not C<79908>:
}
print RT_79908(); # prints 79907
+As of Perl 5.22, this buggy behavior, while preserved for backward
+compatibility, is detected and emits a deprecation warning. If you want
+the subroutine to be inlined (with no warning), make sure the variable is
+not used in a context where it could be modified aside from where it is
+declared.
+
+ # Fine, no warning
+ BEGIN {
+ my $x = 54321;
+ *INLINED = sub () { $x };
+ }
+ # Warns. Future Perl versions will stop inlining it.
+ BEGIN {
+ my $x;
+ $x = 54321;
+ *ALSO_INLINED = sub () { $x };
+ }
+
If you really want a subroutine with a C<()> prototype that returns a
lexical variable you can easily force it to not be inlined by adding
an explicit C<return>:
@@ -1694,7 +1714,7 @@ an explicit C<return>:
print RT_79908(); # prints 79908
The easiest way to tell if a subroutine was inlined is by using
-L<B::Deparse>, consider this example of two subroutines returning
+L<B::Deparse>. Consider this example of two subroutines returning
C<1>, one with a C<()> prototype causing it to be inlined, and one
without (with deparse output truncated for clarity):
@@ -1727,7 +1747,8 @@ of the function will still be using the old value of the
function. If
you need to be able to redefine the subroutine, you need to ensure
that it isn't inlined, either by dropping the C<()> prototype (which
changes calling semantics, so beware) or by thwarting the inlining
-mechanism in some other way, e.g. by adding an explicit C<return>:
+mechanism in some other way, e.g. by adding an explicit C<return>, as
+mentioned above:
sub not_inlined () { return 23 }
diff --git a/proto.h b/proto.h
index 4e36949..5b08806 100644
--- a/proto.h
+++ b/proto.h
@@ -3196,9 +3196,6 @@ 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, CV* cv)
- __attribute__warn_unused_result__;
-
PERL_CALLCONV OP* Perl_op_contextualize(pTHX_ OP* o, I32 context)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_OP_CONTEXTUALIZE \
diff --git a/scope.c b/scope.c
index 0f819e7..43e2e03 100644
--- a/scope.c
+++ b/scope.c
@@ -1079,7 +1079,6 @@ Perl_leave_scope(pTHX_ I32 base)
SvPADSTALE_on(sv); /* mark as no longer live */
}
else { /* Someone has a claim on this, so abandon it. */
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
switch (SvTYPE(sv)) { /* Console ourselves with a new
value */
case SVt_PVAV: *svp = MUTABLE_SV(newAV()); break;
case SVt_PVHV: *svp = MUTABLE_SV(newHV()); break;
diff --git a/sv.c b/sv.c
index 54f939f..a82350f 100644
--- a/sv.c
+++ b/sv.c
@@ -610,6 +610,8 @@ do_curse(pTHX_ SV * const sv) {
if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv)
|| (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv))
return;
+ if (SvPAD_NAME(sv))
+ return;
(void)curse(sv, 0);
}
@@ -6456,10 +6458,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
goto free_head;
}
- assert(!SvOBJECT(sv) || type >= SVt_PVMG); /* objs are always >= MG */
+ /* objs are always >= MG, but pad names use the SVs_OBJECT flag
+ for another purpose */
+ assert(!SvOBJECT(sv) || type >= SVt_PVMG || SvPAD_NAME(sv));
if (type >= SVt_PVMG) {
- if (SvOBJECT(sv)) {
+ if (SvOBJECT(sv) && !SvPAD_NAME(sv)) {
if (!curse(sv, 1)) goto get_next_sv;
type = SvTYPE(sv); /* destructor may have changed it */
}
@@ -13314,7 +13318,9 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
#endif
/* don't clone objects whose class has asked us not to */
- if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) {
+ if (SvOBJECT(sstr) && !SvPAD_NAME(sstr)
+ && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE))
+ {
SvFLAGS(dstr) = 0;
return dstr;
}
@@ -13405,7 +13411,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr,
CLONE_PARAMS *const param)
NOOP;
} else if (SvMAGIC(dstr))
SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param));
- if (SvOBJECT(dstr) && SvSTASH(dstr))
+ if (SvOBJECT(dstr) && !SvPAD_NAME(dstr) && SvSTASH(dstr))
SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param));
else SvSTASH_set(dstr, 0); /* don't copy DESTROY cache */
}
diff --git a/sv.h b/sv.h
index bb3d572..6c77cce 100644
--- a/sv.h
+++ b/sv.h
@@ -380,6 +380,7 @@ perform the upgrade if necessary. See C<svtype>.
#define SVpad_OUR 0x00040000 /* pad name is "our" instead of "my" */
#define SVs_TEMP 0x00080000 /* mortal (implies string is stealable) */
#define SVs_OBJECT 0x00100000 /* is "blessed" */
+#define SVpad_LVALUE 0x00100000 /* pad name is used as lvalue */
#define SVs_GMG 0x00200000 /* has magical get method */
#define SVs_SMG 0x00400000 /* has magical set method */
#define SVs_RMG 0x00800000 /* has random magical methods */
@@ -1143,6 +1144,7 @@ sv_force_normal does nothing.
#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL)
#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL)
+#define SvPAD_NAME(sv) ((SvFLAGS(sv) & SVpad_NAME) == SVpad_NAME)
#define SvPAD_TYPED(sv) \
((SvFLAGS(sv) & (SVpad_NAME|SVpad_TYPED)) == (SVpad_NAME|SVpad_TYPED))
diff --git a/t/op/closure.t b/t/op/closure.t
index 9a4e50d..42453f4 100644
--- a/t/op/closure.t
+++ b/t/op/closure.t
@@ -671,20 +671,6 @@ $r = \$x
"don't copy a stale lexical; create a fresh undef one instead");
}
-# [perl #63540] Donât treat sub { if(){.....}; "constant" } as a constant
-
-BEGIN {
- my $x = 7;
- *baz = sub() { if($x){ () = "tralala"; blonk() }; 0 }
-}
-{
- my $blonk_was_called;
- *blonk = sub { ++$blonk_was_called };
- my $ret = baz();
- is($ret, 0, 'RT #63540');
- is($blonk_was_called, 1, 'RT #63540');
-}
-
# test PL_cv_has_eval. Any anon sub that could conceivably contain an
# eval, should be marked as cloneable
diff --git a/t/op/const-optree.t b/t/op/const-optree.t
new file mode 100644
index 0000000..aa5bee6
--- /dev/null
+++ b/t/op/const-optree.t
@@ -0,0 +1,478 @@
+#!perl
+
+# Test the various op trees that turn sub () { ... } into a constant, and
+# some variants that donât.
+
+BEGIN {
+ chdir 't';
+ require './test.pl';
+ @INC = '../lib';
+}
+plan 166;
+
+# @tests is an array of hash refs, each of which can have various keys:
+#
+# nickname - name of the sub to use in test names
+# generator - a sub returning a code ref to test
+# finally - sub to run after the tests
+#
+# Each of the following gives expected test results. If the key is
+# omitted, the test is skipped:
+#
+# retval - the returned code refâs return value
+# same_retval - whether the same scalar is returned each time
+# inlinable - whether the sub is inlinable
+# deprecated - whether the sub returning a code ref will emit a depreca-
+# tion warning when called
+# method - whether the sub has the :method attribute
+
+# [perl #63540] Donât treat sub { if(){.....}; "constant" } as a constant
+sub blonk { ++$blonk_was_called }
+push @tests, {
+ nickname => 'sub with null+kids (if-block), then constant',
+ generator => sub {
+ # This used to turn into a constant with the value of $x
+ my $x = 7;
+ sub() { if($x){ () = "tralala"; blonk() }; 0 }
+ },
+ retval => 0,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+ finally => sub { ok($blonk_was_called, 'RT #63540'); },
+};
+
+# [perl #79908]
+push @tests, {
+ nickname => 'sub with simple lexical modified elsewhere',
+ generator => sub { my $x = 5; my $ret = sub(){$x}; $x = 7; $ret },
+ retval => 5, # change to 7 when the deprecation cycle is over
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub with simple lexical unmodified elsewhere',
+ generator => sub { my $x = 5; sub(){$x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'return $variable modified elsewhere',
+ generator => sub { my $x=5; my $ret = sub(){return $x}; $x = 7; $ret },
+ retval => 7,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'return $variable unmodified elsewhere',
+ generator => sub { my $x = 5; sub(){return $x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { 0; $x } with $x modified elsewhere',
+ generator => sub { my $x = 5; my $ret = sub(){0;$x}; $x = 8; $ret },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { 0; $x } with $x unmodified elsewhere',
+ generator => sub { my $x = 5; my $y = $x; sub(){0;$x} },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+# Explicit return after optimised statement, not at end of sub
+push @tests, {
+ nickname => 'sub () { 0; return $x; ... }',
+ generator => sub { my $x = 5; sub () { 0; return $x; ... } },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# Explicit return after optimised statement, at end of sub [perl #123092]
+push @tests, {
+ nickname => 'sub () { 0; return $x }',
+ generator => sub { my $x = 5; sub () { 0; return $x } },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# Multiple closure tests
+push @tests, {
+ nickname => 'simple lexical after another closure and no lvalue',
+ generator => sub {
+ my $x = 5;
+ # This closure prevents inlining, though theoretically it shouldnât
+ # have to. If you change the behaviour, just change the test. This
+ # fails the refcount check in op.c:op_const_sv, which is necessary for
+ # the sake of \(my $x = 1) (tested below).
+ my $sub1 = sub () { () = $x };
+ sub () { $x };
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical before another closure and no lvalue',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { $x };
+ # This does not prevent inlining and never has.
+ my $sub1 = sub () { () = $x };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical after an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ # This has always prevented inlining
+ my $sub1 = sub () { $x++ };
+ sub () { $x };
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'simple lexical before an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { $x }; # <-- simple lexical op tree
+ # Traditionally this has not prevented inlining, though it should. But
+ # since $ret has a simple lexical op tree, we preserve backward-compat-
+ # ibility, but deprecate it.
+ my $sub1 = sub () { $x++ };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'complex lexical op tree before an lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { 0; $x }; # <-- more than just a lexical
+ # This used not to prevent inlining, though it should, and now does.
+ my $sub1 = sub () { $x++ };
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'complex lexical op tree before a nested lvalue closure',
+ generator => sub {
+ my $x = 5;
+ my $ret = sub () { 0; $x }; # <-- more than just a lexical
+ # This used not to prevent inlining, though it should, and now does.
+ my $sub1 = sub () { sub () { $x++ } }; # nested
+ $ret;
+ },
+ retval => 5,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+use feature 'state', 'lexical_subs';
+no warnings 'experimental::lexical_subs';
+
+# Constant constants
+push @tests, {
+ nickname => 'sub with constant',
+ generator => sub { sub () { 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with constant and return',
+ generator => sub { sub () { return 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with optimised statement and constant',
+ generator => sub { sub () { 0; 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub with optimised statement, constant and return',
+ generator => sub { sub () { 0; return 8 } },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with constant',
+ generator => sub { my sub x () { 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with constant and return',
+ generator => sub { my sub x () { return 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with optimised statement and constant',
+ generator => sub { my sub x () { 0; 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'my sub with optimised statement, constant and return',
+ generator => sub { my sub x () { 0; return 8 } \&x },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+# String eval
+push @tests, {
+ nickname => 'sub () { $x } with eval in scope',
+ generator => sub {
+ my $outer = 43;
+ my $ret = sub () { $outer };
+ eval '$outer++';
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub () { $x } with s///ee in scope',
+ generator => sub {
+ my $outer = 43;
+ my $dummy = '$outer++';
+ my $ret = sub () { $outer };
+ $dummy =~ s//$dummy/ee;
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub () { $x } with eval not in scope',
+ generator => sub {
+ my $ret;
+ {
+ my $outer = 43;
+ $ret = sub () { $outer };
+ }
+ eval '';
+ $ret;
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub () { my $x; state sub z { $x } $outer }',
+ generator => sub {
+ my $outer = 43;
+ sub () { my $x; state sub z { $x } $outer }
+ },
+ retval => 43,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'closure after \(my $x=1)',
+ generator => sub {
+ $y = \(my $x = 1);
+ my $ret = sub () { $x };
+ $$y += 7;
+ $ret;
+ },
+ retval => 8,
+ same_retval => 0,
+ inlinable => 0,
+ deprecated => 0,
+ method => 0,
+};
+
+push @tests, {
+ nickname => 'sub:method with simple lexical',
+ generator => sub { my $y; sub():method{$y} },
+ retval => undef,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+push @tests, {
+ nickname => 'sub:method with constant',
+ generator => sub { sub():method{3} },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+push @tests, {
+ nickname => 'my sub:method with constant',
+ generator => sub { my sub x ():method{3} \&x },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 1,
+};
+
+push @tests, {
+ nickname => 'sub closing over state var',
+ generator => sub { state $x = 3; sub () {$x} },
+ retval => 3,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 0,
+ method => 0,
+};
+push @tests, {
+ nickname => 'sub closing over state var++',
+ generator => sub { state $x++; sub () { $x } },
+ retval => 1,
+ same_retval => 0,
+ inlinable => 1,
+ deprecated => 1,
+ method => 0,
+};
+
+
+use feature 'refaliasing';
+no warnings 'experimental::refaliasing';
+for \%_ (@tests) {
+ my $nickname = $_{nickname};
+ my $w;
+ local $SIG{__WARN__} = sub { $w = shift };
+ my $sub = &{$_{generator}};
+ if (exists $_{deprecated}) {
+ if ($_{deprecated}) {
+ like $w, qr/^Constants from lexical variables potentially (?x:
+ )modified elsewhere are deprecated at /,
+ "$nickname is deprecated";
+ }
+ else {
+ is $w, undef, "$nickname is not deprecated";
+ }
+ }
+ if (exists $_{retval}) {
+ is &$sub, $_{retval}, "retval of $nickname";
+ }
+ if (exists $_{same_retval}) {
+ my $same = $_{same_retval} ? "same" : "different";
+ &{$_{same_retval} ? \&is : \&isnt}(
+ \scalar &$sub(), \scalar &$sub(),
+ "$nickname gives $same retval each call"
+ );
+ }
+ if (exists $_{inlinable}) {
+ local *temp_inlinability_test = $sub;
+ $w = undef;
+ use warnings 'redefine';
+ *temp_inlinability_test = sub (){};
+ my $S = $_{inlinable} ? "Constant s" : "S";
+ my $not = " not" x! $_{inlinable};
+ like $w, qr/^${S}ubroutine .* redefined at /,
+ "$nickname is$not inlinable";
+ }
+ if (exists $_{method}) {
+ local *time = $sub;
+ $w = undef;
+ use warnings 'ambiguous';
+ eval "()=time";
+ if ($_{method}) {
+ is $w, undef, "$nickname has :method attribute";
+ }
+ else {
+ like $w, qr/^Ambiguous call resolved as CORE::time\(\), (?x:
+ )qualify as such or use & at /,
+ "$nickname has no :method attribute";
+ }
+ }
+
+ &{$_{finally} or next}
+}
diff --git a/t/op/current_sub.t b/t/op/current_sub.t
index 4e86add..2dcc184 100644
--- a/t/op/current_sub.t
+++ b/t/op/current_sub.t
@@ -4,7 +4,7 @@ BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
require './test.pl';
- plan (tests => 20);
+ plan (tests => 22);
}
is __SUB__, "__SUB__", '__SUB__ is a bareword outside of use feature';
@@ -82,3 +82,15 @@ my $f = sub () { __SUB__ };
is &$f, $f, 'anonymous sub(){__SUB__} returns self ref';
my $f2 = sub () { $f++ if 0; __SUB__ };
is &$f2, $f2, 'sub(){__SUB__} anonymous closure returns self ref';
+$f = sub () { eval ""; __SUB__ };
+is &$f, $f, 'anonymous sub(){eval ""; __SUB__} returns self ref';
+{
+ local $ENV{PERL5DB} = 'sub DB::DB {}';
+ is runperl(
+ switches => [ '-d' ],
+ prog => '$f = sub(){CORE::__SUB__}; print qq-ok\n- if $f == &$f;',
+ ),
+ "ok\n",
+ 'sub(){__SUB__} under -d';
+}
+
diff --git a/t/op/lexsub.t b/t/op/lexsub.t
index 385aaee..e170555 100644
--- a/t/op/lexsub.t
+++ b/t/op/lexsub.t
@@ -7,7 +7,7 @@ BEGIN {
*bar::is = *is;
*bar::like = *like;
}
-plan 143;
+plan 144;
# -------------------- Errors with feature disabled -------------------- #
@@ -788,6 +788,11 @@ is runperl(switches => ['-lXMfeature=:all'],
print handel,"ok ",curr_test()," - no 'No comma allowed' after my sub\n";
curr_test(curr_test()+1);
}
+{
+ my $x = 43;
+ my sub y :prototype() {$x};
+ is y, 43, 'my sub that looks like constant closure';
+}
# -------------------- Interactions (and misc tests) -------------------- #
diff --git a/t/op/sub.t b/t/op/sub.t
index 70115e1..db61ac2 100644
--- a/t/op/sub.t
+++ b/t/op/sub.t
@@ -6,7 +6,7 @@ BEGIN {
set_up_inc('../lib');
}
-plan( tests => 38 );
+plan( tests => 35 );
sub empty_sub {}
@@ -147,31 +147,6 @@ is eval {
Munchy(Crunchy);
} || $@, 2, 'freeing ops does not make sub(){42} immutable';
-# [perl #79908]
-{
- my $x = 5;
- *_79908 = sub (){$x};
- $x = 7;
- 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
- my $y;
- no warnings 'once';
- local *time = sub():method{$y};
- my $w;
- local $SIG{__WARN__} = sub { $w .= shift };
- eval "()=time";
- 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
{
no warnings "uninitialized";
--
Perl5 Master Repository
