Add OP_MULTICONCAT op

Allow multiple OP_CONCAT, OP_CONST ops, plus optionally an OP_SASSIGN
or OP_STRINGIFY, to be combined into a single OP_MULTICONCAT op, which can
make things a *lot* faster: 4x or more.

In more detail: it will optimise into a single OP_MULTICONCAT, most
expressions of the form

    LHS RHS

where LHS is one of

    (empty)
    my $lexical =
    $lexical    =
    $lexical   .=
    expression  =
    expression .=

and RHS is one of

    (A . B . C . ...)            where A,B,C etc are expressions and/or
                                 string constants

    "aAbBc..."                   where a,A,b,B etc are expressions and/or
                                 string constants

    sprintf "..%s..%s..", A,B,.. where the format is a constant string
                                 containing only '%s' and '%%' elements,
                                 and A,B, etc are scalar expressions (so
                                 only a fixed, compile-time-known number of
                                 args: no arrays or list context function
                                 calls etc)

It doesn't optimise other forms, such as

    ($a . $b) . ($c. $d)

    ((($a .= $b) .= $c) .= $d);

(although sub-parts of those expressions might be converted to an
OP_MULTICONCAT). This is partly because it would be hard to maintain the
correct ordering of tie or overload calls.

The compiler uses heuristics to determine when to convert: in general,
expressions involving a single OP_CONCAT aren't converted, unless some
other saving can be made, for example if an OP_CONST can be eliminated, or
in the presence of 'my $x = .. ' which OP_MULTICONCAT can apply
OPpTARGET_MY to, but OP_CONST can't.

The multiconcat op is of type UNOP_AUX, with the op_aux structure directly
holding a pointer to a single constant char* string plus a list of segment
lengths. So for

    "a=$a b=$b\n";

the constant string is "a= b=\n", and the segment lengths are (2,3,1).
If the constant string has different non-utf8 and utf8 representations
(such as "\x80") then both variants are pre-computed and stored in the aux
struct, along with two sets of segment lengths.

For all the above LHS types, any SASSIGN op is optimised away. For a LHS
of '$lex=', '$lex.=' or 'my $lex=', the PADSV is optimised away too.

For example where $a and $b are lexical vars, this statement:

    my $c = "a=$a, b=$b\n";

formerly compiled to

    const[PV "a="] s
    padsv[$a:1,3] s
    concat[t4] sK/2
    const[PV ", b="] s
    concat[t5] sKS/2
    padsv[$b:1,3] s
    concat[t6] sKS/2
    const[PV "\n"] s
    concat[t7] sKS/2
    padsv[$c:2,3] sRM*/LVINTRO
    sassign vKS/2

and now compiles to:

    padsv[$a:1,3] s
    padsv[$b:1,3] s
    multiconcat("a=, b=\n",2,4,1)[$c:2,3] vK/LVINTRO,TARGMY,STRINGIFY

In terms of how much faster it is, this code:

    my $a = "the quick brown fox jumps over the lazy dog";
    my $b = "to be, or not to be; sorry, what was the question again?";

    for my $i (1..10_000_000) {
        my $c = "a=$a, b=$b\n";
    }

runs 2.7 times faster, and if you throw utf8 mixtures in it gets even
better. This loop runs 4 times faster:

    my $s;
    my $a = "ab\x{100}cde";
    my $b = "fghij";
    my $c = "\x{101}klmn";

    for my $i (1..10_000_000) {
        $s = "\x{100}wxyz";
        $s .= "foo=$a bar=$b baz=$c";
    }

The main ways in which OP_MULTICONCAT gains its speed are:

* any OP_CONSTs are eliminated, and the constant bits (already in the
  right encoding) are copied directly from the constant string attached to
  the op's aux structure.

* It optimises away any SASSIGN op, and possibly a PADSV op on the LHS, in
  all cases; OP_CONCAT only did this in very limited circumstances.

* Because it has a holistic view of the entire concatenation expression,
  it can do the whole thing in one efficient go, rather than creating and
  copying intermediate results. pp_multiconcat() goes to considerable
  efforts to avoid inefficiencies. For example it will only SvGROW() the
  target once, and to the exact size needed, no matter what mix of utf8
  and non-utf8 appear on the LHS and RHS.  It never allocates any
  temporary SVs except possibly in the case of tie or overloading.

* It does all its own appending and utf8 handling rather than calling
  out to functions like sv_catsv().

* It's very good at handling the LHS appearing on the RHS; for example in

    $x = "abcd";
    $x = "-$x-$x-";

  It will do roughly the equivalent of the following (where targ is $x);

    SvPV_force(targ);
    SvGROW(targ, 11);
    p = SvPVX(targ);
    Move(p,   p+1,  4, char);
    Copy("-", p,    1, char);
    Copy("-", p+5,  1, char);
    Copy(p+1, p+6,  4, char);
    Copy("-", p+10, 1, char);
    SvCUR(targ) = 11;
    p[11] = '\0';

  Formerly, pp_concat would have used multiple PADTMPs or temporary SVs to
  handle situations like that.

The code is quite big; both S_maybe_multiconcat() and pp_multiconcat()
(the main compile-time and runtime parts of the implementation) are over
700 lines each. It turns out that when you combine multiple ops, the
number of edge cases grows exponentially ;-)

2 files changed, 148 insertions, 97 deletions

diff --git a/ext/B/B.xs b/ext/B/B.xs
index 74edd38720..02b78caa5d 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1183,6 +1183,10 @@ string(o, cv)
     PPCODE:
         aux = cUNOP_AUXo->op_aux;
         switch (o->op_type) {
+        case OP_MULTICONCAT:
+            ret = multiconcat_stringify(o);
+            break;
+
         case OP_MULTIDEREF:
             ret = multideref_stringify(o, cv);
             break;
@@ -1238,6 +1242,61 @@ aux_list(o, cv)
                                 (char)aux[2].iv) : &PL_sv_no));
             break;
 
+        case OP_MULTICONCAT:
+            {
+                UV nargs = aux[0].uv;
+                char *p;
+                STRLEN len;
+                U32 utf8 = 0;
+                SV *sv;
+                UNOP_AUX_item *lens;
+
+                /* 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);
+                nargs = aux[PERL_MULTICONCAT_IX_NARGS].uv;
+                EXTEND(SP, ((SSize_t)(2 + (nargs+1))));
+                PUSHs(sv_2mortal(newSViv(nargs)));
+
+                p   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
+                len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].size;
+                if (!p) {
+                    p   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
+                    len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].size;
+                    utf8 = SVf_UTF8;
+                }
+                sv = newSVpvn(p, len);
+                SvFLAGS(sv) |= utf8;
+                PUSHs(sv_2mortal(sv));
+
+                lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
+                nargs++; /* loop (nargs+1) times */
+                if (utf8) {
+                    U8 *p = (U8*)SvPVX(sv);
+                    while (nargs--) {
+                        SSize_t bytes = lens->size;
+                        SSize_t chars;
+                        if (bytes <= 0)
+                            chars = bytes;
+                        else {
+                            /* return char lengths rather than byte lengths */
+                            chars = utf8_length(p, p + bytes);
+                            p += bytes;
+                        }
+                        lens++;
+                        PUSHs(sv_2mortal(newSViv(chars)));
+                    }
+                }
+                else {
+                    while (nargs--) {
+                        PUSHs(sv_2mortal(newSViv(lens->size)));
+                        lens++;
+                    }
+                }
+                break;
+            }
+
         case OP_MULTIDEREF:
 #ifdef USE_ITHREADS
 #  define ITEM_SV(item) *av_fetch(comppad, (item)->pad_offset, FALSE);
diff --git a/ext/B/t/optree_samples.t b/ext/B/t/optree_samples.t
index 7374626663..7b63f6f141 100644
--- a/ext/B/t/optree_samples.t
+++ b/ext/B/t/optree_samples.t
@@ -240,38 +240,36 @@ checkOptree ( name	=> '-exec sub { foreach (1..10) {print "foo $_"} }',
 # 3  <$> const[IV 1] s
 # 4  <$> const[IV 10] s
 # 5  <#> gv[*_] s
-# 6  <{> enteriter(next->d last->g redo->7) KS/DEF
-# e  <0> iter s
-# f  <|> and(other->7) K/1
-# 7      <;> nextstate(main 442 optree.t:158) v:>,<,%
+# 6  <{> enteriter(next->c last->f redo->7) KS/DEF
+# d  <0> iter s
+# e  <|> and(other->7) K/1
+# 7      <;> nextstate(main 1659 optree_samples.t:234) v
 # 8      <0> pushmark s
-# 9      <$> const[PV "foo "] s
-# a      <#> gvsv[*_] s
-# b      <2> concat[t4] sK/2
-# c      <@> print vK
-# d      <0> unstack s
-#            goto e
-# g  <2> leaveloop K/2
-# h  <1> leavesub[1 ref] K/REFC,1
+# 9      <#> gvsv[*_] s
+# a      <+> multiconcat("foo ",4,-1)[t5] sK/STRINGIFY
+# b      <@> print vK
+# c      <0> unstack s
+#            goto d
+# f  <2> leaveloop K/2
+# g  <1> leavesub[1 ref] K/REFC,1
 EOT_EOT
 # 1  <;> nextstate(main 444 optree_samples.t:182) v:>,<,%
 # 2  <0> pushmark s
 # 3  <$> const(IV 1) s
 # 4  <$> const(IV 10) s
 # 5  <$> gv(*_) s
-# 6  <{> enteriter(next->d last->g redo->7) KS/DEF
-# e  <0> iter s
-# f  <|> and(other->7) K/1
+# 6  <{> enteriter(next->c last->f redo->7) KS/DEF
+# d  <0> iter s
+# e  <|> and(other->7) K/1
 # 7      <;> nextstate(main 443 optree_samples.t:182) v:>,<,%
 # 8      <0> pushmark s
-# 9      <$> const(PV "foo ") s
-# a      <$> gvsv(*_) s
-# b      <2> concat[t3] sK/2
-# c      <@> print vK
-# d      <0> unstack s
-#            goto e
-# g  <2> leaveloop K/2
-# h  <1> leavesub[1 ref] K/REFC,1
+# 9      <$> gvsv(*_) s
+# a      <+> multiconcat("foo ",4,-1)[t4] sK/STRINGIFY
+# b      <@> print vK
+# c      <0> unstack s
+#            goto d
+# f  <2> leaveloop K/2
+# g  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT
 
 checkOptree ( name	=> '-basic sub { print "foo $_" foreach (1..10) }',
@@ -279,55 +277,53 @@ checkOptree ( name	=> '-basic sub { print "foo $_" foreach (1..10) }',
 	      bcopts	=> '-basic',
 	      strip_open_hints => 1,
 	      expect	=> <<'EOT_EOT', expect_nt => <<'EONT_EONT');
-# g  <1> leavesub[1 ref] K/REFC,1 ->(end)
-# -     <@> lineseq KP ->g
+# f  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->f
 # 1        <;> nextstate(main 445 optree.t:167) v:>,<,% ->2
-# f        <2> leaveloop K/2 ->g
-# 6           <{> enteriter(next->c last->f redo->7) KS/DEF ->d
+# e        <2> leaveloop K/2 ->f
+# 6           <{> enteriter(next->b last->e redo->7) KS/DEF ->c
 # -              <0> ex-pushmark s ->2
 # -              <1> ex-list lK ->5
 # 2                 <0> pushmark s ->3
 # 3                 <$> const[IV 1] s ->4
 # 4                 <$> const[IV 10] s ->5
 # 5              <#> gv[*_] s ->6
-# -           <1> null K/1 ->f
-# e              <|> and(other->7) K/1 ->f
-# d                 <0> iter s ->e
+# -           <1> null K/1 ->e
+# d              <|> and(other->7) K/1 ->e
+# c                 <0> iter s ->d
 # -                 <@> lineseq sK ->-
-# b                    <@> print vK ->c
+# a                    <@> print vK ->b
 # 7                       <0> pushmark s ->8
-# -                       <1> ex-stringify sK/1 ->b
-# -                          <0> ex-pushmark s ->8
-# a                          <2> concat[t2] sK/2 ->b
-# 8                             <$> const[PV "foo "] s ->9
-# -                             <1> ex-rv2sv sK/1 ->a
-# 9                                <#> gvsv[*_] s ->a
-# c                    <0> unstack s ->d
+# 9                       <+> multiconcat("foo ",4,-1)[t3] sK/STRINGIFY ->a
+# -                          <0> ex-pushmark s ->-
+# -                          <0> ex-const s ->8
+# -                          <1> ex-rv2sv sK/1 ->9
+# 8                             <#> gvsv[*_] s ->9
+# b                    <0> unstack s ->c
 EOT_EOT
-# g  <1> leavesub[1 ref] K/REFC,1 ->(end)
-# -     <@> lineseq KP ->g
+# f  <1> leavesub[1 ref] K/REFC,1 ->(end)
+# -     <@> lineseq KP ->f
 # 1        <;> nextstate(main 446 optree_samples.t:192) v:>,<,% ->2
-# f        <2> leaveloop K/2 ->g
-# 6           <{> enteriter(next->c last->f redo->7) KS/DEF ->d
+# e        <2> leaveloop K/2 ->f
+# 6           <{> enteriter(next->b last->e redo->7) KS/DEF ->c
 # -              <0> ex-pushmark s ->2
 # -              <1> ex-list lK ->5
 # 2                 <0> pushmark s ->3
 # 3                 <$> const(IV 1) s ->4
 # 4                 <$> const(IV 10) s ->5
 # 5              <$> gv(*_) s ->6
-# -           <1> null K/1 ->f
-# e              <|> and(other->7) K/1 ->f
-# d                 <0> iter s ->e
+# -           <1> null K/1 ->e
+# d              <|> and(other->7) K/1 ->e
+# c                 <0> iter s ->d
 # -                 <@> lineseq sK ->-
-# b                    <@> print vK ->c
+# a                    <@> print vK ->b
 # 7                       <0> pushmark s ->8
-# -                       <1> ex-stringify sK/1 ->b
-# -                          <0> ex-pushmark s ->8
-# a                          <2> concat[t1] sK/2 ->b
-# 8                             <$> const(PV "foo ") s ->9
-# -                             <1> ex-rv2sv sK/1 ->a
-# 9                                <$> gvsv(*_) s ->a
-# c                    <0> unstack s ->d
+# 9                       <+> multiconcat("foo ",4,-1)[t2] sK/STRINGIFY ->a
+# -                          <0> ex-pushmark s ->-
+# -                          <0> ex-const s ->8
+# -                          <1> ex-rv2sv sK/1 ->9
+# 8                             <$> gvsv(*_) s ->9
+# b                    <0> unstack s ->c
 EONT_EONT
 
 checkOptree ( name	=> '-exec -e foreach (1..10) {print qq{foo $_}}',
@@ -341,19 +337,18 @@ checkOptree ( name	=> '-exec -e foreach (1..10) {print qq{foo $_}}',
 # 4  <$> const[IV 1] s
 # 5  <$> const[IV 10] s
 # 6  <#> gv[*_] s
-# 7  <{> enteriter(next->e last->h redo->8) vKS/DEF
-# f  <0> iter s
-# g  <|> and(other->8) vK/1
+# 7  <{> enteriter(next->d last->g redo->8) vKS/DEF
+# e  <0> iter s
+# f  <|> and(other->8) vK/1
 # 8      <;> nextstate(main 1 -e:1) v:>,<,%
 # 9      <0> pushmark s
-# a      <$> const[PV "foo "] s
-# b      <#> gvsv[*_] s
-# c      <2> concat[t4] sK/2
-# d      <@> print vK
-# e      <0> unstack v
-#            goto f
-# h  <2> leaveloop vK/2
-# i  <@> leave[1 ref] vKP/REFC
+# a      <#> gvsv[*_] s
+# b      <+> multiconcat("foo ",4,-1)[t5] sK/STRINGIFY
+# c      <@> print vK
+# d      <0> unstack v
+#            goto e
+# g  <2> leaveloop vK/2
+# h  <@> leave[1 ref] vKP/REFC
 EOT_EOT
 # 1  <0> enter 
 # 2  <;> nextstate(main 2 -e:1) v:>,<,%,{
@@ -361,19 +356,18 @@ EOT_EOT
 # 4  <$> const(IV 1) s
 # 5  <$> const(IV 10) s
 # 6  <$> gv(*_) s
-# 7  <{> enteriter(next->e last->h redo->8) vKS/DEF
-# f  <0> iter s
-# g  <|> and(other->8) vK/1
+# 7  <{> enteriter(next->d last->g redo->8) vKS/DEF
+# e  <0> iter s
+# f  <|> and(other->8) vK/1
 # 8      <;> nextstate(main 1 -e:1) v:>,<,%
 # 9      <0> pushmark s
-# a      <$> const(PV "foo ") s
-# b      <$> gvsv(*_) s
-# c      <2> concat[t3] sK/2
-# d      <@> print vK
-# e      <0> unstack v
-#            goto f
-# h  <2> leaveloop vK/2
-# i  <@> leave[1 ref] vKP/REFC
+# a      <$> gvsv(*_) s
+# b      <+> multiconcat("foo ",4,-1)[t4] sK/STRINGIFY
+# c      <@> print vK
+# d      <0> unstack v
+#            goto e
+# g  <2> leaveloop vK/2
+# h  <@> leave[1 ref] vKP/REFC
 EONT_EONT
 
 checkOptree ( name	=> '-exec sub { print "foo $_" foreach (1..10) }',
@@ -386,36 +380,34 @@ checkOptree ( name	=> '-exec sub { print "foo $_" foreach (1..10) }',
 # 3  <$> const[IV 1] s
 # 4  <$> const[IV 10] s
 # 5  <#> gv[*_] s
-# 6  <{> enteriter(next->c last->f redo->7) KS/DEF
-# d  <0> iter s
-# e  <|> and(other->7) K/1
+# 6  <{> enteriter(next->b last->e redo->7) KS/DEF
+# c  <0> iter s
+# d  <|> and(other->7) K/1
 # 7      <0> pushmark s
-# 8      <$> const[PV "foo "] s
-# 9      <#> gvsv[*_] s
-# a      <2> concat[t2] sK/2
-# b      <@> print vK
-# c      <0> unstack s
-#            goto d
-# f  <2> leaveloop K/2
-# g  <1> leavesub[1 ref] K/REFC,1
+# 8      <#> gvsv[*_] s
+# 9      <+> multiconcat("foo ",4,-1)[t3] sK/STRINGIFY
+# a      <@> print vK
+# b      <0> unstack s
+#            goto c
+# e  <2> leaveloop K/2
+# f  <1> leavesub[1 ref] K/REFC,1
 EOT_EOT
 # 1  <;> nextstate(main 447 optree_samples.t:252) v:>,<,%
 # 2  <0> pushmark s
 # 3  <$> const(IV 1) s
 # 4  <$> const(IV 10) s
 # 5  <$> gv(*_) s
-# 6  <{> enteriter(next->c last->f redo->7) KS/DEF
-# d  <0> iter s
-# e  <|> and(other->7) K/1
+# 6  <{> enteriter(next->b last->e redo->7) KS/DEF
+# c  <0> iter s
+# d  <|> and(other->7) K/1
 # 7      <0> pushmark s
-# 8      <$> const(PV "foo ") s
-# 9      <$> gvsv(*_) s
-# a      <2> concat[t1] sK/2
-# b      <@> print vK
-# c      <0> unstack s
-#            goto d
-# f  <2> leaveloop K/2
-# g  <1> leavesub[1 ref] K/REFC,1
+# 8      <$> gvsv(*_) s
+# 9      <+> multiconcat("foo ",4,-1)[t2] sK/STRINGIFY
+# a      <@> print vK
+# b      <0> unstack s
+#            goto c
+# e  <2> leaveloop K/2
+# f  <1> leavesub[1 ref] K/REFC,1
 EONT_EONT
 
 pass("GREP: SAMPLES FROM PERLDOC -F GREP");