Skip to content

Commit

Permalink
[MERGE] pp_multiconcat: don't make lots of mortals
Browse files Browse the repository at this point in the history 
In the 'fallback to traditional concat behaviour if any args are magic'
branch, the code was potentially creating lots of SvTEMPs to emulate the
PADTMPs of the various OP_CONCAT, OP_CONST, etc ops it replaced.

This branch reduces the number of temps required, and of the ones still
needed, mostly replaces them with PADTMPs so that they don't need freeing
and reallocating each time.

In particular, this fixes GH #21360, whereby something like

s/..../x$1/g

was allocating SvTEMPs for each /g iteration, but because it only did a
FREETMPs after the last iteration, memory usage grew and performance
suffered, especially under Windows.
  • Loading branch information
@iabyn
iabyn committed Sep 2, 2023
2 parents abc9d33 + e3777ab commit 7bcd18a
Show file tree
Hide file tree
Showing 6 changed files with 253 additions and 9 deletions.
2 changes: 1 addition & 1 deletion ext/B/B.pm
View file
Expand Up @@ -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.
Expand Down
2 changes: 1 addition & 1 deletion ext/B/B.xs
View file
Expand Up @@ -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)));
Expand Down
17 changes: 17 additions & 0 deletions peep.c
View file
Expand Up @@ -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;
}


Expand Down
7 changes: 5 additions & 2 deletions perl.h
View file
Expand Up @@ -1591,8 +1591,11 @@ Use L</UV> 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.
Expand Down
41 changes: 36 additions & 5 deletions pp_hot.c
View file
Expand Up @@ -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 */

Expand Down Expand Up @@ -1243,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;
Expand All @@ -1265,7 +1267,36 @@ 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));
/* 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) {
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);
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;
}

Expand All @@ -1277,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 {
Expand Down
193 changes: 193 additions & 0 deletions t/perf/benchmarks
View file
Expand Up @@ -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' => {
Expand Down

0 comments on commit 7bcd18a

Please sign in to comment.