summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h
diff options
context:
space:
mode:
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h')
-rwxr-xr-xsystems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h1578
1 files changed, 1254 insertions, 324 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h
index bbf27da6f5..90930184da 100755
--- a/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h
+++ b/systems/texlive/tlnet/tlpkg/tlperl/lib/CORE/inline.h
@@ -34,6 +34,10 @@ SOFTWARE.
* header files, because they depend on proto.h (included after most other
* headers) or struct definitions.
*
+ * Note also perlstatic.h for functions that can't or shouldn't be inlined, but
+ * whose details should be exposed to the compiler, for such things as tail
+ * call optimization.
+ *
* Each section names the header file that the functions "belong" to.
*/
@@ -57,6 +61,161 @@ Perl_av_count(pTHX_ AV *av)
return AvFILL(av) + 1;
}
+/* ------------------------------- av.c ------------------------------- */
+
+/*
+=for apidoc av_store_simple
+
+This is a cut-down version of av_store that assumes that the array is
+very straightforward - no magic, not readonly, and AvREAL - and that
+C<key> is not negative. This function MUST NOT be used in situations
+where any of those assumptions may not hold.
+
+Stores an SV in an array. The array index is specified as C<key>. It
+can be dereferenced to get the C<SV*> that was stored there (= C<val>)).
+
+Note that the caller is responsible for suitably incrementing the reference
+count of C<val> before the call.
+
+Approximate Perl equivalent: C<splice(@myarray, $key, 1, $val)>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE SV**
+Perl_av_store_simple(pTHX_ AV *av, SSize_t key, SV *val)
+{
+ SV** ary;
+
+ PERL_ARGS_ASSERT_AV_STORE_SIMPLE;
+ assert(SvTYPE(av) == SVt_PVAV);
+ assert(!SvMAGICAL(av));
+ assert(!SvREADONLY(av));
+ assert(AvREAL(av));
+ assert(key > -1);
+
+ ary = AvARRAY(av);
+
+ if (AvFILLp(av) < key) {
+ if (key > AvMAX(av)) {
+ av_extend(av,key);
+ ary = AvARRAY(av);
+ }
+ AvFILLp(av) = key;
+ } else
+ SvREFCNT_dec(ary[key]);
+
+ ary[key] = val;
+ return &ary[key];
+}
+
+/*
+=for apidoc av_fetch_simple
+
+This is a cut-down version of av_fetch that assumes that the array is
+very straightforward - no magic, not readonly, and AvREAL - and that
+C<key> is not negative. This function MUST NOT be used in situations
+where any of those assumptions may not hold.
+
+Returns the SV at the specified index in the array. The C<key> is the
+index. If lval is true, you are guaranteed to get a real SV back (in case
+it wasn't real before), which you can then modify. Check that the return
+value is non-null before dereferencing it to a C<SV*>.
+
+The rough perl equivalent is C<$myarray[$key]>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE SV**
+Perl_av_fetch_simple(pTHX_ AV *av, SSize_t key, I32 lval)
+{
+ PERL_ARGS_ASSERT_AV_FETCH_SIMPLE;
+ assert(SvTYPE(av) == SVt_PVAV);
+ assert(!SvMAGICAL(av));
+ assert(!SvREADONLY(av));
+ assert(AvREAL(av));
+ assert(key > -1);
+
+ if ( (key > AvFILLp(av)) || !AvARRAY(av)[key]) {
+ return lval ? av_store_simple(av,key,newSV_type(SVt_NULL)) : NULL;
+ } else {
+ return &AvARRAY(av)[key];
+ }
+}
+
+/*
+=for apidoc av_push_simple
+
+This is a cut-down version of av_push that assumes that the array is very
+straightforward - no magic, not readonly, and AvREAL - and that C<key> is
+not less than -1. This function MUST NOT be used in situations where any
+of those assumptions may not hold.
+
+Pushes an SV (transferring control of one reference count) onto the end of the
+array. The array will grow automatically to accommodate the addition.
+
+Perl equivalent: C<push @myarray, $val;>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE void
+Perl_av_push_simple(pTHX_ AV *av, SV *val)
+{
+ PERL_ARGS_ASSERT_AV_PUSH_SIMPLE;
+ assert(SvTYPE(av) == SVt_PVAV);
+ assert(!SvMAGICAL(av));
+ assert(!SvREADONLY(av));
+ assert(AvREAL(av));
+ assert(AvFILLp(av) > -2);
+
+ (void)av_store_simple(av,AvFILLp(av)+1,val);
+}
+
+/*
+=for apidoc av_new_alloc
+
+This implements L<perlapi/C<newAV_alloc_x>>
+and L<perlapi/C<newAV_alloc_xz>>, which are the public API for this
+functionality.
+
+Creates a new AV and allocates its SV* array.
+
+This is similar to, but more efficient than doing:
+
+ AV *av = newAV();
+ av_extend(av, key);
+
+The size parameter is used to pre-allocate a SV* array large enough to
+hold at least elements C<0..(size-1)>. C<size> must be at least 1.
+
+The C<zeroflag> parameter controls whether or not the array is NULL
+initialized.
+
+=cut
+*/
+
+PERL_STATIC_INLINE AV *
+Perl_av_new_alloc(pTHX_ SSize_t size, bool zeroflag)
+{
+ AV * const av = newAV();
+ SV** ary;
+ PERL_ARGS_ASSERT_AV_NEW_ALLOC;
+ assert(size > 0);
+
+ Newx(ary, size, SV*); /* Newx performs the memwrap check */
+ AvALLOC(av) = ary;
+ AvARRAY(av) = ary;
+ AvMAX(av) = size - 1;
+
+ if (zeroflag)
+ Zero(ary, size, SV*);
+
+ return av;
+}
+
+
/* ------------------------------- cv.h ------------------------------- */
/*
@@ -76,6 +235,13 @@ Perl_CvGV(pTHX_ CV *sv)
: ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
}
+/*
+=for apidoc CvDEPTH
+Returns the recursion level of the CV C<sv>. Hence >= 2 indicates we are in a
+recursive call.
+
+=cut
+*/
PERL_STATIC_INLINE I32 *
Perl_CvDEPTH(const CV * const sv)
{
@@ -115,6 +281,25 @@ S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
}
#endif
+/* ------------------------------- iperlsys.h ------------------------------- */
+#if ! defined(PERL_IMPLICIT_SYS) && defined(USE_ITHREADS)
+
+/* Otherwise this function is implemented as macros in iperlsys.h */
+
+PERL_STATIC_INLINE bool
+S_PerlEnv_putenv(pTHX_ char * str)
+{
+ PERL_ARGS_ASSERT_PERLENV_PUTENV;
+
+ ENV_LOCK;
+ bool retval = putenv(str);
+ ENV_UNLOCK;
+
+ return retval;
+}
+
+#endif
+
/* ------------------------------- mg.h ------------------------------- */
#if defined(PERL_CORE) || defined(PERL_EXT)
@@ -197,6 +382,21 @@ Perl_POPMARK(pTHX)
/* ----------------------------- regexp.h ----------------------------- */
+/* PVLVs need to act as a superset of all scalar types - they are basically
+ * PVMGs with a few extra fields.
+ * REGEXPs are first class scalars, but have many fields that can't be copied
+ * into a PVLV body.
+ *
+ * Hence we take a different approach - instead of a copy, PVLVs store a pointer
+ * back to the original body. To avoid increasing the size of PVLVs just for the
+ * rare case of REGEXP assignment, this pointer is stored in the memory usually
+ * used for SvLEN(). Hence the check for SVt_PVLV below, and the ? : ternary to
+ * read the pointer from the two possible locations. The macro SvLEN() wraps the
+ * access to the union's member xpvlenu_len, but there is no equivalent macro
+ * for wrapping the union's member xpvlenu_rx, hence the direct reference here.
+ *
+ * See commit df6b4bd56551f2d3 for more details. */
+
PERL_STATIC_INLINE struct regexp *
Perl_ReANY(const REGEXP * const re)
{
@@ -209,154 +409,6 @@ Perl_ReANY(const REGEXP * const re)
: (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 *
-Perl_SvREFCNT_inc(SV *sv)
-{
- if (LIKELY(sv != NULL))
- SvREFCNT(sv)++;
- return sv;
-}
-PERL_STATIC_INLINE SV *
-Perl_SvREFCNT_inc_NN(SV *sv)
-{
- PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
-
- SvREFCNT(sv)++;
- return sv;
-}
-PERL_STATIC_INLINE void
-Perl_SvREFCNT_inc_void(SV *sv)
-{
- if (LIKELY(sv != NULL))
- SvREFCNT(sv)++;
-}
-PERL_STATIC_INLINE void
-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);
- }
-}
-
-PERL_STATIC_INLINE void
-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;
- else
- Perl_sv_free2(aTHX_ sv, rc);
-}
-
-PERL_STATIC_INLINE void
-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
-Perl_SvAMAGIC_off(SV *sv)
-{
- PERL_ARGS_ASSERT_SVAMAGIC_OFF;
-
- if (SvROK(sv) && SvOBJECT(SvRV(sv)))
- HvAMAGIC_off(SvSTASH(SvRV(sv)));
-}
-
-PERL_STATIC_INLINE U32
-Perl_SvPADSTALE_on(SV *sv)
-{
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
- return SvFLAGS(sv) |= SVs_PADSTALE;
-}
-PERL_STATIC_INLINE U32
-Perl_SvPADSTALE_off(SV *sv)
-{
- assert(!(SvFLAGS(sv) & SVs_PADTMP));
- return SvFLAGS(sv) &= ~SVs_PADSTALE;
-}
-#if defined(PERL_CORE) || defined (PERL_EXT)
-PERL_STATIC_INLINE STRLEN
-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);
- }
- return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
-}
-#endif
-
/* ------------------------------- utf8.h ------------------------------- */
/*
@@ -535,7 +587,7 @@ Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
/* Here, we know we have at least one full word to process. Process
* per-word as long as we have at least a full word left */
do {
- if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
+ if ((* (const PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
/* Found a variant. Just return if caller doesn't want its
* exact position */
@@ -546,7 +598,7 @@ Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
|| BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
- *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
+ *ep = x + variant_byte_number(* (const PERL_UINTMAX_T *) x);
assert(*ep >= s && *ep < send);
return FALSE;
@@ -581,96 +633,420 @@ Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
return TRUE;
}
-#ifndef EBCDIC
+/* See if the platform has builtins for finding the most/least significant bit,
+ * and which one is right for using on 32 and 64 bit operands */
+#if (__has_builtin(__builtin_clz) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == INTSIZE
+# define PERL_CLZ_32 __builtin_clz
+# endif
+# if defined(U64TYPE) && U64SIZE == INTSIZE
+# define PERL_CLZ_64 __builtin_clz
+# endif
+#endif
+#if (__has_builtin(__builtin_ctz) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == INTSIZE
+# define PERL_CTZ_32 __builtin_ctz
+# endif
+# if defined(U64TYPE) && U64SIZE == INTSIZE
+# define PERL_CTZ_64 __builtin_ctz
+# endif
+#endif
-PERL_STATIC_INLINE unsigned int
-Perl_variant_byte_number(PERL_UINTMAX_T word)
+#if (__has_builtin(__builtin_clzl) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == LONGSIZE && ! defined(PERL_CLZ_32)
+# define PERL_CLZ_32 __builtin_clzl
+# endif
+# if defined(U64TYPE) && U64SIZE == LONGSIZE && ! defined(PERL_CLZ_64)
+# define PERL_CLZ_64 __builtin_clzl
+# endif
+#endif
+#if (__has_builtin(__builtin_ctzl) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == LONGSIZE && ! defined(PERL_CTZ_32)
+# define PERL_CTZ_32 __builtin_ctzl
+# endif
+# if defined(U64TYPE) && U64SIZE == LONGSIZE && ! defined(PERL_CTZ_64)
+# define PERL_CTZ_64 __builtin_ctzl
+# endif
+#endif
+
+#if (__has_builtin(__builtin_clzll) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == LONGLONGSIZE && ! defined(PERL_CLZ_32)
+# define PERL_CLZ_32 __builtin_clzll
+# endif
+# if defined(U64TYPE) && U64SIZE == LONGLONGSIZE && ! defined(PERL_CLZ_64)
+# define PERL_CLZ_64 __builtin_clzll
+# endif
+#endif
+#if (__has_builtin(__builtin_ctzll) || PERL_GCC_VERSION_GE(3,4,0))
+# if U32SIZE == LONGLONGSIZE && ! defined(PERL_CTZ_32)
+# define PERL_CTZ_32 __builtin_ctzll
+# endif
+# if defined(U64TYPE) && U64SIZE == LONGLONGSIZE && ! defined(PERL_CTZ_64)
+# define PERL_CTZ_64 __builtin_ctzll
+# endif
+#endif
+
+#if defined(_MSC_VER)
+# include <intrin.h>
+# pragma intrinsic(_BitScanForward)
+# pragma intrinsic(_BitScanReverse)
+# ifdef _WIN64
+# pragma intrinsic(_BitScanForward64)
+# pragma intrinsic(_BitScanReverse64)
+# endif
+#endif
+
+/* The reason there are not checks to see if ffs() and ffsl() are available for
+ * determining the lsb, is because these don't improve on the deBruijn method
+ * fallback, which is just a branchless integer multiply, array element
+ * retrieval, and shift. The others, even if the function call overhead is
+ * optimized out, have to cope with the possibility of the input being all
+ * zeroes, and almost certainly will have conditionals for this eventuality.
+ * khw, at the time of this commit, looked at the source for both gcc and clang
+ * to verify this. (gcc used a method inferior to deBruijn.) */
+
+/* Below are functions to find the first, last, or only set bit in a word. On
+ * platforms with 64-bit capability, there is a pair for each operation; the
+ * first taking a 64 bit operand, and the second a 32 bit one. The logic is
+ * the same in each pair, so the second is stripped of most comments. */
+
+#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
+
+PERL_STATIC_INLINE unsigned
+Perl_lsbit_pos64(U64 word)
{
+ /* Find the position (0..63) of the least significant set bit in the input
+ * word */
- /* This returns the position in a word (0..7) of the first variant byte in
- * it. This is a helper function. Note that there are no branches */
+ ASSUME(word != 0);
- assert(word);
+ /* If we can determine that the platform has a usable fast method to get
+ * this info, use that */
- /* Get just the msb bits of each byte */
- word &= PERL_VARIANTS_WORD_MASK;
+# if defined(PERL_CTZ_64)
+# define PERL_HAS_FAST_GET_LSB_POS64
-# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+ return (unsigned) PERL_CTZ_64(word);
- /* Bytes are stored like
- * Byte8 ... Byte2 Byte1
- * 63..56...15...8 7...0
+# elif U64SIZE == 8 && defined(_WIN64) && defined(_MSC_VER)
+# define PERL_HAS_FAST_GET_LSB_POS64
+
+ {
+ unsigned long index;
+ _BitScanForward64(&index, word);
+ return (unsigned)index;
+ }
+
+# else
+
+ /* Here, we didn't find a fast method for finding the lsb. Fall back to
+ * making the lsb the only set bit in the word, and use our function that
+ * works on words with a single bit set.
*
- * Isolate the lsb;
+ * Isolate the lsb;
* https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
*
* The word will look like this, with a rightmost set bit in position 's':
- * ('x's are don't cares)
+ * ('x's are don't cares, and 'y's are their complements)
* s
- * x..x100..0
- * x..xx10..0 Right shift (rightmost 0 is shifted off)
- * 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 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'
+ * x..x100..00
+ * y..y011..11 Complement
+ * y..y100..00 Add 1
+ * 0..0100..00 And with the original
*
- * Another method is to do 'word &= -word'; but it generates a compiler
- * message on some platforms about taking the negative of an unsigned */
+ * (Yes, complementing and adding 1 is just taking the negative on 2's
+ * complement machines, but not on 1's complement ones, and some compilers
+ * complain about negating an unsigned.)
+ */
+ return single_1bit_pos64(word & (~word + 1));
- word >>= 1;
- word = 1 + (word ^ (word - 1));
+# endif
-# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+}
- /* Bytes are stored like
- * Byte1 Byte2 ... Byte8
- * 63..56 55..47 ... 7...0
+# define lsbit_pos_uintmax_(word) lsbit_pos64(word)
+#else /* ! QUAD */
+# define lsbit_pos_uintmax_(word) lsbit_pos32(word)
+#endif
+
+PERL_STATIC_INLINE unsigned /* Like above for 32 bit word */
+Perl_lsbit_pos32(U32 word)
+{
+ /* Find the position (0..31) of the least significant set bit in the input
+ * word */
+
+ ASSUME(word != 0);
+
+#if defined(PERL_CTZ_32)
+# define PERL_HAS_FAST_GET_LSB_POS32
+
+ return (unsigned) PERL_CTZ_32(word);
+
+#elif U32SIZE == 4 && defined(_MSC_VER)
+# define PERL_HAS_FAST_GET_LSB_POS32
+
+ {
+ unsigned long index;
+ _BitScanForward(&index, word);
+ return (unsigned)index;
+ }
+
+#else
+
+ return single_1bit_pos32(word & (~word + 1));
+
+#endif
+
+}
+
+
+/* Convert the leading zeros count to the bit position of the first set bit.
+ * This just subtracts from the highest position, 31 or 63. But some compilers
+ * don't optimize this optimally, and so a bit of bit twiddling encourages them
+ * to do the right thing. It turns out that subtracting a smaller non-negative
+ * number 'x' from 2**n-1 for any n is the same as taking the exclusive-or of
+ * the two numbers. To see why, first note that the sum of any number, x, and
+ * its complement, x', is all ones. So all ones minus x is x'. Then note that
+ * the xor of x and all ones is x'. */
+#define LZC_TO_MSBIT_POS_(size, lzc) ((size##SIZE * CHARBITS - 1) ^ (lzc))
+
+#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
+
+PERL_STATIC_INLINE unsigned
+Perl_msbit_pos64(U64 word)
+{
+ /* Find the position (0..63) of the most significant set bit in the input
+ * word */
+
+ ASSUME(word != 0);
+
+ /* If we can determine that the platform has a usable fast method to get
+ * this, use that */
+
+# if defined(PERL_CLZ_64)
+# define PERL_HAS_FAST_GET_MSB_POS64
+
+ return (unsigned) LZC_TO_MSBIT_POS_(U64, PERL_CLZ_64(word));
+
+# elif U64SIZE == 8 && defined(_WIN64) && defined(_MSC_VER)
+# define PERL_HAS_FAST_GET_MSB_POS64
+
+ {
+ unsigned long index;
+ _BitScanReverse64(&index, word);
+ return (unsigned)index;
+ }
+
+# else
+
+ /* Here, we didn't find a fast method for finding the msb. Fall back to
+ * making the msb the only set bit in the word, and use our function that
+ * works on words with a single bit set.
*
* Isolate the msb; http://codeforces.com/blog/entry/10330
*
* Only the most significant set bit matters. Or'ing word with its right
- * shift of 1 makes that bit and the next one to its right both 1. Then
- * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
- * msb and all to the right being 1. */
- word |= word >> 1;
- word |= word >> 2;
- word |= word >> 4;
- word |= word >> 8;
- word |= word >> 16;
- word |= word >> 32; /* This should get optimized out on 32-bit systems. */
+ * shift of 1 makes that bit and the next one to its right both 1.
+ * Repeating that with the right shift of 2 makes for 4 1-bits in a row.
+ * ... We end with the msb and all to the right being 1. */
+ word |= (word >> 1);
+ word |= (word >> 2);
+ word |= (word >> 4);
+ word |= (word >> 8);
+ word |= (word >> 16);
+ word |= (word >> 32);
/* Then subtracting the right shift by 1 clears all but the left-most of
* the 1 bits, which is our desired result */
word -= (word >> 1);
+ /* Now we have a single bit set */
+ return single_1bit_pos64(word);
+
+# endif
+
+}
+
+# define msbit_pos_uintmax_(word) msbit_pos64(word)
+#else /* ! QUAD */
+# define msbit_pos_uintmax_(word) msbit_pos32(word)
+#endif
+
+PERL_STATIC_INLINE unsigned
+Perl_msbit_pos32(U32 word)
+{
+ /* Find the position (0..31) of the most significant set bit in the input
+ * word */
+
+ ASSUME(word != 0);
+
+#if defined(PERL_CLZ_32)
+# define PERL_HAS_FAST_GET_MSB_POS32
+
+ return (unsigned) LZC_TO_MSBIT_POS_(U32, PERL_CLZ_32(word));
+
+#elif U32SIZE == 4 && defined(_MSC_VER)
+# define PERL_HAS_FAST_GET_MSB_POS32
+
+ {
+ unsigned long index;
+ _BitScanReverse(&index, word);
+ return (unsigned)index;
+ }
+
+#else
+
+ word |= (word >> 1);
+ word |= (word >> 2);
+ word |= (word >> 4);
+ word |= (word >> 8);
+ word |= (word >> 16);
+ word -= (word >> 1);
+ return single_1bit_pos32(word);
+
+#endif
+
+}
+
+#if UVSIZE == U64SIZE
+# define msbit_pos(word) msbit_pos64(word)
+# define lsbit_pos(word) lsbit_pos64(word)
+#elif UVSIZE == U32SIZE
+# define msbit_pos(word) msbit_pos32(word)
+# define lsbit_pos(word) lsbit_pos32(word)
+#endif
+
+#ifdef U64TYPE /* HAS_QUAD not usable outside the core */
+
+PERL_STATIC_INLINE unsigned
+Perl_single_1bit_pos64(U64 word)
+{
+ /* Given a 64-bit word known to contain all zero bits except one 1 bit,
+ * find and return the 1's position: 0..63 */
+
+# ifdef PERL_CORE /* macro not exported */
+ ASSUME(isPOWER_OF_2(word));
# else
-# error Unexpected byte order
+ ASSUME(word && (word & (word-1)) == 0);
# endif
- /* 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) */
- word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
- | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
- | (39 << 24) | (47 << 16)
- | (55 << 8) | (63 << 0));
- word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
-
- /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
- word = ((word + 1) >> 3) - 1;
+ /* The only set bit is both the most and least significant bit. If we have
+ * a fast way of finding either one, use that.
+ *
+ * It may appear at first glance that those functions call this one, but
+ * they don't if the corresponding #define is set */
-# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+# ifdef PERL_HAS_FAST_GET_MSB_POS64
- /* And invert the result */
- word = CHARBITS - word - 1;
+ return msbit_pos64(word);
+
+# elif defined(PERL_HAS_FAST_GET_LSB_POS64)
+
+ return lsbit_pos64(word);
+
+# else
+ /* The position of the only set bit in a word can be quickly calculated
+ * using deBruijn sequences. See for example
+ * https://en.wikipedia.org/wiki/De_Bruijn_sequence */
+ return PL_deBruijn_bitpos_tab64[(word * PERL_deBruijnMagic64_)
+ >> PERL_deBruijnShift64_];
# endif
+}
+
+#endif
+
+PERL_STATIC_INLINE unsigned
+Perl_single_1bit_pos32(U32 word)
+{
+ /* Given a 32-bit word known to contain all zero bits except one 1 bit,
+ * find and return the 1's position: 0..31 */
+
+#ifdef PERL_CORE /* macro not exported */
+ ASSUME(isPOWER_OF_2(word));
+#else
+ ASSUME(word && (word & (word-1)) == 0);
+#endif
+#ifdef PERL_HAS_FAST_GET_MSB_POS32
+
+ return msbit_pos32(word);
+
+#elif defined(PERL_HAS_FAST_GET_LSB_POS32)
+
+ return lsbit_pos32(word);
+
+/* Unlikely, but possible for the platform to have a wider fast operation but
+ * not a narrower one. But easy enough to handle the case by widening the
+ * parameter size. (Going the other way, emulating 64 bit by two 32 bit ops
+ * would be slower than the deBruijn method.) */
+#elif defined(PERL_HAS_FAST_GET_MSB_POS64)
+
+ return msbit_pos64(word);
+
+#elif defined(PERL_HAS_FAST_GET_LSB_POS64)
+
+ return lsbit_pos64(word);
+
+#else
+
+ return PL_deBruijn_bitpos_tab32[(word * PERL_deBruijnMagic32_)
+ >> PERL_deBruijnShift32_];
+#endif
+
+}
+
+#ifndef EBCDIC
+
+PERL_STATIC_INLINE unsigned int
+Perl_variant_byte_number(PERL_UINTMAX_T word)
+{
+ /* This returns the position in a word (0..7) of the first variant byte in
+ * it. This is a helper function. Note that there are no branches */
+
+ /* Get just the msb bits of each byte */
+ word &= PERL_VARIANTS_WORD_MASK;
+
+ /* This should only be called if we know there is a variant byte in the
+ * word */
+ assert(word);
+
+# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
+
+ /* Bytes are stored like
+ * Byte8 ... Byte2 Byte1
+ * 63..56...15...8 7...0
+ * so getting the lsb of the whole modified word is getting the msb of the
+ * first byte that has its msb set */
+ word = lsbit_pos_uintmax_(word);
+
+ /* Here, word contains the position 7,15,23,...55,63 of that bit. Convert
+ * to 0..7 */
+ return (unsigned int) ((word + 1) >> 3) - 1;
+
+# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
+
+ /* Bytes are stored like
+ * Byte1 Byte2 ... Byte8
+ * 63..56 55..47 ... 7...0
+ * so getting the msb of the whole modified word is getting the msb of the
+ * first byte that has its msb set */
+ word = msbit_pos_uintmax_(word);
+
+ /* Here, word contains the position 63,55,...,23,15,7 of that bit. Convert
+ * to 0..7 */
+ word = ((word + 1) >> 3) - 1;
+
+ /* And invert the result because of the reversed byte order on this
+ * platform */
+ word = CHARBITS - word - 1;
+
return (unsigned int) word;
+
+# else
+# error Unexpected byte order
+# endif
+
}
#endif
@@ -754,7 +1130,8 @@ S_variant_under_utf8_count(const U8* const s, const U8* const e)
#endif
-#ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
+ /* Keep these around for these files */
+#if ! defined(PERL_IN_REGEXEC_C) && ! defined(PERL_IN_UTF8_C)
# undef PERL_WORDSIZE
# undef PERL_COUNT_MULTIPLIER
# undef PERL_WORD_BOUNDARY_MASK
@@ -1074,6 +1451,108 @@ Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
}
}
+/* The perl core arranges to never call the DFA below without there being at
+ * least one byte available to look at. This allows the DFA to use a do {}
+ * while loop which means that calling it with a UTF-8 invariant has a single
+ * conditional, same as the calling code checking for invariance ahead of time.
+ * And having the calling code remove that conditional speeds up by that
+ * conditional, the case where it wasn't invariant. So there's no reason to
+ * check before caling this.
+ *
+ * But we don't know this for non-core calls, so have to retain the check for
+ * them. */
+#ifdef PERL_CORE
+# define PERL_NON_CORE_CHECK_EMPTY(s,e) assert((e) > (s))
+#else
+# define PERL_NON_CORE_CHECK_EMPTY(s,e) if ((e) <= (s)) return FALSE
+#endif
+
+/*
+ * DFA for checking input is valid UTF-8 syntax.
+ *
+ * This uses adaptations 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 adaptations are
+ * documented at the definition of PL_extended_utf8_dfa_tab[].
+ *
+ * This dfa is fast. There are three exit conditions:
+ * 1) a well-formed code point, acceptable to the table
+ * 2) the beginning bytes of an incomplete character, whose completion might
+ * or might not be acceptable
+ * 3) unacceptable to the table. Some of the adaptations have certain,
+ * hopefully less likely to occur, legal inputs be unacceptable to the
+ * table, so these must be sorted out afterwards.
+ *
+ * This macro is a complete implementation of the code executing the DFA. It
+ * is passed the input sequence bounds and the table to use, and what to do
+ * for each of the exit conditions. There are three canned actions, likely to
+ * be the ones you want:
+ * DFA_RETURN_SUCCESS_
+ * DFA_RETURN_FAILURE_
+ * DFA_GOTO_TEASE_APART_FF_
+ *
+ * You pass a parameter giving the action to take for each of the three
+ * possible exit conditions:
+ *
+ * 'accept_action' This is executed when the DFA accepts the input.
+ * DFA_RETURN_SUCCESS_ is the most likely candidate.
+ * 'reject_action' This is executed when the DFA rejects the input.
+ * DFA_RETURN_FAILURE_ is a candidate, or 'goto label' where
+ * you have written code to distinguish the rejecting state
+ * results. Because it happens in several places, and
+ * involves #ifdefs, the special action
+ * DFA_GOTO_TEASE_APART_FF_ is what you want with
+ * PL_extended_utf8_dfa_tab. On platforms without
+ * EXTRA_LONG_UTF8, there is no need to tease anything apart,
+ * so this evaluates to DFA_RETURN_FAILURE_; otherwise you
+ * need to have a label 'tease_apart_FF' that it will transfer
+ * to.
+ * 'incomplete_char_action' This is executed when the DFA ran off the end
+ * before accepting or rejecting the input.
+ * DFA_RETURN_FAILURE_ is the likely action, but you could
+ * have a 'goto', or NOOP. In the latter case the DFA drops
+ * off the end, and you place your code to handle this case
+ * immediately after it.
+ */
+
+#define DFA_RETURN_SUCCESS_ return s - s0
+#define DFA_RETURN_FAILURE_ return 0
+#ifdef HAS_EXTRA_LONG_UTF8
+# define DFA_TEASE_APART_FF_ goto tease_apart_FF
+#else
+# define DFA_TEASE_APART_FF_ DFA_RETURN_FAILURE_
+#endif
+
+#define PERL_IS_UTF8_CHAR_DFA(s0, e, dfa_tab, \
+ accept_action, \
+ reject_action, \
+ incomplete_char_action) \
+ STMT_START { \
+ const U8 * s = s0; \
+ const U8 * e_ = e; \
+ UV state = 0; \
+ \
+ PERL_NON_CORE_CHECK_EMPTY(s, e_); \
+ \
+ do { \
+ state = dfa_tab[256 + state + dfa_tab[*s]]; \
+ s++; \
+ \
+ if (state == 0) { /* Accepting state */ \
+ accept_action; \
+ } \
+ \
+ if (UNLIKELY(state == 1)) { /* Rejecting state */ \
+ reject_action; \
+ } \
+ } while (s < e_); \
+ \
+ /* Here, dropped out of loop before end-of-char */ \
+ incomplete_char_action; \
+ } STMT_END
+
+
/*
=for apidoc isUTF8_CHAR
@@ -1107,46 +1586,41 @@ machines) is a valid UTF-8 character.
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
+version is given at the beginning of this file. The Perl adaptation 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;
- }
+ PERL_IS_UTF8_CHAR_DFA(s0, e, PL_extended_utf8_dfa_tab,
+ DFA_RETURN_SUCCESS_,
+ DFA_TEASE_APART_FF_,
+ DFA_RETURN_FAILURE_);
- return s - s0 + 1;
- }
+ /* Here, we didn't return success, but dropped out of the loop. In the
+ * case of PL_extended_utf8_dfa_tab, this means the input is either
+ * malformed, or the start byte was FF on a platform that the dfa doesn't
+ * handle FF's. Call a helper function. */
+
+#ifdef HAS_EXTRA_LONG_UTF8
-#if defined(UV_IS_QUAD) || defined(EBCDIC)
+ tease_apart_FF:
- if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
- return is_utf8_char_helper(s0, e, 0);
+ /* In the case of PL_extended_utf8_dfa_tab, getting here means the input is
+ * either malformed, or was for the largest possible start byte, which we
+ * now check, not inline */
+ if (*s0 != I8_TO_NATIVE_UTF8(0xFF)) {
+ return 0;
}
+ return is_utf8_FF_helper_(s0, e,
+ FALSE /* require full, not partial char */
+ );
#endif
- return 0;
}
/*
@@ -1181,7 +1655,7 @@ C<L</is_strict_utf8_string_loclen>> to check entire strings.
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
+version is given at the beginning of this file. The Perl adaptation is
documented at the definition of strict_extended_utf8_dfa_tab[].
*/
@@ -1189,32 +1663,21 @@ 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;
- }
+ PERL_IS_UTF8_CHAR_DFA(s0, e, PL_strict_utf8_dfa_tab,
+ DFA_RETURN_SUCCESS_,
+ goto check_hanguls,
+ DFA_RETURN_FAILURE_);
+ check_hanguls:
-#endif
+ /* Here, we didn't return success, but dropped out of the loop. In the
+ * case of PL_strict_utf8_dfa_tab, this means the input is either
+ * malformed, or was for certain Hanguls; handle them specially */
- return 0;
+ /* The dfa above drops out for incomplete or illegal inputs, and certain
+ * legal Hanguls; check and return accordingly */
+ return is_HANGUL_ED_utf8_safe(s0, e);
}
/*
@@ -1247,7 +1710,7 @@ C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
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
+version is given at the beginning of this file. The Perl adaptation is
documented at the definition of PL_c9_utf8_dfa_tab[].
*/
@@ -1255,23 +1718,12 @@ 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;
+ PERL_IS_UTF8_CHAR_DFA(s0, e, PL_c9_utf8_dfa_tab,
+ DFA_RETURN_SUCCESS_,
+ DFA_RETURN_FAILURE_,
+ DFA_RETURN_FAILURE_);
}
/*
@@ -1552,11 +2004,16 @@ Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
=for apidoc utf8_hop
Return the UTF-8 pointer C<s> displaced by C<off> characters, either
-forward or backward.
+forward (if C<off> is positive) or backward (if negative). C<s> does not need
+to be pointing to the starting byte of a character. If it isn't, one count of
+C<off> will be used up to get to the start of the next character for forward
+hops, and to the start of the current character for negative ones.
-WARNING: do not use the following unless you *know* C<off> is within
-the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
-on the first byte of character or just after the last byte of a character.
+WARNING: Prefer L</utf8_hop_safe> to this one.
+
+Do NOT use this function unless you B<know> C<off> is within
+the UTF-8 data pointed to by C<s> B<and> that on entry C<s> is aligned
+on the first byte of a character or just after the last byte of a character.
=cut
*/
@@ -1567,10 +2024,20 @@ Perl_utf8_hop(const U8 *s, SSize_t off)
PERL_ARGS_ASSERT_UTF8_HOP;
/* Note: cannot use UTF8_IS_...() too eagerly here since e.g
- * the bitops (especially ~) can create illegal UTF-8.
+ * the XXX bitops (especially ~) can create illegal UTF-8.
* In other words: in Perl UTF-8 is not just for Unicode. */
- if (off >= 0) {
+ if (off > 0) {
+
+ /* Get to next non-continuation byte */
+ if (UNLIKELY(UTF8_IS_CONTINUATION(*s))) {
+ do {
+ s++;
+ }
+ while (UTF8_IS_CONTINUATION(*s));
+ off--;
+ }
+
while (off--)
s += UTF8SKIP(s);
}
@@ -1581,6 +2048,7 @@ Perl_utf8_hop(const U8 *s, SSize_t off)
s--;
}
}
+
GCC_DIAG_IGNORE(-Wcast-qual)
return (U8 *)s;
GCC_DIAG_RESTORE
@@ -1590,7 +2058,9 @@ Perl_utf8_hop(const U8 *s, SSize_t off)
=for apidoc utf8_hop_forward
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-forward.
+forward. C<s> does not need to be pointing to the starting byte of a
+character. If it isn't, one count of C<off> will be used up to get to the
+start of the next character.
C<off> must be non-negative.
@@ -1615,6 +2085,15 @@ Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
assert(s <= end);
assert(off >= 0);
+ if (off && UNLIKELY(UTF8_IS_CONTINUATION(*s))) {
+ /* Get to next non-continuation byte */
+ do {
+ s++;
+ }
+ while (UTF8_IS_CONTINUATION(*s));
+ off--;
+ }
+
while (off--) {
STRLEN skip = UTF8SKIP(s);
if ((STRLEN)(end - s) <= skip) {
@@ -1634,7 +2113,9 @@ Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
=for apidoc utf8_hop_back
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-backward.
+backward. C<s> does not need to be pointing to the starting byte of a
+character. If it isn't, one count of C<off> will be used up to get to that
+start.
C<off> must be non-positive.
@@ -1659,6 +2140,13 @@ Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
assert(start <= s);
assert(off <= 0);
+ /* Note: if we know that the input is well-formed, we can do per-word
+ * hop-back. Commit d6ad3b72778369a84a215b498d8d60d5b03aa1af implemented
+ * that. But it was reverted because doing per-word has some
+ * start-up/tear-down overhead, so only makes sense if the distance to be
+ * moved is large, and core perl doesn't currently move more than a few
+ * characters at a time. You can reinstate it if it does become
+ * advantageous. */
while (off++ && s > start) {
do {
s--;
@@ -1674,7 +2162,10 @@ Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
=for apidoc utf8_hop_safe
Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
-either forward or backward.
+either forward or backward. C<s> does not need to be pointing to the starting
+byte of a character. If it isn't, one count of C<off> will be used up to get
+to the start of the next character for forward hops, and to the start of the
+current character for negative ones.
When moving backward it will not move before C<start>.
@@ -1706,6 +2197,73 @@ Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
/*
+=for apidoc isUTF8_CHAR_flags
+
+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, subject to the restrictions given by C<flags>;
+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.
+
+If C<flags> is 0, this gives the same results as C<L</isUTF8_CHAR>>;
+if C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
+as C<L</isSTRICT_UTF8_CHAR>>;
+and if C<flags> is C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives
+the same results as C<L</isC9_STRICT_UTF8_CHAR>>.
+Otherwise C<flags> may be any combination of the C<UTF8_DISALLOW_I<foo>> flags
+understood by C<L</utf8n_to_uvchr>>, with the same meanings.
+
+The three alternative macros are for the most commonly needed validations; they
+are likely to run somewhat faster than this more general one, as they can be
+inlined into your code.
+
+Use L</is_utf8_string_flags>, L</is_utf8_string_loc_flags>, and
+L</is_utf8_string_loclen_flags> to check entire strings.
+
+=cut
+*/
+
+PERL_STATIC_INLINE STRLEN
+Perl_isUTF8_CHAR_flags(const U8 * const s0, const U8 * const e, const U32 flags)
+{
+ PERL_ARGS_ASSERT_ISUTF8_CHAR_FLAGS;
+ assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
+ |UTF8_DISALLOW_PERL_EXTENDED)));
+
+ PERL_IS_UTF8_CHAR_DFA(s0, e, PL_extended_utf8_dfa_tab,
+ goto check_success,
+ DFA_TEASE_APART_FF_,
+ DFA_RETURN_FAILURE_);
+
+ check_success:
+
+ return is_utf8_char_helper_(s0, e, flags);
+
+#ifdef HAS_EXTRA_LONG_UTF8
+
+ tease_apart_FF:
+
+ /* In the case of PL_extended_utf8_dfa_tab, getting here means the input is
+ * either malformed, or was for the largest possible start byte, which
+ * indicates perl extended UTF-8, well above the Unicode maximum */
+ if ( *s0 != I8_TO_NATIVE_UTF8(0xFF)
+ || (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_PERL_EXTENDED)))
+ {
+ return 0;
+ }
+
+ /* Otherwise examine the sequence not inline */
+ return is_utf8_FF_helper_(s0, e,
+ FALSE /* require full, not partial char */
+ );
+#endif
+
+}
+
+/*
+
=for apidoc is_utf8_valid_partial_char
Returns 0 if the sequence of bytes starting at C<s> and looking no further than
@@ -1754,18 +2312,47 @@ determined from just the first one or two bytes.
*/
PERL_STATIC_INLINE bool
-Perl_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 s0, const U8 * const e, const U32 flags)
{
PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
-
assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
|UTF8_DISALLOW_PERL_EXTENDED)));
- if (s >= e || s + UTF8SKIP(s) <= e) {
- return FALSE;
+ PERL_IS_UTF8_CHAR_DFA(s0, e, PL_extended_utf8_dfa_tab,
+ DFA_RETURN_FAILURE_,
+ DFA_TEASE_APART_FF_,
+ NOOP);
+
+ /* The NOOP above causes the DFA to drop down here iff the input was a
+ * partial character. flags=0 => can return TRUE immediately; otherwise we
+ * need to check (not inline) if the partial character is the beginning of
+ * a disallowed one */
+ if (flags == 0) {
+ return TRUE;
}
- return cBOOL(is_utf8_char_helper(s, e, flags));
+ return cBOOL(is_utf8_char_helper_(s0, e, flags));
+
+#ifdef HAS_EXTRA_LONG_UTF8
+
+ tease_apart_FF:
+
+ /* Getting here means the input is either malformed, or, in the case of
+ * PL_extended_utf8_dfa_tab, was for the largest possible start byte. The
+ * latter case has to be extended UTF-8, so can fail immediately if that is
+ * forbidden */
+
+ if ( *s0 != I8_TO_NATIVE_UTF8(0xFF)
+ || (flags & (UTF8_DISALLOW_SUPER|UTF8_DISALLOW_PERL_EXTENDED)))
+ {
+ return 0;
+ }
+
+ return is_utf8_FF_helper_(s0, e,
+ TRUE /* Require to be a partial character */
+ );
+#endif
+
}
/*
@@ -1844,11 +2431,11 @@ Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
PERL_STATIC_INLINE UV
Perl_utf8n_to_uvchr_msgs(const U8 *s,
- STRLEN curlen,
- STRLEN *retlen,
- const U32 flags,
- U32 * errors,
- AV ** msgs)
+ 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
@@ -1860,13 +2447,13 @@ Perl_utf8n_to_uvchr_msgs(const U8 *s,
* 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[].
+ * Perl adaptation 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;
+ UV type;
+ UV uv;
PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
@@ -1875,34 +2462,60 @@ Perl_utf8n_to_uvchr_msgs(const U8 *s,
* 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];
+ /* No calls from core pass in an empty string; non-core need a check */
+#ifdef PERL_CORE
+ assert(curlen > 0);
+#else
+ if (curlen == 0) return _utf8n_to_uvchr_msgs_helper(s0, 0, retlen,
+ flags, errors, msgs);
+#endif
- uv = (state == 0)
- ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
- : UTF8_ACCUMULATE(uv, *s);
- state = PL_strict_utf8_dfa_tab[256 + state + type];
+ type = PL_strict_utf8_dfa_tab[*s];
- if (state != 0) {
- s++;
- continue;
- }
+ /* The table is structured so that 'type' is 0 iff the input byte is
+ * represented identically regardless of the UTF-8ness of the string */
+ if (type == 0) { /* UTF-8 invariants are returned unchanged */
+ uv = *s;
+ }
+ else {
+ UV state = PL_strict_utf8_dfa_tab[256 + type];
+ uv = (0xff >> type) & NATIVE_UTF8_TO_I8(*s);
- if (retlen) {
- *retlen = s - s0 + 1;
- }
- if (errors) {
- *errors = 0;
- }
- if (msgs) {
- *msgs = NULL;
+ while (++s < send) {
+ type = PL_strict_utf8_dfa_tab[*s];
+ state = PL_strict_utf8_dfa_tab[256 + state + type];
+
+ uv = UTF8_ACCUMULATE(uv, *s);
+
+ if (state == 0) {
+#ifdef EBCDIC
+ uv = UNI_TO_NATIVE(uv);
+#endif
+ goto success;
+ }
+
+ if (UNLIKELY(state == 1)) {
+ break;
+ }
}
- 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);
+ }
+
+ success:
+ if (retlen) {
+ *retlen = s - s0 + 1;
+ }
+ if (errors) {
+ *errors = 0;
+ }
+ if (msgs) {
+ *msgs = NULL;
}
- /* Here is potentially problematic. Use the full mechanism */
- return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
+ return uv;
}
PERL_STATIC_INLINE UV
@@ -1922,7 +2535,7 @@ Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
}
else {
UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
- if (retlen && ret == 0 && *s != '\0') {
+ if (retlen && ret == 0 && (send <= s || *s != '\0')) {
*retlen = (STRLEN) -1;
}
@@ -2045,7 +2658,7 @@ S_lossless_NV_to_IV(const NV nv, IV *ivp)
/* ------------------ 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)
+#if defined(PERL_IN_PP_C) || defined(PERL_IN_REGCOMP_ANY) || defined(PERL_IN_TOKE_C) || defined(PERL_IN_UNIVERSAL_C)
#define MAX_CHARSET_NAME_LENGTH 2
@@ -2444,6 +3057,8 @@ Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
cx->blk_loop.itersave = NULL;
SvREFCNT_dec(cursv);
}
+ if (cx->cx_type & (CXp_FOR_GV|CXp_FOR_LVREF))
+ SvREFCNT_dec(cx->blk_loop.itervar_u.svp);
}
@@ -2492,6 +3107,36 @@ Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
SvREFCNT_dec(sv);
}
+/*
+=for apidoc newPADxVOP
+
+Constructs, checks and returns an op containing a pad offset. C<type> is
+the opcode, which should be one of C<OP_PADSV>, C<OP_PADAV>, C<OP_PADHV>
+or C<OP_PADCV>. The returned op will have the C<op_targ> field set by
+the C<padix> argument.
+
+This is convenient when constructing a large optree in nested function
+calls, as it avoids needing to store the pad op directly to set the
+C<op_targ> field as a side-effect. For example
+
+ o = op_append_elem(OP_LINESEQ, o,
+ newPADxVOP(OP_PADSV, 0, padix));
+
+=cut
+*/
+
+PERL_STATIC_INLINE OP *
+Perl_newPADxVOP(pTHX_ I32 type, I32 flags, PADOFFSET padix)
+{
+ PERL_ARGS_ASSERT_NEWPADXVOP;
+
+ assert(type == OP_PADSV || type == OP_PADAV || type == OP_PADHV
+ || type == OP_PADCV);
+ OP *o = newOP(type, flags);
+ o->op_targ = padix;
+ return o;
+}
+
/* ------------------ util.h ------------------------------------------- */
/*
@@ -2509,7 +3154,7 @@ range bytes match only themselves.
*/
PERL_STATIC_INLINE I32
-Perl_foldEQ(const char *s1, const char *s2, I32 len)
+Perl_foldEQ(pTHX_ const char *s1, const char *s2, I32 len)
{
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
@@ -2527,7 +3172,7 @@ 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)
+Perl_foldEQ_latin1(pTHX_ const char *s1, const char *s2, I32 len)
{
/* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
* representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
@@ -2561,7 +3206,7 @@ same case-insensitively in the current locale; false otherwise.
*/
PERL_STATIC_INLINE I32
-Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
+Perl_foldEQ_locale(pTHX_ const char *s1, const char *s2, I32 len)
{
const U8 *a = (const U8 *)s1;
const U8 *b = (const U8 *)s2;
@@ -2571,8 +3216,14 @@ Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
assert(len >= 0);
while (len--) {
- if (*a != *b && *a != PL_fold_locale[*b])
+ if (*a != *b && *a != PL_fold_locale[*b]) {
+ DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+ "%s:%d: Our records indicate %02x is not a fold of %02x"
+ " or its mate %02x\n",
+ __FILE__, __LINE__, *a, *b, PL_fold_locale[*b]));
+
return 0;
+ }
a++,b++;
}
return 1;
@@ -2661,7 +3312,7 @@ Perl_mortal_getenv(const char * str)
* mutex is defined accordingly.
*
* But in all cases, using the mutex prevents these problems, as long as
- * all code uses the same mutex..
+ * 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
@@ -2699,7 +3350,7 @@ Perl_mortal_getenv(const char * str)
* 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
+ * 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
@@ -2779,7 +3430,7 @@ Perl_mortal_getenv(const char * str)
}
}
- /* Then each of the three significant characters */
+ /* Then each of the four significant characters */
if (strchr(ret, 'm')) {
*mem_log_meat++ = 'm';
}
@@ -2789,6 +3440,9 @@ Perl_mortal_getenv(const char * str)
if (strchr(ret, 't')) {
*mem_log_meat++ = 't';
}
+ if (strchr(ret, 'c')) {
+ *mem_log_meat++ = 'c';
+ }
*mem_log_meat = '\0';
assert(mem_log_meat < PL_mem_log + sizeof(PL_mem_log));
@@ -2815,7 +3469,7 @@ Perl_mortal_getenv(const char * str)
ret = getenv(str);
if (ret != NULL) {
- ret = SvPVX(sv_2mortal(newSVpv(ret, 0)));
+ ret = SvPVX( newSVpvn_flags(ret, strlen(ret) ,SVs_TEMP) );
}
GETENV_UNLOCK;
@@ -2830,6 +3484,282 @@ Perl_mortal_getenv(const char * str)
return ret;
}
+PERL_STATIC_INLINE bool
+Perl_sv_isbool(pTHX_ const SV *sv)
+{
+ return SvBoolFlagsOK(sv) && BOOL_INTERNALS_sv_isbool(sv);
+}
+
+#ifdef USE_ITHREADS
+
+PERL_STATIC_INLINE AV *
+Perl_cop_file_avn(pTHX_ const COP *cop) {
+
+ PERL_ARGS_ASSERT_COP_FILE_AVN;
+
+ const char *file = CopFILE(cop);
+ if (file) {
+ GV *gv = gv_fetchfile_flags(file, strlen(file), GVF_NOADD);
+ if (gv) {
+ return GvAVn(gv);
+ }
+ else
+ return NULL;
+ }
+ else
+ return NULL;
+}
+
+#endif
+
+PERL_STATIC_INLINE PADNAME *
+Perl_padname_refcnt_inc(PADNAME *pn)
+{
+ PadnameREFCNT(pn)++;
+ return pn;
+}
+
+PERL_STATIC_INLINE PADNAMELIST *
+Perl_padnamelist_refcnt_inc(PADNAMELIST *pnl)
+{
+ PadnamelistREFCNT(pnl)++;
+ return pnl;
+}
+
+/* copy a string to a safe spot */
+
+/*
+=for apidoc_section $string
+=for apidoc savepv
+
+Perl's version of C<strdup()>. Returns a pointer to a newly allocated
+string which is a duplicate of C<pv>. The size of the string is
+determined by C<strlen()>, which means it may not contain embedded C<NUL>
+characters and must have a trailing C<NUL>. To prevent memory leaks, the
+memory allocated for the new string needs to be freed when no longer needed.
+This can be done with the C<L</Safefree>> function, or
+L<C<SAVEFREEPV>|perlguts/SAVEFREEPV(p)>.
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpv>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savepv(pTHX_ const char *pv)
+{
+ PERL_UNUSED_CONTEXT;
+ if (!pv)
+ return NULL;
+ else {
+ char *newaddr;
+ const STRLEN pvlen = strlen(pv)+1;
+ Newx(newaddr, pvlen, char);
+ return (char*)memcpy(newaddr, pv, pvlen);
+ }
+}
+
+/* same thing but with a known length */
+
+/*
+=for apidoc savepvn
+
+Perl's version of what C<strndup()> would be if it existed. Returns a
+pointer to a newly allocated string which is a duplicate of the first
+C<len> bytes from C<pv>, plus a trailing
+C<NUL> byte. The memory allocated for
+the new string can be freed with the C<Safefree()> function.
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpvn>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savepvn(pTHX_ const char *pv, Size_t len)
+{
+ char *newaddr;
+ PERL_UNUSED_CONTEXT;
+
+ Newx(newaddr,len+1,char);
+ /* Give a meaning to NULL pointer mainly for the use in sv_magic() */
+ if (pv) {
+ /* might not be null terminated */
+ newaddr[len] = '\0';
+ return (char *) CopyD(pv,newaddr,len,char);
+ }
+ else {
+ return (char *) ZeroD(newaddr,len+1,char);
+ }
+}
+
+/*
+=for apidoc savesvpv
+
+A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
+the passed in SV using C<SvPV()>
+
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedsvpv>>.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savesvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+ char *newaddr;
+
+ PERL_ARGS_ASSERT_SAVESVPV;
+
+ ++len;
+ Newx(newaddr,len,char);
+ return (char *) CopyD(pv,newaddr,len,char);
+}
+
+/*
+=for apidoc savesharedsvpv
+
+A version of C<savesharedpv()> which allocates the duplicate string in
+memory which is shared between threads.
+
+=cut
+*/
+
+PERL_STATIC_INLINE char *
+Perl_savesharedsvpv(pTHX_ SV *sv)
+{
+ STRLEN len;
+ const char * const pv = SvPV_const(sv, len);
+
+ PERL_ARGS_ASSERT_SAVESHAREDSVPV;
+
+ return savesharedpvn(pv, len);
+}
+
+#ifndef PERL_GET_CONTEXT_DEFINED
+
+/*
+=for apidoc_section $embedding
+=for apidoc get_context
+
+Implements L<perlapi/C<PERL_GET_CONTEXT>>, which you should use instead.
+
+=cut
+*/
+
+PERL_STATIC_INLINE void *
+Perl_get_context(void)
+{
+# if defined(USE_ITHREADS)
+# ifdef OLD_PTHREADS_API
+ pthread_addr_t t;
+ int error = pthread_getspecific(PL_thr_key, &t);
+ if (error)
+ Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error);
+ return (void*)t;
+# elif defined(I_MACH_CTHREADS)
+ return (void*)cthread_data(cthread_self());
+# else
+ return (void*)PTHREAD_GETSPECIFIC(PL_thr_key);
+# endif
+# else
+ return (void*)NULL;
+# endif
+}
+
+#endif
+
+PERL_STATIC_INLINE MGVTBL*
+Perl_get_vtbl(pTHX_ int vtbl_id)
+{
+ PERL_UNUSED_CONTEXT;
+
+ return (vtbl_id < 0 || vtbl_id >= magic_vtable_max)
+ ? NULL : (MGVTBL*)PL_magic_vtables + vtbl_id;
+}
+
+/*
+=for apidoc my_strlcat
+
+The C library C<strlcat> if available, or a Perl implementation of it.
+This operates on C C<NUL>-terminated strings.
+
+C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
+most S<C<size - strlen(dst) - 1>> characters. It will then C<NUL>-terminate,
+unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
+practice this should not happen as it means that either C<size> is incorrect or
+that C<dst> is not a proper C<NUL>-terminated string).
+
+Note that C<size> is the full size of the destination buffer and
+the result is guaranteed to be C<NUL>-terminated if there is room. Note that
+room for the C<NUL> should be included in C<size>.
+
+The return value is the total length that C<dst> would have if C<size> is
+sufficiently large. Thus it is the initial length of C<dst> plus the length of
+C<src>. If C<size> is smaller than the return, the excess was not appended.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strlcat.3
+*/
+#ifndef HAS_STRLCAT
+PERL_STATIC_INLINE Size_t
+Perl_my_strlcat(char *dst, const char *src, Size_t size)
+{
+ Size_t used, length, copy;
+
+ used = strlen(dst);
+ length = strlen(src);
+ if (size > 0 && used < size - 1) {
+ copy = (length >= size - used) ? size - used - 1 : length;
+ memcpy(dst + used, src, copy);
+ dst[used + copy] = '\0';
+ }
+ return used + length;
+}
+#endif
+
+
+/*
+=for apidoc my_strlcpy
+
+The C library C<strlcpy> if available, or a Perl implementation of it.
+This operates on C C<NUL>-terminated strings.
+
+C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
+to C<dst>, C<NUL>-terminating the result if C<size> is not 0.
+
+The return value is the total length C<src> would be if the copy completely
+succeeded. If it is larger than C<size>, the excess was not copied.
+
+=cut
+
+Description stolen from http://man.openbsd.org/strlcpy.3
+*/
+#ifndef HAS_STRLCPY
+PERL_STATIC_INLINE Size_t
+Perl_my_strlcpy(char *dst, const char *src, Size_t size)
+{
+ Size_t length, copy;
+
+ length = strlen(src);
+ if (size > 0) {
+ copy = (length >= size) ? size - 1 : length;
+ memcpy(dst, src, copy);
+ dst[copy] = '\0';
+ }
+ return length;
+}
+#endif
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/