X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2d7268923bcf822410c0286f060732300ab91ea7..e2e1dd5af807c886b8322d1af8c8311fa0f03adb:/pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index 0bcb7bd..37c8f9d 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1,7 +1,7 @@
 /*    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, 2005, 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.
@@ -16,6 +16,19 @@
  *                     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"
@@ -137,7 +150,7 @@ PP(pp_concat)
     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));
@@ -147,7 +160,7 @@ PP(pp_concat)
 
     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);
@@ -160,7 +173,9 @@ PP(pp_concat)
 	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)
@@ -198,7 +213,7 @@ PP(pp_padsv)
     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;
@@ -229,7 +244,7 @@ PP(pp_eq)
 {
     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;
@@ -295,7 +310,7 @@ PP(pp_eq)
 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)
@@ -521,7 +536,8 @@ PP(pp_add)
 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);
@@ -709,9 +725,6 @@ PP(pp_rv2av)
 	    GV *gv;
 	
 	    if (SvTYPE(sv) != SVt_PVGV) {
-		char *sym;
-		STRLEN len;
-
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
 		    if (SvROK(sv))
@@ -722,29 +735,28 @@ PP(pp_rv2av)
 		      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;
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
-		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
+		    gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
 		    if (!gv
-			&& (!is_gv_magical(sym,len,0)
-			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
+			&& (!is_gv_magical_sv(sv,0)
+			    || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
 		    {
 			RETSETUNDEF;
 		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
-		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+			DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
+		    gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
 		}
 	    }
 	    else {
@@ -775,7 +787,10 @@ PP(pp_rv2av)
 	    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 {
@@ -837,9 +852,6 @@ PP(pp_rv2hv)
 	    GV *gv;
 	
 	    if (SvTYPE(sv) != SVt_PVGV) {
-		char *sym;
-		STRLEN len;
-
 		if (SvGMAGICAL(sv)) {
 		    mg_get(sv);
 		    if (SvROK(sv))
@@ -850,29 +862,28 @@ PP(pp_rv2hv)
 		      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;
 		    }
 		    RETSETUNDEF;
 		}
-		sym = SvPV(sv,len);
 		if ((PL_op->op_flags & OPf_SPECIAL) &&
 		    !(PL_op->op_flags & OPf_MOD))
 		{
-		    gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
+		    gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
 		    if (!gv
-			&& (!is_gv_magical(sym,len,0)
-			    || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
+			&& (!is_gv_magical_sv(sv,0)
+			    || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
 		    {
 			RETSETUNDEF;
 		    }
 		}
 		else {
 		    if (PL_op->op_private & HINT_STRICT_REFS)
-			DIE(aTHX_ PL_no_symref, sym, "a HASH");
-		    gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+			DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
+		    gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
 		}
 	    }
 	    else {
@@ -901,15 +912,7 @@ PP(pp_rv2hv)
     }
     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;
@@ -967,7 +970,8 @@ PP(pp_aassign)
     I32 i;
     int magic;
     int duplicates = 0;
-    SV **firsthashrelem;
+    SV **firsthashrelem = 0;	/* "= 0" keeps gcc 2.95 quiet  */
+
 
     PL_delaymagic = DM_DELAY;		/* catch simultaneous items */
     gimme = GIMME_V;
@@ -1004,9 +1008,8 @@ PP(pp_aassign)
 	    i = 0;
 	    while (relem <= lastrelem) {	/* gobble up all the rest */
 		SV **didstore;
-		sv = NEWSV(28,0);
 		assert(*relem);
-		sv_setsv(sv,*relem);
+		sv = newSVsv(*relem);
 		*(relem++) = sv;
 		didstore = av_store(ary,i++,sv);
 		if (magic) {
@@ -1202,6 +1205,8 @@ PP(pp_match)
 
     if (PL_op->op_flags & OPf_STACKED)
 	TARG = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+	GETTARGET;
     else {
 	TARG = DEFSV;
 	EXTEND(SP,1);
@@ -1260,11 +1265,6 @@ PP(pp_match)
     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;
@@ -1319,10 +1319,10 @@ play_it_again:
 	    /*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);
@@ -1523,7 +1523,7 @@ Perl_do_readline(pTHX)
 	    /* 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;
 	}
@@ -1589,7 +1589,7 @@ Perl_do_readline(pTHX)
 	    if (gimme == G_SCALAR) {
 		if (type != OP_RCATLINE) {
 		    SV_CHECK_THINKFIRST_COW_DROP(TARG);
-		    (void)SvOK_off(TARG);
+		    SvOK_off(TARG);
 		}
 		SPAGAIN;
 		PUSHTARG;
@@ -1823,7 +1823,7 @@ PP(pp_iter)
 {
     dSP;
     register PERL_CONTEXT *cx;
-    SV* sv;
+    SV *sv, *oldsv;
     AV* av;
     SV **itersvp;
 
@@ -1839,8 +1839,8 @@ PP(pp_iter)
 	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 */
@@ -1851,8 +1851,9 @@ PP(pp_iter)
 		    /* 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 */
@@ -1876,28 +1877,47 @@ PP(pp_iter)
 	    /* 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");
@@ -1927,7 +1947,10 @@ PP(pp_iter)
 	sv = (SV*)lv;
     }
 
+    oldsv = *itersvp;
     *itersvp = SvREFCNT_inc(sv);
+    SvREFCNT_dec(oldsv);
+
     RETPUSHYES;
 }
 
@@ -1965,6 +1988,8 @@ PP(pp_subst)
     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);
@@ -1983,8 +2008,8 @@ PP(pp_subst)
 	!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;
 
@@ -2017,10 +2042,7 @@ PP(pp_subst)
 	       ? 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;
@@ -2191,8 +2213,7 @@ PP(pp_subst)
       have_a_cow:
 #endif
 	rxtainted |= RX_MATCH_TAINTED(rx);
-	dstr = NEWSV(25, len);
-	sv_setpvn(dstr, m, s-m);
+	dstr = newSVpvn(m, s-m);
 	if (DO_UTF8(TARG))
 	    SvUTF8_on(dstr);
 	PL_curpm = pm;
@@ -2243,7 +2264,7 @@ PP(pp_subst)
 	} else
 #endif
 	{
-	    (void)SvOOK_off(TARG);
+	    SvOOK_off(TARG);
 	    if (SvLEN(TARG))
 		Safefree(SvPVX(TARG));
 	}
@@ -2297,8 +2318,15 @@ PP(pp_grepwhile)
 	(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;
@@ -2312,7 +2340,10 @@ PP(pp_grepwhile)
 
 	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);
     }
@@ -2373,7 +2404,7 @@ PP(pp_leavesub)
     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
@@ -2531,7 +2562,7 @@ PP(pp_leavesublv)
     PL_curpm = newpm;	/* ... and pop $1 et al */
 
     LEAVESUB(sv);
-    return pop_return();
+    return cx->blk_sub.retop;
 }
 
 
@@ -2661,18 +2692,16 @@ PP(pp_entersub)
 	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);
 	}
@@ -2868,6 +2897,18 @@ PP(pp_aelem)
 	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)
@@ -2905,7 +2946,7 @@ Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
 	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;
 	}
@@ -2992,7 +3033,7 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
 
 	if (!SvOK(sv) ||
 	    !(packname) ||
-	    !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
+	    !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
 	    !(ob=(SV*)GvIO(iogv)))
 	{
 	    /* this isn't the name of a filehandle either */
@@ -3097,3 +3138,13 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
     }
     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * vim: shiftwidth=4:
+*/