add sv_refhek, sv_reftypehek functions for better ref() performance

-ref() PP keyword has extremely high usage. Greping my blead repo shows:
 Searched "ref(" 4347 hits in 605 files of 5879 searched

-High level PP keyword ref(), aka C function Perl_pp_ref(), uses slow,
 inefficient, badly designed, backend public XS/C API called functions
 called Perl_sv_ref()/Perl_sv_reftype().

-This commit fixes all design problems with Perl_sv_ref()/Perl_sv_reftype(),
 and will speed up the very high usage PP keyword ref(), along with a
 very similar but very new and very little used PP keyword called
 "use builtin qw( reftype );" which is near identical to Perl_pp_ref().

-a crude benchmark, with the array ref in $aref holding
43000 SV*s, split 1/3rd SV* IOK, 1/3rd RV* to SV* IOK,
and 1/3rd RV* to CV*, showed a %6 speed increase for this code

sub benchme {
    foreach my $el (@{$aref}) { $cnt++ if ref($el) eq 'SCALAR';}
}

-The all UPPERCASE strings keyword ref() returns are part of the Perl 5
 BNF grammer. Changing their spelling or lowercasing them is not for
 debate, or i18n-ing them dynamically realtime against glibc.so's current
 "OS global locale" with inotify()/kqueue() in the runloop to monitor a
 text file /etc or /var so this race condition works as designed in a
 unit test will never happen:
     $perl -E "dire('hello')"
     Routine indéfinie &cœur::dire aufgerufen bei -e Zeile 1

-sv_reftype() and sv_ref() have very badly designed prototypes, and the
 first time a new Perl in C dev reads their source code, they will think
 these 2 will cause infinite C stack recursion and a SEGV. Probably most
 automated C code analytic tools maybe will complain these 2 functions do
 infinite recursion.

-The 2 functions don't return a string length, forcing all callers to
 execute a libc strlen() call on a string, that could be 8 bytes, or 80 MB.

-All null term-ed strings that they return, are already sitting in virtual
 address space. Either const HW RO, or RCed HEK*s from the PL_strtab pool,
 that were found inside something similar to a
 GV*/HV*/HE*/CV*/AV*/GP*/OP*/SV* in a OP*(no threads)
.
-COW 255 buffers from Newx() under 9 chars can't COW currently by policy.
 CODE is 4, SCALAR is 6. HASH is 4. ARRAY is 5. But very short SV HEK* COWs
 will COW propagate without problems. ref() is also used to retrieve
 "Local::My::Class" strings, which have an extremely high chance to wind
 up getting passed to hv_common() through some high level PP keyword like
 bless or @isa, and hv_common() extracts precalculated U32 hash values
 from SV* with HEK* buffers, speeding up hv_common(). So SV* POKs with
 COW 255 and COW SVs_STATIC buffers are bad choices compared to using SV*
 POK HEK* buffers for a new faster version of sv_reftype()/sv_ref().

-PP code "if(ref($self) eq 'HASH') {}" should never involve all 3-5 calls
 Newx()/Realloc()/strlen()/memcpy()/Safefree(), on each execution of the
 line.

 To improve the src code dev-friendlyness of the prototypes of, and speed
 inside of, and the speed of in all libperl callers of
 Perl_sv_ref()/Perl_sv_reftype(). Make HEK* variants of them. Initially
 the HEK* variants are private to libperl. Maybe after 1-3 years into the
 future, they can be made official public C API for CPAN XS authors.
 These 2 new functions are undocumented/private API until further notice.

 Using SV* holding RC-ed HEK* SvPVX() buffers removes all these libc
 C lang logical and/or Asm machine code steps from during execution of
 PP keyword ref(). The pre-allocated PAD TARG SV* just keeps getting
 a RC-- on the old HEK* inside SvPVX(), and a RC++ on the new HEK* written
 to SvPVX() of the PAD TARG SV*. Touching only 6 void*s/size_t adresses
 total, each one a single read/write CPU instruction pair.
 SvPVX, SvCUR, SvLEN, old_hek.shared_he.shared_he_he.he_valu.hent_refcount,
 new_hek.shared_he.shared_he_he.he_valu.hent_refcount,
 new_hek.shared_he.shared_he_hek.hek_len. This brings PP KW ref() closer
 to C++ style RTTI that just compares const read-only vtable pointers.

 Some design and optimization problems with the old and new
 pp_ref()/pp_reftype()/sv_ref()/sv_reftype()/sv_refhek()/sv_reftypehek()
 calls are intentionally not being fixed in this commit to keep this
 commit small. Check the associated PR of the commit for details.

Author: bulk88

builtin.c

@@ -563,17 +563,43 @@ PP(pp_refaddr)
 
 PP(pp_reftype)
 {
-    dXSTARG;
-    SV *arg = *PL_stack_sp;
+    HEK *hek;
+    SV *rsv;
+    SV ** svp = PL_stack_sp;
+    SV *arg = *svp;
 
     SvGETMAGIC(arg);
 
     if(SvROK(arg))
-        sv_setpv_mg(TARG, sv_reftype(SvRV(arg), FALSE));
+        hek = sv_reftypehek(SvRV(arg), FALSE);
     else
-        sv_setsv(TARG, &PL_sv_undef);
+        hek = NULL;
+
+    /* unrolled dXSTARG; avoid slower sv_setxv_mg(sv_newmortal(), ); */
+    if (PL_op->op_private & OPpENTERSUB_HASTARG) {
+        rsv = PAD_SV(PL_op->op_targ);
+        if (hek)
+            sv_sethek(rsv, hek);
+        /* If a PAD TARG exists, returning &PL_sv_undef will force a slow trip
+           through sv_setsv() in next OP, so do the undef assignment here,
+           with the streamlined sv_set_undef() call, vs universal and complex
+           sv_setsv() call. Note, the prior code here, only fired SMG magic
+           on the sv_sethek()/sv_setpvs() branch, not on the sv_set_undef()
+           branch. */
+        else
+            sv_set_undef(rsv);
+        SvSETMAGIC(rsv);
+        rpp_replace_1_1_NN(rsv); /* no RC_STK =, RC_STK RC++ = */
+    }
+    else {
+        if (!hek)
+            rpp_replace_1_IMM_NN(&PL_sv_undef);
+        else {
+            rsv = newSVhek(hek);
+            rpp_replace_at_norc(svp, rsv); /* no RC_STK mortal =, RC_STK RC++ = */
+        }
+    }
 
-    rpp_replace_1_1_NN(TARG);
     return NORMAL;
 }
 

embed.fnc

@@ -3366,9 +3366,12 @@ AMTdip	|SV *	|SvREFCNT_inc	|NULLOK SV *sv
 AMTdip	|SV *	|SvREFCNT_inc_NN|NN SV *sv
 AMTdip	|void	|SvREFCNT_inc_void					\
 				|NULLOK SV *sv
+EXp	|HEK *	|sv_refhek	|NN const SV * const sv 		\
+				|const int ob
 ARdp	|const char *|sv_reftype|NN const SV * const sv 		\
 				|const int ob
-
+ERXp	|HEK *	|sv_reftypehek	|NN const SV * const sv 		\
+				|const int ob
 Adp	|void	|sv_regex_global_pos_clear				\
 				|NN SV *sv
 ARdp	|bool	|sv_regex_global_pos_get				\

embed.h

@@ -1810,6 +1810,8 @@
 #   define skipspace_flags(a,b)                 Perl_skipspace_flags(aTHX_ a,b)
 #   define sv_magicext_mglob(a)                 Perl_sv_magicext_mglob(aTHX_ a)
 #   define sv_only_taint_gmagic                 Perl_sv_only_taint_gmagic
+#   define sv_refhek(a,b)                       Perl_sv_refhek(aTHX_ a,b)
+#   define sv_reftypehek(a,b)                   Perl_sv_reftypehek(aTHX_ a,b)
 #   define utf16_to_utf8_base(a,b,c,d,e,f)      Perl_utf16_to_utf8_base(aTHX_ a,b,c,d,e,f)
 #   define utf8_to_utf16_base(a,b,c,d,e,f)      Perl_utf8_to_utf16_base(aTHX_ a,b,c,d,e,f)
 #   define validate_proto(a,b,c,d)              Perl_validate_proto(aTHX_ a,b,c,d)

pp.c

@@ -573,13 +573,13 @@ PP(pp_ref)
 
   do_sv_ref:
     {
+        HEK* hek = sv_refhek(SvRV(sv), TRUE);
         dTARGET;
-        sv_ref(TARG, SvRV(sv), TRUE);
+        sv_sethek(TARG, hek);
         rpp_replace_1_1_NN(TARG);
         SvSETMAGIC(TARG);
         return NORMAL;
     }
-
 }
 
 

proto.h

@@ -3000,8 +3000,9 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags)
 
                 return RX_WRAPPED(re);
             } else {
-                const char *const typestring = sv_reftype(referent, 0);
-                const STRLEN typelen = strlen(typestring);
+                HEK * const typestring_hek = sv_reftypehek(referent, 0);
+                const char *const typestring = HEK_KEY(typestring_hek);
+                const I32 typelen = HEK_LEN(typestring_hek);
                 UV addr = PTR2UV(referent);
                 const char *stashname = NULL;
                 STRLEN stashnamelen = 0; /* hush, gcc */
@@ -10634,6 +10635,150 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
     }
 }
 
+/* Experimental faster variant of sv_reftype(). Identical to sv_reftype() except
+   it returns a HEK* from PL_strtab. Does not bump the RC on the HEK*.
+   Caller must bump the RC of the HEK* if they want to preserve it for future
+   use. The easiest way to do the RC bump is with sv_sethek() or newSVhek().
+   It is exported for private P5P experiments with Inline::C or EU::PXS, but
+   it is not a public API for CPAN authors and may change at any time. */
+
+HEK*
+Perl_sv_reftypehek(pTHX_ const SV *const sv, const int ob)
+{
+    PERL_ARGS_ASSERT_SV_REFTYPEHEK;
+
+    if (ob && SvOBJECT(sv))
+        return sv_refhek(sv, ob);
+    else {
+        SV* rsv;
+        /* The SV_CONST() macro can not be used here or else the switch table
+           below will have 17 unique callsites to exported libperl symbol
+           Perl_newSVpvn_share(). In the future, this switch statement can be
+           optimized to an array mapping U8 sv_type codes, to U8 or U16s indexes
+           pointing into array PL_sv_consts, with negative indexs being
+           if (){} else {} special cases needing extra checks.*/
+        U32 idx;
+        /* WARNING - There is code, for instance in mg.c, that assumes that
+         * the only reason that sv_reftype(sv,0) would return a string starting
+         * with 'L' or 'S' is that it is a LVALUE or a SCALAR.
+         * Yes this a dodgy way to do type checking, but it saves practically reimplementing
+         * this routine inside other subs, and it saves time.
+         * Do not change this assumption without searching for "dodgy type check" in
+         * the code.
+         * - Yves */
+        switch (SvTYPE(sv)) {
+        case SVt_NULL:
+        case SVt_IV:
+        case SVt_NV:
+        case SVt_PV:
+        case SVt_PVIV:
+        case SVt_PVNV:
+        case SVt_PVMG:
+            if (SvVOK(sv)) {
+                idx = SV_CONST_VSTRING;
+                break;
+            }
+            else if (SvROK(sv)) {
+                idx = SV_CONST_REF;
+                break;
+            }
+            else {
+                idx = SV_CONST_SCALAR;
+                break;
+            }
+        case SVt_PVLV:		idx = (SvROK(sv) ? SV_CONST_REF
+                                /* tied lvalues should appear to be
+                                 * scalars for backwards compatibility */
+                                : (isALPHA_FOLD_EQ(LvTYPE(sv), 't'))
+                                    ? SV_CONST_SCALAR : SV_CONST_LVALUE); break;
+        case SVt_PVAV: {	idx = SV_CONST_ARRAY; break; }
+        case SVt_PVHV: {	idx = SV_CONST_HASH; break; }
+        case SVt_PVCV: {	idx = SV_CONST_CODE; break; }
+        case SVt_PVGV: {
+            idx = isGV_with_GP(sv) ? SV_CONST_GLOB : SV_CONST_SCALAR;
+            break;
+        }
+        case SVt_PVFM: {	idx = SV_CONST_FORMAT; break; }
+        case SVt_PVIO: {	idx = SV_CONST_IO; break; }
+        case SVt_INVLIST: {	idx = SV_CONST_INVLIST; break; }
+        case SVt_REGEXP: {	idx = SV_CONST_REGEXP; break; }
+        case SVt_PVOBJ: {	idx = SV_CONST_OBJECT; break; }
+        default: {			idx = SV_CONST_UNKNOWN; break; }
+        }
+
+        rsv = PL_sv_consts[idx];
+        if (!rsv) {
+            U8 len;
+            const char * pv;
+            switch(idx) {
+                case SV_CONST_ARRAY:
+                    pv = "ARRAY";
+                    len = STRLENs("ARRAY");
+                    break;
+                case SV_CONST_CODE:
+                    pv = "CODE";
+                    len = STRLENs("CODE");
+                    break;
+                case SV_CONST_FORMAT:
+                    pv = "FORMAT";
+                    len = STRLENs("FORMAT");
+                    break;
+                case SV_CONST_GLOB:
+                    pv = "GLOB";
+                    len = STRLENs("GLOB");
+                    break;
+                case SV_CONST_HASH:
+                    pv = "HASH";
+                    len = STRLENs("HASH");
+                    break;
+                case SV_CONST_INVLIST:
+                    pv = "INVLIST";
+                    len = STRLENs("INVLIST");
+                    break;
+                case SV_CONST_IO:
+                    pv = "IO";
+                    len = STRLENs("IO");
+                    break;
+                case SV_CONST_LVALUE:
+                    pv = "LVALUE";
+                    len = STRLENs("LVALUE");
+                    break;
+                case SV_CONST_OBJECT:
+                    pv = "OBJECT";
+                    len = STRLENs("OBJECT");
+                    break;
+                case SV_CONST_REF:
+                    pv = "REF";
+                    len = STRLENs("REF");
+                    break;
+                case SV_CONST_REGEXP:
+                    pv = "REGEXP";
+                    len = STRLENs("REGEXP");
+                    break;
+                case SV_CONST_SCALAR:
+                    pv = "SCALAR";
+                    len = STRLENs("SCALAR");
+                    break;
+                case SV_CONST_UNKNOWN:
+                    pv = "UNKNOWN";
+                    len = STRLENs("UNKNOWN");
+                    break;
+                case SV_CONST_VSTRING:
+                    pv = "VSTRING";
+                    len = STRLENs("VSTRING");
+                    break;
+                default: /* unreachable, don't make a verbose long string */
+                    croak_no_mem_ext(STR_WITH_LEN("sv_reftypehek"));
+            }
+            rsv = newSVpvn_share(pv, len, 0);
+            PL_sv_consts[idx] = rsv;
+        } /* Never return our secret PL_sv_consts[idx] SV*s to any caller for
+             any reason. We don't SvREADONLY_on(), and we don't trust PP code.
+             Example: my $klass = \ref($self); ${$klass} .= "::Base"; */
+        return SvSHARED_HEK_FROM_PV(SvPVX_const(rsv));
+    }
+}
+
 /*
 =for apidoc sv_ref
 
@@ -10669,6 +10814,33 @@ Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
     return dst;
 }
 
+/* Experimental faster variant of sv_ref(). Identical to sv_ref() except
+   it returns a HEK* from PL_strtab. Does not bump the RC on the HEK*.
+   Caller must bump the RC of the HEK* if they want to preserve it for future
+   use. The easiest way to do the RC bump is with sv_sethek() or newSVhek().
+   It is exported for private P5P experiments with Inline::C or EU::PXS, but
+   it is not a public API for CPAN authors and may change at any time. */
+
+HEK *
+Perl_sv_refhek(pTHX_ const SV *const sv, const int ob)
+{
+    HEK * hek;
+    PERL_ARGS_ASSERT_SV_REFHEK;
+
+    if (ob && SvOBJECT(sv)) {
+        HV* stash = SvSTASH(sv);
+        if (HvHasNAME(stash))
+            hek = HvNAME_HEK(stash);
+        else {
+            SV * rsv = SV_CONST(__ANON__);
+            hek = SvSHARED_HEK_FROM_PV(SvPVX_const(rsv));
+        }
+    }
+    else
+        hek = sv_reftypehek(sv, 0);
+    return hek;
+}
+
 /*
 =for apidoc sv_isobject
 

sv.c

@@ -2695,9 +2695,25 @@ Create a new IO, setting the reference count to 1.
 #  define SV_CONST_CLEAR 32
 #  define SV_CONST_UNTIE 33
 #  define SV_CONST_DESTROY 34
+
+#  define SV_CONST_ARRAY 35
+#  define SV_CONST_CODE 36
+#  define SV_CONST_FORMAT 37
+#  define SV_CONST_GLOB 38
+#  define SV_CONST_HASH 39
+#  define SV_CONST_INVLIST 40
+#  define SV_CONST_IO 41
+#  define SV_CONST_LVALUE 42
+#  define SV_CONST_OBJECT 43
+#  define SV_CONST_REF 44
+#  define SV_CONST_REGEXP 45
+/* "SCALAR" is above */
+#  define SV_CONST_UNKNOWN 46
+#  define SV_CONST_VSTRING 47
+#  define SV_CONST___ANON__ 48
 #endif
 
-#define SV_CONSTS_COUNT 35
+#define SV_CONSTS_COUNT 49
 
 /*
  * Bodyless IVs and NVs!