/* pp_hot.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* Fire, Foes! Awake!
*/
+/* This file contains 'hot' pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * By 'hot', we mean common ops whose execution speed is critical.
+ * By gathering them together into a single file, we encourage
+ * CPU cache hits on hot code. Also it could be taken as a warning not to
+ * change any code in this file unless you're sure it won't affect
+ * performance.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
bool lbyte;
STRLEN rlen;
char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
- bool rbyte = !SvUTF8(right), rcopied = FALSE;
+ bool rbyte = !DO_UTF8(right), rcopied = FALSE;
if (TARG == right && right != left) {
right = sv_2mortal(newSVpvn(rpv, rlen));
if (TARG != left) {
lpv = SvPV(left, llen); /* mg_get(left) may happen here */
- lbyte = !SvUTF8(left);
+ lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
SvUTF8_on(TARG);
if (!SvOK(TARG))
sv_setpv(left, "");
lpv = SvPV_nomg(left, llen);
- lbyte = !SvUTF8(left);
+ lbyte = !DO_UTF8(left);
+ if (IN_BYTES)
+ SvUTF8_off(TARG);
}
#if defined(PERL_Y2KWARN)
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- else if (PL_op->op_private & OPpDEREF) {
+ if (PL_op->op_private & OPpDEREF) {
PUTBACK;
vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
SPAGAIN;
{
dSP; tryAMAGICbinSET(eq,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
RETURN;
PP(pp_preinc)
{
dSP;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
PP(pp_aelemfast)
{
dSP;
- AV *av = GvAV(cGVOP_gv);
+ AV *av = PL_op->op_flags & OPf_SPECIAL ?
+ (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
U32 lval = PL_op->op_flags & OPf_MOD;
SV** svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "an ARRAY");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
if (GIMME == G_ARRAY) {
(void)POPs;
RETURN;
U32 i;
for (i=0; i < (U32)maxarg; i++) {
SV **svp = av_fetch(av, i, FALSE);
- SP[i+1] = (svp) ? *svp : &PL_sv_undef;
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+ : &PL_sv_undef;
}
}
else {
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
if (gimme == G_ARRAY) {
SP--;
RETURN;
}
else if (gimme == G_SCALAR) {
dTARGET;
- if (SvRMAGICAL(hv) && mg_find((SV *)hv, PERL_MAGIC_tied))
- Perl_croak(aTHX_ "Can't provide tied hash usage; "
- "use keys(%%hash) to test if empty");
- if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
- (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
- else
- sv_setiv(TARG, 0);
-
+ TARG = Perl_hv_scalar(aTHX_ hv);
SETTARG;
}
RETURN;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
-
play_it_again:
if (global && rx->startp[0] != -1) {
t = s = rx->endp[0] + truebase;
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
+ s = rx->startp[i] + truebase;
if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers");
- s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
- (void)SvOK_off(TARG);
+ SvOK_off(TARG);
}
PUSHTARG;
}
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
- (void)SvOK_off(TARG);
+ SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
{
dSP;
register PERL_CONTEXT *cx;
- SV* sv;
+ SV *sv, *oldsv;
AV* av;
SV **itersvp;
if (cx->blk_loop.iterlval) {
/* string increment */
register SV* cur = cx->blk_loop.iterlval;
- STRLEN maxlen;
- char *max = SvPV((SV*)av, maxlen);
+ STRLEN maxlen = 0;
+ char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as
* they used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
*itersvp = newSVsv(cur);
+ SvREFCNT_dec(oldsv);
}
if (strEQ(SvPVX(cur), max))
sv_setiv(cur, 0); /* terminate next time */
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
*itersvp = newSViv(cx->blk_loop.iterix++);
+ SvREFCNT_dec(oldsv);
}
RETPUSHYES;
}
/* iterate array */
- if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
- RETPUSHNO;
-
- SvREFCNT_dec(*itersvp);
+ if (PL_op->op_private & OPpITER_REVERSED) {
+ /* In reverse, use itermax as the min :-) */
+ if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
+ RETPUSHNO;
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
- if (svp)
- sv = *svp;
- else
- sv = Nullsv;
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[cx->blk_loop.iterix--];
+ }
}
else {
- sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+ AvFILL(av)))
+ RETPUSHNO;
+
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ }
}
+
if (sv && SvREFCNT(sv) == 0) {
*itersvp = Nullsv;
Perl_croak(aTHX_ "Use of freed value in iteration");
sv = (SV*)lv;
}
+ oldsv = *itersvp;
*itersvp = SvREFCNT_inc(sv);
+ SvREFCNT_dec(oldsv);
+
RETPUSHYES;
}
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
!is_cow &&
#endif
(SvREADONLY(TARG)
- || (SvTYPE(TARG) > SVt_PVLV
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+ || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
+
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
PL_bostr = orig;
} else
#endif
{
- (void)SvOOK_off(TARG);
+ SvOOK_off(TARG);
if (SvLEN(TARG))
Safefree(SvPVX(TARG));
}
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- dTARGET;
- XPUSHi(items);
+ if (PL_op->op_private & OPpGREP_LEX) {
+ SV* sv = sv_newmortal();
+ sv_setiv(sv, items);
+ PUSHs(sv);
+ }
+ else {
+ dTARGET;
+ XPUSHi(items);
+ }
}
else if (gimme == G_ARRAY)
SP += items;
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
RETURNOP(cLOGOP->op_other);
}
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
- return pop_return();
+ return cx->blk_sub.retop;
}
/* This duplicates the above code because the above code must not
PL_curpm = newpm; /* ... and pop $1 et al */
LEAVESUB(sv);
- return pop_return();
+ return cx->blk_sub.retop;
}
dMARK;
register I32 items = SP - MARK;
AV* padlist = CvPADLIST(cv);
- push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
+ cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
/* XXX This would be a natural place to set C<PL_compcv = cv> so
* that eval'' ops within this sub know the correct lexical space.
* Owing the speed considerations, we choose instead to search for
* the cv using find_runcv() when calling doeval().
*/
- if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
- else {
+ if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
pad_push(padlist, CvDEPTH(cv), 1);
}
RETPUSHUNDEF;
svp = av_fetch(av, elem, lval && !defer);
if (lval) {
+#ifdef PERL_MALLOC_WRAP
+ static const char oom_array_extend[] =
+ "Out of memory during array extend"; /* Duplicated in av.c */
+ if (SvUOK(elemsv)) {
+ UV uv = SvUV(elemsv);
+ elem = uv > IV_MAX ? IV_MAX : uv;
+ }
+ else if (SvNOK(elemsv))
+ elem = (IV)SvNV(elemsv);
+ if (elem > 0)
+ MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
+#endif
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!defer)
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
else if (SvTYPE(sv) >= SVt_PV) {
- (void)SvOOK_off(sv);
+ SvOOK_off(sv);
Safefree(SvPVX(sv));
SvLEN(sv) = SvCUR(sv) = 0;
}
https://perl5.git.perl.org / perl5.git / blobdiff