Utf8.c: Generate and use inversion lists for binary swashes

Prior to this patch, every time a code point was matched against a swash,
and the result was not previously known, a linear search through the
swash was performed.  This patch changes that to generate an inversion
list whenever a swash for a binary property is created.  A binary search
is then performed for missing values.

This change does not have much effect on the speed of Perl's regression
test suite, but the speed-up in worst-case scenarios is huge.  The
program at the end of this commit is crafted to avoid the caching that
hides much of the current inefficiencies.  At character classes of 100
isolated code points, the new method is about an order of magnitude
faster; two orders of magnitude at 1000 code points.  The program at the
end of this commit message took 97s to execute on my box using blead,
and 1.5 seconds using this new scheme.  I was surprised to see that even
with classes containing fewer than 10 code points, the binary search
trumped, by a little, the linear search

Even after this patch, under the current scheme, one can easily run out
of memory due to the permanent storing of results of swash lookups in
hashes.  The new search mechanism might be fast enough to enable the
elimination of that memory usage.  Instead, a simple cache in each
inversion list that stored its previous result could be created, and
that checked to see if it's still valid before starting the search,
under the assumption, which the current scheme also makes, that probes
will tend to be clustered together, as nearby code points are often in
the same script.
===============================================
 # This program creates longer and longer character class lists while
 # testing code points matches against them.  By adding or subtracting
 # 65 from the previous member, caching of results is eliminated (as of
 # this writing), so this essentially tests for how long it takes to
 # search through swashes to see if a code point matches or not.

use Benchmark ':hireswallclock';

my $string = "";
my $class_cp = 2**30;   # Divide the code space in half, approx.
my $string_cp = $class_cp;
my $iterations = 10000;
for my $j (1..2048) {

    # Append the next character to the [class]
    my $hex_class_cp = sprintf("%X", $class_cp);
    $string .= "\\x{$hex_class_cp}";
    $class_cp -= 65;

    next if $j % 100 != 0;  # Only test certain ones

    print "$j: lowest is [$hex_class_cp]: ";

    timethis(1, "no warnings qw(portable non_unicode);my \$i = $string_cp; for (0 .. $iterations) { chr(\$i) =~ /[$string]/; \$i+= 65 }");
    $string_cp += ($iterations + 1) * 65;
}

diff --git a/utf8.c b/utf8.c
index 556fee3..e4b927d 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2556,6 +2556,25 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m
                       SVfARG(retval));
        Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
     }
+
+    /* Make sure there is an inversion list for binary properties */
+    if (minbits == 1) {
+       SV** swash_invlistsvp = NULL;
+       SV* swash_invlist = NULL;
+        HV* swash_hv;
+
+           swash_hv = MUTABLE_HV(SvRV(retval));
+
+           swash_invlistsvp = hv_fetchs(swash_hv, "INVLIST", FALSE);
+           if (! swash_invlistsvp || ! *swash_invlistsvp) {
+               swash_invlist = _swash_to_invlist(retval);
+               if (! hv_stores(MUTABLE_HV(SvRV(retval)), "INVLIST", swash_invlist))
+               {
+                   Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
+               }
+           }
+    }
+
     return retval;
 }
 
@@ -2855,6 +2874,8 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
     U8 *l, *lend, *x, *xend, *s, *send;
     STRLEN lcur, xcur, scur;
     HV *const hv = MUTABLE_HV(SvRV(swash));
+    SV** const invlistsvp = hv_fetchs(hv, "INVLIST", FALSE);
+
     SV** listsvp; /* The string containing the main body of the table */
     SV** extssvp;
     SV** invert_it_svp;
@@ -2864,7 +2885,7 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
     UV  none;
     UV  end = start + span;
 
-    {
+    if (invlistsvp == NULL) {
         SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
         SV** const nonesvp = hv_fetchs(hv, "NONE", FALSE);
         SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
@@ -2876,6 +2897,10 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
        none  = SvUV(*nonesvp);
        typestr = (U8*)SvPV_nolen(*typesvp);
     }
+    else {
+       bits = 1;
+       none = 0;
+    }
     octets = bits >> 3; /* if bits == 1, then octets == 0 */
 
     PERL_ARGS_ASSERT_SWATCH_GET;
@@ -2920,8 +2945,12 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
     SvCUR_set(swatch, scur);
     s = (U8*)SvPVX(swatch);
 
-    /* read $swash->{LIST}.  XXX Note that this is a linear scan through a
-     * sorted list.  A binary search would be much more efficient */
+    if (invlistsvp) {  /* If has an inversion list set up use that */
+       _invlist_populate_swatch(*invlistsvp, start, end, s);
+        return swatch;
+    }
+
+    /* read $swash->{LIST} */
     l = (U8*)SvPV(*listsvp, lcur);
     lend = l + lcur;
     while (l < lend) {