Skip to content

Commit

Permalink
mutlitconcat: fix non-folding adjacent consts
Browse files Browse the repository at this point in the history
RT ##132646

v5.27.6-120-gbcc30fd changed multiconcat so that adjacent constants
weren't folded, so that ($overloaded . "a" . "b") is invoked as
    $overloaded->concat("a")->concat("b")
rather than
    $overloaded->concat("ab")

It did this by 'demoting' every second adjacent const as a real arg rather
than adding it to the const string. However, that could leave a
multiconcat op with more than the maximum allowed args.

So include demotion candidates as part of the arg count.
  • Loading branch information
iabyn committed Dec 25, 2017
1 parent 06c214d commit f08f2d0
Show file tree
Hide file tree
Showing 2 changed files with 40 additions and 2 deletions.
10 changes: 9 additions & 1 deletion op.c
Expand Up @@ -2666,6 +2666,7 @@ S_maybe_multiconcat(pTHX_ OP *o)

SSize_t nargs = 0;
SSize_t nconst = 0;
SSize_t nadjconst = 0; /* adjacent consts - may be demoted to args */
STRLEN variant;
bool utf8 = FALSE;
bool kid_is_last = FALSE; /* most args will be the RHS kid of a concat op;
Expand All @@ -2677,6 +2678,7 @@ S_maybe_multiconcat(pTHX_ OP *o)
U8 private_flags = 0; /* ... op_private of the multiconcat op */
bool is_sprintf = FALSE; /* we're optimising an sprintf */
bool is_targable = FALSE; /* targetop is an OPpTARGET_MY candidate */
bool prev_was_const = FALSE; /* previous arg was a const */

/* -----------------------------------------------------------------
* Phase 1:
Expand Down Expand Up @@ -2893,7 +2895,7 @@ S_maybe_multiconcat(pTHX_ OP *o)
last = TRUE;
}

if ( nargs > PERL_MULTICONCAT_MAXARG - 2
if ( nargs + nadjconst > PERL_MULTICONCAT_MAXARG - 2
|| (argp - args + 1) > (PERL_MULTICONCAT_MAXARG*2 + 1) - 2)
{
/* At least two spare slots are needed to decompose both
Expand Down Expand Up @@ -2924,10 +2926,16 @@ S_maybe_multiconcat(pTHX_ OP *o)
argp++->p = sv;
utf8 |= cBOOL(SvUTF8(sv));
nconst++;
if (prev_was_const)
/* this const may be demoted back to a plain arg later;
* make sure we have enough arg slots left */
nadjconst++;
prev_was_const = !prev_was_const;
}
else {
argp++->p = NULL;
nargs++;
prev_was_const = FALSE;
}

if (last)
Expand Down
32 changes: 31 additions & 1 deletion t/opbasic/concat.t
Expand Up @@ -39,7 +39,7 @@ sub is {
return $ok;
}

print "1..251\n";
print "1..252\n";

($a, $b, $c) = qw(foo bar);

Expand Down Expand Up @@ -810,3 +810,33 @@ ok(ref(CORE::state $y = "a $o b") eq 'o',
is($got, $expected, "long concat chain $i");
}
}

# RT #132646
# with adjacent consts, the second const is treated as an arg rather than a
# consts. Make sure this doesn't exceeed the maximum allowed number of
# args
{
my $x = 'X';
my $got =
'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
. 'A' . $x . 'B' . 'C' . $x . 'D'
;
is ($got,
"AXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXDAXBCXD",
"RT #132646");
}

0 comments on commit f08f2d0

Please sign in to comment.