This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regcomp.c, toke.c: swap functions being inline static
authorKarl Williamson <khw@cpan.org>
Sat, 13 Feb 2016 18:53:50 +0000 (11:53 -0700)
committerKarl Williamson <khw@cpan.org>
Fri, 19 Feb 2016 03:44:02 +0000 (20:44 -0700)
grok_bslash_x() is so large that no compiler will inline it.  Move it to
dquote.c from dq_inline.c.  Conversely, move form_octal_warning() to
dq_inline.c.  It is so tiny that the function call overhead is scarcely
smaller than the function body.

This also moves things in embed.fnc so all these functions.  are not
visible outside the few files they are supposed to be used in.

dquote.c
dquote_inline.h
embed.fnc
embed.h
proto.h

index 895f17d..e02308e 100644 (file)
--- a/dquote.c
+++ b/dquote.c
@@ -8,6 +8,7 @@
 #include "EXTERN.h"
 #define PERL_IN_DQUOTE_C
 #include "perl.h"
+#include "dquote_inline.h"
 
 /* XXX Add documentation after final interface and behavior is decided */
 /* May want to show context for error, so would pass S_grok_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
@@ -161,33 +162,124 @@ Perl_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
     return TRUE;
 }
 
-char*
-Perl_form_short_octal_warning(pTHX_
-                           const char * const s, /* Points to first non-octal */
-                           const STRLEN len      /* Length of octals string, so
-                                                    (s-len) points to first
-                                                    octal */
-) {
-    /* Return a character string consisting of a warning message for when a
-     * string constant in octal is weird, like "\078".  */
+bool
+Perl_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
+                      const bool output_warning, const bool strict,
+                      const bool silence_non_portable,
+                      const bool UTF)
+{
 
-    const char * sans_leading_zeros = s - len;
+/*  Documentation to be supplied when interface nailed down finally
+ *  This returns FALSE if there is an error which the caller need not recover
+ *  from; otherwise TRUE.
+ *  It guarantees that the returned codepoint, *uv, when expressed as
+ *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
+ *
+ *  On input:
+ *     s   is the address of a pointer to a NULL terminated string that begins
+ *         with 'x', and the previous character was a backslash.  At exit, *s
+ *         will be advanced to the byte just after those absorbed by this
+ *         function.  Hence the caller can continue parsing from there.  In
+ *         the case of an error, this routine has generally positioned *s to
+ *         point just to the right of the first bad spot, so that a message
+ *         that has a "<--" to mark the spot will be correctly positioned.
+ *     uv  points to a UV that will hold the output value, valid only if the
+ *         return from the function is TRUE
+ *      error_msg is a pointer that will be set to an internal buffer giving an
+ *         error message upon failure (the return is FALSE).  Untouched if
+ *         function succeeds
+ *     output_warning says whether to output any warning messages, or suppress
+ *         them
+ *     strict is true if anything out of the ordinary should cause this to
+ *         fail instead of warn or be silent.  For example, it requires
+ *         exactly 2 digits following the \x (when there are no braces).
+ *         3 digits could be a mistake, so is forbidden in this mode.
+ *      silence_non_portable is true if to suppress warnings about the code
+ *          point returned being too large to fit on all platforms.
+ *     UTF is true iff the string *s is encoded in UTF-8.
+ */
+    char* e;
+    STRLEN numbers_len;
+    I32 flags = PERL_SCAN_DISALLOW_PREFIX;
+#ifdef DEBUGGING
+    char *start = *s - 1;
+    assert(*start == '\\');
+#endif
 
-    PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
+    PERL_ARGS_ASSERT_GROK_BSLASH_X;
 
-    assert(*s == '8' || *s == '9');
+    assert(**s == 'x');
+    (*s)++;
 
-    /* Remove the leading zeros, retaining one zero so won't be zero length */
-    while (*sans_leading_zeros == '0') sans_leading_zeros++;
-    if (sans_leading_zeros == s) {
-        sans_leading_zeros--;
+    if (strict || ! output_warning) {
+        flags |= PERL_SCAN_SILENT_ILLDIGIT;
     }
 
-    return Perl_form(aTHX_
-                     "'%.*s' resolved to '\\o{%.*s}%c'",
-                     (int) (len + 2), s - len - 1,
-                     (int) (s - sans_leading_zeros), sans_leading_zeros,
-                     *s);
+    if (**s != '{') {
+        STRLEN len = (strict) ? 3 : 2;
+
+       *uv = grok_hex(*s, &len, &flags, NULL);
+       *s += len;
+        if (strict && len != 2) {
+            if (len < 2) {
+                *s += (UTF) ? UTF8SKIP(*s) : 1;
+                *error_msg = "Non-hex character";
+            }
+            else {
+                *error_msg = "Use \\x{...} for more than two hex characters";
+            }
+            return FALSE;
+        }
+       return TRUE;
+    }
+
+    e = strchr(*s, '}');
+    if (!e) {
+        (*s)++;  /* Move past the '{' */
+        while (isXDIGIT(**s)) { /* Position beyond the legal digits */
+            (*s)++;
+        }
+        /* XXX The corresponding message above for \o is just '\\o{'; other
+         * messages for other constructs include the '}', so are inconsistent.
+         */
+       *error_msg = "Missing right brace on \\x{}";
+       return FALSE;
+    }
+
+    (*s)++;    /* Point to expected first digit (could be first byte of utf8
+                  sequence if not a digit) */
+    numbers_len = e - *s;
+    if (numbers_len == 0) {
+        if (strict) {
+            (*s)++;    /* Move past the } */
+            *error_msg = "Number with no digits";
+            return FALSE;
+        }
+        *s = e + 1;
+        *uv = 0;
+        return TRUE;
+    }
+
+    flags |= PERL_SCAN_ALLOW_UNDERSCORES;
+    if (silence_non_portable) {
+        flags |= PERL_SCAN_SILENT_NON_PORTABLE;
+    }
+
+    *uv = grok_hex(*s, &numbers_len, &flags, NULL);
+    /* Note that if has non-hex, will ignore everything starting with that up
+     * to the '}' */
+
+    if (strict && numbers_len != (STRLEN) (e - *s)) {
+        *s += numbers_len;
+        *s += (UTF) ? UTF8SKIP(*s) : 1;
+        *error_msg = "Non-hex character";
+        return FALSE;
+    }
+
+    /* Return past the '}' */
+    *s = e + 1;
+
+    return TRUE;
 }
 
 /*
index 050b14f..1c7694d 100644 (file)
@@ -33,124 +33,35 @@ S_regcurly(const char *s)
     return *s == '}';
 }
 
-PERL_STATIC_INLINE bool
-S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
-                      const bool output_warning, const bool strict,
-                      const bool silence_non_portable,
-                      const bool UTF)
+/* This is inline not for speed, but because it is so tiny */
+
+PERL_STATIC_INLINE char*
+S_form_short_octal_warning(pTHX_
+                           const char * const s, /* Points to first non-octal */
+                           const STRLEN len      /* Length of octals string, so
+                                                    (s-len) points to first
+                                                    octal */
+)
 {
+    /* Return a character string consisting of a warning message for when a
+     * string constant in octal is weird, like "\078".  */
 
-/*  Documentation to be supplied when interface nailed down finally
- *  This returns FALSE if there is an error which the caller need not recover
- *  from; otherwise TRUE.
- *  It guarantees that the returned codepoint, *uv, when expressed as
- *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
- *
- *  On input:
- *     s   is the address of a pointer to a NULL terminated string that begins
- *         with 'x', and the previous character was a backslash.  At exit, *s
- *         will be advanced to the byte just after those absorbed by this
- *         function.  Hence the caller can continue parsing from there.  In
- *         the case of an error, this routine has generally positioned *s to
- *         point just to the right of the first bad spot, so that a message
- *         that has a "<--" to mark the spot will be correctly positioned.
- *     uv  points to a UV that will hold the output value, valid only if the
- *         return from the function is TRUE
- *      error_msg is a pointer that will be set to an internal buffer giving an
- *         error message upon failure (the return is FALSE).  Untouched if
- *         function succeeds
- *     output_warning says whether to output any warning messages, or suppress
- *         them
- *     strict is true if anything out of the ordinary should cause this to
- *         fail instead of warn or be silent.  For example, it requires
- *         exactly 2 digits following the \x (when there are no braces).
- *         3 digits could be a mistake, so is forbidden in this mode.
- *      silence_non_portable is true if to suppress warnings about the code
- *          point returned being too large to fit on all platforms.
- *     UTF is true iff the string *s is encoded in UTF-8.
- */
-    char* e;
-    STRLEN numbers_len;
-    I32 flags = PERL_SCAN_DISALLOW_PREFIX;
-#ifdef DEBUGGING
-    char *start = *s - 1;
-    assert(*start == '\\');
-#endif
-
-    PERL_ARGS_ASSERT_GROK_BSLASH_X;
+    const char * sans_leading_zeros = s - len;
 
-    assert(**s == 'x');
-    (*s)++;
-
-    if (strict || ! output_warning) {
-        flags |= PERL_SCAN_SILENT_ILLDIGIT;
-    }
+    PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
 
-    if (**s != '{') {
-        STRLEN len = (strict) ? 3 : 2;
+    assert(*s == '8' || *s == '9');
 
-       *uv = grok_hex(*s, &len, &flags, NULL);
-       *s += len;
-        if (strict && len != 2) {
-            if (len < 2) {
-                *s += (UTF) ? UTF8SKIP(*s) : 1;
-                *error_msg = "Non-hex character";
-            }
-            else {
-                *error_msg = "Use \\x{...} for more than two hex characters";
-            }
-            return FALSE;
-        }
-       return TRUE;
+    /* Remove the leading zeros, retaining one zero so won't be zero length */
+    while (*sans_leading_zeros == '0') sans_leading_zeros++;
+    if (sans_leading_zeros == s) {
+        sans_leading_zeros--;
     }
 
-    e = strchr(*s, '}');
-    if (!e) {
-        (*s)++;  /* Move past the '{' */
-        while (isXDIGIT(**s)) { /* Position beyond the legal digits */
-            (*s)++;
-        }
-        /* XXX The corresponding message above for \o is just '\\o{'; other
-         * messages for other constructs include the '}', so are inconsistent.
-         */
-       *error_msg = "Missing right brace on \\x{}";
-       return FALSE;
-    }
-
-    (*s)++;    /* Point to expected first digit (could be first byte of utf8
-                  sequence if not a digit) */
-    numbers_len = e - *s;
-    if (numbers_len == 0) {
-        if (strict) {
-            (*s)++;    /* Move past the } */
-            *error_msg = "Number with no digits";
-            return FALSE;
-        }
-        *s = e + 1;
-        *uv = 0;
-        return TRUE;
-    }
-
-    flags |= PERL_SCAN_ALLOW_UNDERSCORES;
-    if (silence_non_portable) {
-        flags |= PERL_SCAN_SILENT_NON_PORTABLE;
-    }
-
-    *uv = grok_hex(*s, &numbers_len, &flags, NULL);
-    /* Note that if has non-hex, will ignore everything starting with that up
-     * to the '}' */
-
-    if (strict && numbers_len != (STRLEN) (e - *s)) {
-        *s += numbers_len;
-        *s += (UTF) ? UTF8SKIP(*s) : 1;
-        *error_msg = "Non-hex character";
-        return FALSE;
-    }
-
-    /* Return past the '}' */
-    *s = e + 1;
-
-    return TRUE;
+    return Perl_form(aTHX_
+                     "'%.*s' resolved to '\\o{%.*s}%c'",
+                     (int) (len + 2), s - len - 1,
+                     (int) (s - sans_leading_zeros), sans_leading_zeros,
+                     *s);
 }
-
 #endif  /* DQUOTE_INLINE_H */
index f5ace28..a2cad1a 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -801,14 +801,13 @@ Ap        |void   |vload_module|U32 flags|NN SV* name|NULLOK SV* ver|NULLOK va_list* args
 p      |OP*    |localize       |NN OP *o|I32 lex
 ApdR   |I32    |looks_like_number|NN SV *const sv
 Apd    |UV     |grok_bin       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
-EMiR   |bool   |grok_bslash_x  |NN char** s|NN UV* uv           \
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_DQUOTE_C)
+EMpRX  |bool   |grok_bslash_x  |NN char** s|NN UV* uv           \
                                |NN const char** error_msg       \
                                |const bool output_warning       \
                                |const bool strict               \
                                |const bool silence_non_portable \
                                |const bool utf8
-#endif
 EMpRX  |char   |grok_bslash_c  |const char source|const bool output_warning
 EMpRX  |bool   |grok_bslash_o  |NN char** s|NN UV* uv           \
                                |NN const char** error_msg       \
@@ -816,8 +815,10 @@ EMpRX      |bool   |grok_bslash_o  |NN char** s|NN UV* uv           \
                                |const bool strict               \
                                |const bool silence_non_portable \
                                |const bool utf8
-EMpPRX |char*|form_short_octal_warning|NN const char * const s  \
+EMiR   |char*|form_short_octal_warning|NN const char * const s  \
                                |const STRLEN len
+EiPRn  |I32    |regcurly       |NN const char *s
+#endif
 Apd    |UV     |grok_hex       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 Apd    |int    |grok_infnan    |NN const char** sp|NN const char *send
 Apd    |int    |grok_number    |NN const char *pv|STRLEN len|NULLOK UV *valuep
@@ -1199,9 +1200,6 @@ Ap        |char*  |re_intuit_start|NN REGEXP * const rx \
                                |const U32 flags \
                                |NULLOK re_scream_pos_data *data
 Ap     |SV*    |re_intuit_string|NN REGEXP  *const r
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
-EiPRn  |I32    |regcurly       |NN const char *s
-#endif
 Ap     |I32    |regexec_flags  |NN REGEXP *const rx|NN char *stringarg \
                                |NN char *strend|NN char *strbeg \
                                |SSize_t minend|NN SV *sv \
diff --git a/embed.h b/embed.h
index a12a3e6..eb8ffa5 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define av_reify(a)            Perl_av_reify(aTHX_ a)
 #define current_re_engine()    Perl_current_re_engine(aTHX)
 #define cv_ckproto_len_flags(a,b,c,d,e)        Perl_cv_ckproto_len_flags(aTHX_ a,b,c,d,e)
-#define form_short_octal_warning(a,b)  Perl_form_short_octal_warning(aTHX_ a,b)
 #define grok_atoUV             Perl_grok_atoUV
-#define grok_bslash_c(a,b)     Perl_grok_bslash_c(aTHX_ a,b)
-#define grok_bslash_o(a,b,c,d,e,f,g)   Perl_grok_bslash_o(aTHX_ a,b,c,d,e,f,g)
 #define mg_find_mglob(a)       Perl_mg_find_mglob(aTHX_ a)
 #define multideref_stringify(a,b)      Perl_multideref_stringify(aTHX_ a,b)
 #define op_clear(a)            Perl_op_clear(aTHX_ a)
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_REGEXEC_C) || defined(PERL_IN_UTF8_C) || defined(PERL_IN_TOKE_C)
 #define _core_swash_init(a,b,c,d,e,f,g)        Perl__core_swash_init(aTHX_ a,b,c,d,e,f,g)
 #  endif
-#  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
-#define grok_bslash_x(a,b,c,d,e,f,g)   S_grok_bslash_x(aTHX_ a,b,c,d,e,f,g)
+#  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_DQUOTE_C)
+#define form_short_octal_warning(a,b)  S_form_short_octal_warning(aTHX_ a,b)
+#define grok_bslash_c(a,b)     Perl_grok_bslash_c(aTHX_ a,b)
+#define grok_bslash_o(a,b,c,d,e,f,g)   Perl_grok_bslash_o(aTHX_ a,b,c,d,e,f,g)
+#define grok_bslash_x(a,b,c,d,e,f,g)   Perl_grok_bslash_x(aTHX_ a,b,c,d,e,f,g)
 #define regcurly               S_regcurly
 #  endif
 #  if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_UTF8_C)
diff --git a/proto.h b/proto.h
index c3adf2d..8f2b730 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -880,12 +880,6 @@ PERL_CALLCONV char*        Perl_form(pTHX_ const char* pat, ...)
 #define PERL_ARGS_ASSERT_FORM  \
        assert(pat)
 
-PERL_CALLCONV char*    Perl_form_short_octal_warning(pTHX_ const char * const s, const STRLEN len)
-                       __attribute__warn_unused_result__
-                       __attribute__pure__;
-#define PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING      \
-       assert(s)
-
 PERL_CALLCONV void     Perl_free_tied_hv_pool(pTHX);
 PERL_CALLCONV void     Perl_free_tmps(pTHX);
 PERL_CALLCONV AV*      Perl_get_av(pTHX_ const char *name, I32 flags);
@@ -947,14 +941,6 @@ PERL_CALLCONV bool Perl_grok_atoUV(const char* pv, UV* valptr, const char** endp
 PERL_CALLCONV UV       Perl_grok_bin(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result);
 #define PERL_ARGS_ASSERT_GROK_BIN      \
        assert(start); assert(len_p); assert(flags)
-PERL_CALLCONV char     Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
-                       __attribute__warn_unused_result__;
-
-PERL_CALLCONV bool     Perl_grok_bslash_o(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
-                       __attribute__warn_unused_result__;
-#define PERL_ARGS_ASSERT_GROK_BSLASH_O \
-       assert(s); assert(uv); assert(error_msg)
-
 PERL_CALLCONV UV       Perl_grok_hex(pTHX_ const char* start, STRLEN* len_p, I32* flags, NV *result);
 #define PERL_ARGS_ASSERT_GROK_HEX      \
        assert(start); assert(len_p); assert(flags)
@@ -4983,8 +4969,21 @@ PERL_CALLCONV SV*        Perl__core_swash_init(pTHX_ const char* pkg, const char* name,
 #define PERL_ARGS_ASSERT__CORE_SWASH_INIT      \
        assert(pkg); assert(name); assert(listsv)
 #endif
-#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C)
-PERL_STATIC_INLINE bool        S_grok_bslash_x(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
+#if defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_DQUOTE_C)
+PERL_STATIC_INLINE char*       S_form_short_octal_warning(pTHX_ const char * const s, const STRLEN len)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING      \
+       assert(s)
+
+PERL_CALLCONV char     Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
+                       __attribute__warn_unused_result__;
+
+PERL_CALLCONV bool     Perl_grok_bslash_o(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
+                       __attribute__warn_unused_result__;
+#define PERL_ARGS_ASSERT_GROK_BSLASH_O \
+       assert(s); assert(uv); assert(error_msg)
+
+PERL_CALLCONV bool     Perl_grok_bslash_x(pTHX_ char** s, UV* uv, const char** error_msg, const bool output_warning, const bool strict, const bool silence_non_portable, const bool utf8)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_GROK_BSLASH_X \
        assert(s); assert(uv); assert(error_msg)