X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=a69b5156a2c939189cb376b56bcca58be9302dd8;hb=788611b6a6a160290f10302fc348e5dff91edc6e;hp=f3e616f9a861c229efd12185271322df41e06816;hpb=ddeae0f14c58a5f1101e1a8c75be3b67f60cf6fd;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/op.c b/op.c
index f3e616f..a69b515 100644
--- a/op.c
+++ b/op.c
@@ -30,13 +30,8 @@
 #define PERL_SLAB_SIZE 2048
 #endif
 
-#define NewOp(m,var,c,type) \
-	STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
-
-#define FreeOp(p) Slab_Free(p)
-
-STATIC void *
-S_Slab_Alloc(pTHX_ int m, size_t sz)
+void *
+Perl_Slab_Alloc(pTHX_ int m, size_t sz)
 {
     /*
      * To make incrementing use count easy PL_OpSlab is an I32 *
@@ -74,8 +69,8 @@ S_Slab_Alloc(pTHX_ int m, size_t sz)
     return (void *)(PL_OpPtr + 1);
 }
 
-STATIC void
-S_Slab_Free(pTHX_ void *op)
+void
+Perl_Slab_Free(pTHX_ void *op)
 {
     I32 **ptr = (I32 **) op;
     I32 *slab = ptr[-1];
@@ -93,10 +88,6 @@ S_Slab_Free(pTHX_ void *op)
 	}
     }
 }
-
-#else
-#define NewOp(m, var, c, type) Newz(m, var, c, type)
-#define FreeOp(p) Safefree(p)
 #endif
 /*
  * In the following definition, the ", Nullop" is just to make the compiler
@@ -194,7 +185,7 @@ Perl_allocmy(pTHX_ char *name)
 
     /* check for duplicate declaration */
     pad_check_dup(name,
-		PL_in_my == KEY_our,
+		(bool)(PL_in_my == KEY_our),
 		(PL_curstash ? PL_curstash : PL_defstash)
     );
 
@@ -1829,8 +1820,11 @@ Perl_newPROG(pTHX_ OP *o)
 	CALL_PEEP(PL_eval_start);
     }
     else {
-	if (o->op_type == OP_STUB)
+	if (o->op_type == OP_STUB) {
+	    PL_comppad_name = 0;
+	    PL_compcv = 0;
 	    return;
+	}
 	PL_main_root = scope(sawparens(scalarvoid(o)));
 	PL_curcop = &PL_compiling;
 	PL_main_start = LINKLIST(PL_main_root);
@@ -2009,6 +2003,8 @@ Perl_gen_constant_list(pTHX_ register OP *o)
 
     o->op_type = OP_RV2AV;
     o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+    o->op_flags &= ~OPf_REF;	/* treat \(1..2) like an ordinary list */
+    o->op_flags |= OPf_PARENS;	/* and flatten \(1..2,3) */
     o->op_seq = 0;		/* needs to be revisited in peep() */
     curop = ((UNOP*)o)->op_first;
     ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
@@ -2169,7 +2165,7 @@ Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
 	    listop->op_last = pushop;
     }
 
-    return (OP*)listop;
+    return CHECKOP(type, listop);
 }
 
 OP *
@@ -2292,13 +2288,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 	U8* tend = t + tlen;
 	U8* rend = r + rlen;
 	STRLEN ulen;
-	U32 tfirst = 1;
-	U32 tlast = 0;
-	I32 tdiff;
-	U32 rfirst = 1;
-	U32 rlast = 0;
-	I32 rdiff;
-	I32 diff;
+	UV tfirst = 1;
+	UV tlast = 0;
+	IV tdiff;
+	UV rfirst = 1;
+	UV rlast = 0;
+	IV rdiff;
+	IV diff;
 	I32 none = 0;
 	U32 max = 0;
 	I32 bits;
@@ -2606,7 +2602,7 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
 	PmopSTASH_set(pmop,PL_curstash);
     }
 
-    return (OP*)pmop;
+    return CHECKOP(type, pmop);
 }
 
 OP *
@@ -2653,6 +2649,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 			   : OPf_KIDS);
 	rcop->op_private = 1;
 	rcop->op_other = o;
+	/* /$x/ may cause an eval, since $x might be qr/(?{..})/  */
+	PL_cv_has_eval = 1;
 
 	/* establish postfix order */
 	if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
@@ -2672,7 +2670,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, OP *repl)
 	OP *curop;
 	if (pm->op_pmflags & PMf_EVAL) {
 	    curop = 0;
-	    if (CopLINE(PL_curcop) < PL_multi_end)
+	    if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
 		CopLINE_set(PL_curcop, (line_t)PL_multi_end);
 	}
 	else if (repl->op_type == OP_CONST)
@@ -2924,6 +2922,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
     PL_hints |= HINT_BLOCK_SCOPE;
     PL_copline = NOLINE;
     PL_expect = XSTATE;
+    PL_cop_seqmax++; /* Purely for B::*'s benefit */
 }
 
 /*
@@ -3410,6 +3409,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     first->op_next = (OP*)logop;
     first->op_sibling = other;
 
+    CHECKOP(type,logop);
+
     o = newUNOP(OP_NULL, 0, (OP*)logop);
     other->op_next = o;
 
@@ -3454,6 +3455,8 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
     logop->op_other = LINKLIST(trueop);
     logop->op_next = LINKLIST(falseop);
 
+    CHECKOP(OP_COND_EXPR, /* that's logop->op_type */
+	    logop);
 
     /* establish postfix order */
     start = LINKLIST(first);
@@ -3618,11 +3621,6 @@ Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *
 	if (!next)
 	    next = unstack;
 	cont = append_elem(OP_LINESEQ, cont, unstack);
-	if ((line_t)whileline != NOLINE) {
-	    PL_copline = (line_t)whileline;
-	    cont = append_elem(OP_LINESEQ, cont,
-			       newSTATEOP(0, Nullch, Nullop));
-	}
     }
 
     listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
@@ -3675,13 +3673,16 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     OP *wop;
     PADOFFSET padoff = 0;
     I32 iterflags = 0;
+    I32 iterpflags = 0;
 
     if (sv) {
 	if (sv->op_type == OP_RV2SV) {	/* symbol table variable */
+	    iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
 	    sv->op_type = OP_RV2GV;
 	    sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
 	}
 	else if (sv->op_type == OP_PADSV) { /* private variable */
+	    iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
 	    padoff = sv->op_targ;
 	    sv->op_targ = 0;
 	    op_free(sv);
@@ -3740,6 +3741,9 @@ Perl_newFOROP(pTHX_ I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *blo
     loop = (LOOP*)list(convert(OP_ENTERITER, iterflags,
 			       append_elem(OP_LIST, expr, scalar(sv))));
     assert(!loop->op_next);
+    /* for my  $x () sets OPpLVAL_INTRO;
+     * for our $x () sets OPpOUR_INTRO */
+    loop->op_private = (U8)iterpflags;
 #ifdef PL_OP_SLAB_ALLOC
     {
 	LOOP *tmp;
@@ -3885,6 +3889,26 @@ Perl_cv_const_sv(pTHX_ CV *cv)
     return (SV*)CvXSUBANY(cv).any_ptr;
 }
 
+/* op_const_sv:  examine an optree to determine whether it's in-lineable.
+ * Can be called in 3 ways:
+ *
+ * !cv
+ * 	look for a single OP_CONST with attached value: return the value
+ *
+ * cv && CvCLONE(cv) && !CvCONST(cv)
+ *
+ * 	examine the clone prototype, and if contains only a single
+ * 	OP_CONST referencing a pad const, or a single PADSV referencing
+ * 	an outer lexical, return a non-zero value to indicate the CV is
+ * 	a candidate for "constizing" at clone time
+ *
+ * cv && CvCONST(cv)
+ *
+ *	We have just cloned an anon prototype that was marked as a const
+ *	candidiate. Try to grab the current value, and in the case of
+ *	PADSV, ignore it if it has multiple references. Return the value.
+ */
+
 SV *
 Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
@@ -3913,26 +3937,31 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 	    return Nullsv;
 	if (type == OP_CONST && cSVOPo->op_sv)
 	    sv = cSVOPo->op_sv;
-	else if ((type == OP_PADSV || type == OP_CONST) && cv) {
+	else if (cv && type == OP_CONST) {
 	    sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
 	    if (!sv)
 		return Nullsv;
-	    if (CvCONST(cv)) {
-		/* We get here only from cv_clone2() while creating a closure.
-		   Copy the const value here instead of in cv_clone2 so that
-		   SvREADONLY_on doesn't lead to problems when leaving
-		   scope.
-		*/
+	}
+	else if (cv && type == OP_PADSV) {
+	    if (CvCONST(cv)) { /* newly cloned anon */
+		sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
+		/* the candidate should have 1 ref from this pad and 1 ref
+		 * from the parent */
+		if (!sv || SvREFCNT(sv) != 2)
+		    return Nullsv;
 		sv = newSVsv(sv);
+		SvREADONLY_on(sv);
+		return sv;
+	    }
+	    else {
+		if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
+		    sv = &PL_sv_undef; /* an arbitrary non-null value */
 	    }
-	    if (!SvREADONLY(sv) && SvREFCNT(sv) > 1)
-		return Nullsv;
 	}
-	else
+	else {
 	    return Nullsv;
+	}
     }
-    if (sv)
-	SvREADONLY_on(sv);
     return sv;
 }
 
@@ -4134,6 +4163,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
 	/* ... before we throw it away */
 	SvREFCNT_dec(PL_compcv);
+	PL_compcv = cv;
 	if (PERLDB_INTER)/* Advice debugger on the new sub. */
 	  ++PL_sub_generation;
     }
@@ -4320,6 +4350,9 @@ Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
     CvCONST_on(cv);
     sv_setpv((SV*)cv, "");  /* prototype is "" */
 
+    if (stash)
+	CopSTASH_free(PL_curcop);
+
     LEAVE;
 
     return cv;
@@ -4647,9 +4680,10 @@ Perl_ck_bitop(pTHX_ OP *o)
 	 (op) == OP_NE   || (op) == OP_I_NE || \
 	 (op) == OP_NCMP || (op) == OP_I_NCMP)
     o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
-    if (o->op_type == OP_BIT_OR
-	    || o->op_type == OP_BIT_AND
-	    || o->op_type == OP_BIT_XOR)
+    if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
+	    && (o->op_type == OP_BIT_OR
+	     || o->op_type == OP_BIT_AND
+	     || o->op_type == OP_BIT_XOR))
     {
 	OP * left = cBINOPo->op_first;
 	OP * right = left->op_sibling;
@@ -4670,8 +4704,9 @@ Perl_ck_bitop(pTHX_ OP *o)
 OP *
 Perl_ck_concat(pTHX_ OP *o)
 {
-    if (cUNOPo->op_first->op_type == OP_CONCAT)
-	o->op_flags |= OPf_STACKED;
+    OP *kid = cUNOPo->op_first;
+    if (kid->op_type == OP_CONCAT && !(kUNOP->op_first->op_flags & OPf_MOD))
+        o->op_flags |= OPf_STACKED;
     return o;
 }
 
@@ -4783,8 +4818,10 @@ Perl_ck_eval(pTHX_ OP *o)
 	    enter->op_other = o;
 	    return o;
 	}
-	else
+	else {
 	    scalar((OP*)kid);
+	    PL_cv_has_eval = 1;
+	}
     }
     else {
 	op_free(o);
@@ -5264,7 +5301,7 @@ Perl_ck_glob(pTHX_ OP *o)
 
 #if !defined(PERL_EXTERNAL_GLOB)
     /* XXX this can be tightened up and made more failsafe. */
-    if (!gv) {
+    if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
 	GV *glob_gv;
 	ENTER;
 	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,