summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--av.c14
-rw-r--r--doop.c6
-rw-r--r--embed.fnc1
-rw-r--r--embed.h2
-rw-r--r--global.sym1
-rw-r--r--mg.c4
-rw-r--r--pp.c8
-rw-r--r--pp_hot.c6
-rw-r--r--pp_sort.c2
-rw-r--r--pp_sys.c2
-rw-r--r--proto.h3
-rw-r--r--regcomp.c4
-rw-r--r--sv.c14
-rw-r--r--universal.c6
-rw-r--r--util.c15
15 files changed, 55 insertions, 33 deletions
diff --git a/av.c b/av.c
index 6e45b95d3b..86aaae0195 100644
--- 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 c43ecb111c..c1a357cc3e 100644
--- 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 e9287ea482..81427fd399 100644
--- 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 80457a2ec5..56ac2cf632 100644
--- 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 459f7968d9..30d89f7106 100644
--- 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 052fee5452..47844e0867 100644
--- 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 ab1c680579..a596ad3d66 100644
--- 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 dc2c442445..29928d7201 100644
--- 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 48d4273e23..ed9c809117 100644
--- 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 1f1f59c06c..d0b0423d69 100644
--- 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 31ef03ddc3..03148fa82c 100644
--- 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 0a343ecdaa..49651b27b7 100644
--- 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 c9e6f9e057..cc8fe49e3b 100644
--- 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 3df8321f9c..1190e9716f 100644
--- 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 666f99fc0f..0e265beb7c 100644
--- 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.
View Lorry Controller Status