Perl_sv_setsv_flags: extract croaks to a cold helper function

Perl_sv_setsv_flags has a number of fail-safe checks which will croak
if triggered. However, these code paths are *really* cold - they aren't
even hit by the test harness. Since they are so cold and always result
in an immediate croak, they can be pulled out into an unoptimized helper
function. This leaves Perl_sv_setsv_flags smaller and therefore more
cache friendly.

Author: richardleach

embed.fnc

@@ -5815,6 +5815,9 @@ S	|void	|assert_uft8_cache_coherent				\
 				|STRLEN from_cache			\
 				|STRLEN real				\
 				|NN SV * const sv
+S	|void	|croak_sv_setsv_flags					\
+				|NN SV * const dsv			\
+				|NN SV * const ssv
 S	|bool	|curse		|NN SV * const sv			\
 				|const bool check_refcnt
 RS	|STRLEN |expect_number	|NN const char ** const pattern

embed.h

@@ -2158,6 +2158,7 @@
 #     define F0convert                          S_F0convert
 #     define anonymise_cv_maybe(a,b)            S_anonymise_cv_maybe(aTHX_ a,b)
 #     define assert_uft8_cache_coherent(a,b,c,d) S_assert_uft8_cache_coherent(aTHX_ a,b,c,d)
+#     define croak_sv_setsv_flags(a,b)          S_croak_sv_setsv_flags(aTHX_ a,b)
 #     define curse(a,b)                         S_curse(aTHX_ a,b)
 #     define expect_number(a)                   S_expect_number(aTHX_ a)
 #     define find_array_subscript(a,b)          S_find_array_subscript(aTHX_ a,b)

proto.h

@@ -4275,24 +4275,17 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
         SvREFCNT_dec(old_rv);
         return;
     }
-
+/*
 #if NVSIZE <= IVSIZE
     both_type = (stype | dtype);
 #endif
-
+*/
     if (UNLIKELY(both_type == SVTYPEMASK)) {
-        if (SvIS_FREED(dsv)) {
-            Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
-                       " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
-        }
-        if (SvIS_FREED(ssv)) {
-            Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
-                       (void*)ssv, (void*)dsv);
-        }
+        croak_sv_setsv_flags(dsv, ssv);
+        NOT_REACHED;
     }
 
 
-
     SV_CHECK_THINKFIRST_COW_DROP(dsv);
     dtype = SvTYPE(dsv); /* THINKFIRST may have changed type */
 
@@ -4390,14 +4383,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
         invlist_clone(ssv, dsv);
         return;
     default:
-        {
-        const char * const type = sv_reftype(ssv,0);
-        if (PL_op)
-            /* diag_listed_as: Bizarre copy of %s */
-            Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op));
-        else
-            Perl_croak(aTHX_ "Bizarre copy of %s", type);
-        }
+        croak_sv_setsv_flags(dsv, ssv);
         NOT_REACHED; /* NOTREACHED */
 
     case SVt_REGEXP:
@@ -4451,12 +4437,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags)
     else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV
              || dtype == SVt_PVFM))
     {
-        const char * const type = sv_reftype(dsv,0);
-        if (PL_op)
-            /* diag_listed_as: Cannot copy to %s */
-            Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op));
-        else
-            Perl_croak(aTHX_ "Cannot copy to %s", type);
+        croak_sv_setsv_flags(dsv, ssv);
+        NOT_REACHED;
     } else if (sflags & SVf_ROK) {
         if (isGV_with_GP(dsv)
             && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) {
@@ -17736,6 +17718,44 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv)
     GCC_DIAG_RESTORE_STMT;
 }
 
+/* This helper function for Perl_sv_setsv_flags is as cold as they come.
+ * We should almost never call it and it will definitely croak when we do.
+ * Therefore it should not matter that it is not close to the main function
+ * or that we make it redo work that the caller already did.
+ * The main aim is to keep Perl_sv_setsv_flags as slim as possible and this
+ * includes keeping the call sites for this function small.
+ */
+void S_croak_sv_setsv_flags(pTHX_ SV * const dsv, SV * const ssv)
+{
+    OP *op = PL_op;
+    if (SvIS_FREED(dsv)) {
+        Perl_croak(aTHX_ "panic: attempt to copy value %" SVf
+                   " to a freed scalar %p", SVfARG(ssv), (void *)dsv);
+    }
+    if (SvIS_FREED(ssv)) {
+        Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p to %p",
+                   (void*)ssv, (void*)dsv);
+    }
+
+    if (SvTYPE(ssv) > SVt_PVLV)
+    {
+        const char * const type = sv_reftype(ssv,0);
+        if (op)
+            /* diag_listed_as: Bizarre copy of %s */
+            Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(op));
+        else
+            Perl_croak(aTHX_ "Bizarre copy of %s", type);
+    }
+
+    const char * const type = sv_reftype(dsv,0);
+    if (op)
+        /* diag_listed_as: Cannot copy to %s */
+        Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(op));
+    else
+        Perl_croak(aTHX_ "Cannot copy to %s", type);
+
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */