Move UTF-8 case changing data into core
authorKarl Williamson <khw@cpan.org>
Fri, 23 Mar 2018 19:43:56 +0000 (13:43 -0600)
committerKarl Williamson <khw@cpan.org>
Mon, 26 Mar 2018 22:26:54 +0000 (16:26 -0600)
Prior to this commit, if a program wanted to compute the case-change of
a character above 0xFF, the C code would switch to perl, loading
lib/utf8heavy.pl and then read another file from disk, and then create a
hash.  Future references would use the hash, but the start up cost is
quite large.  There are five case change types, uc, lc, tc, fc, and
simple fc.  Only the first encountered requires loading of utf8_heavy,
but each required switching to utf8_heavy, and reading the appropriate
file from disk.

This commit changes these functions to use compiled-in C data structures
(inversion maps) to represent the data.  To look something up requires a
binary search instead of a hash lookup.

An individual hash lookup tends to be faster than a binary search,  but
the differences are small for small sizes.  I did some benchmarking some
years ago, (commit message 87367d5f9dc9bbf7db1a6cf87820cea76571bf1a) and
the results were that for fewer than 512 entries, the binary search was
just as fast as a hash, if not actually faster.  Now, I've done some
more benchmarks on blead, using the tool benchmark.pl, which wasn't
available back then.  The results below indicate that the differences
are minimal up through 2047 entries, which all Unicode properties are
well within.

A hash, PL_foldclosures, is still constructed at runtime for the case of
regular expression /i matching, and this could be generated at Perl
compile time, as a further enhancement for later.  But reading a file
from disk is no longer required to do this.

======================= benchmarking results =======================

Key:
    Ir   Instruction read
    Dr   Data read
    Dw   Data write
    COND conditional branches
    IND  indirect branches
    _m   branch predict miss
    _m1  level 1 cache miss
    _mm  last cache (e.g. L3) miss
    -    indeterminate percentage (e.g. 1/0)

The numbers represent raw counts per loop iteration.

"\x{10000}" =~ qr/\p{CWKCF}/"

        swash invlist Ratio %
        fetch search
       ------ ------- -------
    Ir 2259.0  2264.0    99.8
    Dr  665.0   664.0   100.2
    Dw  406.0   404.0   100.5
  COND  406.0   405.0   100.2
   IND   17.0    15.0   113.3

COND_m    8.0     8.0   100.0
 IND_m    4.0     4.0   100.0

 Ir_m1    8.9    17.0    52.4
 Dr_m1    4.5     3.4   132.4
 Dw_m1    1.9     1.2   158.3

 Ir_mm    0.0     0.0   100.0
 Dr_mm    0.0     0.0   100.0
 Dw_mm    0.0     0.0   100.0

These were constructed by using the file whose contents are below, which
uses the property in Unicode that currently has the largest number of
entries in its inversion list, > 1600.  The test was run on blead -O2,
no debugging, no threads.  Then the cut-off boundary was changed from
512 to 2047 for when we use a hash vs an inversion list, and the test
run again.  This yields the difference between a hash fetch and an
inversion list binary search
===================== The benchmark file is below ===============

no warnings 'once';

my @benchmarks;

    push @benchmarks, 'swash' => {
        desc    => '"\x{10000}" =~ qr/\p{CWKCF}/"',
        setup   => 'no warnings "once"; my $re = qr/\p{CWKCF}/; my $a =
"\x{10000}";',
        code     => '$a =~ $re;',
    };

\@benchmarks;

embed.fnc
embed.h
embedvar.h
intrpvar.h
perl.c
proto.h
regcomp.c
sv.c
utf8.c

index 5adc705..43fc31a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1745,7 +1745,7 @@ EiMRn     |UV     |_invlist_len   |NN SV* const invlist
 EMiRn  |bool   |_invlist_contains_cp|NN SV* const invlist|const UV cp
 EXpMRn |SSize_t|_invlist_search        |NN SV* const invlist|const UV cp
 EXMpR  |SV*    |_get_swash_invlist|NN SV* const swash
-EXMpR  |HV*    |_swash_inversion_hash  |NN SV* const swash
+EXMpR  |HV*    |_swash_inversion_hash
 #endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C)
 EXpM   |SV*    |_get_regclass_nonbitmap_data                              \
@@ -1797,9 +1797,11 @@ s        |UV     |_to_utf8_case  |const UV uv1                                   \
                                |NN const U8 *p                                 \
                                |NN U8* ustrp                                   \
                                |NULLOK STRLEN *lenp                            \
-                               |NN SV **swashp                                 \
-                               |NN const char *normal                          \
-                               |NULLOK const char *special
+                               |NN SV *invlist                                 \
+                               |NN const IV * const invmap                     \
+                               |NULLOK const int * const * const aux_tables    \
+                               |NULLOK const U8 * const aux_table_lengths      \
+                               |NN const char * const normal
 #endif
 ApbmdD |UV     |to_utf8_lower  |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp
 AMp    |UV     |_to_utf8_lower_flags|NN const U8 *p|NULLOK const U8* e         \
diff --git a/embed.h b/embed.h
index b95410c..f77aa4e 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define _invlist_contains_cp   S__invlist_contains_cp
 #define _invlist_len           S__invlist_len
 #define _invlist_search                Perl__invlist_search
-#define _swash_inversion_hash(a)       Perl__swash_inversion_hash(aTHX_ a)
+#define _swash_inversion_hash()        Perl__swash_inversion_hash(aTHX)
 #define get_invlist_offset_addr        S_get_invlist_offset_addr
 #define invlist_array          S_invlist_array
 #  endif
 #define isa_lookup(a,b,c,d)    S_isa_lookup(aTHX_ a,b,c,d)
 #  endif
 #  if defined(PERL_IN_UTF8_C)
-#define _to_utf8_case(a,b,c,d,e,f,g)   S__to_utf8_case(aTHX_ a,b,c,d,e,f,g)
+#define _to_utf8_case(a,b,c,d,e,f,g,h,i)       S__to_utf8_case(aTHX_ a,b,c,d,e,f,g,h,i)
 #define check_and_deprecate(a,b,c,d,e,f)       S_check_and_deprecate(aTHX_ a,b,c,d,e,f)
 #define check_locale_boundary_crossing(a,b,c,d)        S_check_locale_boundary_crossing(aTHX_ a,b,c,d)
 #define does_utf8_overflow     S_does_utf8_overflow
index a3f7fb3..4e39a94 100644 (file)
 #define PL_utf8_swash_ptrs     (vTHX->Iutf8_swash_ptrs)
 #define PL_utf8_tofold         (vTHX->Iutf8_tofold)
 #define PL_utf8_tolower                (vTHX->Iutf8_tolower)
+#define PL_utf8_tosimplefold   (vTHX->Iutf8_tosimplefold)
 #define PL_utf8_totitle                (vTHX->Iutf8_totitle)
 #define PL_utf8_toupper                (vTHX->Iutf8_toupper)
 #define PL_utf8cache           (vTHX->Iutf8cache)
index 6b56971..cad55e3 100644 (file)
@@ -649,6 +649,7 @@ PERLVAR(I, utf8_toupper, SV *)
 PERLVAR(I, utf8_totitle, SV *)
 PERLVAR(I, utf8_tolower, SV *)
 PERLVAR(I, utf8_tofold,        SV *)
+PERLVAR(I, utf8_tosimplefold,  SV *)
 PERLVAR(I, utf8_charname_begin, SV *)
 PERLVAR(I, utf8_charname_continue, SV *)
 
diff --git a/perl.c b/perl.c
index 1bc8bbf..1c29285 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -319,6 +319,12 @@ perl_construct(pTHXx)
     PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist);
     PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist);
     PL_SCX_invlist = _new_invlist_C_array(_Perl_SCX_invlist);
+    PL_utf8_toupper = _new_invlist_C_array(Uppercase_Mapping_invlist);
+    PL_utf8_tolower = _new_invlist_C_array(Lowercase_Mapping_invlist);
+    PL_utf8_totitle = _new_invlist_C_array(Titlecase_Mapping_invlist);
+    PL_utf8_tofold = _new_invlist_C_array(Case_Folding_invlist);
+    PL_utf8_tosimplefold = _new_invlist_C_array(Simple_Case_Folding_invlist);
+
 
 
 #if defined(LOCAL_PATCH_COUNT)
@@ -1197,6 +1203,7 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_utf8_totitle);
     SvREFCNT_dec(PL_utf8_tolower);
     SvREFCNT_dec(PL_utf8_tofold);
+    SvREFCNT_dec(PL_utf8_tosimplefold);
     SvREFCNT_dec(PL_utf8_foldclosures);
     SvREFCNT_dec(PL_InBitmap);
 #ifdef USE_LOCALE_CTYPE
@@ -1207,6 +1214,7 @@ perl_destruct(pTHXx)
     PL_utf8_totitle    = NULL;
     PL_utf8_tolower    = NULL;
     PL_utf8_tofold     = NULL;
+    PL_utf8_tosimplefold = NULL;
     PL_utf8_foldclosures = NULL;
     PL_InBitmap          = NULL;
 #ifdef USE_LOCALE_CTYPE
diff --git a/proto.h b/proto.h
index e711e10..1e89967 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5469,10 +5469,8 @@ PERL_CALLCONV SSize_t    Perl__invlist_search(SV* const invlist, const UV cp)
 #define PERL_ARGS_ASSERT__INVLIST_SEARCH       \
        assert(invlist)
 
-PERL_CALLCONV HV*      Perl__swash_inversion_hash(pTHX_ SV* const swash)
+PERL_CALLCONV HV*      Perl__swash_inversion_hash(pTHX)
                        __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT__SWASH_INVERSION_HASH \
-       assert(swash)
 
 #ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE bool*       S_get_invlist_offset_addr(SV* invlist)
@@ -5969,9 +5967,9 @@ STATIC bool       S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U
        assert(stash); assert(name)
 #endif
 #if defined(PERL_IN_UTF8_C)
-STATIC UV      S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, const char *normal, const char *special);
+STATIC UV      S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, SV *invlist, const IV * const invmap, const int * const * const aux_tables, const U8 * const aux_table_lengths, const char * const normal);
 #define PERL_ARGS_ASSERT__TO_UTF8_CASE \
-       assert(p); assert(ustrp); assert(swashp); assert(normal)
+       assert(p); assert(ustrp); assert(invlist); assert(invmap); assert(normal)
 STATIC U32     S_check_and_deprecate(pTHX_ const U8 * p, const U8 ** e, const unsigned type, const bool use_locale, const char * const file, const unsigned line);
 #define PERL_ARGS_ASSERT_CHECK_AND_DEPRECATE   \
        assert(p); assert(e); assert(file)
index 4594bca..e494214 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -10185,19 +10185,7 @@ Perl__invlist_dump(pTHX_ PerlIO *file, I32 level,
 void
 Perl__load_PL_utf8_foldclosures (pTHX)
 {
-    assert(! PL_utf8_foldclosures);
-
-    /* If the folds haven't been read in, call a fold function
-     * to force that */
-    if (! PL_utf8_tofold) {
-        U8 dummy[UTF8_MAXBYTES_CASE+1];
-        const U8 hyphen[] = HYPHEN_UTF8;
-
-        /* This string is just a short named one above \xff */
-        toFOLD_utf8_safe(hyphen, hyphen + sizeof(hyphen) - 1, dummy, NULL);
-        assert(PL_utf8_tofold); /* Verify that worked */
-    }
-    PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
+    PL_utf8_foldclosures = _swash_inversion_hash();
 }
 #endif
 
diff --git a/sv.c b/sv.c
index 1090384..4f03736 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -15596,6 +15596,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_utf8_totitle    = sv_dup_inc(proto_perl->Iutf8_totitle, param);
     PL_utf8_tolower    = sv_dup_inc(proto_perl->Iutf8_tolower, param);
     PL_utf8_tofold     = sv_dup_inc(proto_perl->Iutf8_tofold, param);
+    PL_utf8_tosimplefold       = sv_dup_inc(proto_perl->Iutf8_tosimplefold, param);
     PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param);
     PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param);
 
diff --git a/utf8.c b/utf8.c
index 9fb6c37..b063565 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2947,17 +2947,39 @@ Perl__to_upper_title_latin1(pTHX_ const U8 c, U8* p, STRLEN *lenp,
  * The functions return the ordinal of the first character in the string of
  * 'd' */
 #define CALL_UPPER_CASE(uv, s, d, lenp)                                     \
-                _to_utf8_case(uv, s, d, lenp, &PL_utf8_toupper, "ToUc", "")
+                _to_utf8_case(uv, s, d, lenp, PL_utf8_toupper,              \
+                                              Uppercase_Mapping_invmap,     \
+                                              UC_AUX_TABLE_ptrs,            \
+                                              UC_AUX_TABLE_lengths,         \
+                                              "uppercase")
 #define CALL_TITLE_CASE(uv, s, d, lenp)                                     \
-                _to_utf8_case(uv, s, d, lenp, &PL_utf8_totitle, "ToTc", "")
+                _to_utf8_case(uv, s, d, lenp, PL_utf8_totitle,              \
+                                              Titlecase_Mapping_invmap,     \
+                                              TC_AUX_TABLE_ptrs,            \
+                                              TC_AUX_TABLE_lengths,         \
+                                              "titlecase")
 #define CALL_LOWER_CASE(uv, s, d, lenp)                                     \
-                _to_utf8_case(uv, s, d, lenp, &PL_utf8_tolower, "ToLc", "")
+                _to_utf8_case(uv, s, d, lenp, PL_utf8_tolower,              \
+                                              Lowercase_Mapping_invmap,     \
+                                              LC_AUX_TABLE_ptrs,            \
+                                              LC_AUX_TABLE_lengths,         \
+                                              "lowercase")
+
 
 /* This additionally has the input parameter 'specials', which if non-zero will
  * cause this to use the specials hash for folding (meaning get full case
  * folding); otherwise, when zero, this implies a simple case fold */
 #define CALL_FOLD_CASE(uv, s, d, lenp, specials)                            \
-_to_utf8_case(uv, s, d, lenp, &PL_utf8_tofold, "ToCf", (specials) ? "" : NULL)
+        (specials)                                                          \
+        ?  _to_utf8_case(uv, s, d, lenp, PL_utf8_tofold,                    \
+                                          Case_Folding_invmap,              \
+                                          CF_AUX_TABLE_ptrs,                \
+                                          CF_AUX_TABLE_lengths,             \
+                                          "foldcase")                       \
+        : _to_utf8_case(uv, s, d, lenp, PL_utf8_tosimplefold,               \
+                                         Simple_Case_Folding_invmap,        \
+                                         NULL, NULL,                        \
+                                         "foldcase")
 
 UV
 Perl_to_uni_upper(pTHX_ UV c, U8* p, STRLEN *lenp)
@@ -3434,8 +3456,7 @@ Perl__is_utf8_mark(pTHX_ const U8 *p)
 
     /* change namve uv1 to 'from' */
 STATIC UV
-S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
-               SV **swashp, const char *normal, const char *special)
+S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp, SV *invlist, const IV * const invmap, const int * const * aux_tables, const U8 * const aux_table_lengths, const char * const normal)
 {
     STRLEN len = 0;
 
@@ -3503,7 +3524,6 @@ S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
                  * some others */
                 if (uv1 < 0xFB00) {
                     goto cases_to_self;
-
                 }
 
                 if (UNLIKELY(UNICODE_IS_SUPER(uv1))) {
@@ -3533,62 +3553,37 @@ S__to_utf8_case(pTHX_ const UV uv1, const U8 *p, U8* ustrp, STRLEN *lenp,
         }
 
        /* Note that non-characters are perfectly legal, so no warning should
-         * be given.  There are so few of them, that it isn't worth the extra
-         * tests to avoid swash creation */
+         * be given. */
     }
 
-    if (!*swashp) /* load on-demand */
-         *swashp = _core_swash_init("utf8", normal, &PL_sv_undef,
-                                    4, 0, NULL, NULL);
+    {
+        unsigned int i;
+        const int * cp_list;
+        U8 * d;
+        SSize_t index = _invlist_search(invlist, uv1);
+        IV base = invmap[index];
 
-    if (special) {
-         /* It might be "special" (sometimes, but not always,
-         * a multicharacter mapping) */
-         HV *hv = NULL;
-        SV **svp;
+        if (base >= 0) {
+            IV lc;
 
-        /* If passed in the specials name, use that; otherwise use any
-         * given in the swash */
-         if (*special != '\0') {
-            hv = get_hv(special, 0);
-        }
-        else {
-            svp = hv_fetchs(MUTABLE_HV(SvRV(*swashp)), "SPECIALS", 0);
-            if (svp) {
-                hv = MUTABLE_HV(SvRV(*svp));
+            if (base == 0) {
+                goto cases_to_self;
             }
-        }
-
-        if (hv
-             && (svp = hv_fetch(hv, (const char*)p, UVCHR_SKIP(uv1), FALSE))
-             && (*svp))
-         {
-            const char *s;
-
-             s = SvPV_const(*svp, len);
-             if (len == 1)
-                  /* EIGHTBIT */
-                  len = uvchr_to_utf8(ustrp, *(U8*)s) - ustrp;
-             else {
-                  Copy(s, ustrp, len, U8);
-             }
-        }
-    }
-
-    if (!len && *swashp) {
-       const UV uv2 = swash_fetch(*swashp, p, TRUE /* => is UTF-8 */);
 
-        if (uv2) {
-             /* It was "normal" (a single character mapping). */
-             len = uvchr_to_utf8(ustrp, uv2) - ustrp;
-        }
-    }
+            lc = base + uv1 - invlist_array(invlist)[index];
+            *lenp = uvchr_to_utf8(ustrp, lc) - ustrp;
+            return lc;
+        }
 
-    if (len) {
-        if (lenp) {
-            *lenp = len;
+        cp_list = aux_tables[-base];
+        d = ustrp;
+        for (i = 0; i < aux_table_lengths[-base]; i++) {
+            d = uvchr_to_utf8(d, cp_list[i]);
         }
-        return valid_utf8_to_uvchr(ustrp, 0);
+        *d = '\0';
+        *lenp = d - ustrp;
+
+        return cp_list[0];
     }
 
     /* Here, there was no mapping defined, which means that the code point maps
@@ -5028,7 +5023,7 @@ S_swatch_get(pTHX_ SV* swash, UV start, UV span)
 }
 
 HV*
-Perl__swash_inversion_hash(pTHX_ SV* const swash)
+Perl__swash_inversion_hash(pTHX)
 {
 
    /* Subject to change or removal.  For use only in regcomp.c and regexec.c
@@ -5090,6 +5085,7 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
 
     U8 *l, *lend;
     STRLEN lcur;
+    SV * swash = _core_swash_init("utf8", "ToCf", &PL_sv_undef, 4, 0, NULL, NULL);
     HV *const hv = MUTABLE_HV(SvRV(swash));
 
     /* The string containing the main body of the table.  This will have its
@@ -5108,8 +5104,6 @@ Perl__swash_inversion_hash(pTHX_ SV* const swash)
 
     HV* ret = newHV();
 
-    PERL_ARGS_ASSERT__SWASH_INVERSION_HASH;
-
     /* Must have at least 8 bits to get the mappings */
     if (bits != 8 && bits != 16 && bits != 32) {
        Perl_croak(aTHX_ "panic: swash_inversion_hash doesn't expect bits %"