Add Perl_croak_no_modify() to implement Perl_croak("%s", PL_no_modify).

This reduces object code size, reducing CPU cache pressure on the non-exception
paths.

diff --git a/av.c b/av.c
index 6e45b95..86aaae0 100644 (file)
--- a/av.c
+++ b/av.c
@@ -339,7 +339,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val)
     }
 
     if (SvREADONLY(av) && key >= AvFILL(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
 
     if (!AvREAL(av) && AvREIFY(av))
        av_reify(av);
@@ -440,7 +440,7 @@ Perl_av_clear(pTHX_ register AV *av)
 #endif
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
 
     /* Give any tie a chance to cleanup first */
     if (SvRMAGICAL(av)) {
@@ -546,7 +546,7 @@ Perl_av_push(pTHX_ register AV *av, SV *val)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1,
@@ -576,7 +576,7 @@ Perl_av_pop(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0);
        if (retval)
@@ -635,7 +635,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
        Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT",
@@ -697,7 +697,7 @@ Perl_av_shift(pTHX_ register AV *av)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
        retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0);
        if (retval)
@@ -813,7 +813,7 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags)
     assert(SvTYPE(av) == SVt_PVAV);
 
     if (SvREADONLY(av))
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
 
     if (SvRMAGICAL(av)) {
         const MAGIC * const tied_magic

diff --git a/doop.c b/doop.c
index c43ecb1..c1a357c 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -635,7 +635,7 @@ Perl_do_trans(pTHX_ SV *sv)
         if (SvIsCOW(sv))
             sv_force_normal_flags(sv, 0);
         if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
+            Perl_croak_no_modify(aTHX);
     }
     (void)SvPV_const(sv, len);
     if (!len)
@@ -1017,7 +1017,7 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
            sv_force_normal_flags(sv, 0);
         }
         if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
+            Perl_croak_no_modify(aTHX);
     }
 
     if (PL_encoding && !SvUTF8(sv)) {
@@ -1103,7 +1103,7 @@ Perl_do_chomp(pTHX_ register SV *sv)
            sv_force_normal_flags(sv, 0);
         }
         if (SvREADONLY(sv))
-            Perl_croak(aTHX_ "%s", PL_no_modify);
+            Perl_croak_no_modify(aTHX);
     }
 
     if (PL_encoding) {

diff --git a/embed.fnc b/embed.fnc
index e9287ea..81427fd 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -236,6 +236,7 @@ Aprd        |void   |croak_sv       |NN SV *baseex
 : croak()'s first parm can be NULL.  Otherwise, mod_perl breaks.
 Afprd  |void   |croak          |NULLOK const char* pat|...
 Aprd   |void   |vcroak         |NULLOK const char* pat|NULLOK va_list* args
+Aprd   |void   |croak_no_modify
 Aprd   |void   |croak_xs_usage |NN const CV *const cv \
                                |NN const char *const params
 

diff --git a/embed.h b/embed.h
index 80457a2..56ac2cf 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -105,6 +105,7 @@
 #define croak_sv               Perl_croak_sv
 #define croak                  Perl_croak
 #define vcroak                 Perl_vcroak
+#define croak_no_modify                Perl_croak_no_modify
 #define croak_xs_usage         Perl_croak_xs_usage
 #if defined(PERL_IMPLICIT_CONTEXT)
 #define croak_nocontext                Perl_croak_nocontext
@@ -2546,6 +2547,7 @@
 #endif
 #define croak_sv(a)            Perl_croak_sv(aTHX_ a)
 #define vcroak(a,b)            Perl_vcroak(aTHX_ a,b)
+#define croak_no_modify()      Perl_croak_no_modify(aTHX)
 #define croak_xs_usage(a,b)    Perl_croak_xs_usage(aTHX_ a,b)
 #if defined(PERL_IMPLICIT_CONTEXT)
 #endif

diff --git a/global.sym b/global.sym
index 459f796..30d89f7 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -65,6 +65,7 @@ Perl_my_chsize
 Perl_croak_sv
 Perl_croak
 Perl_vcroak
+Perl_croak_no_modify
 Perl_croak_xs_usage
 Perl_croak_nocontext
 Perl_die_nocontext

diff --git a/mg.c b/mg.c
index 052fee5..47844e0 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -635,7 +635,7 @@ Perl_magic_regdatum_set(pTHX_ SV *sv, MAGIC *mg)
     PERL_ARGS_ASSERT_MAGIC_REGDATUM_SET;
     PERL_UNUSED_ARG(sv);
     PERL_UNUSED_ARG(mg);
-    Perl_croak(aTHX_ "%s", PL_no_modify);
+    Perl_croak_no_modify(aTHX);
     NORETURN_FUNCTION_END;
 }
 
@@ -2372,7 +2372,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
              * set without a previous pattern match. Unless it's C<local $1>
              */
             if (!PL_localizing) {
-                Perl_croak(aTHX_ "%s", PL_no_modify);
+                Perl_croak_no_modify(aTHX);
             }
         }
     case '\001':       /* ^A */

diff --git a/pp.c b/pp.c
index ab1c680..a596ad3 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -162,7 +162,7 @@ PP(pp_rv2gv)
                 * NI-S 1999/05/07
                 */
                if (SvREADONLY(sv))
-                   Perl_croak(aTHX_ "%s", PL_no_modify);
+                   Perl_croak_no_modify(aTHX);
                if (PL_op->op_private & OPpDEREF) {
                    GV *gv;
                    if (cUNOP->op_targ) {
@@ -885,7 +885,7 @@ PP(pp_predec)
 {
     dVAR; dSP;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MIN)
     {
@@ -902,7 +902,7 @@ PP(pp_postinc)
 {
     dVAR; dSP; dTARGET;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
@@ -924,7 +924,7 @@ PP(pp_postdec)
 {
     dVAR; dSP; dTARGET;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MIN)

diff --git a/pp_hot.c b/pp_hot.c
index dc2c442..29928d7 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -405,7 +405,7 @@ PP(pp_preinc)
 {
     dVAR; dSP;
     if (SvTYPE(TOPs) >= SVt_PVAV || isGV_with_GP(TOPs))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
     {
@@ -2111,7 +2111,7 @@ PP(pp_subst)
         || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
               || SvTYPE(TARG) > SVt_PVLV)
             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
-       DIE(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     PUTBACK;
 
   setup_match:
@@ -3027,7 +3027,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
     SvGETMAGIC(sv);
     if (!SvOK(sv)) {
        if (SvREADONLY(sv))
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        prepare_SV_for_RV(sv);
        switch (to_what) {
        case OPpDEREF_SV:

diff --git a/pp_sort.c b/pp_sort.c
index 48d4273..ed9c809 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
@@ -1568,7 +1568,7 @@ PP(pp_sort)
        }
        else {
            if (SvREADONLY(av))
-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
            else
                SvREADONLY_on(av);
            p1 = p2 = AvARRAY(av);

diff --git a/pp_sys.c b/pp_sys.c
index 1f1f59c..d0b0423 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1043,7 +1043,7 @@ PP(pp_sselect)
            if (SvIsCOW(sv))
                sv_force_normal_flags(sv, 0);
            if (SvREADONLY(sv) && !(SvPOK(sv) && SvCUR(sv) == 0))
-               DIE(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (!SvPOK(sv)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask");

diff --git a/proto.h b/proto.h
index 31ef03d..03148fa 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -336,6 +336,9 @@ PERL_CALLCONV void  Perl_croak(pTHX_ const char* pat, ...)
 PERL_CALLCONV void     Perl_vcroak(pTHX_ const char* pat, va_list* args)
                        __attribute__noreturn__;
 
+PERL_CALLCONV void     Perl_croak_no_modify(pTHX)
+                       __attribute__noreturn__;
+
 PERL_CALLCONV void     Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
                        __attribute__noreturn__
                        __attribute__nonnull__(pTHX_1)

diff --git a/regcomp.c b/regcomp.c
index 0a343ec..49651b2 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -4995,7 +4995,7 @@ Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
     if (flags & RXapif_FETCH) {
         return reg_named_buff_fetch(rx, key, flags);
     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
         return NULL;
     } else if (flags & RXapif_EXISTS) {
         return reg_named_buff_exists(rx, key, flags)
@@ -5295,7 +5295,7 @@ Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
     PERL_UNUSED_ARG(value);
 
     if (!PL_localizing)
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
 }
 
 I32

diff --git a/sv.c b/sv.c
index c9e6f9e..cc8fe49 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3520,7 +3520,7 @@ Perl_sv_utf8_encode(pTHX_ register SV *const sv)
         sv_force_normal_flags(sv, 0);
     }
     if (SvREADONLY(sv)) {
-       Perl_croak(aTHX_ "%s", PL_no_modify);
+       Perl_croak_no_modify(aTHX);
     }
     (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);
@@ -4593,7 +4593,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
             }
        }
        else if (IN_PERL_RUNTIME)
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
     }
 #else
     if (SvREADONLY(sv)) {
@@ -4610,7 +4610,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
            unshare_hek(SvSHARED_HEK_FROM_PV(pvx));
        }
        else if (IN_PERL_RUNTIME)
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
     }
 #endif
     if (SvROK(sv))
@@ -5063,7 +5063,7 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
            && how != PERL_MAGIC_backref
           )
        {
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        }
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
@@ -7353,7 +7353,7 @@ Perl_sv_inc_nomg(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (SvROK(sv)) {
            IV i;
@@ -7534,7 +7534,7 @@ Perl_sv_dec_nomg(pTHX_ register SV *const sv)
            sv_force_normal_flags(sv, 0);
        if (SvREADONLY(sv)) {
            if (IN_PERL_RUNTIME)
-               Perl_croak(aTHX_ "%s", PL_no_modify);
+               Perl_croak_no_modify(aTHX);
        }
        if (SvROK(sv)) {
            IV i;
@@ -8841,7 +8841,7 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
        if (SvIsCOW(tmpRef))
            sv_force_normal_flags(tmpRef, 0);
        if (SvREADONLY(tmpRef))
-           Perl_croak(aTHX_ "%s", PL_no_modify);
+           Perl_croak_no_modify(aTHX);
        if (SvOBJECT(tmpRef)) {
            if (SvTYPE(tmpRef) != SVt_PVIO)
                --PL_sv_objcount;

diff --git a/universal.c b/universal.c
index 3df8321..1190e97 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -1283,7 +1283,7 @@ XS(XS_Tie_Hash_NamedCapture_STORE)
 
     if (!rx || !SvROK(ST(0))) {
         if (!PL_localizing)
-            Perl_croak(aTHX_ "%s", PL_no_modify);
+            Perl_croak_no_modify(aTHX);
         else
             XSRETURN_UNDEF;
     }
@@ -1305,7 +1305,7 @@ XS(XS_Tie_Hash_NamedCapture_DELETE)
        croak_xs_usage(cv, "$key, $flags");
 
     if (!rx || !SvROK(ST(0)))
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
 
     SP -= items;
 
@@ -1326,7 +1326,7 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR)
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
     if (!rx || !SvROK(ST(0)))
-        Perl_croak(aTHX_ "%s", PL_no_modify);
+        Perl_croak_no_modify(aTHX);
 
     SP -= items;
 

diff --git a/util.c b/util.c
index 666f99f..0e265be 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1638,6 +1638,21 @@ Perl_croak(pTHX_ const char *pat, ...)
 }
 
 /*
+=for apidoc Am|void|croak_no_modify
+
+Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
+terser object code than using C<Perl_croak>. Less code used on exception code
+paths reduces CPU cache pressure.
+
+*/
+
+void
+Perl_croak_no_modify(pTHX)
+{
+    Perl_croak(aTHX_ "%s", PL_no_modify);
+}
+
+/*
 =for apidoc Am|void|warn_sv|SV *baseex
 
 This is an XS interface to Perl's C<warn> function.