[MERGE] add OP_MULTICONCAT and optimize_optree()

This branch contains one main commit which adds the new OP_MULTICONCAT op,
plus a few prior commits to provide support; in particular, adding an extra
top-down optree scan phase to allow extra optimisation opportunities, just
before the peephole optimiser is run.

See the OP_MULTICONCAT for more details, but in summary it:
allows 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.

Author: iabyn

dist/Safe/t/safeops.t

@@ -234,6 +234,7 @@ exists		exists $h{Key}
 rv2hv		%h
 helem		$h{kEy}
 hslice		@h{kEy}
+multiconcat	SKIP (set by optimizer)
 multideref	SKIP (set by optimizer)
 unpack		unpack
 pack		pack

dump.c

@@ -1141,6 +1141,15 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
 	break;
     }
 
+    case OP_MULTICONCAT:
+	S_opdump_indent(aTHX_ o, level, bar, file, "NARGS = %" UVuf "\n",
+            cUNOP_AUXo->op_aux[PERL_MULTICONCAT_IX_NARGS].uv);
+        /* XXX really ought to dump each field individually,
+         * but that's too much like hard work */
+	S_opdump_indent(aTHX_ o, level, bar, file, "CONSTS = (%" SVf ")\n",
+            SVfARG(multiconcat_stringify(o)));
+	break;
+
     case OP_CONST:
     case OP_HINTSEVAL:
     case OP_METHOD_NAMED:
@@ -2728,6 +2737,48 @@ Perl_multideref_stringify(pTHX_ const OP *o, CV *cv)
 }
 
 
+/* Return a temporary SV containing a stringified representation of
+ * the op_aux field of a MULTICONCAT op. Note that if the aux contains
+ * both plain and utf8 versions of the const string and indices, only
+ * the first is displayed.
+ */
+
+SV*
+Perl_multiconcat_stringify(pTHX_ const OP *o)
+{
+    UNOP_AUX_item *aux = cUNOP_AUXo->op_aux;
+    UNOP_AUX_item *lens;
+    STRLEN len;
+    UV nargs;
+    char *s;
+    SV *out = newSVpvn_flags("", 0, SVs_TEMP);
+
+    PERL_ARGS_ASSERT_MULTICONCAT_STRINGIFY;
+
+    nargs = aux[PERL_MULTICONCAT_IX_NARGS].uv;
+    s   = aux[PERL_MULTICONCAT_IX_PLAIN_PV].pv;
+    len = aux[PERL_MULTICONCAT_IX_PLAIN_LEN].size;
+    if (!s) {
+        s   = aux[PERL_MULTICONCAT_IX_UTF8_PV].pv;
+        len = aux[PERL_MULTICONCAT_IX_UTF8_LEN].size;
+        sv_catpvs(out, "UTF8 ");
+    }
+    pv_pretty(out, s, len, 50,
+                NULL, NULL,
+                (PERL_PV_PRETTY_NOCLEAR
+                |PERL_PV_PRETTY_QUOTE
+                |PERL_PV_PRETTY_ELLIPSES));
+
+    lens = aux + PERL_MULTICONCAT_IX_LENGTHS;
+    nargs++;
+    while (nargs-- > 0) {
+        Perl_sv_catpvf(aTHX_ out, ",%" IVdf, (IV)lens->size);
+        lens++;
+    }
+    return out;
+}
+
+
 I32
 Perl_debop(pTHX_ const OP *o)
 {
@@ -2772,6 +2823,11 @@ Perl_debop(pTHX_ const OP *o)
             SVfARG(multideref_stringify(o, deb_curcv(cxstack_ix))));
         break;
 
+    case OP_MULTICONCAT:
+        PerlIO_printf(Perl_debug_log, "(%" SVf ")",
+            SVfARG(multiconcat_stringify(o)));
+        break;
+
     default:
 	break;
     }

embed.fnc

@@ -395,6 +395,7 @@ Afp	|void	|deb		|NN const char* pat|...
 Ap	|void	|vdeb		|NN const char* pat|NULLOK va_list* args
 Ap	|void	|debprofdump
 EXp	|SV*	|multideref_stringify	|NN const OP* o|NULLOK CV *cv
+EXp	|SV*	|multiconcat_stringify	|NN const OP* o
 Ap	|I32	|debop		|NN const OP* o
 Ap	|I32	|debstack
 Ap	|I32	|debstackptrs
@@ -1046,7 +1047,9 @@ Apn	|void	|mini_mktime	|NN struct tm *ptm
 AMmd	|OP*	|op_lvalue	|NULLOK OP* o|I32 type
 poX	|OP*	|op_lvalue_flags|NULLOK OP* o|I32 type|U32 flags
 p	|void	|finalize_optree		|NN OP* o
+p	|void	|optimize_optree|NN OP* o
 #if defined(PERL_IN_OP_C)
+s	|void	|optimize_op	|NN OP* o
 s	|void	|finalize_op	|NN OP* o
 s	|void	|move_proto_attr|NN OP **proto|NN OP **attrs \
 				|NN const GV *name|bool curstash

embed.h

@@ -923,6 +923,7 @@
 #define cv_ckproto_len_flags(a,b,c,d,e)	Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
 #define grok_atoUV		Perl_grok_atoUV
 #define mg_find_mglob(a)	Perl_mg_find_mglob(aTHX_ a)
+#define multiconcat_stringify(a)	Perl_multiconcat_stringify(aTHX_ a)
 #define multideref_stringify(a,b)	Perl_multideref_stringify(aTHX_ a,b)
 #define op_clear(a)		Perl_op_clear(aTHX_ a)
 #define qerror(a)		Perl_qerror(aTHX_ a)
@@ -1337,6 +1338,7 @@
 #define oopsAV(a)		Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)		Perl_oopsHV(aTHX_ a)
 #define op_unscope(a)		Perl_op_unscope(aTHX_ a)
+#define optimize_optree(a)	Perl_optimize_optree(aTHX_ a)
 #define package(a)		Perl_package(aTHX_ a)
 #define package_version(a)	Perl_package_version(aTHX_ a)
 #define pad_add_weakref(a)	Perl_pad_add_weakref(aTHX_ a)
@@ -1647,6 +1649,7 @@
 #define no_fh_allowed(a)	S_no_fh_allowed(aTHX_ a)
 #define op_integerize(a)	S_op_integerize(aTHX_ a)
 #define op_std_init(a)		S_op_std_init(aTHX_ a)
+#define optimize_op(a)		S_optimize_op(aTHX_ a)
 #define pmtrans(a,b,c)		S_pmtrans(aTHX_ a,b,c)
 #define process_special_blocks(a,b,c,d)	S_process_special_blocks(aTHX_ a,b,c,d)
 #define ref_array_or_hash(a)	S_ref_array_or_hash(aTHX_ a)

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);