In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/e03e82a04dda6a44b815f3367c69afb0e953dc91?hp=fb882494267edb919d5a9a3fe0aca2dfeb30d012>
- Log ----------------------------------------------------------------- commit e03e82a04dda6a44b815f3367c69afb0e953dc91 Author: David Mitchell <[email protected]> Date: Thu Nov 24 09:40:44 2016 +0000 add sv_set_undef() API function This function is equivalent to sv_setsv(sv, &PL_sv_undef), but more efficient. Also change the obvious places in the core to use the new idiom. M embed.fnc M embed.h M mg.c M pod/perldelta.pod M pp.c M pp_hot.c M proto.h M regcomp.c M sv.c M t/perf/benchmarks M util.c commit d24e3eb1402c1294265f99342e2ec0ecfd0f5d34 Author: David Mitchell <[email protected]> Date: Tue Nov 22 16:41:54 2016 +0000 avoid premature free of referent in list assign RT #130132 My recent commit v5.25.6-266-ga083329 made it so that perl could sometimes avoid mortalising the referent when assigning to a reference (e.g. for $ref1 = $ref2, where $$ref1 has a ref count of 1). Unfortunately it turns out that list assign relied on this behaviour to avoid premature freeing, e.g. ($ref1, $x) = ($y, $$ref1); where $$ref1 needs to continue to live for at least the rest of the assign. This commit fixes it by mortalising the referent in pp_assign when required. M op.c M pp_hot.c M t/op/aassign.t M t/perf/benchmarks ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + mg.c | 28 ++++++++++++++------------ op.c | 16 +++++++++++++++ pod/perldelta.pod | 3 ++- pp.c | 2 +- pp_hot.c | 22 +++++++++++++++++++- proto.h | 3 +++ regcomp.c | 2 +- sv.c | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- t/op/aassign.t | 34 +++++++++++++++++++++++++++++++ t/perf/benchmarks | 18 +++++++++++++++++ util.c | 7 +++---- 13 files changed, 175 insertions(+), 22 deletions(-) diff --git a/embed.fnc b/embed.fnc index 4743aed..e03c4d2 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2709,6 +2709,7 @@ sRM |U8* |swash_scan_list_line|NN U8* l|NN U8* const lend|NN UV* min \ AiMn |void |append_utf8_from_native_byte|const U8 byte|NN U8** dest #endif +Apd |void |sv_set_undef |NN SV *sv Apd |void |sv_setsv_flags |NN SV *dstr|NULLOK SV *sstr|const I32 flags Apd |void |sv_catpvn_flags|NN SV *const dstr|NN const char *sstr|const STRLEN len \ |const I32 flags diff --git a/embed.h b/embed.h index d54ed6c..6061d55 100644 --- a/embed.h +++ b/embed.h @@ -664,6 +664,7 @@ #define sv_report_used() Perl_sv_report_used(aTHX) #define sv_reset(a,b) Perl_sv_reset(aTHX_ a,b) #define sv_rvweaken(a) Perl_sv_rvweaken(aTHX_ a) +#define sv_set_undef(a) Perl_sv_set_undef(aTHX_ a) #define sv_setiv(a,b) Perl_sv_setiv(aTHX_ a,b) #define sv_setiv_mg(a,b) Perl_sv_setiv_mg(aTHX_ a,b) #define sv_setnv(a,b) Perl_sv_setnv(aTHX_ a,b) diff --git a/mg.c b/mg.c index b7ce69d..cbabcc6 100644 --- a/mg.c +++ b/mg.c @@ -725,7 +725,7 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv) PERL_ARGS_ASSERT_EMULATE_COP_IO; if (!(CopHINTS_get(c) & (HINT_LEXICAL_IO_IN|HINT_LEXICAL_IO_OUT))) - sv_setsv(sv, &PL_sv_undef); + sv_set_undef(sv); else { SvPVCLEAR(sv); SvUTF8_off(sv); @@ -800,9 +800,9 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { do_numbuf_fetch: CALLREG_NUMBUF_FETCH(rx,paren,sv); - } else { - sv_setsv(sv,&PL_sv_undef); } + else + goto set_undef; return 0; } @@ -810,7 +810,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) switch (*mg->mg_ptr) { case '\001': /* ^A */ if (SvOK(PL_bodytarget)) sv_copypv(sv, PL_bodytarget); - else sv_setsv(sv, &PL_sv_undef); + else + sv_set_undef(sv); if (SvTAINTED(PL_bodytarget)) SvTAINTED_on(sv); break; @@ -994,8 +995,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setpvn(sv, WARN_NONEstring, WARNsize) ; } else if (PL_compiling.cop_warnings == pWARN_STD) { - sv_setsv(sv, &PL_sv_undef); - break; + goto set_undef; } else if (PL_compiling.cop_warnings == pWARN_ALL) { /* Get the bit mask for $warnings::Bits{all}, because @@ -1024,16 +1024,14 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { paren = RX_LASTCLOSEPAREN(rx); if (paren) goto do_numbuf_fetch; } - sv_setsv(sv,&PL_sv_undef); - break; + goto set_undef; case '.': if (GvIO(PL_last_in_gv)) { sv_setiv(sv, (IV)IoLINES(GvIOp(PL_last_in_gv))); @@ -1092,7 +1090,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) if (PL_ors_sv) sv_copypv(sv, PL_ors_sv); else - sv_setsv(sv, &PL_sv_undef); + goto set_undef; break; case '$': /* $$ */ { @@ -1138,6 +1136,10 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) break; } return 0; + + set_undef: + sv_set_undef(sv); + return 0; } int @@ -1341,7 +1343,7 @@ Perl_magic_getsig(pTHX_ SV *sv, MAGIC *mg) if(sigstate == (Sighandler_t) SIG_IGN) sv_setpvs(sv,"IGNORE"); else - sv_setsv(sv,&PL_sv_undef); + sv_set_undef(sv); PL_psig_ptr[i] = SvREFCNT_inc_simple_NN(sv); SvTEMP_off(sv); } @@ -2189,7 +2191,7 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg) negrem ? -(IV)rem : (IV)rem, !negrem, &offs, &rem )) { Perl_ck_warner(aTHX_ packWARN(WARN_SUBSTR), "substr outside of string"); - sv_setsv_nomg(sv, &PL_sv_undef); + sv_set_undef(sv); return 0; } diff --git a/op.c b/op.c index 9724ff0..3cd7ea2 100644 --- a/op.c +++ b/op.c @@ -12635,6 +12635,11 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int *scalars_p) break; } + /* XXX this assumes that all other ops are "transparent" - i.e. that + * they can return some of their children. While this true for e.g. + * sort and grep, it's not true for e.g. map. We really need a + * 'transparent' flag added to regen/opcodes + */ if (o->op_flags & OPf_KIDS) { OP *kid; for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) @@ -14605,6 +14610,17 @@ Perl_rpeep(pTHX_ OP *o) NOOP; } else if (r & (AAS_PKG_SCALAR|AAS_PKG_AGG|AAS_DANGEROUS)) + /* if there are only lexicals on the LHS and no + * common ones on the RHS, then we assume that the + * only way those lexicals could also get + * on the RHS is via some sort of dereffing or + * closure, e.g. + * $r = \$lex; + * ($lex, $x) = (1, $$r) + * and in this case we assume the var must have + * a bumped ref count. So if its ref count is 1, + * it must only be on the LHS. + */ o->op_private |= OPpASSIGN_COMMON_RC1; } } diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 9719550..070fd4a 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -323,7 +323,8 @@ well. =item * -XXX +A new API function, C<sv_set_undef(sv)>, has been added. This is +equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but is more efficient. =back diff --git a/pp.c b/pp.c index ce589a0..d406ee1 100644 --- a/pp.c +++ b/pp.c @@ -3249,7 +3249,7 @@ PP(pp_length) } } else { if (!SvPADTMP(TARG)) { - sv_setsv_nomg(TARG, &PL_sv_undef); + sv_set_undef(TARG); } else { /* TARG is on stack at this point and is overwriten by SETs. This branch is the odd one out, so put TARG by default on stack earlier to let local SP go out of liveness sooner */ diff --git a/pp_hot.c b/pp_hot.c index 7db8cbe..dd2c611 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1708,6 +1708,8 @@ PP(pp_aassign) default: if (!SvIMMORTAL(lsv)) { + SV *ref; + if (UNLIKELY( SvTEMP(lsv) && !SvSMAGICAL(lsv) && SvREFCNT(lsv) == 1 && (!isGV_with_GP(lsv) || SvFAKE(lsv)) && ckWARN(WARN_MISC) @@ -1716,6 +1718,24 @@ PP(pp_aassign) packWARN(WARN_MISC), "Useless assignment to a temporary" ); + + /* avoid freeing $$lsv if it might be needed for further + * elements, e.g. ($ref, $foo) = (1, $$ref) */ + if ( SvROK(lsv) + && ( ((ref = SvRV(lsv)), SvREFCNT(ref)) == 1) + && lelem <= lastlelem + ) { + SSize_t ix; + SvREFCNT_inc_simple_void_NN(ref); + /* an unrolled sv_2mortal */ + ix = ++PL_tmps_ix; + if (UNLIKELY(ix >= PL_tmps_max)) + /* speculatively grow enough to cover other + * possible refs */ + ix = tmps_grow_p(ix + (lastlelem - lelem)); + PL_tmps_stack[ix] = ref; + } + sv_setsv(lsv, *relem); *relem = lsv; SvSETMAGIC(lsv); @@ -1756,7 +1776,7 @@ PP(pp_aassign) default: if (!SvIMMORTAL(lsv)) { - sv_setsv(lsv, &PL_sv_undef); + sv_set_undef(lsv); SvSETMAGIC(lsv); *relem++ = lsv; } diff --git a/proto.h b/proto.h index 5ff6bfe..b760924 100644 --- a/proto.h +++ b/proto.h @@ -3224,6 +3224,9 @@ PERL_CALLCONV void Perl_sv_resetpvn(pTHX_ const char* s, STRLEN len, HV *const s PERL_CALLCONV SV* Perl_sv_rvweaken(pTHX_ SV *const sv); #define PERL_ARGS_ASSERT_SV_RVWEAKEN \ assert(sv) +PERL_CALLCONV void Perl_sv_set_undef(pTHX_ SV *sv); +#define PERL_ARGS_ASSERT_SV_SET_UNDEF \ + assert(sv) PERL_CALLCONV void Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek); #define PERL_ARGS_ASSERT_SV_SETHEK \ assert(sv) diff --git a/regcomp.c b/regcomp.c index bb4b502..095b13f 100644 --- a/regcomp.c +++ b/regcomp.c @@ -8139,7 +8139,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, } } else { ret_undef: - sv_setsv(sv,&PL_sv_undef); + sv_set_undef(sv); return; } } diff --git a/sv.c b/sv.c index f3c057b..6a17049 100644 --- a/sv.c +++ b/sv.c @@ -4782,6 +4782,64 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, SV* sstr, const I32 flags) SvTAINT(dstr); } + +/* +=for apidoc sv_set_undef + +Equivalent to C<sv_setsv(sv, &PL_sv_undef)>, but more efficient. +Doesn't handle set magic. + +The perl equivalent is C<$sv = undef;>. Note that it doesn't free any string +buffer, unlike C<undef $sv>. + +Introduced in perl 5.26.0. + +=cut +*/ + +void +Perl_sv_set_undef(pTHX_ SV *sv) +{ + U32 type = SvTYPE(sv); + + PERL_ARGS_ASSERT_SV_SET_UNDEF; + + /* shortcut, NULL, IV, RV */ + + if (type <= SVt_IV) { + assert(!SvGMAGICAL(sv)); + if (SvREADONLY(sv)) + Perl_croak_no_modify(); + + if (SvROK(sv)) { + if (SvWEAKREF(sv)) + sv_unref_flags(sv, 0); + else { + SV *rv = SvRV(sv); + SvFLAGS(sv) = type; /* quickly turn off all flags */ + SvREFCNT_dec_NN(rv); + return; + } + } + SvFLAGS(sv) = type; /* quickly turn off all flags */ + return; + } + + if (SvIS_FREED(sv)) + Perl_croak(aTHX_ "panic: attempt to undefine a freed scalar %p", + (void *)sv); + + SV_CHECK_THINKFIRST_COW_DROP(sv); + + if (isGV_with_GP(sv)) + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Undefined value assigned to typeglob"); + + SvOK_off(sv); +} + + + /* =for apidoc sv_setsv_mg @@ -10272,7 +10330,7 @@ Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const p PERL_ARGS_ASSERT_SV_SETREF_PV; if (!pv) { - sv_setsv(rv, &PL_sv_undef); + sv_set_undef(rv); SvSETMAGIC(rv); } else diff --git a/t/op/aassign.t b/t/op/aassign.t index e789210..b8025cf 100644 --- a/t/op/aassign.t +++ b/t/op/aassign.t @@ -559,5 +559,39 @@ SKIP: { like($@, qr//, "RT #129991"); } +{ + # [perl #130132] + # lexical refs on LHS, dereffed on the RHS + + my $fill; + + my $sref = do { my $tmp = 2; \$tmp }; + ($sref, $fill) = (1, $$sref); + is ($sref, 1, "RT #130132 scalar 1"); + is ($fill, 2, "RT #130132 scalar 2"); + + my $x = 1; + $sref = \$x; + ($sref, $$sref) = (2, 3); + is ($sref, 2, "RT #130132 scalar derefffed 1"); + is ($x, 3, "RT #130132 scalar derefffed 2"); + + $x = 1; + $sref = \$x; + ($sref, $$sref) = (2); + is ($sref, 2, "RT #130132 scalar undef 1"); + is ($x, undef, "RT #130132 scalar undef 2"); + + my @a; + $sref = do { my $tmp = 2; \$tmp }; + @a = (($sref) = (1, $$sref)); + is ($sref, 1, "RT #130132 scalar list cxt 1"); + is ($a[0], 1, "RT #130132 scalar list cxt a[0]"); + + my $aref = [ 1, 2 ]; + ($aref, $fill) = @$aref; + is ($aref, 1, "RT #130132 array 1"); + is ($fill, 2, "RT #130132 array 2"); +} done_testing(); diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 8306b1f..92411a2 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -320,6 +320,11 @@ setup => 'my ($x,$y,$z)', code => '($x,$y,$z) = ()', }, + 'expr::aassign::3lref_empty' => { + desc => 'three lexical ref vars assigned empty', + setup => 'my ($x,$y,$z); my $r = []; ', + code => '($x,$y,$z) = ($r,$r,$r); ($x,$y,$z) = ()', + }, 'expr::aassign::pa_empty' => { desc => 'package array assigned empty', setup => '', @@ -694,6 +699,19 @@ code => '($x, $y) = (1, 2)', }, + 'expr::aassign::lex_rv' => { + desc => 'lexical ($ref1, $ref2) = ($ref3, $ref4)', + setup => 'my ($r1, $r2, $r3, $r4); + ($r1, $r2) = (($r3, $r4) = ([], []));', + code => '($r1, $r2) = ($r3, $r4)', + }, + + 'expr::aassign::lex_rv1' => { + desc => 'lexical ($ref1, $ref2) = ($ref3, $ref4) where ref1,2 are freed', + setup => 'my ($r1, $r2);', + code => '($r1, $r2) = ([], []);', + }, + # array assign of strings 'expr::aassign::la_3s' => { diff --git a/util.c b/util.c index adbe51d..02c84c8 100644 --- a/util.c +++ b/util.c @@ -4083,8 +4083,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in #define SV_CWD_RETURN_UNDEF \ -sv_setsv(sv, &PL_sv_undef); \ -return FALSE + sv_set_undef(sv); \ + return FALSE #define SV_CWD_ISDOT(dp) \ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ @@ -4128,8 +4128,7 @@ Perl_getcwd_sv(pTHX_ SV *sv) return TRUE; } else { - sv_setsv(sv, &PL_sv_undef); - return FALSE; + SV_CWD_RETURN_UNDEF; } } -- Perl5 Master Repository
