tr///; simplify $utf8 =~ tr/nonutf8/nonutf8/

The run-time code to handle a non-utf8 tr/// against a utf8 string
is complex, with many variants of similar code repeated depending on the
presence of the /s and /c flags.

Simplify them all into a single code block by changing how the translation
table is stored. Formerly, the tr struct contained possibly two tables:
the basic 0-255 slot one, plus in the presence of /c, a second one
to map the implicit search range (\x{100}...) against any residual
replacement chars not consumed by the first table.

This commit merges the two tables into a single unified whole. For example

    tr/\x00-\xfe/abcd/c

is equivalent to

    tr/xff-\x{7fffffff}/abcd/

which generates a 259-entry translation table consisting of:

    0x00  => -1
    0x01  => -1
    ...
    0xfe  => -1
    0xff  =>  a
    0x100 =>  b
    0x101 =>  c
    0x102 =>  d

In addition we store:
    1) the size of the translation table (0x103 in the example above);
    2) an extra 'wildcard' entry stored 1 slot beyond the main table,
       which specifies the action for any codepoints outside the range of
       the table (i.e. chars 0x103..0x7fffffff). This can be either:
        a) a character, when the last replacement char is repeated;
        b) -1 when /c isn't in effect;
        c) -2 when /d is in effect;
        c) -3 identity: when the replacement list is empty but not /d.

       In the example above, this would be
            0x103 =>  d

The addition of -3 as a valid slot value is new.

This makes the main runtime code for the utf8 string with non-utf8 tr//
case look like, at its core:

    size = tbl->size;
    mapped_ch = tbl->map[ch >= size ? size : ch];

which then processes mapped_ch based on whether its >=0, or -1/-2/-3.

This is a lot simpler than the old scheme, and should generally be faster
too.

5 files changed, 77 insertions, 175 deletions

diff --git a/doop.c b/doop.c
index edc403838c..22431ef7f0 100644
--- a/doop.c
+++ b/doop.c
@@ -166,11 +166,11 @@ S_do_trans_complex(pTHX_ SV * const sv)
     U8 *s = (U8*)SvPV_nomg(sv, len);
     U8 * const send = s+len;
     I32 matches = 0;
-    const OPtrans_map_ex * const extbl = (OPtrans_map_ex*)cPVOP->op_pv;
+    const OPtrans_map * const tbl = (OPtrans_map*)cPVOP->op_pv;
 
     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
 
-    if (!extbl)
+    if (!tbl)
 	Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
 
     if (!SvUTF8(sv)) {
@@ -180,7 +180,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
 	if (PL_op->op_private & OPpTRANS_SQUASH) {
 	    const U8* p = send;
 	    while (s < send) {
-		const I32 ch = extbl->map[*s];
+		const I32 ch = tbl->map[*s];
 		if (ch >= 0) {
 		    *d = (U8)ch;
 		    matches++;
@@ -196,7 +196,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
 	}
 	else {
 	    while (s < send) {
-		const I32 ch = extbl->map[*s];
+		const I32 ch = tbl->map[*s];
 		if (ch >= 0) {
 		    matches++;
 		    *d++ = (U8)ch;
@@ -212,25 +212,19 @@ S_do_trans_complex(pTHX_ SV * const sv)
 	SvCUR_set(sv, d - dstart);
     }
     else { /* is utf8 */
-	const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
+	const bool squash =  cBOOL(PL_op->op_private & OPpTRANS_SQUASH);
 	const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
-	const I32 del = PL_op->op_private & OPpTRANS_DELETE;
 	U8 *d;
 	U8 *dstart;
-	SSize_t excess = 0;
+	Size_t size = tbl->size;
+        UV pch = 0xfeedface;
 
 	if (grows)
 	    Newx(d, len*2+1, U8);
 	else
 	    d = s;
 	dstart = d;
-	if (complement)
-            /* number of replacement chars in excess of any 0x00..0xff
-             * search characters */
-	    excess = extbl->excess_len;
 
-	if (PL_op->op_private & OPpTRANS_SQUASH) {
-	    UV pch = 0xfeedface;
 	    while (s < send) {
 		STRLEN len;
 		const UV comp = utf8n_to_uvchr(s, send - s, &len,
@@ -238,40 +232,13 @@ S_do_trans_complex(pTHX_ SV * const sv)
 		UV     ch;
                 short sch;
 
-		if (comp > 0xff) {
-		    if (!complement) {
-			Move(s, d, len, U8);
-			d += len;
-		    }
-		    else {
-                        /* use the implicit 0x100..0x7fffffff search range */
-                        UV comp100 = comp - 0x100;
-			matches++;
-                        ch = del
-                               /* setting ch to pch forces char to be deleted */
-                             ? ((excess > (IV)comp100)
-                                            ? (UV)extbl->map_ex[comp100]
-                                            : pch           )
-
-			     : (        (excess == -1) ? comp :
-                                 (UV)((  excess ==  0
-                                      || excess <= (IV)comp100)
-                                            ? extbl->repeat_char
-                                            : extbl->map_ex[comp100]
-                                     )
-                               );
-                        if (ch != pch) {
-                            d = uvchr_to_utf8(d, ch);
-                            pch = ch;
-                        }
-                        s += len;
-                        continue;
-		    }
-		}
-		else if ((sch = extbl->map[comp]) >= 0) {
+                sch = tbl->map[comp >= size ? size : comp];
+
+		if (sch >= 0) {
                     ch = (UV)sch;
+                  replace:
 		    matches++;
-		    if (ch != pch) {
+		    if (LIKELY(!squash || ch != pch)) {
 		        d = uvchr_to_utf8(d, ch);
 		        pch = ch;
 		    }
@@ -282,59 +249,18 @@ S_do_trans_complex(pTHX_ SV * const sv)
 		    Move(s, d, len, U8);
 		    d += len;
 		}
-		else if (sch == -2)      /* -2 is delete character */
+		else if (sch == -2)     /* -2 is delete character */
 		    matches++;
+                else {
+                    assert(sch == -3);  /* -3 is empty replacement */
+                    ch = comp;
+                    goto replace;
+                }
+
 		s += len;
 		pch = 0xfeedface;
 	    }
-	}
-	else {
-	    while (s < send) {
-		STRLEN len;
-		const UV comp = utf8n_to_uvchr(s, send - s, &len,
-					       UTF8_ALLOW_DEFAULT);
-		UV     ch;
-		short sch;
-		if (comp > 0xff) {
-		    if (!complement) {
-			Move(s, d, len, U8);
-			d += len;
-		    }
-		    else {
-                        /* use the implicit 0x100..0x7fffffff search range */
-                        UV comp100 = comp - 0x100;
-			matches++;
-                        if (del) {
-                             if (excess > (IV)comp100) {
-                                ch = (UV)extbl->map_ex[comp100];
-                                d = uvchr_to_utf8(d, ch);
-                            }
-                        }
-                        else {
-                            /* tr/...//c should call S_do_trans_count
-                             * instead */
-                            assert(excess != -1);
-			    ch = (   excess ==  0
-                                      || excess <= (IV)comp100)
-                                            ? (UV)extbl->repeat_char
-                                            : (UV)extbl->map_ex[comp100];
-                            d = uvchr_to_utf8(d, ch);
-                        }
-		    }
-		}
-		else if ((sch = extbl->map[comp]) >= 0) {
-		    d = uvchr_to_utf8(d, (UV)sch);
-		    matches++;
-		}
-		else if (sch == -1) {	/* -1 is unmapped character */
-		    Move(s, d, len, U8);
-		    d += len;
-		}
-		else if (sch == -2)      /* -2 is delete character */
-		    matches++;
-		s += len;
-	    }
-	}
+
 	if (grows) {
 	    sv_setpvn(sv, (char*)dstart, d - dstart);
 	    Safefree(dstart);
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 426cbf3319..d9d77157c6 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -1022,22 +1022,17 @@ next(o)
 		ret = make_sv_object(aTHX_ NULL);
 		break;
 	    case 41: /* B::PVOP::pv */
-		/* OP_TRANS uses op_pv to point to a OPtrans_map or
-                 * OPtrans_map_ex struct, whereas other PVOPs point to a
-                 * null terminated string. For trans, for now just return the
-                 * whole struct as a string and let the caller unpack() it */
+                /* OP_TRANS uses op_pv to point to a OPtrans_map struct,
+                 * whereas other PVOPs point to a null terminated string.
+                 * For trans, for now just return the whole struct as a
+                 * string and let the caller unpack() it */
 		if (   cPVOPo->op_type == OP_TRANS
                     || cPVOPo->op_type == OP_TRANSR)
                 {
-                    const OPtrans_map_ex * const extbl =
-                                                (OPtrans_map_ex*)cPVOPo->op_pv;
-                    char *end = (char*)(&(extbl->map[256]));
-                    if (cPVOPo->op_private & OPpTRANS_COMPLEMENT) {
-                        SSize_t excess_len = extbl->excess_len;
-                        end = (char*)(&(extbl->map_ex[excess_len]));
-                    }
+                    const OPtrans_map *const tbl = (OPtrans_map*)cPVOPo->op_pv;
 		    ret = newSVpvn_flags(cPVOPo->op_pv,
-                                            end - (char*)extbl,
+                                              (char*)(&tbl->map[tbl->size + 1])
+                                            - (char*)tbl,
                                             SVs_TEMP);
 		}
 		else
diff --git a/lib/B/Deparse.pm b/lib/B/Deparse.pm
index 0b4fafc012..ab691c2491 100644
--- a/lib/B/Deparse.pm
+++ b/lib/B/Deparse.pm
@@ -5610,8 +5610,9 @@ sub collapse {
 sub tr_decode_byte {
     my($table, $flags) = @_;
     my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l';
-    my (@table) = unpack("s256${ssize_t}ss*", $table);
-    my ($excess_len, $repeat_char) = splice(@table, 256, 2);
+    my ($size, @table) = unpack("${ssize_t}s*", $table);
+    printf "XXX len=%d size=%d scalar\@table=%d\n", length($table), $size, scalar@table;
+    pop @table; # remove the wildcard final entry
 
     my($c, $tr, @from, @to, @delfrom, $delhyphen);
     if ($table[ord "-"] != -1 and
diff --git a/op.c b/op.c
index 2fc4d94d41..4ea83d172c 100644
--- a/op.c
+++ b/op.c
@@ -6344,8 +6344,9 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     I32 j;
     I32 grows = 0;
     OPtrans_map *tbl;
+    SSize_t struct_size; /* malloced size of table struct */
 
-    const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
+    const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
     const I32 squash     = o->op_private & OPpTRANS_SQUASH;
     I32 del              = o->op_private & OPpTRANS_DELETE;
     SV* swash;
@@ -6611,35 +6612,43 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	goto warnins;
     }
 
-    /* Non-utf8 case: set o->op_pv to point to a simple 256-entry lookup
+    /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
      * table. Entries with the value -1 indicate chars not to be
      * translated, while -2 indicates a search char without a
      * corresponding replacement char under /d.
      *
-     * With /c, an extra length arg is stored at the end of the table to
-     * indicate the number of chars in the replacement string, plus any
-     * excess replacement chars not paired with search chars. The extra
-     * chars are needed for utf8 strings. For example,
-     * tr/\x00-\xfd/abcd/c is logically equivalent to
-     * tr/\xfe\xff\x{100}\x{101}.../abcdddd.../, so the c,d chars need to
-     * be kept even though they aren't paired with any chars in the table
-     * (which represents chars \x00-\xff). Even without excess chars, the
-     * last replacement char needs to be kept.
+     * Normally, the table has 256 slots. However, in the presence of
+     * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
+     * added, and if there are enough replacement chars to start pairing
+     * with the \x{100},... search chars, then a larger (> 256) table
+     * is allocated.
+     *
+     * In addition, regardless of whether under /c, an extra slot at the
+     * end is used to store the final repeating char, or -3 under an empty
+     * replacement list, or -2 under /d; which makes the runtime code
+     * easier.
      *
      * The toker will have already expanded char ranges in t and r.
      */
 
-    tbl = (OPtrans_map*)PerlMemShared_calloc(
-                    complement  ? sizeof(OPtrans_map_ex) : sizeof(OPtrans_map),
-                    sizeof(char));
+    /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
+     * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
+     * The OPtrans_map struct already contains one slot; hence the -1.
+     */
+    struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
+    tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
+    tbl->size = 256;
     cPVOPo->op_pv = (char*)tbl;
 
     if (complement) {
+        SSize_t excess;
+
         /* in this branch, j is a count of 'consumed' (i.e. paired off
          * with a search char) replacement chars (so j <= rlen always)
          */
 	for (i = 0; i < (I32)tlen; i++)
 	    tbl->map[t[i]] = -1;
+
 	for (i = 0, j = 0; i < 256; i++) {
 	    if (!tbl->map[i]) {
 		if (j == (I32)rlen) {
@@ -6659,52 +6668,29 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	}
 
         assert(j <= (I32)rlen);
+        excess = rlen - (SSize_t)j;
 
-        /* populate extended portion of table */
-
-	{
-                    /* the repeat char: it may be used to fill the 0x100+
-                     * range. For example,
-                     *     tr/\x00-AE-\xff/bcd/c
-                     * is equivalent to
-                     *     tr/BCD\x{100}-\x{7fffffff}/bcd/
-                     * which is equivalent to
-                     *     tr/BCD\x{100}-\x{7fffffff}/bcddddddddd..../
-                     * So remember the 'd'.
-                     */
-            short   repeat_char;
-            SSize_t excess = rlen - (SSize_t)j;
-            OPtrans_map_ex *extbl = (OPtrans_map_ex*)tbl;
+        if (excess) {
+            /* More replacement chars than search chars:
+             * store excess replacement chars at end of main table.
+             */
 
-	    if (excess) {
-                /* More replacement chars than search chars:
-                 * store excess replacement chars at end of main table.
-                 */
+            struct_size += excess;
+            tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
+                        struct_size + excess * sizeof(short));
+            tbl->size += excess;
+            cPVOPo->op_pv = (char*)tbl;
 
-		extbl = (OPtrans_map_ex *) PerlMemShared_realloc(extbl,
-                            sizeof(OPtrans_map_ex) + excess * sizeof(short));
-		cPVOPo->op_pv = (char*)extbl;
-                for (i = 0; i < (I32)excess; i++)
-                    extbl->map_ex[i] = r[j+i];
-                repeat_char = r[rlen-1];
-	    }
-	    else {
-                /* no more replacement chars than search chars */
+            for (i = 0; i < (I32)excess; i++)
+                tbl->map[i + 256] = r[j+i];
+        }
+        else {
+            /* no more replacement chars than search chars */
+            if (!rlen && !del && !squash)
+                o->op_private |= OPpTRANS_IDENTICAL;
+        }
 
-                if (rlen)
-                    repeat_char = r[rlen - 1];
-                else {
-                    /* empty replacement list */
-                    repeat_char = 0; /* this value isn't used at runtime */
-                    /* -1 excess count indicates empty replacement charlist */
-                    excess = -1;
-                    if (!(squash | del))
-                        o->op_private |= OPpTRANS_IDENTICAL;
-                }
-	    }
-            extbl->excess_len  = excess;      /* excess char count */
-            extbl->repeat_char = (short)repeat_char; /* repeated replace char */
-	}
+        tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
     }
     else {
 	if (!rlen && !del) {
@@ -6715,6 +6701,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
 	    o->op_private |= OPpTRANS_IDENTICAL;
 	}
+
 	for (i = 0; i < 256; i++)
 	    tbl->map[i] = -1;
 	for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
@@ -6733,6 +6720,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 		tbl->map[t[i]] = r[j];
 	    }
 	}
+        tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
     }
 
     /* both non-utf8 and utf8 code paths end up here */
diff --git a/op.h b/op.h
index 5ba716751c..ed4ff9d1a7 100644
--- a/op.h
+++ b/op.h
@@ -628,21 +628,13 @@ typedef enum {
 #endif
 
 
-/* basic and extended translation tables attached to OP_TRANS/OP_TRANSR ops */
+/* translation table attached to OP_TRANS/OP_TRANSR ops */
 
 typedef struct {
-    short map[256];
+    Size_t size; /* number of entries in map[], not including final slot */
+    short map[1]; /* Unwarranted chumminess */
 } OPtrans_map;
 
-/* used in the presence of tr///c to record any replacement chars that
- * are paired with the implicit 0x100..0x7fffffff search chars */
-typedef struct {
-    short map[256];
-    SSize_t excess_len; /* number of entries in map_ex[] */
-    short repeat_char;
-    short map_ex[1];  /* Unwarranted chumminess */
-} OPtrans_map_ex;
-
 
 /*
 =head1 Optree Manipulation Functions