pp_ref() builtin_pp_reftype(): strlen()+Newx()+memcpy()->100% pre-made COWs

-ref() PP keyword has extremely high usage. Greping my blead repo shows:
 Searched "ref(" 4347 hits in 605 files of 5879 searched
-The strings keyword ref() returns are part of the Perl 5 BNF grammer.
 This is not up for debate. Changing their spelling or lowercasing them
 is not for debate, or i18n-ing them dynamically realtime against
 glibc.so's current OS process global locale is not up for debate or
 wiring, or wiring inotify/kqueue into the runloop to monitor /etc or /var
 so this race condition works as designed in a unit test:
     $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 will complain these 2 functions do
 infinite recursion too.
-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.
-The 2 functions don't split, parse, cat, or glue multiple strings to
 create their output. 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.
-PP code "if(ref($self) eq 'HASH') {}" should never involve all 3-4 calls
 Newx()/Realloc()/strlen()/memcpy().

 So this fix all of this, and make pp_ref()/PP KW ref() be closer in speed
 to C/C++/Asm style object type checking, which is almost always going to
 be 1 or 2 or 3 ptr equality tests against C constant &sum_vtbl_sum_class,
 or in Microsoft ecosystem SW, its a equality test of a 16 byte GUID in
 memory, against a 16 byte SSE literal stored in a SSE opcode (TLDR ver).
 Just convert backends sv_ref()/sv_reftype() to HEK* retvals, and convert
 the front end pp_*() ops to fetch HEK*s and return SV*s with
 POK_on SvPVX()== HEK*. In all likely hood, if right side of PP code is
 "if (ref($self) eq 'HASH') {}", during the execution of
 memcpy(pv1, pv2, len) as part of pp_eq, pv1 and pv2 are the same mem addr.
 But I didn't single step eq operator to verify that yet.
-inside PP(pp_reftype) previously the branch sv_setsv(TARG, &PL_sv_undef);
 did not fire SMG, after this commit it does, IDK why it wasnt firing
 before, or consequences of SMG firing now on sv_set_undef(rsv); path.
-I suspect "sv_setsv(TARG, &PL_sv_undef);" and "sv_set_undef(rsv);" are
 not perfect behavior copies of each other, in extreme/bizzare/user error
 and bad CPAN XS code situtations but I haven't found any side effects of
 the switch from sv_setsv(TARG, &PL_sv_undef); to sv_set_undef(rsv)
 Untested typothetical cases like
 sv_setsv(gv_star, &PL_sv_undef);  sv_setsv(hv_star, &PL_sv_undef);
 sv_setsv(svt_regexp_star, &PL_sv_undef);
 sv_setsv(svt_invlist_star, &PL_sv_undef);
 sv_setsv(svt_object_star, &PL_sv_undef);
 sv_setsv(svt_io_star, &PL_sv_undef);

-sv_sethek() has a severe pathologic performance problem, if args
 SV* dsv and HEK* src_hek, test true for
     if(SvPVX(dsv) == HEK_KEY(src_hek)) {}.
 But its still better than a strlen()/Newx()/memcpy()/push_save_stack()/
 delayed_Safefree(); cycle. Any fix for this would be for the future.
-these 2 functions are experimental for now, hence undocumented and not
 public API, if they are made public, arg "const int ob" should be removed
 because of its confusing faux-infinite recursion but not real life
 infinite recursion. The fuctions are exported so P5P hackers and
 CPAN XS devs (unsanctioned by P5P) can benchmark and research these 2 new
 functions using Inline::C/EU::PXS.
-future improvements not done here, make sv_reftype() and sv_ref() wrappers
 around their HEK* counterparts. Note the HEK* must be RC++ed and stuffed
 in a new SV*, or a PAD TARG SV*, before the rpp_replace_1_1_NN(TARG); call
 because in artificial situations/fuzzing, strange things can happen during
 a SvREFCNT_dec_NN(); call, and the HEK* sitting in a C auto might
 get freed during the SvREFCNT_dec_NN();
-another improvement, sv_sethek(rsv, hek); is somewhat heavy, and doesn't
 have a shortcut, to RC-- an existing SVPV HEK* COW itself, instead it
 uses SV_THINKFIRST_***() and sv_force_normal***() to RC-- an existing
 SVPV HEK* COW. If the SV* PAD TARG, is being used over and over by ref()
 opcode, its always going to have a stale HEK* SVPVX() that needs to be
 RC--ed.
-another improvement, check if(sv_reftypehek() == SvPVX(targ)) before
 calling sv_sethek(rsv, hek);
-another improvement, beyond scope for me, make into 1 OP*/opcode:
	if(ref($self) eq 'HASH')
and
	if(ref($self) eq 'ARRAY')
-another improvement, dont deref my_perl->Iop/PL_ptr many times in a row.
 I didn't do any CPU opcode/instruction stripping in this commit. Thats
 for a future commit.
-another improvement, investigate if most of large switch() inside
 Perl_sv_reftypehek() can be turned into a
 const I8 arr_of_PL_sv_consts_idxs[];  with a couple tiny special cases.
-todo invert "if (!rsv) {" branch, so hot path (yes cached in PL_sv_consts).
 comes first in machine code/asm order.

Author: bulk88

builtin.c

@@ -563,17 +563,37 @@ 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);
+        else /* if a PAD TARG exists, returning &PL_sv_undef will force a */
+            sv_set_undef(rsv); /* slow trip through sv_setsv() in next OP */
+        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;
     }
-
 }
 
 

pp_hot.c

@@ -224,7 +224,8 @@ Perl_rpp_free_2_(pTHX_ SV *const sv1,  SV *const sv2,
 
 PP(pp_const)
 {
-    rpp_xpush_1(cSVOP_sv);
+    SV* sv = cSVOP_sv;
+    rpp_xpush_1(sv);
     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,135 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
     }
 }
 
+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;
+        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;
+        }
+        return SvSHARED_HEK_FROM_PV(SvPVX_const(rsv));
+    }
+}
+
 /*
 =for apidoc sv_ref
 
@@ -10669,6 +10799,26 @@ Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
     return dst;
 }
 
+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!