From f37cd5e9bc43e0d839b4007ceefca5a02c4701c6 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Fri, 18 Aug 2023 11:54:33 +0100 Subject: [PATCH 1/4] perf/benchmarks: add concat tests for magic vars There are already extensive tests for various permutations of string concatenation (mainly to exercise the pp_multiconcat() optimisation introduced in 5.28.0) This commit adds copies of of most of those tests, but where lexical vars are replaced by a variable which has get magic, in this case $1. pp_multiconcat() takes a very pessimised approach when it detects magic vars (the possible side effects of which rule out most of the possible optimisations, mainly due to ordering). But it's been pointed out (GH #21360) that this can make expressions involving such vars actually slower than before pp_multiconcat() was introduced. So add tests now, then subsequent commits will try to speed them up. --- t/perf/benchmarks | 193 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 193 insertions(+) diff --git a/t/perf/benchmarks b/t/perf/benchmarks index 92f946bbce9e..59da49cafcad 100644 --- a/t/perf/benchmarks +++ b/t/perf/benchmarks @@ -1348,6 +1348,199 @@ }, + # concatenation with magic vars; + # quite possibly optimised to OP_MULTICONCAT + + 'expr::concat::mg::cM' => { + setup => '"abcd" =~ /(.*)/', + code => '"foo" . $1', + }, + 'expr::concat::mg::Mc' => { + setup => '"abcd" =~ /(.*)/', + code => '$1 . "foo"', + }, + 'expr::concat::mg::MM' => { + setup => '"abcd" =~ /(.*)/', + code => '$1 . $1', + }, + + 'expr::concat::mg::l_append_M' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + pre => '$lex = "abcd"', + code => '$lex .= $1', + }, + 'expr::concat::mg::l_append_MM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + pre => '$lex = "abcd"', + code => '$lex .= $1 .$1', + }, + 'expr::concat::mg::l_append_cMcMc' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + pre => '$lex = "abcd"', + code => '$lex .= "-foo-$1-foo-$1-foo"', + }, + 'expr::concat::mg::l_append_MMM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + pre => '$lex = "abcd"', + code => '$lex .= $1 .$1 . $1', + }, + + 'expr::concat::mg::m_MM' => { + setup => '"abcd" =~ /(.*)/;', + code => 'my $lex = $1 . $1', + }, + 'expr::concat::mg::m_MMM' => { + setup => '"abcd" =~ /(.*)/;', + code => 'my $lex = $1 . $1 . $1', + }, + 'expr::concat::mg::m_cL' => { + setup => '"abcd" =~ /(.*)/;', + code => 'my $lex = "const$1"', + }, + 'expr::concat::mg::m_cMcMc' => { + setup => '"abcd" =~ /(.*)/;', + code => 'my $lex = "foo=$1 bar=$1\n"', + }, + 'expr::concat::mg::m_cMcMc_long' => { + desc => 'my $lex = "foooooooooo=$1 baaaaaaaaar=$1\n" where $1 is 400 chars', + setup => 'my $s = "abcd" x 100; $s =~ /(.*)/;', + code => 'my $lex = "foooooooooo=$1 baaaaaaaaar=$1\n"', + }, + + 'expr::concat::mg::l_MM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = $1 . $1', + }, + 'expr::concat::mg::l_lM_ldup' => { + setup => 'my $lex1; "abcd" =~ /(.*)/;', + pre => '$lex1 = "abcd"', + code => '$lex1 = $lex1 . $1', + }, + 'expr::concat::mg::l_Ml_rdup' => { + setup => 'my $lex1; "abcd" =~ /(.*)/;', + pre => '$lex1 = "abcd"', + code => '$lex1 = $1 . $lex1', + }, + 'expr::concat::mg::l_MMM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = $1 . $1 . $1', + }, + 'expr::concat::mg::l_MMMMM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = $1 . $1 . $1 . $1 . $1', + }, + 'expr::concat::mg::l_cM' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = "const$1"', + }, + 'expr::concat::mg::l_cMcMc' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = "foo=$1 bar=$1\n"', + }, + 'expr::concat::mg::l_cMcMc_long' => { + desc => '$lex = "foooooooooo=$1 baaaaaaaaar=$1\n" where $1 is 400 chars', + setup => 'my $s = "abcd" x 100; $s =~ /(.*)/;', + code => '$lex = "foooooooooo=$1 baaaaaaaaar=$1\n"', + }, + 'expr::concat::mg::l_cMcMcMcMcMc' => { + setup => 'my $lex; "abcd" =~ /(.*)/;', + code => '$lex = "foo1=$1 foo2=$1 foo3=$1 foo4=$1\n"', + }, + + 'expr::concat::mg::g_append_M' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + pre => '$pkg = "abcd"', + code => '$pkg .= $1', + }, + 'expr::concat::mg::g_append_MM' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + pre => '$pkg = "abcd"', + code => '$pkg .= $1', + code => '$pkg .= $1 . $1', + }, + 'expr::concat::mg::g_append_cMcMc' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + pre => '$pkg = "abcd"', + code => '$pkg .= "-foo-$1-foo-$1-foo-"', + }, + + 'expr::concat::mg::g_MM' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + code => '$pkg = $1 . $1', + }, + 'expr::concat::mg::g_gM_ldup' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + pre => '$pkg = "abcd"', + code => '$pkg = $pkg . $1', + }, + 'expr::concat::mg::g_Mg_rdup' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + pre => '$pkg = "abcd"', + code => '$pkg = $1 . $pkg', + }, + 'expr::concat::mg::g_MMM' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + code => '$pkg = $1 . $1 . $1', + }, + 'expr::concat::mg::g_cM' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + code => '$pkg = "const$1"', + }, + 'expr::concat::mg::g_cMcMc' => { + setup => 'our $pkg; "abcd" =~ /(.*)/;', + code => '$pkg = "foo=$1 bar=$1\n"', + }, + 'expr::concat::mg::g_cMcMc_long' => { + desc => '$lex = "foooooooooo=$1 baaaaaaaaar=$1\n" where $1 is 400 chars', + setup => 'our $pkg; my $s = "abcd" x 100; $s =~ /(.*)/;', + code => '$pkg = "foooooooooo=$1 baaaaaaaaar=$1\n"', + }, + + 'expr::concat::mg::utf8_uuu' => { + desc => 'my $s = $1.$1.$1 where $1 utf8', + setup => 'my $s; "ab\x{100}cde" =~ /(.*)/;', + code => '$s = $1.$1.$1', + }, + 'expr::concat::mg::utf8_suu' => { + desc => 'my $s = "foo=$a bar=$1 baz=$1" where $1 is utf8', + setup => 'my $s; my $a = "abcde"; "ab\x{100}cde" =~ /(.*)/;', + code => '$s = "foo=$a bar=$1 baz=$1"', + }, + + # OP_MULTICONCAT with magic within s///g - see GH #21360 + + 'expr::concat::mg::subst1_1' => { + desc => 's/(.)/$1-/g, 1 iteration', + pre => '$_ = "a"', + code => 's/(.)/$1-/g', + }, + + 'expr::concat::mg::subst1_2' => { + desc => 's/(.)/$1-/g, 2 iterations', + pre => '$_ = "aa"', + code => 's/(.)/$1-/g', + }, + + 'expr::concat::mg::subst1_5' => { + desc => 's/(.)/$1-/g, 5 iterations', + pre => '$_ = "aaaaa"', + code => 's/(.)/$1-/g', + }, + + 'expr::concat::mg::subst2_1' => { + desc => 's/(.)/$1-$1/g, 1 iteration', + pre => '$_ = "a"', + code => 's/(.)/$1-/g', + }, + + 'expr::concat::mg::subst3_1' => { + desc => 's/(.)/$1-$1-$1/g, 1 iteration', + pre => '$_ = "a"', + code => 's/(.)/$1-$1-$1/g', + }, + + + # scalar assign, OP_SASSIGN 'expr::sassign::undef_lex' => { From 212b6b3f3b2c904f656295bc1871a735c9589ceb Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Fri, 18 Aug 2023 13:24:06 +0100 Subject: [PATCH 2/4] pp_multiconcat(): use a single TEMP for consts In the 'fallback to traditional concat behaviour if any args are magic' branch, the code creates an SvTEMP() SV for each constant string segment that needs to be concatenated. This commit makes it reuse the same TEMP for each constant segment, rather than creating a new one each time. The code originally reused the TEMP, but that broke things where the method which was called for an overloaded object took a reference to one of its args (RT #132385). My original fix was a blanket "don't reuse". This commit makes the rule into "reuse unless the TEMP has a refcount > 1, in which case abandon it", which shou;d make things faster. See GH #21360. --- pp_hot.c | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/pp_hot.c b/pp_hot.c index ffe3fdd8a446..d0bb1ed6a03f 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1200,6 +1200,7 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) U32 utf8 = 0; SV **svp; const char *cpv = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv; + SV *csv = NULL; /* SV which will hold cpv */ UNOP_AUX_item *lens = aux + PERL_MULTICONCAT_IX_LENGTHS; Size_t arg_count = 0; /* how many args have been processed */ @@ -1265,7 +1266,14 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) else if (len < 0) continue; /* no const in this position */ else { - right = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP)); + /* try to reuse csv if possible. If the refcount has gone + * up, something like overload code has taken a reference + * to it, so abandon it */ + if (csv && SvREFCNT(csv) == 1) + sv_setpvn(csv, cpv, len); + else + csv = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP)); + right = csv; cpv += len; } From ea6e0ec28eeb0c56edbc0e88c5337efb1b17bda0 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Fri, 18 Aug 2023 14:19:28 +0100 Subject: [PATCH 3/4] pp_multiconcat(): use shared-buffer const SV In the 'fallback to traditional concat behaviour if any args are magic' branch, the code creates a resuable SvTEMP() SV, which is temporarily set for each constant string segment that needs to be concatenated. Make that SV be of the kind where SvLEN(sv) == 0, which means the PV buffer is shared and won't be freed when the SV is freed. Then just set the SvPV pointer to point to the appropriate offset in the string constants buffer attached to the multiconcat op. This avoids malloc()ing and free()ing the PV buffer each time, and so should speed things up. See GH #21360. --- pp_hot.c | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/pp_hot.c b/pp_hot.c index d0bb1ed6a03f..c5eadec3dd6f 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1269,10 +1269,22 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) /* try to reuse csv if possible. If the refcount has gone * up, something like overload code has taken a reference * to it, so abandon it */ - if (csv && SvREFCNT(csv) == 1) - sv_setpvn(csv, cpv, len); - else - csv = newSVpvn_flags(cpv, len, (utf8 | SVs_TEMP)); + if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) { + csv = newSV_type_mortal(SVt_PV); + if (utf8) + SvUTF8_on(csv); + SvREADONLY_on(csv); + SvPOK_on(csv); + } + /* use the const string buffer directly with the + * SvLEN==0 trick */ + + /* cast away constness because we think we know it's safe + * (SvREADONLY) */ + SvPV_set(csv, (char *)cpv); + SvLEN_set(csv, 0); + SvCUR_set(csv, len); + right = csv; cpv += len; } From e3777abb2629e5b080a66f5f2b52bd980a47c4c1 Mon Sep 17 00:00:00 2001 From: David Mitchell Date: Tue, 29 Aug 2023 13:15:31 +0100 Subject: [PATCH 4/4] pp_multiconcat(): use PADTMPs for magic stuff In the 'fallback to traditional concat behaviour if any args are magic' branch, the code creates up to four SvTEMP() SVs to emulate the PADTMPs of the various OP_CONCAT, OP_CONST, etc ops it replaced. This commit allocates up to three extra PADTMPs (indexed from the aux array) for pp_multiconcat()'s use, to avoid having to allocate and free SvTEMPs each time. It also fixes the issue in GH #21360, whereby something like s/..../x$1/g was allocating SvTEMPs for each /g iteration, but because it only does a FREETMPs after the last iteration, memory usage grew and performance suffered. After this commit, only two places still create a mortal. The first is in the tie/overload handling code (which emulates Perl_try_amagic_bin) for the rare case of both args being magic and the same SV. Before pp_multiconcat() was added, this would create a mortal anyway. The seconds is in the rare case where a PADTMP used to emulate the SV of an OP_CONST is stolen (e.g. by an overload method taking a reference to it.) In this case it is abandoned and a mortal used instead. The idea to add extra PADTMPs, indexed from aux, was stolen from Richard Leach. --- ext/B/B.pm | 2 +- ext/B/B.xs | 2 +- peep.c | 17 +++++++++++++++++ perl.h | 7 +++++-- pp_hot.c | 27 +++++++++++++++++++-------- 5 files changed, 43 insertions(+), 12 deletions(-) diff --git a/ext/B/B.pm b/ext/B/B.pm index d0a04c6a12f9..b39385b35e81 100644 --- a/ext/B/B.pm +++ b/ext/B/B.pm @@ -20,7 +20,7 @@ sub import { # walkoptree comes from B.xs BEGIN { - $B::VERSION = '1.88'; + $B::VERSION = '1.89'; @B::EXPORT_OK = (); # Our BOOT code needs $VERSION set, and will append to @EXPORT_OK. diff --git a/ext/B/B.xs b/ext/B/B.xs index 49b35cbf2fa2..0b8ef47cf21d 100644 --- a/ext/B/B.xs +++ b/ext/B/B.xs @@ -1244,7 +1244,7 @@ aux_list(o, cv) /* return (nargs, const string, segment len 0, 1, 2, ...) */ /* if this changes, this block of code probably needs fixing */ - assert(PERL_MULTICONCAT_HEADER_SIZE == 5); + assert(PERL_MULTICONCAT_HEADER_SIZE == 8); nargs = aux[PERL_MULTICONCAT_IX_NARGS].ssize; EXTEND(SP, ((SSize_t)(2 + (nargs+1)))); PUSHs(sv_2mortal(newSViv((IV)nargs))); diff --git a/peep.c b/peep.c index 574a4ec83906..72dab9539762 100644 --- a/peep.c +++ b/peep.c @@ -997,6 +997,23 @@ S_maybe_multiconcat(pTHX_ OP *o) o->op_type = OP_MULTICONCAT; o->op_ppaddr = PL_ppaddr[OP_MULTICONCAT]; cUNOP_AUXo->op_aux = aux; + + + /* add some PADTMPs, as needed, for the 'fallback to OP_CONCAT + * behaviour if magic / overloaded etc present' code path */ + + /* general PADTMP for the target of each concat */ + aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset = + pad_alloc(OP_MULTICONCAT, SVs_PADTMP); + + /* PADTMP for recreating OP_CONST return values */ + aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset = + (is_sprintf || nconst) ? pad_alloc(OP_MULTICONCAT, SVs_PADTMP) : 0; + + /* PADTMP for stringifying the result */ + aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset = + (o->op_private &OPpMULTICONCAT_STRINGIFY) + ? pad_alloc(OP_MULTICONCAT, SVs_PADTMP) : 0; } diff --git a/perl.h b/perl.h index d0c8439bb22a..8536040209a7 100644 --- a/perl.h +++ b/perl.h @@ -1591,8 +1591,11 @@ Use L to declare variables of the maximum usable size on this platform. #define PERL_MULTICONCAT_IX_PLAIN_LEN 2 /* non-utf8 constant string length */ #define PERL_MULTICONCAT_IX_UTF8_PV 3 /* utf8 constant string */ #define PERL_MULTICONCAT_IX_UTF8_LEN 4 /* utf8 constant string length */ -#define PERL_MULTICONCAT_IX_LENGTHS 5 /* first of nargs+1 const segment lens */ -#define PERL_MULTICONCAT_HEADER_SIZE 5 /* The number of fields of a +#define PERL_MULTICONCAT_IX_PADTMP0 5 /* up to 3 pad indexes for PADTMPs */ +#define PERL_MULTICONCAT_IX_PADTMP1 6 +#define PERL_MULTICONCAT_IX_PADTMP2 7 +#define PERL_MULTICONCAT_IX_LENGTHS 8 /* first of nargs+1 const segment lens */ +#define PERL_MULTICONCAT_HEADER_SIZE 8 /* The number of fields of a multiconcat header */ /* We no longer default to creating a new SV for GvSV. diff --git a/pp_hot.c b/pp_hot.c index c5eadec3dd6f..68fecb1c90d0 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1244,7 +1244,8 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) ) ) { - SV *tmp = newSV_type_mortal(SVt_PV); + assert(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset); + SV *tmp = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP2].pad_offset); sv_copypv(tmp, left); SvSETMAGIC(tmp); left = tmp; @@ -1266,11 +1267,21 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) else if (len < 0) continue; /* no const in this position */ else { - /* try to reuse csv if possible. If the refcount has gone - * up, something like overload code has taken a reference - * to it, so abandon it */ + /* Use one of our PADTMPs to fake up the SV which would + * have been returned by an OP_CONST. Try to reuse it if + * possible. If the refcount has gone up, something like + * overload code has taken a reference to it, so abandon + * it */ if (!csv || SvREFCNT(csv) > 1 || SvLEN(csv) != 0) { - csv = newSV_type_mortal(SVt_PV); + if (csv) + csv = newSV_type_mortal(SVt_PV); + else { + assert(aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset); + csv = PAD_SV( + aux[PERL_MULTICONCAT_IX_PADTMP1].pad_offset); + SvUPGRADE(csv, SVt_PV); + } + if (utf8) SvUTF8_on(csv); SvREADONLY_on(csv); @@ -1297,10 +1308,10 @@ PP_wrapped(pp_multiconcat, S_multiconcat_argcount(aTHX), 0) } if (arg_count == 2 && i < n) { - /* for the first concat, create a mortal acting like the - * padtmp from OP_CONST. In later iterations this will + /* for the first concat, use one of the PADTMPs to emulate + * the PADTMP from OP_CONST. In later iterations this will * be appended to */ - nexttarg = sv_newmortal(); + nexttarg = PAD_SV(aux[PERL_MULTICONCAT_IX_PADTMP0].pad_offset); nextappend = FALSE; } else {