PP(pp_const)
{
- dVAR;
dSP;
XPUSHs(cSVOP_sv);
RETURN;
PP(pp_nextstate)
{
- dVAR;
PL_curcop = (COP*)PL_op;
+ PL_sawalias = 0;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
PP(pp_gvsv)
{
- dVAR;
dSP;
EXTEND(SP,1);
- if (PL_op->op_private & OPpLVAL_INTRO)
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
PUSHs(save_scalar(cGVOP_gv));
else
PUSHs(GvSVn(cGVOP_gv));
+ if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
+ PL_sawalias = TRUE;
RETURN;
}
PP(pp_null)
{
- dVAR;
return NORMAL;
}
/* This is sometimes called directly by pp_coreargs and pp_grepstart. */
PP(pp_pushmark)
{
- dVAR;
PUSHMARK(PL_stack_sp);
return NORMAL;
}
PP(pp_stringify)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
SETs(TARG);
sv_copypv(TARG, sv);
PP(pp_gv)
{
- dVAR; dSP;
+ dSP;
XPUSHs(MUTABLE_SV(cGVOP_gv));
+ if (isGV(cGVOP_gv)
+ && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
+ PL_sawalias = TRUE;
RETURN;
}
PP(pp_and)
{
- dVAR;
PERL_ASYNC_CHECK();
{
/* SP is not used to remove a variable that is saved across the
PP(pp_sassign)
{
- dVAR; dSP;
+ dSP;
/* sassign keeps its args in the optree traditionally backwards.
So we pop them differently.
*/
SV * const temp = left;
left = right; right = temp;
}
- if (TAINTING_get && TAINT_get && !SvTAINTED(right))
+ if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
TAINT_NOT;
- if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
+ if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
+ /* *foo =\&bar */
SV * const cv = SvRV(right);
const U32 cv_type = SvTYPE(cv);
const bool is_gv = isGV_with_GP(left);
}
if (
- SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
(!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
)
Perl_warner(aTHX_
PP(pp_cond_expr)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
PP(pp_unstack)
{
- dVAR;
PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
+ dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
else
SvUTF8_off(TARG);
}
- else { /* $l .= $r */
- if (!SvOK(TARG)) {
+ else { /* $l .= $r and left == TARG */
+ if (!SvOK(left)) {
if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
report_uninit(right);
sv_setpvs(left, "");
}
- SvPV_force_nomg_nolen(left);
+ else {
+ SvPV_force_nomg_nolen(left);
+ }
lbyte = !DO_UTF8(left);
if (IN_BYTES)
- SvUTF8_off(TARG);
+ SvUTF8_off(left);
}
if (!rcopied) {
dSP;
const SSize_t maxarg = AvFILL(av) + 1;
EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
+ if (UNLIKELY(SvRMAGICAL(av))) {
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV * const sv = AvARRAY(av)[i];
- SP[i+1] = sv ? sv : &PL_sv_undef;
+ SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
}
}
SP += maxarg;
PP(pp_padrange)
{
- dVAR; dSP;
+ dSP;
PADOFFSET base = PL_op->op_targ;
int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
int i;
PP(pp_padsv)
{
- dVAR; dSP;
+ dSP;
EXTEND(SP, 1);
{
OP * const op = PL_op;
PP(pp_readline)
{
- dVAR;
dSP;
if (TOPs) {
SvGETMAGIC(TOPs);
PP(pp_eq)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
PP(pp_preinc)
{
- dVAR; dSP;
+ dSP;
const bool inc =
PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
- if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
+ if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
Perl_croak_no_modify();
- if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
PP(pp_or)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
PP(pp_defined)
{
- dVAR; dSP;
+ dSP;
SV* sv;
bool defined;
const int op_type = PL_op->op_type;
if (is_dor) {
PERL_ASYNC_CHECK();
sv = TOPs;
- if (!sv || !SvANY(sv)) {
+ if (UNLIKELY(!sv || !SvANY(sv))) {
if (op_type == OP_DOR)
--SP;
RETURNOP(cLOGOP->op_other);
else {
/* OP_DEFINED */
sv = POPs;
- if (!sv || !SvANY(sv))
+ if (UNLIKELY(!sv || !SvANY(sv)))
RETPUSHNO;
}
PP(pp_add)
{
- dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ dSP; dATARGET; bool useleft; SV *svl, *svr;
tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
PP(pp_aelemfast)
{
- dVAR; dSP;
+ dSP;
AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
- SV** const svp = av_fetch(av, PL_op->op_private, lval);
+ SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
+
+ if (UNLIKELY(!svp && lval))
+ DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
+
EXTEND(SP, 1);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
mg_get(sv);
PP(pp_join)
{
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
MARK++;
do_join(TARG, *MARK, MARK, SP);
SP = MARK;
PP(pp_pushre)
{
- dVAR; dSP;
+ dSP;
#ifdef DEBUGGING
/*
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
PP(pp_print)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
PerlIO *fp;
MAGIC *mg;
GV * const gv
PP(pp_rv2av)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
const I32 gimme = GIMME_V;
static const char an_array[] = "an ARRAY";
static const char a_hash[] = "a HASH";
SvGETMAGIC(sv);
if (SvROK(sv)) {
- if (SvAMAGIC(sv)) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
}
sv = SvRV(sv);
- if (SvTYPE(sv) != type)
+ if (UNLIKELY(SvTYPE(sv) != type))
/* diag_listed_as: Not an ARRAY reference */
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- else if (PL_op->op_flags & OPf_MOD
- && PL_op->op_private & OPpLVAL_INTRO)
+ else if (UNLIKELY(PL_op->op_flags & OPf_MOD
+ && PL_op->op_private & OPpLVAL_INTRO))
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
- else if (SvTYPE(sv) != type) {
+ else if (UNLIKELY(SvTYPE(sv) != type)) {
GV *gv;
if (!isGV_with_GP(sv)) {
SETs(sv);
RETURN;
}
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
else if (gimme == G_SCALAR) {
dTARG;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SPAGAIN;
SETTARG;
}
}
STATIC void
S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_ODDBALL;
if (*oddkey) {
* Don't bother if LHS is just an empty hash or array.
*/
- if ( (PL_op->op_private & OPpASSIGN_COMMON)
+ if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
&& (
firstlelem != lastlelem
|| ! ((sv = *firstlelem))
) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
- if ((sv = *relem)) {
+ if (LIKELY((sv = *relem))) {
TAINT_NOT; /* Each item is independent */
/* Dear TODO test in t/op/sort.t, I love you.
(It's relying on a panic, not a "semi-panic" from newSVsv()
and then an assertion failure below.) */
- if (SvIS_FREED(sv)) {
+ if (UNLIKELY(SvIS_FREED(sv))) {
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
(void*)sv);
}
ary = NULL;
hash = NULL;
- while (lelem <= lastlelem) {
+ while (LIKELY(lelem <= lastlelem)) {
TAINT_NOT; /* Each item stands on its own, taintwise. */
sv = *lelem++;
switch (SvTYPE(sv)) {
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
- if (*relem)
+ if (LIKELY(*relem))
SvGETMAGIC(*relem); /* before newSV, in case it dies */
sv = newSV(0);
sv_setsv_nomg(sv, *relem);
}
TAINT_NOT;
}
- if (PL_delaymagic & DM_ARRAY_ISA)
+ if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
SvSETMAGIC(MUTABLE_SV(ary));
LEAVE;
break;
magic = SvMAGICAL(hash) != 0;
odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
- if ( odd ) {
+ if (UNLIKELY(odd)) {
do_oddball(lastrelem, firsthashrelem);
/* we have firstlelem to reuse, it's not needed anymore
*/
ENTER;
SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
hv_clear(hash);
- while (relem < lastrelem+odd) { /* gobble up all the rest */
+ while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
HE *didstore;
assert(*relem);
/* Copy the key if aassign is called in lvalue context,
break;
}
if (relem <= lastrelem) {
- if (
+ if (UNLIKELY(
SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
(!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
- )
+ ))
Perl_warner(aTHX_
packWARN(WARN_MISC),
"Useless assignment to a temporary"
break;
}
}
- if (PL_delaymagic & ~DM_DELAY) {
+ if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
/* Will be used to set PL_tainting below */
Uid_t tmp_uid = PerlProc_getuid();
Uid_t tmp_euid = PerlProc_geteuid();
Gid_t tmp_gid = PerlProc_getgid();
Gid_t tmp_egid = PerlProc_getegid();
+ /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
- (Uid_t)-1);
+ PERL_UNUSED_RESULT(
+ setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
+ (Uid_t)-1));
#else
# ifdef HAS_SETREUID
- (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
+ PERL_UNUSED_RESULT(
+ setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(PL_delaymagic_uid);
+ PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_delaymagic_euid);
+ PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
if (PL_delaymagic_uid != PL_delaymagic_euid)
DIE(aTHX_ "No setreuid available");
- (void)PerlProc_setuid(PL_delaymagic_uid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
+
tmp_uid = PerlProc_getuid();
tmp_euid = PerlProc_geteuid();
}
+ /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
- (Gid_t)-1);
+ PERL_UNUSED_RESULT(
+ setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
+ (Gid_t)-1));
#else
# ifdef HAS_SETREGID
- (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
+ PERL_UNUSED_RESULT(
+ setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(PL_delaymagic_gid);
+ PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_delaymagic_egid);
+ PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
if (PL_delaymagic_gid != PL_delaymagic_egid)
DIE(aTHX_ "No setregid available");
- (void)PerlProc_setgid(PL_delaymagic_gid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
+
tmp_gid = PerlProc_getgid();
tmp_egid = PerlProc_getegid();
}
PP(pp_qr)
{
- dVAR; dSP;
+ dSP;
PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SvROK_on(rv);
cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
- if ((cv = *cvp) && CvCLONE(*cvp)) {
+ if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
*cvp = cv_clone(cv);
SvREFCNT_dec_NN(cv);
}
(void)sv_bless(rv, stash);
}
- if (RX_ISTAINTED(rx)) {
+ if (UNLIKELY(RX_ISTAINTED(rx))) {
SvTAINTED_on(rv);
SvTAINTED_on(SvRV(rv));
}
PP(pp_match)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
const char *s;
EXTEND_MORTAL(nparens + i);
for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
- if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
+ if (LIKELY((RX_OFFS(rx)[i].start != -1)
+ && RX_OFFS(rx)[i].end != -1 ))
+ {
const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
const char * const s = RX_OFFS(rx)[i].start + truebase;
- if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
- len < 0 || len > strend - s)
+ if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
+ || len < 0 || len > strend - s))
DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
"start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
(long) i, (long) RX_OFFS(rx)[i].start,
OP *
Perl_do_readline(pTHX)
{
- dVAR; dSP; dTARGETSTACKED;
+ dSP; dTARGETSTACKED;
SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
- if (av_len(GvAVn(PL_last_in_gv)) < 0) {
+ if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
- do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
+ do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALPHANUMERIC(*t1) &&
- strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+#ifdef __VMS
+ if (strchr("*%?", *t1))
+#else
+ if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+#endif
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
(void)POPs; /* Unmatched wildcard? Chuck it... */
PP(pp_helem)
{
- dVAR; dSP;
+ dSP;
HE* he;
SV **svp;
SV * const keysv = POPs;
PP(pp_iter)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *oldsv;
SV **itersvp;
It has SvPVX of "" and SvCUR of 0, which is what we want. */
STRLEN maxlen = 0;
const char *max = SvPV_const(end, maxlen);
- if (SvNIOK(cur) || SvCUR(cur) > maxlen)
+ if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
RETPUSHNO;
oldsv = *itersvp;
- if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
/* safe to reuse old SV */
sv_setsv(oldsv, cur);
}
case CXt_LOOP_LAZYIV: /* integer increment */
{
IV cur = cx->blk_loop.state_u.lazyiv.cur;
- if (cur > cx->blk_loop.state_u.lazyiv.end)
+ if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
RETPUSHNO;
oldsv = *itersvp;
/* don't risk potential race */
- if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
/* safe to reuse old SV */
sv_setiv(oldsv, cur);
}
SvREFCNT_dec_NN(oldsv);
}
- if (cur == IV_MAX) {
+ if (UNLIKELY(cur == IV_MAX)) {
/* Handle end of range at IV_MAX */
cx->blk_loop.state_u.lazyiv.end = IV_MIN;
} else
}
if (PL_op->op_private & OPpITER_REVERSED) {
ix = --cx->blk_loop.state_u.ary.ix;
- if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
+ if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
RETPUSHNO;
}
else {
ix = ++cx->blk_loop.state_u.ary.ix;
- if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
+ if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
RETPUSHNO;
}
- if (SvMAGICAL(av) || AvREIFY(av)) {
+ if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
SV * const * const svp = av_fetch(av, ix, FALSE);
sv = svp ? *svp : NULL;
}
sv = AvARRAY(av)[ix];
}
- if (sv) {
- if (SvIS_FREED(sv)) {
+ if (LIKELY(sv)) {
+ if (UNLIKELY(SvIS_FREED(sv))) {
*itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- if (SvPADTMP(sv) && !IS_PADGV(sv))
+ if (SvPADTMP(sv)) {
sv = newSVsv(sv);
+ }
else {
SvTEMP_off(sv);
SvREFCNT_inc_simple_void_NN(sv);
PL_tainted will get set (via TAINT_set) if any component of the pattern
is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
-TAINT_get).
+TAINT_get). It will also be set if any component of the pattern matches
+based on locale-dependent behavior.
When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
the pattern is marked as tainted. This means that subsequent usage, such
as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
on the new pattern too.
-At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
-regex is cleared; during execution, locale-variant ops such as POSIXL may
-set RXf_TAINTED_SEEN.
-
RXf_TAINTED_SEEN is used post-execution by the get magic code
of $1 et al to indicate whether the returned value should be tainted.
It is the responsibility of the caller of the pattern (i.e. pp_match,
PP(pp_subst)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *rpm = pm;
char *s;
d = s = RX_OFFS(rx)[0].start + orig;
do {
I32 i;
- if (iters++ > maxiters)
+ if (UNLIKELY(iters++ > maxiters))
DIE(aTHX_ "Substitution loop");
- if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
m = RX_OFFS(rx)[0].start + orig;
if ((i = m - s)) {
}
first = TRUE;
do {
- if (iters++ > maxiters)
+ if (UNLIKELY(iters++ > maxiters))
DIE(aTHX_ "Substitution loop");
- if (RX_MATCH_TAINTED(rx))
+ if (UNLIKELY(RX_MATCH_TAINTED(rx)))
rxtainted |= SUBST_TAINT_PAT;
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
char *old_s = s;
sv_catsv(dstr, nsv);
}
else sv_catsv(dstr, repl);
- if (SvTAINTED(repl))
+ if (UNLIKELY(SvTAINTED(repl)))
rxtainted |= SUBST_TAINT_REPL;
}
if (once)
PP(pp_grepwhile)
{
- dVAR; dSP;
+ dSP;
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
- if (PL_stack_base + *PL_markstack_ptr > SP) {
+ if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
I32 items;
const I32 gimme = GIMME_V;
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
- if (SvPADTMP(src) && !IS_PADGV(src)) {
+ if (SvPADTMP(src)) {
src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
PL_tmps_floor++;
}
PP(pp_leavesub)
{
- dVAR; dSP;
+ dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
TAINT_NOT;
if (gimme == G_SCALAR) {
MARK = newsp + 1;
- if (MARK <= SP) {
+ if (LIKELY(MARK <= SP)) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
&& !SvMAGICAL(TOPs)) {
PP(pp_entersub)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
GV *gv;
CV *cv;
PERL_CONTEXT *cx;
I32 gimme;
const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
- if (!sv)
+ if (UNLIKELY(!sv))
DIE(aTHX_ "Not a CODE reference");
- switch (SvTYPE(sv)) {
- /* This is overwhelming the most common case: */
- case SVt_PVGV:
- we_have_a_glob:
- if (!(cv = GvCVu((const GV *)sv))) {
- HV *stash;
- cv = sv_2cv(sv, &stash, &gv, 0);
- }
- if (!cv) {
- ENTER;
- SAVETMPS;
- goto try_autoload;
- }
- break;
- case SVt_PVLV:
- if(isGV_with_GP(sv)) goto we_have_a_glob;
- /*FALLTHROUGH*/
- default:
- if (sv == &PL_sv_yes) { /* unfound import, ignore */
- if (hasargs)
- SP = PL_stack_base + POPMARK;
- else
- (void)POPMARK;
- RETURN;
- }
- SvGETMAGIC(sv);
- if (SvROK(sv)) {
- if (SvAMAGIC(sv)) {
- sv = amagic_deref_call(sv, to_cv_amg);
- /* Don't SPAGAIN here. */
- }
- }
- else {
- const char *sym;
- STRLEN len;
- if (!SvOK(sv))
- DIE(aTHX_ PL_no_usym, "a subroutine");
- sym = SvPV_nomg_const(sv, len);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
- cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
- break;
- }
- cv = MUTABLE_CV(SvRV(sv));
- if (SvTYPE(cv) == SVt_PVCV)
- break;
- /* FALL THROUGH */
- case SVt_PVHV:
- case SVt_PVAV:
- DIE(aTHX_ "Not a CODE reference");
- /* This is the second most common case: */
- case SVt_PVCV:
- cv = MUTABLE_CV(sv);
- break;
+ /* This is overwhelmingly the most common case: */
+ if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
+ switch (SvTYPE(sv)) {
+ case SVt_PVGV:
+ we_have_a_glob:
+ if (!(cv = GvCVu((const GV *)sv))) {
+ HV *stash;
+ cv = sv_2cv(sv, &stash, &gv, 0);
+ }
+ if (!cv) {
+ ENTER;
+ SAVETMPS;
+ goto try_autoload;
+ }
+ break;
+ case SVt_PVLV:
+ if(isGV_with_GP(sv)) goto we_have_a_glob;
+ /* FALLTHROUGH */
+ default:
+ if (sv == &PL_sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
+ RETURN;
+ }
+ SvGETMAGIC(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
+ }
+ else {
+ const char *sym;
+ STRLEN len;
+ if (!SvOK(sv))
+ DIE(aTHX_ PL_no_usym, "a subroutine");
+ sym = SvPV_nomg_const(sv, len);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
+ cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
+ break;
+ }
+ cv = MUTABLE_CV(SvRV(sv));
+ if (SvTYPE(cv) == SVt_PVCV)
+ break;
+ /* FALLTHROUGH */
+ case SVt_PVHV:
+ case SVt_PVAV:
+ DIE(aTHX_ "Not a CODE reference");
+ /* This is the second most common case: */
+ case SVt_PVCV:
+ cv = MUTABLE_CV(sv);
+ break;
+ }
}
ENTER;
retry:
- if (CvCLONE(cv) && ! CvCLONED(cv))
+ if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
DIE(aTHX_ "Closure prototype called");
- if (!CvROOT(cv) && !CvXSUB(cv)) {
+ if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
GV* autogv;
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv))) {
- if (CvNAMED(cv))
- DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
- HEKfARG(CvNAME_HEK(cv)));
+ if (CvLEXICAL(cv) && CvHASGV(cv))
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called",
+ SVfARG(cv_name(cv, NULL)));
+ if (CvANON(cv) || !CvHASGV(cv)) {
DIE(aTHX_ "Undefined subroutine called");
}
/* autoloaded stub? */
- if (cv != GvCV(gv)) {
+ if (cv != GvCV(gv = CvGV(cv))) {
cv = GvCV(gv);
}
/* should call AUTOLOAD now? */
goto retry;
}
- gimme = GIMME_V;
- if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
+ if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
+ && !CvNODEBUG(cv)))
+ {
Perl_get_db_sub(aTHX_ &sv, cv);
if (CvISXSUB(cv))
PL_curcopdb = PL_curcop;
if (CvLVALUE(cv)) {
/* check for lsub that handles lvalue subroutines */
- cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+ cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
/* if lsub not found then fall back to DB::sub */
if (!cv) cv = GvCV(PL_DBsub);
} else {
DIE(aTHX_ "No DB::sub routine defined");
}
+ gimme = GIMME_V;
+
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- SSize_t items = SP - MARK;
PADLIST * const padlist = CvPADLIST(cv);
+ I32 depth;
+
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.retop = PL_op->op_next;
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2) {
+ if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
PERL_STACK_OVERFLOW_CHECK();
- pad_push(padlist, CvDEPTH(cv));
+ pad_push(padlist, depth);
}
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (hasargs) {
+ PAD_SET_CUR_NOSAVE(padlist, depth);
+ if (LIKELY(hasargs)) {
AV *const av = MUTABLE_AV(PAD_SVl(0));
- if (AvREAL(av)) {
+ SSize_t items;
+ AV **defavp;
+
+ if (UNLIKELY(AvREAL(av))) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
av_clear(av);
AvREAL_off(av);
AvREIFY_on(av);
}
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
+ defavp = &GvAV(PL_defgv);
+ cx->blk_sub.savearray = *defavp;
+ *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
- ++MARK;
+ items = SP - MARK;
- if (items - 1 > AvMAX(av)) {
+ if (UNLIKELY(items - 1 > AvMAX(av))) {
SV **ary = AvALLOC(av);
AvMAX(av) = items - 1;
Renew(ary, items, SV*);
AvARRAY(av) = ary;
}
- Copy(MARK,AvARRAY(av),items,SV*);
+ Copy(MARK+1,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
MARK = AvARRAY(av);
while (items--) {
if (*MARK)
{
- if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+ if (SvPADTMP(*MARK)) {
*MARK = sv_mortalcopy(*MARK);
+ }
SvTEMP_off(*MARK);
}
MARK++;
}
}
SAVETMPS;
- if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv))
+ if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
/* warning must come *after* we fully set up the context
* stuff so that __WARN__ handlers can safely dounwind()
* if they want to
*/
- if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
- && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+ if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
+ && ckWARN(WARN_RECURSION)
+ && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
sub_crush_depth(cv);
RETURNOP(CvSTART(cv));
}
SAVETMPS;
PUTBACK;
- if (((PL_op->op_private
+ if (UNLIKELY(((PL_op->op_private
& PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv))
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- if (!hasargs && GvAV(PL_defgv)) {
+ if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
SSize_t items = SP - mark;
while (items--) {
mark++;
- if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
+ if (*mark && SvPADTMP(*mark)) {
*mark = sv_mortalcopy(*mark);
+ }
}
}
/* We assume first XSUB in &DB::sub is the called one. */
- if (PL_curcopdb) {
+ if (UNLIKELY(PL_curcopdb)) {
SAVEVPTR(PL_curcop);
PL_curcop = PL_curcopdb;
PL_curcopdb = NULL;
CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
- if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else
- *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
+ if (gimme == G_SCALAR) {
+ SV **svp = PL_stack_base + markix + 1;
+ if (svp != PL_stack_sp) {
+ *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
+ PL_stack_sp = svp;
+ }
}
LEAVE;
return NORMAL;
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- HEK *const hek = CvNAME_HEK(cv);
- SV *tmpstr;
- if (hek) {
- tmpstr = sv_2mortal(newSVhek(hek));
- }
- else {
- tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), NULL);
- }
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
- SVfARG(tmpstr));
+ SVfARG(cv_name(cv,NULL)));
}
}
PP(pp_aelem)
{
- dVAR; dSP;
+ dSP;
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
bool preeminent = TRUE;
SV *sv;
- if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
+ if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Use of reference \"%"SVf"\" as array index",
SVfARG(elemsv));
- if (SvTYPE(av) != SVt_PVAV)
+ if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
RETPUSHUNDEF;
- if (localizing) {
+ if (UNLIKELY(localizing)) {
MAGIC *mg;
HV *stash;
IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- len = av_len(av);
+ len = av_tindex(av);
mPUSHs(newSVavdefelem(av,
/* Resolve a negative index now, unless it points before the
beginning of the array, in which case record it for error
1));
RETURN;
}
- if (localizing) {
+ if (UNLIKELY(localizing)) {
if (preeminent)
save_aelem(av, elem, svp);
else
PP(pp_method)
{
- dVAR; dSP;
+ dSP;
SV* const sv = TOPs;
if (SvROK(sv)) {
PP(pp_method_named)
{
- dVAR; dSP;
+ dSP;
SV* const sv = cSVOP_sv;
U32 hash = SvSHARED_HASH(sv);
STATIC SV *
S_method_common(pTHX_ SV* meth, U32* hashp)
{
- dVAR;
SV* ob;
GV* gv;
HV* stash;
PERL_ARGS_ASSERT_METHOD_COMMON;
- if (!sv)
+ if (UNLIKELY(!sv))
undefined:
Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
SVfARG(meth));
GV* iogv;
STRLEN packlen;
const char * const packname = SvPV_nomg_const(sv, packlen);
- const bool packname_is_utf8 = !!SvUTF8(sv);
- const HE* const he =
- (const HE *)hv_common(
- PL_stashcache, NULL, packname, packlen,
- packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
- );
-
- if (he) {
- stash = INT2PTR(HV*,SvIV(HeVAL(he)));
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
- stash, sv));
- goto fetch;
- }
+ const U32 packname_utf8 = SvUTF8(sv);
+ stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
+ if (stash) goto fetch;
if (!(iogv = gv_fetchpvn_flags(
- packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+ packname, packlen, packname_utf8, SVt_PVIO
)) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
SVfARG(meth));
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
- if (!stash)
- packsv = sv;
- else {
- SV* const ref = newSViv(PTR2IV(stash));
- (void)hv_store(PL_stashcache, packname,
- packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
- stash, sv));
- }
+ stash = gv_stashpvn(packname, packlen, packname_utf8);
+ if (!stash) packsv = sv;
goto fetch;
}
/* it _is_ a filehandle name -- replace with a reference */
const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
if (he) {
gv = MUTABLE_GV(HeVAL(he));
+ assert(stash);
if (isGV(gv) && GvCV(gv) &&
(!GvCVGEN(gv) || GvCVGEN(gv)
== (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
}
}
+ assert(stash || packsv);
gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
- meth, GV_AUTOLOAD | GV_CROAK);
-
+ meth, GV_AUTOLOAD | GV_CROAK);
assert(gv);
return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
https://perl5.git.perl.org / perl5.git / blobdiff