This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
utf8.c: New function to retrieve non-copy of swash
authorKarl Williamson <public@khwilliamson.com>
Tue, 22 Nov 2011 19:06:41 +0000 (12:06 -0700)
committerKarl Williamson <public@khwilliamson.com>
Fri, 13 Jan 2012 16:58:34 +0000 (09:58 -0700)
Currently, swash_init returns a copy of the swash it finds.  The core
portions of the swash are read-only, and the non-read-only portions are
derived from them.  When the value for a code point is looked up, the
results for it and adjacent code points are stored in a new element,
so that the lookup never has to be performed again.  But since a copy is
returned, those results are stored only in the copy, and any other uses
of the same logical stash don't have access to them, so the lookups have
to be performed for each logical use.

Here's an example.  If you have 2 occurrences of /\p{Upper}/ in your
program, there are 2 different swashes created, both initialized
identically.  As you start matching against code points, say "A" =~
/\p{Upper}/, the swashes diverge, as the results for each match are
saved in the one applicable to that match.  If you match "A" in each
swash, it has to be looked up in each swash, and an (identical) element
will be saved for it in each swash.  This is wasteful of both time and
memory.

This patch renames the function and returns the original and not a copy,
thus eliminating the overhead for stashes accessed through the new
interface.  The old function name is serviced by a new function which
merely wraps the new name result with a copy, thus preserving the
interface for existing calls.

Thus, in the example above, there is only one swash, and matching "A"
against it results in only one new element, and so the second use will
find that, and not have to go out looking again.  In a program with lots
of regular expressions, the savings in time and memory can be quite
large.

The new name is restricted to use only in regcomp.c and utf8.c (unless
XS code cheats the preprocessor), where we will code so as to not
destroy the original's data.  Otherwise, a change to that would change
the definition of a Unicode property everywhere in the program.

Note that there are no current callers of the new interface; these will
be added in future commits.

embed.fnc
embed.h
proto.h
utf8.c

index c587946..ce8e2e2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1384,6 +1384,9 @@ EXMpR     |SV*    |_new_invlist   |IV initial_size
 EXMpR  |SV*    |_swash_to_invlist      |NN SV* const swash
 EXMp   |void   |_append_range_to_invlist   |NN SV* const invlist|const UV start|const UV end
 #endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
+EXp    |SV*    |_core_swash_init|NN const char* pkg|NN const char* name|NN SV* listsv|I32 minbits|I32 none
+#endif
 Ap     |void   |taint_env
 Ap     |void   |taint_proper   |NULLOK const char* f|NN const char *const s
 Apd    |UV     |to_utf8_case   |NN const U8 *p|NN U8* ustrp|NULLOK STRLEN *lenp \
diff --git a/embed.h b/embed.h
index 9d140ee..3bf886a 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define set_regclass_bit_fold(a,b,c,d,e)       S_set_regclass_bit_fold(aTHX_ a,b,c,d,e)
 #define study_chunk(a,b,c,d,e,f,g,h,i,j,k)     S_study_chunk(aTHX_ a,b,c,d,e,f,g,h,i,j,k)
 #  endif
+#  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
+#define _core_swash_init(a,b,c,d,e)    Perl__core_swash_init(aTHX_ a,b,c,d,e)
+#  endif
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
 #define _append_range_to_invlist(a,b,c)        Perl__append_range_to_invlist(aTHX_ a,b,c)
 #define _invlist_intersection(a,b,c)   Perl__invlist_intersection(aTHX_ a,b,c)
diff --git a/proto.h b/proto.h
index e0939eb..ed74a1f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -6523,6 +6523,15 @@ STATIC I32       S_study_chunk(pTHX_ struct RExC_state_t *pRExC_state, regnode **scanp
        assert(pRExC_state); assert(scanp); assert(minlenp); assert(deltap); assert(last)
 
 #endif
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C)
+PERL_CALLCONV SV*      Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV* listsv, I32 minbits, I32 none)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT__CORE_SWASH_INIT      \
+       assert(pkg); assert(name); assert(listsv)
+
+#endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
 PERL_CALLCONV void     Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
                        __attribute__nonnull__(pTHX_1);
diff --git a/utf8.c b/utf8.c
index 13aa2dc..6374125 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -2454,11 +2454,43 @@ Perl__to_utf8_fold_flags(pTHX_ const U8 *p, U8* ustrp, STRLEN *lenp, U8 flags, b
  * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
  * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
  */
+
 SV*
 Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
 {
+    PERL_ARGS_ASSERT_SWASH_INIT;
+
+    /* Returns a copy of a swash initiated by the called function.  This is the
+     * public interface, and returning a copy prevents others from doing
+     * mischief on the original */
+
+    return newSVsv(_core_swash_init(pkg, name, listsv, minbits, none));
+}
+
+SV*
+Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
+{
+    /* Initialize and return a swash, creating it if necessary.  It does this
+     * by calling utf8_heavy.pl.
+     *
+     * This interface should only be used by functions that won't destroy or
+     * adversely change the swash, as doing so affects all other uses of the
+     * swash in the program; the general public should use 'Perl_swash_init'
+     * instead.
+     *
+     * pkg  is the name of the package that <name> should be in.
+     * name is the name of the swash to find.  Typically it is a Unicode
+     *     property name, including user-defined ones
+     * listsv is a string to initialize the swash with.  It must be of the form
+     *     documented as the subroutine return value in
+     *     L<perlunicode/User-Defined Character Properties>
+     * minbits is the number of bits required to represent each data element.
+     *     It is '1' for binary properties.
+     * none I (khw) do not understand this one, but it is used only in tr///.
+     */
+
     dVAR;
-    SV* retval;
+    SV* retval = &PL_sv_undef;
     dSP;
     const size_t pkg_len = strlen(pkg);
     const size_t name_len = strlen(name);
@@ -2466,7 +2498,7 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits
     SV* errsv_save;
     GV *method;
 
-    PERL_ARGS_ASSERT_SWASH_INIT;
+    PERL_ARGS_ASSERT__CORE_SWASH_INIT;
 
     PUSHSTACKi(PERLSI_MAGIC);
     ENTER;
@@ -2506,9 +2538,10 @@ Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits
        to repeat the lookup.  */
     if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
        : call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
-       retval = newSVsv(*PL_stack_sp--);
-    else
-       retval = &PL_sv_undef;
+    {
+        retval = *PL_stack_sp--;
+        SvREFCNT_inc(retval);
+    }
     if (!SvTRUE(ERRSV))
        sv_setsv(ERRSV, errsv_save);
     SvREFCNT_dec(errsv_save);