make SvREFCNT_dec() more efficient

Historically, SvREFCNT_dec was just

    #define SvREFCNT_dec(sv)        sv_free((SV*)(sv))

then in 5.10.0, for GCC, the macro was partially inlined, avoiding a
function call for the refcnt > 1 case. Recently, the macro was turned into
an inline function, providing the function-call avoidance to other
platforms too. However, the macro/inline-function is quite big, and
appears over 500 times in the core source. Its action is logically
equivalent to:

    if (sv) {
        if (SvREFCNT(sv) > 1)
            SvREFCNT(sv)--;
        else if (SvREFCNT == 1) {
            // normal case
            SvREFCNT(sv)--;
            sv_free2(sv);
        }
        else {
            // exceptional case
            sv_free(sv);
        }
    }

Where sv_free2() handles the "normal" quick cases, while sv_free()
handles the odd cases (e,g. a ref count already at 0 during global
destruction).

This means we have to plant code that potentially calls two different
subs, over 500 times.

This commit changes SvREFCNT_dec and sv_free2() to look like:

    PERL_STATIC_INLINE void
    S_SvREFCNT_dec(pTHX_ SV *sv)
    {
        if (sv) {
            U32 rc = SvREFCNT(sv);
            if (rc > 1)
                SvREFCNT(sv) = rc - 1;
            else
                Perl_sv_free2(aTHX_ sv, rc);
        }
    }

    Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
    {
        if (rc == 1) {
	    SvREFCNT(sv) = 0;
            ... do sv_clear, del_SV etc ...
            return
        }
        /* handle exceptional rc == 0 */
        ...
    }

So for the normal cases (rc > 1, rc == 1) there is the same amount of
testing and function calls, but the second test has been moved inside
the sv_free2() function.

This makes the perl executable about 10-15K smaller, and apparently a bit
faster (modulo the fact that most benchmarks are just measuring noise).

The refcount is passed as a second arg to sv_free2(), as on platforms
that pass the first few args in registers, it saves reading sv->sv_refcnt
again.

diff --git a/embed.fnc b/embed.fnc
index a1e1f5e..337769f 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1294,9 +1294,7 @@ ApdR      |bool   |sv_does_pvn    |NN SV* sv|NN const char *const name|const STRLEN len \
 Amd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
 Apd    |I32    |sv_eq_flags    |NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags
 Apd    |void   |sv_free        |NULLOK SV *const sv
-: FIXME Used in SvREFCNT_dec() but only
-: if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
-poMX   |void   |sv_free2       |NN SV *const sv
+poMX   |void   |sv_free2       |NN SV *const sv|const U32 refcnt
 : Used only in perl.c
 pd     |void   |sv_free_arenas
 Apd    |char*  |sv_gets        |NN SV *const sv|NN PerlIO *const fp|I32 append

diff --git a/inline.h b/inline.h
index 0d53860..5e11b69 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -55,12 +55,11 @@ PERL_STATIC_INLINE void
 S_SvREFCNT_dec(pTHX_ SV *sv)
 {
     if (sv) {
-       if (SvREFCNT(sv)) {
-           if (--(SvREFCNT(sv)) == 0)
-               Perl_sv_free2(aTHX_ sv);
-       } else {
-           sv_free(sv);
-       }
+       U32 rc = SvREFCNT(sv);
+       if (rc > 1)
+           SvREFCNT(sv) = rc - 1;
+       else
+           Perl_sv_free2(aTHX_ sv, rc);
     }
 }
 

diff --git a/proto.h b/proto.h
index f9d7b9e..22210ab 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3938,7 +3938,7 @@ PERL_CALLCONV void        Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flag
        assert(sv)
 
 PERL_CALLCONV void     Perl_sv_free(pTHX_ SV *const sv);
-PERL_CALLCONV void     Perl_sv_free2(pTHX_ SV *const sv)
+PERL_CALLCONV void     Perl_sv_free2(pTHX_ SV *const sv, const U32 refcnt)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_FREE2      \
        assert(sv)

diff --git a/sv.c b/sv.c
index 397d992..72d41ca 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6549,76 +6549,85 @@ Normally called via a wrapper macro C<SvREFCNT_dec>.
 void
 Perl_sv_free(pTHX_ SV *const sv)
 {
-    dVAR;
-    if (!sv)
-       return;
-    if (SvREFCNT(sv) == 0) {
-       if (SvFLAGS(sv) & SVf_BREAK)
-           /* this SV's refcnt has been artificially decremented to
-            * trigger cleanup */
-           return;
-       if (PL_in_clean_all) /* All is fair */
-           return;
-       if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
-           /* make sure SvREFCNT(sv)==0 happens very seldom */
-           SvREFCNT(sv) = (~(U32)0)/2;
-           return;
-       }
-       if (ckWARN_d(WARN_INTERNAL)) {
-#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
-           Perl_dump_sv_child(aTHX_ sv);
-#else
-  #ifdef DEBUG_LEAKING_SCALARS
-           sv_dump(sv);
-  #endif
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
-           if (PL_warnhook == PERL_WARNHOOK_FATAL
-               || ckDEAD(packWARN(WARN_INTERNAL))) {
-               /* Don't let Perl_warner cause us to escape our fate:  */
-               abort();
-           }
-#endif
-           /* This may not return:  */
-           Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                        "Attempt to free unreferenced scalar: SV 0x%"UVxf
-                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
-#endif
-       }
-#ifdef DEBUG_LEAKING_SCALARS_ABORT
-       abort();
-#endif
-       return;
-    }
-    if (--(SvREFCNT(sv)) > 0)
-       return;
-    Perl_sv_free2(aTHX_ sv);
+    SvREFCNT_dec(sv);
 }
 
+
+/* Private helper function for SvREFCNT_dec().
+ * Called with rc set to original SvREFCNT(sv), where rc == 0 or 1 */
+
 void
-Perl_sv_free2(pTHX_ SV *const sv)
+Perl_sv_free2(pTHX_ SV *const sv, const U32 rc)
 {
     dVAR;
 
     PERL_ARGS_ASSERT_SV_FREE2;
 
+    if (rc == 1) {
+        /* normal case */
+        SvREFCNT(sv) = 0;
+
 #ifdef DEBUGGING
-    if (SvTEMP(sv)) {
-       Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
-                        "Attempt to free temp prematurely: SV 0x%"UVxf
-                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
-       return;
-    }
+        if (SvTEMP(sv)) {
+            Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING),
+                             "Attempt to free temp prematurely: SV 0x%"UVxf
+                             pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+            return;
+        }
 #endif
+        if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
+            /* make sure SvREFCNT(sv)==0 happens very seldom */
+            SvREFCNT(sv) = (~(U32)0)/2;
+            return;
+        }
+        sv_clear(sv);
+        if (! SvREFCNT(sv)) /* may have have been resurrected */
+            del_SV(sv);
+        return;
+    }
+
+    /* handle exceptional cases */
+
+    assert(rc == 0);
+
+    if (SvFLAGS(sv) & SVf_BREAK)
+        /* this SV's refcnt has been artificially decremented to
+         * trigger cleanup */
+        return;
+    if (PL_in_clean_all) /* All is fair */
+        return;
     if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
-       /* make sure SvREFCNT(sv)==0 happens very seldom */
-       SvREFCNT(sv) = (~(U32)0)/2;
-       return;
+        /* make sure SvREFCNT(sv)==0 happens very seldom */
+        SvREFCNT(sv) = (~(U32)0)/2;
+        return;
     }
-    sv_clear(sv);
-    if (! SvREFCNT(sv))
-       del_SV(sv);
+    if (ckWARN_d(WARN_INTERNAL)) {
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+        Perl_dump_sv_child(aTHX_ sv);
+#else
+    #ifdef DEBUG_LEAKING_SCALARS
+        sv_dump(sv);
+    #endif
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+        if (PL_warnhook == PERL_WARNHOOK_FATAL
+            || ckDEAD(packWARN(WARN_INTERNAL))) {
+            /* Don't let Perl_warner cause us to escape our fate:  */
+            abort();
+        }
+#endif
+        /* This may not return:  */
+        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
+                    "Attempt to free unreferenced scalar: SV 0x%"UVxf
+                    pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#endif
+    }
+#ifdef DEBUG_LEAKING_SCALARS_ABORT
+    abort();
+#endif
+
 }
 
+
 /*
 =for apidoc sv_len