diff options
| -rw-r--r-- | cop.h | 2 | ||||
| -rw-r--r-- | ext/B/B/Concise.pm | 2 | ||||
| -rw-r--r-- | ext/B/t/f_map.t | 4 | ||||
| -rw-r--r-- | ext/B/t/optree_samples.t | 8 | ||||
| -rw-r--r-- | op.c | 21 | ||||
| -rw-r--r-- | op.h | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 26 | ||||
| -rw-r--r-- | pp_hot.c | 27 | ||||
| -rw-r--r-- | t/op/gmagic.t | 11 | ||||
| -rw-r--r-- | t/op/sub_lval.t | 22 |
10 files changed, 107 insertions, 17 deletions
@@ -635,7 +635,7 @@ struct block_format { #define PUSHSUB(cx) \ PUSHSUB_BASE(cx) \ cx->blk_u16 = PL_op->op_private & \ - (OPpLVAL_INTRO|OPpENTERSUB_INARGS); + (OPpLVAL_INTRO|OPpENTERSUB_INARGS|OPpENTERSUB_DEREF); /* variant for use by OP_DBSTATE, where op_private holds hint bits */ #define PUSHSUB_DB(cx) \ diff --git a/ext/B/B/Concise.pm b/ext/B/B/Concise.pm index b27de10a22..25d908c0f3 100644 --- a/ext/B/B/Concise.pm +++ b/ext/B/B/Concise.pm @@ -611,7 +611,7 @@ $priv{$_}{4} = "DREFed" for (qw(rv2sv rv2av rv2hv)); @{$priv{$_}}{32,64,96} = ("DREFAV", "DREFHV", "DREFSV") for (qw(rv2gv rv2sv padsv aelem helem)); $priv{$_}{16} = "STATE" for ("padav", "padhv", "padsv"); -@{$priv{"entersub"}}{4,16,32,64} = ("INARGS","DBG","TARG","NOMOD"); +@{$priv{"entersub"}}{1,4,16,32,64} = qw( DREF INARGS DBG TARG NOMOD ); @{$priv{rv2cv}}{1,8,128} = ("CONST","AMPER","NO()"); $priv{"gv"}{32} = "EARLYCV"; $priv{"aelem"}{16} = $priv{"helem"}{16} = "LVDEFER"; diff --git a/ext/B/t/f_map.t b/ext/B/t/f_map.t index e6735d9e60..189ec20a4a 100644 --- a/ext/B/t/f_map.t +++ b/ext/B/t/f_map.t @@ -103,7 +103,7 @@ checkOptree(note => q{}, # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -179,7 +179,7 @@ checkOptree(note => q{}, # k <0> pushmark s # l <#> gvsv[*_] s # m <#> gv[*getkey] s/EARLYCV -# n <1> entersub[t10] sKS/TARG,1 +# n <1> entersub[t10] sKS/TARG # o <2> helem sKRM*/2 # p <2> sassign vKS/2 # q <0> unstack s diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t index 3cc0f266c5..3e0b7f8997 100644 --- a/ext/B/t/optree_samples.t +++ b/ext/B/t/optree_samples.t @@ -477,7 +477,7 @@ checkOptree ( name => '%h = map { getkey($_) => $_ } @a', # b <0> pushmark s # c <#> gvsv[*_] s # d <#> gv[*getkey] s/EARLYCV -# e <1> entersub[t5] lKS/TARG,1 +# e <1> entersub[t5] lKS/TARG # f <#> gvsv[*_] s # g <@> list lK # h <@> leave lKP @@ -501,7 +501,7 @@ EOT_EOT # b <0> pushmark s # c <$> gvsv(*_) s # d <$> gv(*getkey) s/EARLYCV -# e <1> entersub[t2] lKS/TARG,1 +# e <1> entersub[t2] lKS/TARG # f <$> gvsv(*_) s # g <@> list lK # h <@> leave lKP @@ -539,7 +539,7 @@ checkOptree ( name => '%h=(); for $_(@a){$h{getkey($_)} = $_}', # i <0> pushmark s # j <#> gvsv[*_] s # k <#> gv[*getkey] s/EARLYCV -# l <1> entersub[t10] sKS/TARG,1 +# l <1> entersub[t10] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s @@ -569,7 +569,7 @@ EOT_EOT # i <0> pushmark s # j <$> gvsv(*_) s # k <$> gv(*getkey) s/EARLYCV -# l <1> entersub[t4] sKS/TARG,1 +# l <1> entersub[t4] sKS/TARG # m <2> helem sKRM*/2 # n <2> sassign vKS/2 # o <0> unstack s @@ -1471,9 +1471,8 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) if ((type == OP_UNDEF || type == OP_REFGEN) && !(o->op_flags & OPf_STACKED)) { o->op_type = OP_RV2CV; /* entersub => rv2cv */ - /* The default is to set op_private to the number of children, - which for a UNOP such as RV2CV is always 1. And w're using - the bit for a flag in RV2CV, so we need it clear. */ + /* Both ENTERSUB and RV2CV use this bit, but for different pur- + poses, so we need it clear. */ o->op_private &= ~1; o->op_ppaddr = PL_ppaddr[OP_RV2CV]; assert(cUNOPo->op_first->op_type == OP_NULL); @@ -1894,6 +1893,11 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) o->op_flags |= OPf_SPECIAL; o->op_private &= ~1; } + else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){ + o->op_private |= OPpENTERSUB_DEREF; + o->op_flags |= OPf_MOD; + } + break; case OP_COND_EXPR: @@ -9040,6 +9044,7 @@ Perl_ck_subr(pTHX_ OP *o) cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; o->op_private |= (PL_hints & HINT_STRICT_REFS); if (PERLDB_SUB && PL_curstash != PL_debstash) @@ -9783,14 +9788,20 @@ Perl_rpeep(pTHX_ register OP *o) case OP_RV2SV: case OP_RV2AV: case OP_RV2HV: - if (oldop - && ( oldop->op_type == OP_AELEM + if (oldop && + ( + ( + ( oldop->op_type == OP_AELEM || oldop->op_type == OP_PADSV || oldop->op_type == OP_RV2SV || oldop->op_type == OP_RV2GV || oldop->op_type == OP_HELEM ) && (oldop->op_private & OPpDEREF) + ) + || ( oldop->op_type == OP_ENTERSUB + && oldop->op_private & OPpENTERSUB_DEREF ) + ) ) { o->op_private |= OPpDEREFed; } @@ -204,6 +204,7 @@ Deprecated. Use C<GIMME_V> instead. #define OPpENTERSUB_HASTARG 32 /* Called from OP tree. */ #define OPpENTERSUB_NOMOD 64 /* Immune to op_lvalue() for :attrlist. */ #define OPpENTERSUB_INARGS 4 /* Lval used as arg to a sub. */ +#define OPpENTERSUB_DEREF 1 /* Lval call that autovivifies. */ /* OP_RV2CV only */ #define OPpENTERSUB_AMPER 8 /* Used & form to call. */ #define OPpENTERSUB_NOPAREN 128 /* bare sub call (without parens) */ @@ -2228,8 +2228,24 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, } else *++newsp = &PL_sv_undef; + if (CxLVAL(cx) & OPpENTERSUB_DEREF) { + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + U8 deref_type; + if (cx->blk_sub.retop->op_type == OP_RV2SV) + deref_type = OPpDEREF_SV; + else if (cx->blk_sub.retop->op_type == OP_RV2AV) + deref_type = OPpDEREF_AV; + else { + assert(cx->blk_sub.retop->op_type == OP_RV2HV); + deref_type = OPpDEREF_HV; + } + vivify_ref(TOPs, deref_type); + } + } } else if (gimme == G_ARRAY) { + assert (!(CxLVAL(cx) & OPpENTERSUB_DEREF)); while (++MARK <= SP) { *++newsp = *MARK; TAINT_NOT; /* Each item is independent */ @@ -2245,6 +2261,7 @@ PP(pp_return) bool popsub2 = FALSE; bool clear_errsv = FALSE; bool lval = FALSE; + bool gmagic = FALSE; I32 gimme; SV **newsp; PMOP *newpm; @@ -2287,6 +2304,7 @@ PP(pp_return) popsub2 = TRUE; lval = !!CvLVALUE(cx->blk_sub.cv); retop = cx->blk_sub.retop; + gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF; cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */ break; case CXt_EVAL: @@ -2332,11 +2350,15 @@ PP(pp_return) FREETMPS; *++newsp = sv_mortalcopy(sv); SvREFCNT_dec(sv); + if (gmagic) SvGETMAGIC(sv); } } + else if (SvTEMP(*SP)) { + *++newsp = *SP; + if (gmagic) SvGETMAGIC(*SP); + } else - *++newsp = - SvTEMP(*SP) ? *SP : sv_mortalcopy(*SP); + *++newsp = sv_mortalcopy(*SP); } else *++newsp = sv_mortalcopy(*SP); @@ -2595,12 +2595,14 @@ PP(pp_leavesub) I32 gimme; register PERL_CONTEXT *cx; SV *sv; + bool gmagic; if (CxMULTICALL(&cxstack[cxstack_ix])) return 0; POPBLOCK(cx,newpm); cxstack_ix++; /* temporarily protect top context */ + gmagic = CxLVAL(cx) & OPpENTERSUB_DEREF; TAINT_NOT; if (gimme == G_SCALAR) { @@ -2611,6 +2613,7 @@ PP(pp_leavesub) *MARK = SvREFCNT_inc(TOPs); FREETMPS; sv_2mortal(*MARK); + if (gmagic) SvGETMAGIC(*MARK); } else { sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */ @@ -2619,8 +2622,12 @@ PP(pp_leavesub) SvREFCNT_dec(sv); } } + else if (SvTEMP(TOPs)) { + *MARK = TOPs; + if (gmagic) SvGETMAGIC(TOPs); + } else - *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs); + *MARK = sv_mortalcopy(TOPs); } else { MEXTEND(MARK, 0); @@ -2818,6 +2825,24 @@ PP(pp_leavesublv) SP = MARK; } } + + if (CxLVAL(cx) & OPpENTERSUB_DEREF) { + assert(gimme == G_SCALAR); + SvGETMAGIC(TOPs); + if (!SvOK(TOPs)) { + U8 deref_type; + if (cx->blk_sub.retop->op_type == OP_RV2SV) + deref_type = OPpDEREF_SV; + else if (cx->blk_sub.retop->op_type == OP_RV2AV) + deref_type = OPpDEREF_AV; + else { + assert(cx->blk_sub.retop->op_type == OP_RV2HV); + deref_type = OPpDEREF_HV; + } + vivify_ref(TOPs, deref_type); + } + } + rvalue_array: PUTBACK; diff --git a/t/op/gmagic.t b/t/op/gmagic.t index 2979c08b31..6901609033 100644 --- a/t/op/gmagic.t +++ b/t/op/gmagic.t @@ -69,6 +69,17 @@ my($rgot, $wgot) = $tyre->init(0); ok($rgot == 0, 'a plain *foo causes no get-magic'); ok($wgot == 0, 'a plain *foo causes no set-magic'); +# get-magic when exiting a non-lvalue sub in potentially autovivify- +# ing context +$tied_to = tie $_{elem}, "Tie::Monitor"; +eval { () = sub { delete $_{elem} }->()->[3] }; +ok +($tied_to->init)[0], + 'get-magic is called on mortal magic var on sub exit in autoviv context'; +$tied_to = tie $_{elem}, "Tie::Monitor"; +eval { () = sub { return delete $_{elem} }->()->[3] }; +ok +($tied_to->init)[0], + 'get-magic is called on mortal magic var on return in autoviv context'; + done_testing(); # adapted from Tie::Counter by Abigail diff --git a/t/op/sub_lval.t b/t/op/sub_lval.t index f490ec4261..0af4d9134a 100644 --- a/t/op/sub_lval.t +++ b/t/op/sub_lval.t @@ -3,7 +3,7 @@ BEGIN { @INC = '../lib'; require './test.pl'; } -plan tests=>124; +plan tests=>134; sub a : lvalue { my $a = 34; ${\(bless \$a)} } # Return a temporary sub b : lvalue { ${\shift} } @@ -709,3 +709,23 @@ for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { is $_, '44', '(lvalue)[0]'.$suffix; } continue { $suffix = ' (explicit return)' } + +# autovivification +for my $sub (sub :lvalue {$_}, sub :lvalue {return $_}) { + undef $_; + &$sub()->[3] = 4; + is $_->[3], 4, 'func->[...] autovivification'.$suffix; + undef $_; + &$sub()->{3} = 4; + is $_->{3}, 4, 'func->{...} autovivification'.$suffix; + undef $_; + ${&$sub()} = 4; + is $$_, 4, '${func()} autovivification' .$suffix; + undef $_; + @{&$sub()} = 4; + is "@$_", 4, '@{func()} autovivification' .$suffix; + undef $_; + %{&$sub()} = (4,5); + is join('-',%$_), '4-5', '%{func()} autovivification'.$suffix; +} +continue { $suffix = ' (explicit return)' } |