This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fixup Perl_magic_freemglob()
[perl5.git] / inline.h
index 6c460e5..bbf27da 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -5,8 +5,33 @@
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
  *
+ *    This file contains tables and code adapted from
+ *    https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
+ *    copyright notice:
+
+Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy of
+this software and associated documentation files (the "Software"), to deal in
+the Software without restriction, including without limitation the rights to
+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
+of the Software, and to permit persons to whom the Software is furnished to do
+so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.
+
+ *
  * This file is a home for static inline functions that cannot go in other
- * headers files, because they depend on proto.h (included after most other
+ * header files, because they depend on proto.h (included after most other
  * headers) or struct definitions.
  *
  * Each section names the header file that the functions "belong" to.
 
 /* ------------------------------- av.h ------------------------------- */
 
-PERL_STATIC_INLINE SSize_t
-S_av_top_index(pTHX_ AV *av)
+/*
+=for apidoc_section $AV
+=for apidoc av_count
+Returns the number of elements in the array C<av>.  This is the true length of
+the array, including any undefined elements.  It is always the same as
+S<C<av_top_index(av) + 1>>.
+
+=cut
+*/
+PERL_STATIC_INLINE Size_t
+Perl_av_count(pTHX_ AV *av)
 {
-    PERL_ARGS_ASSERT_AV_TOP_INDEX;
+    PERL_ARGS_ASSERT_AV_COUNT;
     assert(SvTYPE(av) == SVt_PVAV);
 
-    return AvFILL(av);
+    return AvFILL(av) + 1;
 }
 
 /* ------------------------------- cv.h ------------------------------- */
 
+/*
+=for apidoc_section $CV
+=for apidoc CvGV
+Returns the GV associated with the CV C<sv>, reifying it if necessary.
+
+=cut
+*/
 PERL_STATIC_INLINE GV *
-S_CvGV(pTHX_ CV *sv)
+Perl_CvGV(pTHX_ CV *sv)
 {
+    PERL_ARGS_ASSERT_CVGV;
+
     return CvNAMED(sv)
-       ? Perl_cvgv_from_hek(aTHX_ sv)
-       : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
+        ? Perl_cvgv_from_hek(aTHX_ sv)
+        : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
 }
 
 PERL_STATIC_INLINE I32 *
-S_CvDEPTHp(const CV * const sv)
+Perl_CvDEPTH(const CV * const sv)
 {
+    PERL_ARGS_ASSERT_CVDEPTH;
     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
+
     return &((XPVCV*)SvANY(sv))->xcv_depth;
 }
 
@@ -60,13 +105,13 @@ S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
     tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
     tmps = SvPVX(tmpsv);
     while ((*len)--) {
-       if (!isSPACE(*orig))
-           *tmps++ = *orig;
-       orig++;
+        if (!isSPACE(*orig))
+            *tmps++ = *orig;
+        orig++;
     }
     *tmps = '\0';
     *len = tmps - SvPVX(tmpsv);
-               return SvPVX(tmpsv);
+                return SvPVX(tmpsv);
 }
 #endif
 
@@ -80,12 +125,12 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
     assert(mg->mg_type == PERL_MAGIC_regex_global);
     assert(mg->mg_len != -1);
     if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
-       return (STRLEN)mg->mg_len;
+        return (STRLEN)mg->mg_len;
     else {
-       const STRLEN pos = (STRLEN)mg->mg_len;
-       /* Without this check, we may read past the end of the buffer: */
-       if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
-       return sv_or_pv_pos_u2b(sv, s, pos, NULL);
+        const STRLEN pos = (STRLEN)mg->mg_len;
+        /* Without this check, we may read past the end of the buffer: */
+        if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
+        return sv_or_pv_pos_u2b(sv, s, pos, NULL);
     }
 }
 #endif
@@ -94,33 +139,35 @@ S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
 
 #if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
 PERL_STATIC_INLINE bool
-PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
+S_PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
 {
+    PERL_ARGS_ASSERT_PADNAMEIN_SCOPE;
+
     /* is seq within the range _LOW to _HIGH ?
      * This is complicated by the fact that PL_cop_seqmax
      * may have wrapped around at some point */
     if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
-       return FALSE; /* not yet introduced */
+        return FALSE; /* not yet introduced */
 
     if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
     /* in compiling scope */
-       if (
-           (seq >  COP_SEQ_RANGE_LOW(pn))
-           ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
-           : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
-       )
-           return TRUE;
+        if (
+            (seq >  COP_SEQ_RANGE_LOW(pn))
+            ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
+            : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
+        )
+            return TRUE;
     }
     else if (
-       (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
-       ?
-           (  seq >  COP_SEQ_RANGE_LOW(pn)
-           || seq <= COP_SEQ_RANGE_HIGH(pn))
+        (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
+        ?
+            (  seq >  COP_SEQ_RANGE_LOW(pn)
+            || seq <= COP_SEQ_RANGE_HIGH(pn))
 
-       :    (  seq >  COP_SEQ_RANGE_LOW(pn)
-            && seq <= COP_SEQ_RANGE_HIGH(pn))
+        :    (  seq >  COP_SEQ_RANGE_LOW(pn)
+             && seq <= COP_SEQ_RANGE_HIGH(pn))
     )
-       return TRUE;
+        return TRUE;
     return FALSE;
 }
 #endif
@@ -128,22 +175,22 @@ PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
 /* ------------------------------- pp.h ------------------------------- */
 
 PERL_STATIC_INLINE I32
-S_TOPMARK(pTHX)
+Perl_TOPMARK(pTHX)
 {
     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
-                                "MARK top  %p %" IVdf "\n",
-                                 PL_markstack_ptr,
-                                 (IV)*PL_markstack_ptr)));
+                                 "MARK top  %p %" IVdf "\n",
+                                  PL_markstack_ptr,
+                                  (IV)*PL_markstack_ptr)));
     return *PL_markstack_ptr;
 }
 
 PERL_STATIC_INLINE I32
-S_POPMARK(pTHX)
+Perl_POPMARK(pTHX)
 {
     DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
-                                "MARK pop  %p %" IVdf "\n",
-                                 (PL_markstack_ptr-1),
-                                 (IV)*(PL_markstack_ptr-1))));
+                                 "MARK pop  %p %" IVdf "\n",
+                                  (PL_markstack_ptr-1),
+                                  (IV)*(PL_markstack_ptr-1))));
     assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
     return *PL_markstack_ptr--;
 }
@@ -151,78 +198,147 @@ S_POPMARK(pTHX)
 /* ----------------------------- regexp.h ----------------------------- */
 
 PERL_STATIC_INLINE struct regexp *
-S_ReANY(const REGEXP * const re)
+Perl_ReANY(const REGEXP * const re)
 {
     XPV* const p = (XPV*)SvANY(re);
+
+    PERL_ARGS_ASSERT_REANY;
     assert(isREGEXP(re));
+
     return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
                                    : (struct regexp *)p;
 }
 
 /* ------------------------------- sv.h ------------------------------- */
 
+PERL_STATIC_INLINE bool
+Perl_SvTRUE(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE;
+
+    if (UNLIKELY(sv == NULL))
+        return FALSE;
+    SvGETMAGIC(sv);
+    return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_nomg(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE_NOMG;
+
+    if (UNLIKELY(sv == NULL))
+        return FALSE;
+    return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_NN(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE_NN;
+
+    SvGETMAGIC(sv);
+    return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
+{
+    PERL_ARGS_ASSERT_SVTRUE_COMMON;
+
+    if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
+        return SvIMMORTAL_TRUE(sv);
+
+    if (! SvOK(sv))
+        return FALSE;
+
+    if (SvPOK(sv))
+        return SvPVXtrue(sv);
+
+    if (SvIOK(sv))
+        return SvIVX(sv) != 0; /* casts to bool */
+
+    if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
+        return TRUE;
+
+    if (sv_2bool_is_fallback)
+        return sv_2bool_nomg(sv);
+
+    return isGV_with_GP(sv);
+}
+
+
 PERL_STATIC_INLINE SV *
-S_SvREFCNT_inc(SV *sv)
+Perl_SvREFCNT_inc(SV *sv)
 {
     if (LIKELY(sv != NULL))
-       SvREFCNT(sv)++;
+        SvREFCNT(sv)++;
     return sv;
 }
 PERL_STATIC_INLINE SV *
-S_SvREFCNT_inc_NN(SV *sv)
+Perl_SvREFCNT_inc_NN(SV *sv)
 {
+    PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
+
     SvREFCNT(sv)++;
     return sv;
 }
 PERL_STATIC_INLINE void
-S_SvREFCNT_inc_void(SV *sv)
+Perl_SvREFCNT_inc_void(SV *sv)
 {
     if (LIKELY(sv != NULL))
-       SvREFCNT(sv)++;
+        SvREFCNT(sv)++;
 }
 PERL_STATIC_INLINE void
-S_SvREFCNT_dec(pTHX_ SV *sv)
+Perl_SvREFCNT_dec(pTHX_ SV *sv)
 {
     if (LIKELY(sv != NULL)) {
-       U32 rc = SvREFCNT(sv);
-       if (LIKELY(rc > 1))
-           SvREFCNT(sv) = rc - 1;
-       else
-           Perl_sv_free2(aTHX_ sv, rc);
+        U32 rc = SvREFCNT(sv);
+        if (LIKELY(rc > 1))
+            SvREFCNT(sv) = rc - 1;
+        else
+            Perl_sv_free2(aTHX_ sv, rc);
     }
 }
 
 PERL_STATIC_INLINE void
-S_SvREFCNT_dec_NN(pTHX_ SV *sv)
+Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
 {
     U32 rc = SvREFCNT(sv);
+
+    PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
+
     if (LIKELY(rc > 1))
-       SvREFCNT(sv) = rc - 1;
+        SvREFCNT(sv) = rc - 1;
     else
-       Perl_sv_free2(aTHX_ sv, rc);
+        Perl_sv_free2(aTHX_ sv, rc);
 }
 
 PERL_STATIC_INLINE void
-SvAMAGIC_on(SV *sv)
+Perl_SvAMAGIC_on(SV *sv)
 {
+    PERL_ARGS_ASSERT_SVAMAGIC_ON;
     assert(SvROK(sv));
+
     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
 }
 PERL_STATIC_INLINE void
-SvAMAGIC_off(SV *sv)
+Perl_SvAMAGIC_off(SV *sv)
 {
+    PERL_ARGS_ASSERT_SVAMAGIC_OFF;
+
     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
-       HvAMAGIC_off(SvSTASH(SvRV(sv)));
+        HvAMAGIC_off(SvSTASH(SvRV(sv)));
 }
 
 PERL_STATIC_INLINE U32
-S_SvPADSTALE_on(SV *sv)
+Perl_SvPADSTALE_on(SV *sv)
 {
     assert(!(SvFLAGS(sv) & SVs_PADTMP));
     return SvFLAGS(sv) |= SVs_PADSTALE;
 }
 PERL_STATIC_INLINE U32
-S_SvPADSTALE_off(SV *sv)
+Perl_SvPADSTALE_off(SV *sv)
 {
     assert(!(SvFLAGS(sv) & SVs_PADTMP));
     return SvFLAGS(sv) &= ~SVs_PADSTALE;
@@ -233,33 +349,22 @@ S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 {
     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
     if (SvGAMAGIC(sv)) {
-       U8 *hopped = utf8_hop((U8 *)pv, pos);
-       if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
-       return (STRLEN)(hopped - (U8 *)pv);
+        U8 *hopped = utf8_hop((U8 *)pv, pos);
+        if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
+        return (STRLEN)(hopped - (U8 *)pv);
     }
     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 }
 #endif
 
-/* ------------------------------- handy.h ------------------------------- */
-
-/* saves machine code for a common noreturn idiom typically used in Newx*() */
-GCC_DIAG_IGNORE_DECL(-Wunused-function);
-static void
-S_croak_memory_wrap(void)
-{
-    Perl_croak_nocontext("%s",PL_memory_wrap);
-}
-GCC_DIAG_RESTORE_DECL;
-
 /* ------------------------------- utf8.h ------------------------------- */
 
 /*
-=head1 Unicode Support
+=for apidoc_section $unicode
 */
 
 PERL_STATIC_INLINE void
-S_append_utf8_from_native_byte(const U8 byte, U8** dest)
+Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
 {
     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
      * encoded string at '*dest', updating '*dest' to include it */
@@ -276,10 +381,10 @@ S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 
 /*
 =for apidoc valid_utf8_to_uvchr
-Like C<L</utf8_to_uvchr_buf>>, but should only be called when it is known that
-the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
-it passes C<L</isUTF8_CHAR>>.  Surrogates, non-character code points, and
-non-Unicode code points are allowed.
+Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
+known that the next character in the input UTF-8 string C<s> is well-formed
+(I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>.  Surrogates, non-character code
+points, and non-Unicode code points are allowed.
 
 =cut
 
@@ -300,7 +405,7 @@ Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
 
     /* An invariant is trivially returned */
     if (expectlen == 1) {
-       return uv;
+        return uv;
     }
 
     /* Remove the leading bits that indicate the number of bytes, leaving just
@@ -369,7 +474,7 @@ UTF-8 invariant, this function does not change the contents of C<*ep>.
 */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
+Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 {
     const U8* send;
     const U8* x = s;
@@ -382,25 +487,25 @@ S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 
     send = s + len;
 
-#ifndef EBCDIC
-
 /* This looks like 0x010101... */
-#define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
+#  define PERL_COUNT_MULTIPLIER   (~ (UINTMAX_C(0)) / 0xFF)
 
 /* This looks like 0x808080... */
-#define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
-#define PERL_WORDSIZE            sizeof(PERL_COUNT_MULTIPLIER)
-#define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
+#  define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
+#  define PERL_WORDSIZE            sizeof(PERL_UINTMAX_T)
+#  define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
 
 /* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
  * or'ing together the lowest bits of 'x'.  Hopefully the final term gets
  * optimized out completely on a 32-bit system, and its mask gets optimized out
  * on a 64-bit system */
-#define PERL_IS_SUBWORD_ADDR(x) (1 & (       PTR2nat(x)                       \
+#  define PERL_IS_SUBWORD_ADDR(x) (1 & (       PTR2nat(x)                     \
                                       |   (  PTR2nat(x) >> 1)                 \
                                       | ( ( (PTR2nat(x)                       \
                                            & PERL_WORD_BOUNDARY_MASK) >> 2))))
 
+#ifndef EBCDIC
+
     /* Do the word-at-a-time iff there is at least one usable full word.  That
      * means that after advancing to a word boundary, there still is at least a
      * full word left.  The number of bytes needed to advance is 'wordsize -
@@ -438,19 +543,19 @@ S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
                     return FALSE;
                 }
 
-#if   BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    \
-   || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+#  if   BYTEORDER == 0x1234 || BYTEORDER == 0x12345678    \
+     || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
 
-                *ep = x + _variant_byte_number(* (PERL_UINTMAX_T *) x);
+                *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
                 assert(*ep >= s && *ep < send);
 
                 return FALSE;
 
-#else   /* If weird byte order, drop into next loop to do byte-at-a-time
+#  else   /* If weird byte order, drop into next loop to do byte-at-a-time
            checks. */
 
                 break;
-#endif
+#  endif
             }
 
             x += PERL_WORDSIZE;
@@ -458,11 +563,11 @@ S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
         } while (x + PERL_WORDSIZE <= send);
     }
 
-#endif
+#endif      /* End of ! EBCDIC */
 
     /* Process per-byte */
     while (x < send) {
-       if (! UTF8_IS_INVARIANT(*x)) {
+        if (! UTF8_IS_INVARIANT(*x)) {
             if (ep) {
                 *ep = x;
             }
@@ -479,7 +584,7 @@ S_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
 #ifndef EBCDIC
 
 PERL_STATIC_INLINE unsigned int
-S__variant_byte_number(PERL_UINTMAX_T word)
+Perl_variant_byte_number(PERL_UINTMAX_T word)
 {
 
     /* This returns the position in a word (0..7) of the first variant byte in
@@ -499,7 +604,7 @@ S__variant_byte_number(PERL_UINTMAX_T word)
      *  Isolate the lsb;
      * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
      *
-     * The word will look this this, with a rightmost set bit in position 's':
+     * The word will look like this, with a rightmost set bit in position 's':
      * ('x's are don't cares)
      *      s
      *  x..x100..0
@@ -507,8 +612,8 @@ S__variant_byte_number(PERL_UINTMAX_T word)
      *  x..xx01..1      Subtract 1, turns all the trailing zeros into 1's and
      *                  the 1 just to their left into a 0; the remainder is
      *                  untouched
-     *  0..0011..1      The xor with x..xx10..0 clears that remainder, sets
-     *                  bottom to all 1
+     *  0..0011..1      The xor with the original, x..xx10..0, clears that
+     *                  remainder, sets the bottom to all 1
      *  0..0100..0      Add 1 to clear the word except for the bit in 's'
      *
      * Another method is to do 'word &= -word'; but it generates a compiler
@@ -544,8 +649,8 @@ S__variant_byte_number(PERL_UINTMAX_T word)
 #    error Unexpected byte order
 #  endif
 
-    /* Here 'word' has a single bit set, the  msb is of the first byte which
-     * has it set.  Calculate that position in the word.  We can use this
+    /* Here 'word' has a single bit set: the  msb of the first byte in which it
+     * is set.  Calculate that position in the word.  We can use this
      * specialized solution: https://stackoverflow.com/a/32339674/1626653,
      * assumes an 8-bit byte.  (On a 32-bit machine, the larger numbers should
      * just get shifted off at compile time) */
@@ -568,7 +673,7 @@ S__variant_byte_number(PERL_UINTMAX_T word)
     return (unsigned int) word;
 }
 
-#endif /* ! EBCDIC */
+#endif
 #if defined(PERL_CORE) || defined(PERL_EXT)
 
 /*
@@ -624,9 +729,11 @@ S_variant_under_utf8_count(const U8* const s, const U8* const e)
         /* Process per-word as long as we have at least a full word left */
         do {    /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
                    explanation of how this works */
-            count += ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
+            PERL_UINTMAX_T increment
+                = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
                       * PERL_COUNT_MULTIPLIER)
                     >> ((PERL_WORDSIZE - 1) * CHARBITS);
+            count += (Size_t) increment;
             x += PERL_WORDSIZE;
         } while (x + PERL_WORDSIZE <= e);
     }
@@ -635,7 +742,7 @@ S_variant_under_utf8_count(const U8* const s, const U8* const e)
 
     /* Process per-byte */
     while (x < e) {
-       if (! UTF8_IS_INVARIANT(*x)) {
+        if (! UTF8_IS_INVARIANT(*x)) {
             count++;
         }
 
@@ -713,7 +820,7 @@ at this low a level.  A valid use case could change that.
 */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
+Perl_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
 {
     const U8 * first_variant;
 
@@ -847,7 +954,7 @@ C<L</is_c9strict_utf8_string_loclen>>.
 */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
+Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
 {
     const U8 * first_variant;
 
@@ -969,6 +1076,206 @@ Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 
 /*
 
+=for apidoc isUTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
+that represents some code point; otherwise it evaluates to 0.  If non-zero, the
+value gives how many bytes starting at C<s> comprise the code point's
+representation.  Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
+
+The code point can be any that will fit in an IV on this machine, using Perl's
+extension to official UTF-8 to represent those higher than the Unicode maximum
+of 0x10FFFF.  That means that this macro is used to efficiently decide if the
+next few bytes in C<s> is legal UTF-8 for a single character.
+
+Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
+defined by Unicode to be fully interchangeable across applications;
+C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
+C<L</is_utf8_string_loclen>> to check entire strings.
+
+Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
+machines) is a valid UTF-8 character.
+
+=cut
+
+This uses an adaptation of the table and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version.  A copyright notice for the original
+version is given at the beginning of this file.  The Perl adapation is
+documented at the definition of PL_extended_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+    const U8 * s = s0;
+    UV state = 0;
+
+    PERL_ARGS_ASSERT_ISUTF8_CHAR;
+
+    /* This dfa is fast.  If it accepts the input, it was for a well-formed,
+     * code point, which can be returned immediately.  Otherwise, it is either
+     * malformed, or for the start byte FF which the dfa doesn't handle (except
+     * on 32-bit ASCII platforms where it trivially is an error).  Call a
+     * helper function for the other platforms. */
+
+    while (s < e && LIKELY(state != 1)) {
+        state = PL_extended_utf8_dfa_tab[256
+                                         + state
+                                         + PL_extended_utf8_dfa_tab[*s]];
+        if (state != 0) {
+            s++;
+            continue;
+        }
+
+        return s - s0 + 1;
+    }
+
+#if defined(UV_IS_QUAD) || defined(EBCDIC)
+
+    if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
+       return is_utf8_char_helper(s0, e, 0);
+    }
+
+#endif
+
+    return 0;
+}
+
+/*
+
+=for apidoc isSTRICT_UTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
+Unicode code point completely acceptable for open interchange between all
+applications; otherwise it evaluates to 0.  If non-zero, the value gives how
+many bytes starting at C<s> comprise the code point's representation.  Any
+bytes remaining before C<e>, but beyond the ones needed to form the first code
+point in C<s>, are not examined.
+
+The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
+be a surrogate nor a non-character code point.  Thus this excludes any code
+point from Perl's extended UTF-8.
+
+This is used to efficiently decide if the next few bytes in C<s> is
+legal Unicode-acceptable UTF-8 for a single character.
+
+Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
+#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
+code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
+and C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
+C<L</is_strict_utf8_string_loclen>> to check entire strings.
+
+=cut
+
+This uses an adaptation of the tables and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version.  A copyright notice for the original
+version is given at the beginning of this file.  The Perl adapation is
+documented at the definition of strict_extended_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+    const U8 * s = s0;
+    UV state = 0;
+
+    PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
+
+    while (s < e && LIKELY(state != 1)) {
+        state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
+
+        if (state != 0) {
+            s++;
+            continue;
+        }
+
+        return s - s0 + 1;
+    }
+
+#ifndef EBCDIC
+
+    /* The dfa above drops out for certain Hanguls; handle them specially */
+    if (is_HANGUL_ED_utf8_safe(s0, e)) {
+        return 3;
+    }
+
+#endif
+
+    return 0;
+}
+
+/*
+
+=for apidoc isC9_STRICT_UTF8_CHAR
+
+Evaluates to non-zero if the first few bytes of the string starting at C<s> and
+looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
+Unicode non-surrogate code point; otherwise it evaluates to 0.  If non-zero,
+the value gives how many bytes starting at C<s> comprise the code point's
+representation.  Any bytes remaining before C<e>, but beyond the ones needed to
+form the first code point in C<s>, are not examined.
+
+The largest acceptable code point is the Unicode maximum 0x10FFFF.  This
+differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
+code points.  This corresponds to
+L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
+which said that non-character code points are merely discouraged rather than
+completely forbidden in open interchange.  See
+L<perlunicode/Noncharacter code points>.
+
+Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
+C<L</isUTF8_CHAR_flags>> for a more customized definition.
+
+Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
+C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
+
+=cut
+
+This uses an adaptation of the tables and algorithm given in
+https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
+documentation of the original version.  A copyright notice for the original
+version is given at the beginning of this file.  The Perl adapation is
+documented at the definition of PL_c9_utf8_dfa_tab[].
+
+*/
+
+PERL_STATIC_INLINE Size_t
+Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
+{
+    const U8 * s = s0;
+    UV state = 0;
+
+    PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
+
+    while (s < e && LIKELY(state != 1)) {
+        state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
+
+        if (state != 0) {
+            s++;
+            continue;
+        }
+
+        return s - s0 + 1;
+    }
+
+    return 0;
+}
+
+/*
+
 =for apidoc is_strict_utf8_string_loc
 
 Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
@@ -998,7 +1305,7 @@ See also C<L</is_strict_utf8_string_loc>>.
 */
 
 PERL_STATIC_INLINE bool
-S_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 {
     const U8 * first_variant;
 
@@ -1075,7 +1382,7 @@ See also C<L</is_c9strict_utf8_string_loc>>.
 */
 
 PERL_STATIC_INLINE bool
-S_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
+Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
 {
     const U8 * first_variant;
 
@@ -1157,7 +1464,7 @@ See also C<L</is_utf8_string_loc_flags>>.
 */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
+Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
 {
     const U8 * first_variant;
 
@@ -1264,19 +1571,19 @@ Perl_utf8_hop(const U8 *s, SSize_t off)
      * In other words: in Perl UTF-8 is not just for Unicode. */
 
     if (off >= 0) {
-       while (off--)
-           s += UTF8SKIP(s);
+        while (off--)
+            s += UTF8SKIP(s);
     }
     else {
-       while (off++) {
-           s--;
-           while (UTF8_IS_CONTINUATION(*s))
-               s--;
-       }
+        while (off++) {
+            s--;
+            while (UTF8_IS_CONTINUATION(*s))
+                s--;
+        }
     }
-    GCC_DIAG_IGNORE_STMT(-Wcast-qual);
+    GCC_DIAG_IGNORE(-Wcast-qual)
     return (U8 *)s;
-    GCC_DIAG_RESTORE_STMT;
+    GCC_DIAG_RESTORE
 }
 
 /*
@@ -1311,16 +1618,16 @@ Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
     while (off--) {
         STRLEN skip = UTF8SKIP(s);
         if ((STRLEN)(end - s) <= skip) {
-            GCC_DIAG_IGNORE_STMT(-Wcast-qual);
+            GCC_DIAG_IGNORE(-Wcast-qual)
             return (U8 *)end;
-            GCC_DIAG_RESTORE_STMT;
+            GCC_DIAG_RESTORE
         }
         s += skip;
     }
 
-    GCC_DIAG_IGNORE_STMT(-Wcast-qual);
+    GCC_DIAG_IGNORE(-Wcast-qual)
     return (U8 *)s;
-    GCC_DIAG_RESTORE_STMT;
+    GCC_DIAG_RESTORE
 }
 
 /*
@@ -1353,14 +1660,14 @@ Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
     assert(off <= 0);
 
     while (off++ && s > start) {
-        s--;
-        while (UTF8_IS_CONTINUATION(*s) && s > start)
+        do {
             s--;
+        } while (UTF8_IS_CONTINUATION(*s) && s > start);
     }
-    
-    GCC_DIAG_IGNORE_STMT(-Wcast-qual);
+
+    GCC_DIAG_IGNORE(-Wcast-qual)
     return (U8 *)s;
-    GCC_DIAG_RESTORE_STMT;
+    GCC_DIAG_RESTORE
 }
 
 /*
@@ -1447,7 +1754,7 @@ determined from just the first one or two bytes.
  */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
+Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
 {
     PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
 
@@ -1458,7 +1765,7 @@ S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const
         return FALSE;
     }
 
-    return cBOOL(_is_utf8_char_helper(s, e, flags));
+    return cBOOL(is_utf8_char_helper(s, e, flags));
 }
 
 /*
@@ -1515,7 +1822,7 @@ complete, valid characters found in the C<el> pointer.
 */
 
 PERL_STATIC_INLINE bool
-S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
+Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
                                        STRLEN len,
                                        const U8 **ep,
                                        STRLEN *el,
@@ -1535,25 +1842,118 @@ S_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
            || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
 }
 
+PERL_STATIC_INLINE UV
+Perl_utf8n_to_uvchr_msgs(const U8 *s,
+                      STRLEN curlen,
+                      STRLEN *retlen,
+                      const U32 flags,
+                      U32 * errors,
+                      AV ** msgs)
+{
+    /* This is the inlined portion of utf8n_to_uvchr_msgs.  It handles the
+     * simple cases, and, if necessary calls a helper function to deal with the
+     * more complex ones.  Almost all well-formed non-problematic code points
+     * are considered simple, so that it's unlikely that the helper function
+     * will need to be called.
+     *
+     * This is an adaptation of the tables and algorithm given in
+     * https://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
+     * comprehensive documentation of the original version.  A copyright notice
+     * for the original version is given at the beginning of this file.  The
+     * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
+     */
+
+    const U8 * const s0 = s;
+    const U8 * send = s0 + curlen;
+    UV uv = 0;      /* The 0 silences some stupid compilers */
+    UV state = 0;
+
+    PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
+
+    /* This dfa is fast.  If it accepts the input, it was for a well-formed,
+     * non-problematic code point, which can be returned immediately.
+     * Otherwise we call a helper function to figure out the more complicated
+     * cases. */
+
+    while (s < send && LIKELY(state != 1)) {
+        UV type = PL_strict_utf8_dfa_tab[*s];
+
+        uv = (state == 0)
+             ?  ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
+             : UTF8_ACCUMULATE(uv, *s);
+        state = PL_strict_utf8_dfa_tab[256 + state + type];
+
+        if (state != 0) {
+            s++;
+            continue;
+        }
+
+        if (retlen) {
+            *retlen = s - s0 + 1;
+        }
+        if (errors) {
+            *errors = 0;
+        }
+        if (msgs) {
+            *msgs = NULL;
+        }
+
+        return UNI_TO_NATIVE(uv);
+    }
+
+    /* Here is potentially problematic.  Use the full mechanism */
+    return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
+}
+
+PERL_STATIC_INLINE UV
+Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
+{
+    PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
+
+    assert(s < send);
+
+    if (! ckWARN_d(WARN_UTF8)) {
+
+        /* EMPTY is not really allowed, and asserts on debugging builds.  But
+         * on non-debugging we have to deal with it, and this causes it to
+         * return the REPLACEMENT CHARACTER, as the documentation indicates */
+        return utf8n_to_uvchr(s, send - s, retlen,
+                              (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
+    }
+    else {
+        UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
+        if (retlen && ret == 0 && *s != '\0') {
+            *retlen = (STRLEN) -1;
+        }
+
+        return ret;
+    }
+}
+
 /* ------------------------------- perl.h ----------------------------- */
 
 /*
-=head1 Miscellaneous Functions
+=for apidoc_section $utility
 
-=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
+=for apidoc is_safe_syscall
 
-Test that the given C<pv> doesn't contain any internal C<NUL> characters.
-If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
+Test that the given C<pv> (with length C<len>) doesn't contain any internal
+C<NUL> characters.
+If it does, set C<errno> to C<ENOENT>, optionally warn using the C<syscalls>
+category, and return FALSE.
 
 Return TRUE if the name is safe.
 
+C<what> and C<op_name> are used in any warning.
+
 Used by the C<IS_SAFE_SYSCALL()> macro.
 
 =cut
 */
 
 PERL_STATIC_INLINE bool
-S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
+Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
+{
     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
      * perl itself uses xce*() functions which accept 8-bit strings.
      */
@@ -1594,7 +1994,8 @@ then calling:
 #ifdef PERL_CORE
 
 PERL_STATIC_INLINE bool
-S_should_warn_nl(const char *pv) {
+S_should_warn_nl(const char *pv)
+{
     STRLEN len;
 
     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
@@ -1606,13 +2007,53 @@ S_should_warn_nl(const char *pv) {
 
 #endif
 
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
+
+PERL_STATIC_INLINE bool
+S_lossless_NV_to_IV(const NV nv, IV *ivp)
+{
+    /* This function determines if the input NV 'nv' may be converted without
+     * loss of data to an IV.  If not, it returns FALSE taking no other action.
+     * But if it is possible, it does the conversion, returning TRUE, and
+     * storing the converted result in '*ivp' */
+
+    PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
+
+#  if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+    /* Normally any comparison with a NaN returns false; if we can't rely
+     * on that behaviour, check explicitly */
+    if (UNLIKELY(Perl_isnan(nv))) {
+        return FALSE;
+    }
+#  endif
+
+    /* Written this way so that with an always-false NaN comparison we
+     * return false */
+    if (!(LIKELY(nv >= (NV) IV_MIN) && LIKELY(nv < IV_MAX_P1))) {
+        return FALSE;
+    }
+
+    if ((IV) nv != nv) {
+        return FALSE;
+    }
+
+    *ivp = (IV) nv;
+    return TRUE;
+}
+
+#endif
+
 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_C) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
+
 #define MAX_CHARSET_NAME_LENGTH 2
 
 PERL_STATIC_INLINE const char *
-get_regex_charset_name(const U32 flags, STRLEN* const lenp)
+S_get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 {
+    PERL_ARGS_ASSERT_GET_REGEX_CHARSET_NAME;
+
     /* Returns a string that corresponds to the name of the regex character set
      * given by 'flags', and *lenp is set the length of that string, which
      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
@@ -1622,10 +2063,10 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
-       case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
-       case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
-           *lenp = 2;
-           return ASCII_MORE_RESTRICT_PAT_MODS;
+        case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
+        case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
+            *lenp = 2;
+            return ASCII_MORE_RESTRICT_PAT_MODS;
     }
     /* The NOT_REACHED; hides an assert() which has a rather complex
      * definition in perl.h. */
@@ -1633,6 +2074,8 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp)
     return "?";            /* Unknown */
 }
 
+#endif
+
 /*
 
 Return false if any get magic is on the SV other than taint magic.
@@ -1640,7 +2083,8 @@ Return false if any get magic is on the SV other than taint magic.
 */
 
 PERL_STATIC_INLINE bool
-S_sv_only_taint_gmagic(SV *sv) {
+Perl_sv_only_taint_gmagic(SV *sv)
+{
     MAGIC *mg = SvMAGIC(sv);
 
     PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
@@ -1659,11 +2103,28 @@ S_sv_only_taint_gmagic(SV *sv) {
 
 /* ------------------ cop.h ------------------------------------------- */
 
+/* implement GIMME_V() macro */
+
+PERL_STATIC_INLINE U8
+Perl_gimme_V(pTHX)
+{
+    I32 cxix;
+    U8  gimme = (PL_op->op_flags & OPf_WANT);
+
+    if (gimme)
+        return gimme;
+    cxix = PL_curstackinfo->si_cxsubix;
+    if (cxix < 0)
+        return PL_curstackinfo->si_type == PERLSI_SORT ? G_SCALAR: G_VOID;
+    assert(cxstack[cxix].blk_gimme & G_WANT);
+    return (cxstack[cxix].blk_gimme & G_WANT);
+}
+
 
 /* Enter a block. Push a new base context and return its address. */
 
 PERL_STATIC_INLINE PERL_CONTEXT *
-S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
+Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
 {
     PERL_CONTEXT * cx;
 
@@ -1690,7 +2151,7 @@ S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
 /* Exit a block (RETURN and LAST). */
 
 PERL_STATIC_INLINE void
-S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_POPBLOCK;
 
@@ -1715,7 +2176,7 @@ S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
  * *after* cx_pushblock() was called. */
 
 PERL_STATIC_INLINE void
-S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_TOPBLOCK;
 
@@ -1730,13 +2191,15 @@ S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
+Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
 {
     U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
 
     PERL_ARGS_ASSERT_CX_PUSHSUB;
 
     PERL_DTRACE_PROBE_ENTRY(cv);
+    cx->blk_sub.old_cxsubix     = PL_curstackinfo->si_cxsubix;
+    PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
     cx->blk_sub.cv = cv;
     cx->blk_sub.olddepth = CvDEPTH(cv);
     cx->blk_sub.prevcomppad = PL_comppad;
@@ -1750,7 +2213,7 @@ S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
 /* subsets of cx_popsub() */
 
 PERL_STATIC_INLINE void
-S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
 {
     CV *cv;
 
@@ -1763,13 +2226,14 @@ S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
     CvDEPTH(cv) = cx->blk_sub.olddepth;
     cx->blk_sub.cv = NULL;
     SvREFCNT_dec(cv);
+    PL_curstackinfo->si_cxsubix = cx->blk_sub.old_cxsubix;
 }
 
 
 /* handle the @_ part of leaving a sub */
 
 PERL_STATIC_INLINE void
-S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
 {
     AV *av;
 
@@ -1791,7 +2255,7 @@ S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_POPSUB;
     assert(CxTYPE(cx) == CXt_SUB);
@@ -1805,10 +2269,12 @@ S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
+Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
 {
     PERL_ARGS_ASSERT_CX_PUSHFORMAT;
 
+    cx->blk_format.old_cxsubix = PL_curstackinfo->si_cxsubix;
+    PL_curstackinfo->si_cxsubix= cx - PL_curstackinfo->si_cxstack;
     cx->blk_format.cv          = cv;
     cx->blk_format.retop       = retop;
     cx->blk_format.gv          = gv;
@@ -1823,7 +2289,7 @@ S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
 
 
 PERL_STATIC_INLINE void
-S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
 {
     CV *cv;
     GV *dfout;
@@ -1842,14 +2308,13 @@ S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
     cx->blk_format.cv = NULL;
     --CvDEPTH(cv);
     SvREFCNT_dec_NN(cv);
+    PL_curstackinfo->si_cxsubix = cx->blk_format.old_cxsubix;
 }
 
 
 PERL_STATIC_INLINE void
-S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
+Perl_push_evalortry_common(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
 {
-    PERL_ARGS_ASSERT_CX_PUSHEVAL;
-
     cx->blk_eval.retop         = retop;
     cx->blk_eval.old_namesv    = namesv;
     cx->blk_eval.old_eval_root = PL_eval_root;
@@ -1862,9 +2327,32 @@ S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
     cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
 }
 
+PERL_STATIC_INLINE void
+Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
+{
+    PERL_ARGS_ASSERT_CX_PUSHEVAL;
+
+    Perl_push_evalortry_common(aTHX_ cx, retop, namesv);
+
+    cx->blk_eval.old_cxsubix    = PL_curstackinfo->si_cxsubix;
+    PL_curstackinfo->si_cxsubix = cx - PL_curstackinfo->si_cxstack;
+}
+
+PERL_STATIC_INLINE void
+Perl_cx_pushtry(pTHX_ PERL_CONTEXT *cx, OP *retop)
+{
+    PERL_ARGS_ASSERT_CX_PUSHTRY;
+
+    Perl_push_evalortry_common(aTHX_ cx, retop, NULL);
+
+    /* Don't actually change it, just store the current value so it's restored
+     * by the common popeval */
+    cx->blk_eval.old_cxsubix = PL_curstackinfo->si_cxsubix;
+}
+
 
 PERL_STATIC_INLINE void
-S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
 {
     SV *sv;
 
@@ -1885,6 +2373,7 @@ S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
         cx->blk_eval.old_namesv = NULL;
         SvREFCNT_dec_NN(sv);
     }
+    PL_curstackinfo->si_cxsubix = cx->blk_eval.old_cxsubix;
 }
 
 
@@ -1896,7 +2385,7 @@ S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
  */
 
 PERL_STATIC_INLINE void
-S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
     cx->blk_loop.my_op = cLOOP;
@@ -1908,7 +2397,7 @@ S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
  */
 
 PERL_STATIC_INLINE void
-S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
+Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 {
     PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
 
@@ -1926,7 +2415,7 @@ S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
 /* pop all loop types, including plain */
 
 PERL_STATIC_INLINE void
-S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_POPLOOP;
 
@@ -1959,7 +2448,7 @@ S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_PUSHWHEN;
 
@@ -1968,7 +2457,7 @@ S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
 {
     PERL_ARGS_ASSERT_CX_POPWHEN;
     assert(CxTYPE(cx) == CXt_WHEN);
@@ -1980,7 +2469,7 @@ S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
 
 
 PERL_STATIC_INLINE void
-S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
+Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
 {
     PERL_ARGS_ASSERT_CX_PUSHGIVEN;
 
@@ -1990,7 +2479,7 @@ S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
 
 
 PERL_STATIC_INLINE void
-S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
+Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
 {
     SV *sv;
 
@@ -2006,7 +2495,7 @@ S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
 /* ------------------ util.h ------------------------------------------- */
 
 /*
-=head1 Miscellaneous Functions
+=for apidoc_section $string
 
 =for apidoc foldEQ
 
@@ -2030,9 +2519,9 @@ Perl_foldEQ(const char *s1, const char *s2, I32 len)
     assert(len >= 0);
 
     while (len--) {
-       if (*a != *b && *a != PL_fold[*b])
-           return 0;
-       a++,b++;
+        if (*a != *b && *a != PL_fold[*b])
+            return 0;
+        a++,b++;
     }
     return 1;
 }
@@ -2040,10 +2529,10 @@ Perl_foldEQ(const char *s1, const char *s2, I32 len)
 PERL_STATIC_INLINE I32
 Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
 {
-    /* Compare non-utf8 using Unicode (Latin1) semantics.  Does not work on
-     * MICRO_SIGN, LATIN_SMALL_LETTER_SHARP_S, nor
-     * LATIN_SMALL_LETTER_Y_WITH_DIAERESIS, and does not check for these.  Nor
-     * does it check that the strings each have at least 'len' characters */
+    /* Compare non-UTF-8 using Unicode (Latin1) semantics.  Works on all folds
+     * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
+     * does not check for this.  Nor does it check that the strings each have
+     * at least 'len' characters. */
 
     const U8 *a = (const U8 *)s1;
     const U8 *b = (const U8 *)s2;
@@ -2053,15 +2542,16 @@ Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
     assert(len >= 0);
 
     while (len--) {
-       if (*a != *b && *a != PL_fold_latin1[*b]) {
-           return 0;
-       }
-       a++, b++;
+        if (*a != *b && *a != PL_fold_latin1[*b]) {
+            return 0;
+        }
+        a++, b++;
     }
     return 1;
 }
 
 /*
+=for apidoc_section $locale
 =for apidoc foldEQ_locale
 
 Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
@@ -2073,7 +2563,6 @@ same case-insensitively in the current locale; false otherwise.
 PERL_STATIC_INLINE I32
 Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
 {
-    dVAR;
     const U8 *a = (const U8 *)s1;
     const U8 *b = (const U8 *)s2;
 
@@ -2082,13 +2571,44 @@ Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
     assert(len >= 0);
 
     while (len--) {
-       if (*a != *b && *a != PL_fold_locale[*b])
-           return 0;
-       a++,b++;
+        if (*a != *b && *a != PL_fold_locale[*b])
+            return 0;
+        a++,b++;
     }
     return 1;
 }
 
+/*
+=for apidoc_section $string
+=for apidoc my_strnlen
+
+The C library C<strnlen> if available, or a Perl implementation of it.
+
+C<my_strnlen()> computes the length of the string, up to C<maxlen>
+characters.  It will never attempt to address more than C<maxlen>
+characters, making it suitable for use with strings that are not
+guaranteed to be NUL-terminated.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strnlen.3,
+implementation stolen from PostgreSQL.
+*/
+#ifndef HAS_STRNLEN
+
+PERL_STATIC_INLINE Size_t
+Perl_my_strnlen(const char *str, Size_t maxlen)
+{
+    const char *end = (char *) memchr(str, '\0', maxlen);
+
+    PERL_ARGS_ASSERT_MY_STRNLEN;
+
+    if (end == NULL) return maxlen;
+    return end - str;
+}
+
+#endif
+
 #if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
 
 PERL_STATIC_INLINE void *
@@ -2112,6 +2632,204 @@ S_my_memrchr(const char * s, const char c, const STRLEN len)
 
 #endif
 
+PERL_STATIC_INLINE char *
+Perl_mortal_getenv(const char * str)
+{
+    /* This implements a (mostly) thread-safe, sequential-call-safe getenv().
+     *
+     * It's (mostly) thread-safe because it uses a mutex to prevent other
+     * threads (that look at this mutex) from destroying the result before this
+     * routine has a chance to copy the result to a place that won't be
+     * destroyed before the caller gets a chance to handle it.  That place is a
+     * mortal SV.  khw chose this over SAVEFREEPV because he is under the
+     * impression that the SV will hang around longer under more circumstances
+     *
+     * The reason it isn't completely thread-safe is that other code could
+     * simply not pay attention to the mutex.  All of the Perl core uses the
+     * mutex, but it is possible for code from, say XS, to not use this mutex,
+     * defeating the safety.
+     *
+     * getenv() returns, in some implementations, a pointer to a spot in the
+     * **environ array, which could be invalidated at any time by this or
+     * another thread changing the environment.  Other implementations copy the
+     * **environ value to a static buffer, returning a pointer to that.  That
+     * buffer might or might not be invalidated by a getenv() call in another
+     * thread.  If it does get zapped, we need an exclusive lock.  Otherwise,
+     * many getenv() calls can safely be running simultaneously, so a
+     * many-reader (but no simultaneous writers) lock is ok.  There is a
+     * Configure probe to see if another thread destroys the buffer, and the
+     * mutex is defined accordingly.
+     *
+     * But in all cases, using the mutex prevents these problems, as long as
+     * all code uses the same mutex..
+     *
+     * A complication is that this can be called during phases where the
+     * mortalization process isn't available.  These are in interpreter
+     * destruction or early in construction.  khw believes that at these times
+     * there shouldn't be anything else going on, so plain getenv is safe AS
+     * LONG AS the caller acts on the return before calling it again. */
+
+    char * ret;
+    dTHX;
+
+    PERL_ARGS_ASSERT_MORTAL_GETENV;
+
+    /* Can't mortalize without stacks.  khw believes that no other threads
+     * should be running, so no need to lock things, and this may be during a
+     * phase when locking isn't even available */
+    if (UNLIKELY(PL_scopestack_ix == 0)) {
+        return getenv(str);
+    }
+
+#ifdef PERL_MEM_LOG
+
+    /* A major complication arises under PERL_MEM_LOG.  When that is active,
+     * every memory allocation may result in logging, depending on the value of
+     * ENV{PERL_MEM_LOG} at the moment.  That means, as we create the SV for
+     * saving ENV{foo}'s value (but before saving it), the logging code will
+     * call us recursively to find out what ENV{PERL_MEM_LOG} is.  Without some
+     * care that could lead to: 1) infinite recursion; or 2) deadlock (trying to
+     * lock a boolean mutex recursively); 3) destroying the getenv() static
+     * buffer; or 4) destroying the temporary created by this for the copy
+     * causes a log entry to be made which could cause a new temporary to be
+     * created, which will need to be destroyed at some point, leading to an
+     * infinite loop.
+     *
+     * The solution adopted here (after some gnashing of teeth) is to detect
+     * the recursive calls and calls from the logger, and treat them specially.
+     * Let's say we want to do getenv("foo").  We first find
+     * getenv(PERL_MEM_LOG) and save it to a fixed-length per-interpreter
+     * variable, so no temporary is required.  Then we do getenv(foo}, and in
+     * the process of creating a temporary to save it, this function will be
+     * called recursively to do a getenv(PERL_MEM_LOG).  On the recursed call,
+     * we detect that it is such a call and return our saved value instead of
+     * locking and doing a new getenv().  This solves all of problems 1), 2),
+     * and 3).  Because all the getenv()s are done while the mutex is locked,
+     * the state cannot have changed.  To solve 4), we don't create a temporary
+     * when this is called from the logging code.  That code disposes of the
+     * return value while the mutex is still locked.
+     *
+     * The value of getenv(PERL_MEM_LOG) can be anything, but only initial
+     * digits and 3 particular letters are significant; the rest are ignored by
+     * the memory logging code.  Thus the per-interpreter variable only needs
+     * to be large enough to save the significant information, the size of
+     * which is known at compile time.  The first byte is extra, reserved for
+     * flags for our use.  To protect against overflowing, only the reserved
+     * byte, as many digits as don't overflow, and the three letters are
+     * stored.
+     *
+     * The reserved byte has two bits:
+     *      0x1 if set indicates that if we get here, it is a recursive call of
+     *          getenv()
+     *      0x2 if set indicates that the call is from the logging code.
+     *
+     * If the flag indicates this is a recursive call, just return the stored
+     * value of PL_mem_log;  An empty value gets turned into NULL. */
+    if (strEQ(str, "PERL_MEM_LOG") && PL_mem_log[0] & 0x1) {
+        if (PL_mem_log[1] == '\0') {
+            return NULL;
+        } else {
+            return PL_mem_log + 1;
+        }
+    }
+
+#endif
+
+    GETENV_LOCK;
+
+#ifdef PERL_MEM_LOG
+
+    /* Here we are in a critical section.  As explained above, we do our own
+     * getenv(PERL_MEM_LOG), saving the result safely. */
+    ret = getenv("PERL_MEM_LOG");
+    if (ret == NULL) {  /* No logging active */
+
+        /* Return that immediately if called from the logging code */
+        if (PL_mem_log[0] & 0x2) {
+            GETENV_UNLOCK;
+            return NULL;
+        }
+
+        PL_mem_log[1] = '\0';
+    }
+    else {
+        char *mem_log_meat = PL_mem_log + 1;    /* first byte reserved */
+
+        /* There is nothing to prevent the value of PERL_MEM_LOG from being an
+         * extremely long string.  But we want only a few characters from it.
+         * PL_mem_log has been made large enough to hold just the ones we need.
+         * First the file descriptor. */
+        if (isDIGIT(*ret)) {
+            const char * s = ret;
+            if (UNLIKELY(*s == '0')) {
+
+                /* Reduce multiple leading zeros to a single one.  This is to
+                 * allow the caller to change what to do with leading zeros. */
+                *mem_log_meat++ = '0';
+                s++;
+                while (*s == '0') {
+                    s++;
+                }
+            }
+
+            /* If the input overflows, copy just enough for the result to also
+             * overflow, plus 1 to make sure */
+            while (isDIGIT(*s) && s < ret + TYPE_DIGITS(UV) + 1) {
+                *mem_log_meat++ = *s++;
+            }
+        }
+
+        /* Then each of the three significant characters */
+        if (strchr(ret, 'm')) {
+            *mem_log_meat++ = 'm';
+        }
+        if (strchr(ret, 's')) {
+            *mem_log_meat++ = 's';
+        }
+        if (strchr(ret, 't')) {
+            *mem_log_meat++ = 't';
+        }
+        *mem_log_meat = '\0';
+
+        assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
+    }
+
+    /* If we are being called from the logger, it only needs the significant
+     * portion of PERL_MEM_LOG, and doesn't need a safe copy */
+    if (PL_mem_log[0] & 0x2) {
+        assert(strEQ(str, "PERL_MEM_LOG"));
+        GETENV_UNLOCK;
+        return PL_mem_log + 1;
+    }
+
+    /* Here is a generic getenv().  This could be a getenv("PERL_MEM_LOG") that
+     * is coming from other than the logging code, so it should be treated the
+     * same as any other getenv(), returning the full value, not just the
+     * significant part, and having its value saved.  Set the flag that
+     * indicates any call to this routine will be a recursion from here */
+    PL_mem_log[0] = 0x1;
+
+#endif
+
+    /* Now get the value of the real desired variable, and save a copy */
+    ret = getenv(str);
+
+    if (ret != NULL) {
+        ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+    }
+
+    GETENV_UNLOCK;
+
+#ifdef PERL_MEM_LOG
+
+    /* Clear the buffer */
+    Zero(PL_mem_log, sizeof(PL_mem_log), char);
+
+#endif
+
+    return ret;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */