X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/58182927067ecc460e3d1befd5302093f53edafd..84bafc024a74c819ac3d2b4406253dbe983e6502:/op.c

diff --git a/op.c b/op.c
index 8e3e5f8..42f997d 100644
--- a/op.c
+++ b/op.c
@@ -104,12 +104,17 @@ recursive, but it's recursive on basic blocks, not on tree nodes.
 
 #if defined(PL_OP_SLAB_ALLOC)
 
+#ifdef PERL_DEBUG_READONLY_OPS
+#  define PERL_SLAB_SIZE 4096
+#  include <sys/mman.h>
+#endif
+
 #ifndef PERL_SLAB_SIZE
 #define PERL_SLAB_SIZE 2048
 #endif
 
 void *
-Perl_Slab_Alloc(pTHX_ int m, size_t sz)
+Perl_Slab_Alloc(pTHX_ size_t sz)
 {
     /*
      * To make incrementing use count easy PL_OpSlab is an I32 *
@@ -119,11 +124,26 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz)
      */
     sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
     if ((PL_OpSpace -= sz) < 0) {
-        PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*)); 
+#ifdef PERL_DEBUG_READONLY_OPS
+	/* We need to allocate chunk by chunk so that we can control the VM
+	   mapping */
+	PL_OpPtr = mmap(0, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE,
+			MAP_ANON|MAP_PRIVATE, -1, 0);
+
+	DEBUG_m(PerlIO_printf(Perl_debug_log, "mapped %lu at %p\n",
+			      (unsigned long) PERL_SLAB_SIZE*sizeof(I32*),
+			      PL_OpPtr));
+	if(PL_OpPtr == MAP_FAILED) {
+	    perror("mmap failed");
+	    abort();
+	}
+#else
+
+        PL_OpPtr = (I32 **) PerlMemShared_calloc(PERL_SLAB_SIZE,sizeof(I32*)); 
+#endif
     	if (!PL_OpPtr) {
 	    return NULL;
 	}
-	Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
 	/* We reserve the 0'th I32 sized chunk as a use count */
 	PL_OpSlab = (I32 *) PL_OpPtr;
 	/* Reduce size by the use count word, and by the size we need.
@@ -135,6 +155,14 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz)
 	   means that at run time access is cache friendly upward
 	 */
 	PL_OpPtr += PERL_SLAB_SIZE;
+
+#ifdef PERL_DEBUG_READONLY_OPS
+	/* We remember this slab.  */
+	/* This implementation isn't efficient, but it is simple. */
+	PL_slabs = realloc(PL_slabs, sizeof(I32**) * (PL_slab_count + 1));
+	PL_slabs[PL_slab_count++] = PL_OpSlab;
+	DEBUG_m(PerlIO_printf(Perl_debug_log, "Allocate %p\n", PL_OpSlab));
+#endif
     }
     assert( PL_OpSpace >= 0 );
     /* Move the allocation pointer down */
@@ -147,6 +175,70 @@ Perl_Slab_Alloc(pTHX_ int m, size_t sz)
     return (void *)(PL_OpPtr + 1);
 }
 
+#ifdef PERL_DEBUG_READONLY_OPS
+void
+Perl_pending_Slabs_to_ro(pTHX) {
+    /* Turn all the allocated op slabs read only.  */
+    U32 count = PL_slab_count;
+    I32 **const slabs = PL_slabs;
+
+    /* Reset the array of pending OP slabs, as we're about to turn this lot
+       read only. Also, do it ahead of the loop in case the warn triggers,
+       and a warn handler has an eval */
+
+    PL_slabs = NULL;
+    PL_slab_count = 0;
+
+    /* Force a new slab for any further allocation.  */
+    PL_OpSpace = 0;
+
+    while (count--) {
+	void *const start = slabs[count];
+	const size_t size = PERL_SLAB_SIZE* sizeof(I32*);
+	if(mprotect(start, size, PROT_READ)) {
+	    Perl_warn(aTHX_ "mprotect for %p %lu failed with %d",
+		      start, (unsigned long) size, errno);
+	}
+    }
+
+    free(slabs);
+}
+
+STATIC void
+S_Slab_to_rw(pTHX_ void *op)
+{
+    I32 * const * const ptr = (I32 **) op;
+    I32 * const slab = ptr[-1];
+    assert( ptr-1 > (I32 **) slab );
+    assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+    assert( *slab > 0 );
+    if(mprotect(slab, PERL_SLAB_SIZE*sizeof(I32*), PROT_READ|PROT_WRITE)) {
+	Perl_warn(aTHX_ "mprotect RW for %p %lu failed with %d",
+		  slab, (unsigned long) PERL_SLAB_SIZE*sizeof(I32*), errno);
+    }
+}
+
+OP *
+Perl_op_refcnt_inc(pTHX_ OP *o)
+{
+    if(o) {
+	Slab_to_rw(o);
+	++o->op_targ;
+    }
+    return o;
+
+}
+
+PADOFFSET
+Perl_op_refcnt_dec(pTHX_ OP *o)
+{
+    Slab_to_rw(o);
+    return --o->op_targ;
+}
+#else
+#  define Slab_to_rw(op)
+#endif
+
 void
 Perl_Slab_Free(pTHX_ void *op)
 {
@@ -155,12 +247,38 @@ Perl_Slab_Free(pTHX_ void *op)
     assert( ptr-1 > (I32 **) slab );
     assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
     assert( *slab > 0 );
+    Slab_to_rw(op);
     if (--(*slab) == 0) {
 #  ifdef NETWARE
 #    define PerlMemShared PerlMem
 #  endif
 	
+#ifdef PERL_DEBUG_READONLY_OPS
+	U32 count = PL_slab_count;
+	/* Need to remove this slab from our list of slabs */
+	if (count) {
+	    while (count--) {
+		if (PL_slabs[count] == slab) {
+		    /* Found it. Move the entry at the end to overwrite it.  */
+		    DEBUG_m(PerlIO_printf(Perl_debug_log,
+					  "Deallocate %p by moving %p from %lu to %lu\n",
+					  PL_OpSlab,
+					  PL_slabs[PL_slab_count - 1],
+					  PL_slab_count, count));
+		    PL_slabs[count] = PL_slabs[--PL_slab_count];
+		    /* Could realloc smaller at this point, but probably not
+		       worth it.  */
+		    if(munmap(slab, PERL_SLAB_SIZE*sizeof(I32*))) {
+			perror("munmap failed");
+			abort();
+		    }
+		    break;
+		}
+	    }
+	}
+#else
     PerlMemShared_free(slab);
+#endif
 	if (slab == PL_OpSlab) {
 	    PL_OpSpace = 0;
 	}
@@ -234,7 +352,7 @@ Perl_allocmy(pTHX_ const char *const name)
 {
     dVAR;
     PADOFFSET off;
-    const bool is_our = (PL_in_my == KEY_our);
+    const bool is_our = (PL_parser->in_my == KEY_our);
 
     /* complain about "my $<special_var>" etc etc */
     if (*name &&
@@ -245,42 +363,51 @@ Perl_allocmy(pTHX_ const char *const name)
     {
 	/* name[2] is true if strlen(name) > 2  */
 	if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
-	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
-			      name[0], toCTRL(name[1]), name + 2));
+	    yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
+			      name[0], toCTRL(name[1]), name + 2,
+			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	} else {
-	    yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
+	    yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+			      PL_parser->in_my == KEY_state ? "state" : "my"));
 	}
     }
 
     /* check for duplicate declaration */
     pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
 
-    if (PL_in_my_stash && *name != '$') {
+    if (PL_parser->in_my_stash && *name != '$') {
 	yyerror(Perl_form(aTHX_
 		    "Can't declare class for non-scalar %s in \"%s\"",
  		     name,
- 		     is_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+ 		     is_our ? "our"
+			    : PL_parser->in_my == KEY_state ? "state" : "my"));
     }
 
     /* allocate a spare slot and store the name in that slot */
 
     off = pad_add_name(name,
-		    PL_in_my_stash,
+		    PL_parser->in_my_stash,
 		    (is_our
 		        /* $_ is always in main::, even with our */
 			? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
 			: NULL
 		    ),
 		    0, /*  not fake */
-		    PL_in_my == KEY_state
+		    PL_parser->in_my == KEY_state
     );
+    /* anon sub prototypes contains state vars should always be cloned,
+     * otherwise the state var would be shared between anon subs */
+
+    if (PL_parser->in_my == KEY_state && CvANON(PL_compcv))
+	CvCLONE_on(PL_compcv);
+
     return off;
 }
 
 /* free the body of an op without examining its contents.
  * Always use this rather than FreeOp directly */
 
-void
+static void
 S_op_destroy(pTHX_ OP *o)
 {
     if (o->op_latefree) {
@@ -290,6 +417,11 @@ S_op_destroy(pTHX_ OP *o)
     FreeOp(o);
 }
 
+#ifdef USE_ITHREADS
+#  define forget_pmop(a,b)	S_forget_pmop(aTHX_ a,b)
+#else
+#  define forget_pmop(a,b)	S_forget_pmop(aTHX_ a)
+#endif
 
 /* Destructor */
 
@@ -299,7 +431,7 @@ Perl_op_free(pTHX_ OP *o)
     dVAR;
     OPCODE type;
 
-    if (!o || o->op_static)
+    if (!o)
 	return;
     if (o->op_latefreed) {
 	if (o->op_latefree)
@@ -321,9 +453,13 @@ Perl_op_free(pTHX_ OP *o)
 	    OP_REFCNT_LOCK;
 	    refcnt = OpREFCNT_dec(o);
 	    OP_REFCNT_UNLOCK;
-	    if (refcnt)
+	    if (refcnt) {
+		/* Need to find and remove any pattern match ops from the list
+		   we maintain for reset().  */
+		find_and_forget_pmops(o);
 		return;
 	    }
+	    }
 	    break;
 	default:
 	    break;
@@ -340,10 +476,15 @@ Perl_op_free(pTHX_ OP *o)
     if (type == OP_NULL)
 	type = (OPCODE)o->op_targ;
 
+#ifdef PERL_DEBUG_READONLY_OPS
+    Slab_to_rw(o);
+#endif
+
     /* COP* is not cleared by op_clear() so that we may track line
      * numbers etc even after null() */
-    if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE)
+    if (type == OP_NEXTSTATE || type == OP_SETSTATE || type == OP_DBSTATE) {
 	cop_free((COP*)o);
+    }
 
     op_clear(o);
     if (o->op_latefree) {
@@ -454,45 +595,24 @@ Perl_op_clear(pTHX_ OP *o)
 	}
 	break;
     case OP_SUBST:
-	op_free(cPMOPo->op_pmreplroot);
+	op_free(cPMOPo->op_pmreplrootu.op_pmreplroot);
 	goto clear_pmop;
     case OP_PUSHRE:
 #ifdef USE_ITHREADS
-        if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
+        if (cPMOPo->op_pmreplrootu.op_pmtargetoff) {
 	    /* No GvIN_PAD_off here, because other references may still
 	     * exist on the pad */
-	    pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot), TRUE);
+	    pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE);
 	}
 #else
-	SvREFCNT_dec((SV*)cPMOPo->op_pmreplroot);
+	SvREFCNT_dec((SV*)cPMOPo->op_pmreplrootu.op_pmtargetgv);
 #endif
 	/* FALL THROUGH */
     case OP_MATCH:
     case OP_QR:
 clear_pmop:
-	{
-	    HV * const pmstash = PmopSTASH(cPMOPo);
-	    if (pmstash && !SvIS_FREED(pmstash)) {
-		MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
-		if (mg) {
-		    PMOP *pmop = (PMOP*) mg->mg_obj;
-		    PMOP *lastpmop = NULL;
-		    while (pmop) {
-			if (cPMOPo == pmop) {
-			    if (lastpmop)
-				lastpmop->op_pmnext = pmop->op_pmnext;
-			    else
-				mg->mg_obj = (SV*) pmop->op_pmnext;
-			    break;
-			}
-			lastpmop = pmop;
-			pmop = pmop->op_pmnext;
-		    }
-		}
-	    }
-	    PmopSTASH_free(cPMOPo);
-	}
-	cPMOPo->op_pmreplroot = NULL;
+	forget_pmop(cPMOPo, 1);
+	cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
         /* we use the "SAFE" version of the PM_ macros here
          * since sv_clean_all might release some PMOPs
          * after PL_regex_padav has been cleared
@@ -504,6 +624,7 @@ clear_pmop:
 #ifdef USE_ITHREADS
 	if(PL_regex_pad) {        /* We could be in destruction */
             av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
+            SvREADONLY_off(PL_regex_pad[(cPMOPo)->op_pmoffset]);
 	    SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
             PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
         }
@@ -529,6 +650,65 @@ S_cop_free(pTHX_ COP* cop)
     Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
 }
 
+STATIC void
+S_forget_pmop(pTHX_ PMOP *const o
+#ifdef USE_ITHREADS
+	      , U32 flags
+#endif
+	      )
+{
+    HV * const pmstash = PmopSTASH(o);
+    if (pmstash && !SvIS_FREED(pmstash)) {
+	MAGIC * const mg = mg_find((SV*)pmstash, PERL_MAGIC_symtab);
+	if (mg) {
+	    PMOP **const array = (PMOP**) mg->mg_ptr;
+	    U32 count = mg->mg_len / sizeof(PMOP**);
+	    U32 i = count;
+
+	    while (i--) {
+		if (array[i] == o) {
+		    /* Found it. Move the entry at the end to overwrite it.  */
+		    array[i] = array[--count];
+		    mg->mg_len = count * sizeof(PMOP**);
+		    /* Could realloc smaller at this point always, but probably
+		       not worth it. Probably worth free()ing if we're the
+		       last.  */
+		    if(!count) {
+			Safefree(mg->mg_ptr);
+			mg->mg_ptr = NULL;
+		    }
+		    break;
+		}
+	    }
+	}
+    }
+    if (PL_curpm == o) 
+	PL_curpm = NULL;
+#ifdef USE_ITHREADS
+    if (flags)
+	PmopSTASH_free(o);
+#endif
+}
+
+STATIC void
+S_find_and_forget_pmops(pTHX_ OP *o)
+{
+    if (o->op_flags & OPf_KIDS) {
+        OP *kid = cUNOPo->op_first;
+	while (kid) {
+	    switch (kid->op_type) {
+	    case OP_SUBST:
+	    case OP_PUSHRE:
+	    case OP_MATCH:
+	    case OP_QR:
+		forget_pmop((PMOP*)kid, 0);
+	    }
+	    find_and_forget_pmops(kid);
+	    kid = kid->op_sibling;
+	}
+    }
+}
+
 void
 Perl_op_null(pTHX_ OP *o)
 {
@@ -611,8 +791,8 @@ S_scalarboolean(pTHX_ OP *o)
 	if (ckWARN(WARN_SYNTAX)) {
 	    const line_t oldline = CopLINE(PL_curcop);
 
-	    if (PL_copline != NOLINE)
-		CopLINE_set(PL_curcop, PL_copline);
+	    if (PL_parser && PL_parser->copline != NOLINE)
+		CopLINE_set(PL_curcop, PL_parser->copline);
 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
 	    CopLINE_set(PL_curcop, oldline);
 	}
@@ -627,7 +807,8 @@ Perl_scalar(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || PL_error_count || (o->op_flags & OPf_WANT)
+    if (!o || (PL_parser && PL_parser->error_count)
+	 || (o->op_flags & OPf_WANT)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -647,7 +828,7 @@ Perl_scalar(pTHX_ OP *o)
 	break;
     case OP_SPLIT:
 	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
-	    if (!kPMOP->op_pmreplroot)
+	    if (!kPMOP->op_pmreplrootu.op_pmreplroot)
 		deprecate_old("implicit split to @_");
 	}
 	/* FALL THROUGH */
@@ -725,7 +906,8 @@ Perl_scalarvoid(pTHX_ OP *o)
 
     /* assumes no premature commitment */
     want = o->op_flags & OPf_WANT;
-    if ((want && want != OPf_WANT_SCALAR) || PL_error_count
+    if ((want && want != OPf_WANT_SCALAR)
+	 || (PL_parser && PL_parser->error_count)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -942,7 +1124,7 @@ Perl_scalarvoid(pTHX_ OP *o)
 	return scalar(o);
     case OP_SPLIT:
 	if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
-	    if (!kPMOP->op_pmreplroot)
+	    if (!kPMOP->op_pmreplrootu.op_pmreplroot)
 		deprecate_old("implicit split to @_");
 	}
 	break;
@@ -970,7 +1152,8 @@ Perl_list(pTHX_ OP *o)
     OP *kid;
 
     /* assumes no premature commitment */
-    if (!o || (o->op_flags & OPf_WANT) || PL_error_count
+    if (!o || (o->op_flags & OPf_WANT)
+	 || (PL_parser && PL_parser->error_count)
 	 || o->op_type == OP_RETURN)
     {
 	return o;
@@ -1096,7 +1279,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
     /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
     int localize = -1;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     if ((o->op_private & OPpTARGET_MY)
@@ -1129,7 +1312,7 @@ Perl_mod(pTHX_ OP *o, I32 type)
 	    Perl_croak(aTHX_ "That use of $[ is unsupported");
 	break;
     case OP_STUB:
-	if (o->op_flags & OPf_PARENS || PL_madskills)
+	if ((o->op_flags & OPf_PARENS) || PL_madskills)
 	    break;
 	goto nomod;
     case OP_ENTERSUB:
@@ -1478,6 +1661,7 @@ S_scalar_mod_type(const OP *o, I32 type)
     case OP_RECV:
     case OP_ANDASSIGN:
     case OP_ORASSIGN:
+    case OP_DORASSIGN:
 	return TRUE;
     default:
 	return FALSE;
@@ -1524,7 +1708,7 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
     dVAR;
     OP *kid;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     switch (o->op_type) {
@@ -1646,7 +1830,6 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
 
     /* fake up C<use attributes $pkg,$rv,@attrs> */
     ENTER;		/* need to protect against side-effects of 'use' */
-    SAVEINT(PL_expect);
     stashsv = stash ? newSVhek(HvNAME_HEK(stash)) : &PL_sv_no;
 
 #define ATTRSMODULE "attributes"
@@ -1773,7 +1956,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     dVAR;
     I32 type;
 
-    if (!o || PL_error_count)
+    if (!o || (PL_parser && PL_parser->error_count))
 	return o;
 
     type = o->op_type;
@@ -1798,11 +1981,13 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
 	if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
 	    yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
 			OP_DESC(o),
-			PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+			PL_parser->in_my == KEY_our
+			    ? "our"
+			    : PL_parser->in_my == KEY_state ? "state" : "my"));
 	} else if (attrs) {
 	    GV * const gv = cGVOPx_gv(cUNOPo->op_first);
-	    PL_in_my = FALSE;
-	    PL_in_my_stash = NULL;
+	    PL_parser->in_my = FALSE;
+	    PL_parser->in_my_stash = NULL;
 	    apply_attrs(GvSTASH(gv),
 			(type == OP_RV2SV ? GvSV(gv) :
 			 type == OP_RV2AV ? (SV*)GvAV(gv) :
@@ -1819,14 +2004,16 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     {
 	yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
 			  OP_DESC(o),
-			  PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my"));
+			  PL_parser->in_my == KEY_our
+			    ? "our"
+			    : PL_parser->in_my == KEY_state ? "state" : "my"));
 	return o;
     }
     else if (attrs && type != OP_PUSHMARK) {
 	HV *stash;
 
-	PL_in_my = FALSE;
-	PL_in_my_stash = NULL;
+	PL_parser->in_my = FALSE;
+	PL_parser->in_my_stash = NULL;
 
 	/* check for C<my Dog $spot> when deciding package */
 	stash = PAD_COMPNAME_TYPE(o->op_targ);
@@ -1836,7 +2023,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
     }
     o->op_flags |= OPf_MOD;
     o->op_private |= OPpLVAL_INTRO;
-    if (PL_in_my == KEY_state)
+    if (PL_parser->in_my == KEY_state)
 	o->op_private |= OPpPAD_STATE;
     return o;
 }
@@ -1870,8 +2057,8 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs)
 	else
 	    o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
     }
-    PL_in_my = FALSE;
-    PL_in_my_stash = NULL;
+    PL_parser->in_my = FALSE;
+    PL_parser->in_my_stash = NULL;
     return o;
 }
 
@@ -2089,10 +2276,11 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	NOOP;
 #endif
     else {
-	if ( PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ','
+	if ( PL_parser->bufptr > PL_parser->oldbufptr
+	    && PL_parser->bufptr[-1] == ','
 	    && ckWARN(WARN_PARENTHESIS))
 	{
-	    char *s = PL_bufptr;
+	    char *s = PL_parser->bufptr;
 	    bool sigil = FALSE;
 
 	    /* some heuristics to detect a potential error */
@@ -2115,8 +2303,13 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	    if (sigil && (*s == ';' || *s == '=')) {
 		Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
 				"Parentheses missing around \"%s\" list",
-				lex ? (PL_in_my == KEY_our ? "our" : PL_in_my == KEY_state ? "state" : "my")
-				: "local");
+				lex
+				    ? (PL_parser->in_my == KEY_our
+					? "our"
+					: PL_parser->in_my == KEY_state
+					    ? "state"
+					    : "my")
+				    : "local");
 	    }
 	}
     }
@@ -2124,8 +2317,8 @@ Perl_localize(pTHX_ OP *o, I32 lex)
 	o = my(o);
     else
 	o = mod(o, OP_NULL);		/* a bit kludgey */
-    PL_in_my = FALSE;
-    PL_in_my_stash = NULL;
+    PL_parser->in_my = FALSE;
+    PL_parser->in_my_stash = NULL;
     return o;
 }
 
@@ -2191,7 +2384,7 @@ Perl_fold_constants(pTHX_ register OP *o)
 	    goto nope;
     }
 
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	goto nope;		/* Don't try to run w/ errors */
 
     for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
@@ -2277,7 +2470,7 @@ Perl_gen_constant_list(pTHX_ register OP *o)
     const I32 oldtmps_floor = PL_tmps_floor;
 
     list(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	return o;		/* Don't attempt to run with errors */
 
     PL_op = curop = LINKLIST(o);
@@ -2625,7 +2818,7 @@ Perl_newMADsv(pTHX_ char key, SV* sv)
 }
 
 MADPROP *
-Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
+Perl_newMADPROP(pTHX_ char key, char type, const void* val, I32 vlen)
 {
     MADPROP *mp;
     Newxz(mp, 1, MADPROP);
@@ -2646,7 +2839,7 @@ Perl_mad_free(pTHX_ MADPROP* mp)
 	return;
     if (mp->mad_next)
 	mad_free(mp->mad_next);
-/*    if (PL_lex_state != LEX_NOTPARSING && mp->mad_vlen)
+/*    if (PL_parser && PL_parser->lex_state != LEX_NOTPARSING && mp->mad_vlen)
 	PerlIO_printf(PerlIO_stderr(), "DESTROYING '%c'=<%s>\n", mp->mad_key & 255, mp->mad_val); */
     switch (mp->mad_type) {
     case MAD_NULL:
@@ -3161,10 +3354,10 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
     pmop->op_private = (U8)(0 | (flags >> 8));
 
     if (PL_hints & HINT_RE_TAINT)
-	pmop->op_pmpermflags |= PMf_RETAINT;
+	pmop->op_pmflags |= PMf_RETAINT;
     if (PL_hints & HINT_LOCALE)
-	pmop->op_pmpermflags |= PMf_LOCALE;
-    pmop->op_pmflags = pmop->op_pmpermflags;
+	pmop->op_pmflags |= PMf_LOCALE;
+
 
 #ifdef USE_ITHREADS
     if (av_len((AV*) PL_regex_pad[0]) > -1) {
@@ -3180,18 +3373,6 @@ Perl_newPMOP(pTHX_ I32 type, I32 flags)
     }
 #endif
 
-        /* link into pm list */
-    if (type != OP_TRANS && PL_curstash) {
-	MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
-
-	if (!mg) {
-	    mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0, 0);
-	}
-	pmop->op_pmnext = (PMOP*)mg->mg_obj;
-	mg->mg_obj = (SV*)pmop;
-	PmopSTASH_set(pmop,PL_curstash);
-    }
-
     return CHECKOP(type, pmop);
 }
 
@@ -3251,37 +3432,17 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
     pm = (PMOP*)o;
 
     if (expr->op_type == OP_CONST) {
-	STRLEN plen;
 	SV * const pat = ((SVOP*)expr)->op_sv;
-	const char *p = SvPV_const(pat, plen);
-	if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) {
-	    U32 was_readonly = SvREADONLY(pat);
+	U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 
-	    if (was_readonly) {
-		if (SvFAKE(pat)) {
-		    sv_force_normal_flags(pat, 0);
-		    assert(!SvREADONLY(pat));
-		    was_readonly = 0;
-		} else {
-		    SvREADONLY_off(pat);
-		}
-	    }   
+	if (o->op_flags & OPf_SPECIAL)
+	    pm_flags |= RXf_SPLIT;
 
-	    sv_setpvn(pat, "\\s+", 3);
+	if (DO_UTF8(pat))
+	    pm_flags |= RXf_UTF8;
 
-	    SvFLAGS(pat) |= was_readonly;
+	PM_SETRE(pm, CALLREGCOMP(pat, pm_flags));
 
-	    p = SvPV_const(pat, plen);
-	    pm->op_pmflags |= PMf_SKIPWHITE;
-	}
-        if (DO_UTF8(pat))
-	    pm->op_pmdynflags |= PMdf_UTF8;
-	/* FIXME - can we make this function take const char * args?  */
-	PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm));
-	if (PM_GETRE(pm)->extflags & RXf_WHITE)
-	    pm->op_pmflags |= PMf_WHITE;
-	else
-	    pm->op_pmflags &= ~PMf_WHITE;
 #ifdef PERL_MAD
 	op_getmad(expr,(OP*)pm,'e');
 #else
@@ -3327,8 +3488,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 	OP *curop;
 	if (pm->op_pmflags & PMf_EVAL) {
 	    curop = NULL;
-	    if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
-		CopLINE_set(PL_curcop, (line_t)PL_multi_end);
+	    if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
+		CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
 	}
 	else if (repl->op_type == OP_CONST)
 	    curop = repl;
@@ -3371,16 +3532,14 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 	if (curop == repl
 	    && !(repl_has_vars
 		 && (!PM_GETRE(pm)
-		     || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN)))
+		     || RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
 	{
 	    pm->op_pmflags |= PMf_CONST;	/* const for long enough */
-	    pm->op_pmpermflags |= PMf_CONST;	/* const for long enough */
 	    prepend_elem(o->op_type, scalar(repl), o);
 	}
 	else {
 	    if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
 		pm->op_pmflags |= PMf_MAYBE_CONST;
-		pm->op_pmpermflags |= PMf_MAYBE_CONST;
 	    }
 	    NewOp(1101, rcop, 1, LOGOP);
 	    rcop->op_type = OP_SUBSTCONT;
@@ -3394,8 +3553,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg)
 	    rcop->op_next = LINKLIST(repl);
 	    repl->op_next = (OP*)rcop;
 
-	    pm->op_pmreplroot = scalar((OP*)rcop);
-	    pm->op_pmreplstart = LINKLIST(rcop);
+	    pm->op_pmreplrootu.op_pmreplroot = scalar((OP*)rcop);
+	    assert(!(pm->op_pmflags & PMf_ONCE));
+	    pm->op_pmstashstartu.op_pmreplstart = LINKLIST(rcop);
 	    rcop->op_next = 0;
 	}
     }
@@ -3452,9 +3612,9 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
     assert(gv);
 #ifdef USE_ITHREADS
     GvIN_PAD_on(gv);
-    return newPADOP(type, flags, SvREFCNT_inc_simple(gv));
+    return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv));
 #else
-    return newSVOP(type, flags, SvREFCNT_inc_simple(gv));
+    return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv));
 #endif
 }
 
@@ -3493,11 +3653,12 @@ Perl_package(pTHX_ OP *o)
     save_item(PL_curstname);
 
     PL_curstash = gv_stashsv(sv, GV_ADD);
+
     sv_setsv(PL_curstname, sv);
 
     PL_hints |= HINT_BLOCK_SCOPE;
-    PL_copline = NOLINE;
-    PL_expect = XSTATE;
+    PL_parser->copline = NOLINE;
+    PL_parser->expect = XSTATE;
 
 #ifndef PERL_MAD
     op_free(o);
@@ -3621,8 +3782,8 @@ 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_parser->copline = NOLINE;
+    PL_parser->expect = XSTATE;
     PL_cop_seqmax++; /* Purely for B::*'s benefit */
 
 #ifdef PERL_MAD
@@ -3700,17 +3861,19 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
 	    sv = va_arg(*args, SV*);
 	}
     }
-    {
-	const line_t ocopline = PL_copline;
-	COP * const ocurcop = PL_curcop;
-	const int oexpect = PL_expect;
 
-	utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
-		veop, modname, imop);
-	PL_expect = oexpect;
-	PL_copline = ocopline;
-	PL_curcop = ocurcop;
-    }
+    /* utilize() fakes up a BEGIN { require ..; import ... }, so make sure
+     * that it has a PL_parser to play with while doing that, and also
+     * that it doesn't mess with any existing parser, by creating a tmp
+     * new parser with lex_start(). This won't actually be used for much,
+     * since pp_require() will create another parser for the real work. */
+
+    ENTER;
+    SAVEVPTR(PL_curcop);
+    lex_start(NULL, NULL, FALSE);
+    utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
+	    veop, modname, imop);
+    LEAVE;
 }
 
 OP *
@@ -3811,12 +3974,14 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
     }
 
     if (is_list_assignment(left)) {
+	static const char no_list_state[] = "Initialization of state variables"
+	    " in list context currently forbidden";
 	OP *curop;
 
 	PL_modcount = 0;
 	/* Grandfathering $[ assignment here.  Bletch.*/
 	/* Only simple assignments like C<< ($[) = 1 >> are allowed */
-	PL_eval_start = (left->op_type == OP_CONST) ? right : 0;
+	PL_eval_start = (left->op_type == OP_CONST) ? right : NULL;
 	left = mod(left, OP_AASSIGN);
 	if (PL_eval_start)
 	    PL_eval_start = 0;
@@ -3876,19 +4041,24 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 			    break;
 		    }
 		    else if (curop->op_type == OP_PUSHRE) {
-			if (((PMOP*)curop)->op_pmreplroot) {
 #ifdef USE_ITHREADS
-			    GV *gv = (GV*)PAD_SVl(INT2PTR(PADOFFSET,
-					((PMOP*)curop)->op_pmreplroot));
-#else
-			    GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
-#endif
+			if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
+			    GV *const gv = (GV*)PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff);
 			    if (gv == PL_defgv
 				|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
 				break;
 			    GvASSIGN_GENERATION_set(gv, PL_generation);
+			}
+#else
+			GV *const gv
+			    = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+			if (gv) {
+			    if (gv == PL_defgv
+				|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
+				break;
 			    GvASSIGN_GENERATION_set(gv, PL_generation);
 			}
+#endif
 		    }
 		    else
 			break;
@@ -3899,34 +4069,55 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		o->op_private |= OPpASSIGN_COMMON;
 	}
 
-	if ( ((left->op_private & OPpLVAL_INTRO) || ckWARN(WARN_MISC))
-		&& (left->op_type == OP_LIST
-		    || (left->op_type == OP_NULL && left->op_targ == OP_LIST)))
-	{
+	if ((left->op_type == OP_LIST
+	     || (left->op_type == OP_NULL && left->op_targ == OP_LIST))) {
 	    OP* lop = ((LISTOP*)left)->op_first;
 	    while (lop) {
 		if (lop->op_type == OP_PADSV ||
 		    lop->op_type == OP_PADAV ||
 		    lop->op_type == OP_PADHV ||
-		    lop->op_type == OP_PADANY)
-		{
+		    lop->op_type == OP_PADANY) {
 		    if (lop->op_private & OPpPAD_STATE) {
 			if (left->op_private & OPpLVAL_INTRO) {
-			    o->op_private |= OPpASSIGN_STATE;
-			    /* hijacking PADSTALE for uninitialized state variables */
-			    SvPADSTALE_on(PAD_SVl(lop->op_targ));
+			    /* Each variable in state($a, $b, $c) = ... */
 			}
-			else { /* we already checked for WARN_MISC before */
-			    Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
-				    PAD_COMPNAME_PV(lop->op_targ));
+			else {
+			    /* Each state variable in
+			       (state $a, my $b, our $c, $d, undef) = ... */
 			}
+			yyerror(no_list_state);
+		    } else {
+			/* Each my variable in
+			   (state $a, my $b, our $c, $d, undef) = ... */
 		    }
+		} else {
+		    /* Other ops in the list. undef may be interesting in
+		       (state $a, undef, state $c) */
 		}
 		lop = lop->op_sibling;
 	    }
 	}
-
-	if (right && right->op_type == OP_SPLIT) {
+	else if (((left->op_private & (OPpLVAL_INTRO | OPpPAD_STATE))
+		    == (OPpLVAL_INTRO | OPpPAD_STATE))
+		&& (   left->op_type == OP_PADSV
+		    || left->op_type == OP_PADAV
+		    || left->op_type == OP_PADHV
+		    || left->op_type == OP_PADANY))
+	{
+	    /* All single variable list context state assignments, hence
+	       state ($a) = ...
+	       (state $a) = ...
+	       state @a = ...
+	       state (@a) = ...
+	       (state @a) = ...
+	       state %a = ...
+	       state (%a) = ...
+	       (state %a) = ...
+	    */
+	    yyerror(no_list_state);
+	}
+
+	if (right && right->op_type == OP_SPLIT && !PL_madskills) {
 	    OP* tmpop = ((LISTOP*)right)->op_first;
 	    if (tmpop && (tmpop->op_type == OP_PUSHRE)) {
 		PMOP * const pm = (PMOP*)tmpop;
@@ -3935,12 +4126,20 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 		    !(o->op_private & OPpASSIGN_COMMON) )
 		{
 		    tmpop = ((UNOP*)left)->op_first;
-		    if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
+		    if (tmpop->op_type == OP_GV
 #ifdef USE_ITHREADS
-			pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
+			&& !pm->op_pmreplrootu.op_pmtargetoff
+#else
+			&& !pm->op_pmreplrootu.op_pmtargetgv
+#endif
+			) {
+#ifdef USE_ITHREADS
+			pm->op_pmreplrootu.op_pmtargetoff
+			    = cPADOPx(tmpop)->op_padix;
 			cPADOPx(tmpop)->op_padix = 0;	/* steal it */
 #else
-			pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
+			pm->op_pmreplrootu.op_pmtargetgv
+			    = (GV*)cSVOPx(tmpop)->op_sv;
 			cSVOPx(tmpop)->op_sv = NULL;	/* steal it */
 #endif
 			pm->op_pmflags |= PMf_ONCE;
@@ -3948,11 +4147,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
 			tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
 			tmpop->op_sibling = NULL;	/* don't free split */
 			right->op_next = tmpop->op_next;  /* fix starting loc */
-#ifdef PERL_MAD
-			op_getmad(o,right,'R');		/* blow off assign */
-#else
 			op_free(o);			/* blow off assign */
-#endif
 			right->op_flags &= ~OPf_WANT;
 				/* "I don't know and I don't care." */
 			return right;
@@ -4033,11 +4228,12 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
 	HINTS_REFCNT_UNLOCK;
     }
 
-    if (PL_copline == NOLINE)
+    if (PL_parser && PL_parser->copline == NOLINE)
         CopLINE_set(cop, CopLINE(PL_curcop));
     else {
-	CopLINE_set(cop, PL_copline);
-        PL_copline = NOLINE;
+	CopLINE_set(cop, PL_parser->copline);
+	if (PL_parser)
+	    PL_parser->copline = NOLINE;
     }
 #ifdef USE_ITHREADS
     CopFILE_set(cop, CopFILE(PL_curcop));	/* XXX share in a pvtable? */
@@ -4084,7 +4280,8 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
     /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
     if (first->op_type == OP_NOT
 	&& (first->op_flags & OPf_SPECIAL)
-	&& (first->op_flags & OPf_KIDS)) {
+	&& (first->op_flags & OPf_KIDS)
+	&& !PL_madskills) {
 	if (type == OP_AND || type == OP_OR) {
 	    if (type == OP_AND)
 		type = OP_OR;
@@ -4095,11 +4292,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	    if (o->op_next)
 		first->op_next = o->op_next;
 	    cUNOPo->op_first = NULL;
-#ifdef PERL_MAD
-	    op_getmad(o,first,'O');
-#else
 	    op_free(o);
-#endif
 	}
     }
     if (first->op_type == OP_CONST) {
@@ -4134,6 +4327,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	    if ((o2->op_type == OP_PADSV || o2->op_type == OP_PADAV
 			|| o2->op_type == OP_PADHV)
 		&& o2->op_private & OPpLVAL_INTRO
+		&& !(o2->op_private & OPpPAD_STATE)
 		&& ckWARN(WARN_DEPRECATED))
 	    {
 		Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
@@ -4183,7 +4377,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp)
 	}
 	if (warnop) {
 	    const line_t oldline = CopLINE(PL_curcop);
-	    CopLINE_set(PL_curcop, PL_copline);
+	    CopLINE_set(PL_curcop, PL_parser->copline);
 	    Perl_warner(aTHX_ packWARN(WARN_MISC),
 		 "Value of %s%s can be \"0\"; test with defined()",
 		 PL_op_desc[warnop],
@@ -4236,38 +4430,24 @@ Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
 
     scalarboolean(first);
     if (first->op_type == OP_CONST) {
+	/* Left or right arm of the conditional?  */
+	const bool left = SvTRUE(((SVOP*)first)->op_sv);
+	OP *live = left ? trueop : falseop;
+	OP *const dead = left ? falseop : trueop;
         if (first->op_private & OPpCONST_BARE &&
 	    first->op_private & OPpCONST_STRICT) {
 	    no_bareword_allowed(first);
 	}
-	if (SvTRUE(((SVOP*)first)->op_sv)) {
-#ifdef PERL_MAD
-	    if (PL_madskills) {
-		trueop = newUNOP(OP_NULL, 0, trueop);
-		op_getmad(first,trueop,'C');
-		op_getmad(falseop,trueop,'e');
-	    }
-	    /* FIXME for MAD - should there be an ELSE here?  */
-#else
-	    op_free(first);
-	    op_free(falseop);
-#endif
-	    return trueop;
-	}
-	else {
-#ifdef PERL_MAD
-	    if (PL_madskills) {
-		falseop = newUNOP(OP_NULL, 0, falseop);
-		op_getmad(first,falseop,'C');
-		op_getmad(trueop,falseop,'t');
-	    }
-	    /* FIXME for MAD - should there be an ELSE here?  */
-#else
+	if (PL_madskills) {
+	    /* This is all dead code when PERL_MAD is not defined.  */
+	    live = newUNOP(OP_NULL, 0, live);
+	    op_getmad(first, live, 'C');
+	    op_getmad(dead, live, left ? 'e' : 't');
+	} else {
 	    op_free(first);
-	    op_free(trueop);
-#endif
-	    return falseop;
+	    op_free(dead);
 	}
+	return live;
     }
     NewOp(1101, logop, 1, LOGOP);
     logop->op_type = OP_COND_EXPR;
@@ -4466,7 +4646,7 @@ whileline, OP *expr, OP *block, OP *cont, I32 has_my)
     redo = LINKLIST(listop);
 
     if (expr) {
-	PL_copline = (line_t)whileline;
+	PL_parser->copline = (line_t)whileline;
 	scalar(listop);
 	o = new_logop(OP_AND, 0, &expr, &listop);
 	if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
@@ -4521,7 +4701,15 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
 	    iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
 	    sv->op_type = OP_RV2GV;
 	    sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
-	    if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
+
+	    /* The op_type check is needed to prevent a possible segfault
+	     * if the loop variable is undeclared and 'strict vars' is in
+	     * effect. This is illegal but is nonetheless parsed, so we
+	     * may reach this point with an OP_CONST where we're expecting
+	     * an OP_GV.
+	     */
+	    if (cUNOPx(sv)->op_first->op_type == OP_GV
+	     && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
 		iterpflags |= OPpITER_DEF;
 	}
 	else if (sv->op_type == OP_PADSV) { /* private variable */
@@ -4617,7 +4805,7 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP
     wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont, 0);
     if (madsv)
 	op_getmad(madsv, (OP*)loop, 'v');
-    PL_copline = forline;
+    PL_parser->copline = forline;
     return newSTATEOP(0, label, wop);
 }
 
@@ -4633,7 +4821,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label)
 	    o = newOP(type, OPf_SPECIAL);
 	else {
 	    o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST
-					? SvPVx_nolen_const(((SVOP*)label)->op_sv)
+					? SvPV_nolen_const(((SVOP*)label)->op_sv)
 					: ""));
 	}
 #ifdef PERL_MAD
@@ -4682,8 +4870,7 @@ S_ref_array_or_hash(pTHX_ OP *cond)
    op_other if the match fails.)
  */
 
-STATIC
-OP *
+STATIC OP *
 S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
 		   I32 enter_opcode, I32 leave_opcode,
 		   PADOFFSET entertarg)
@@ -4737,8 +4924,7 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
    
    [*] possibly surprising
  */
-STATIC
-bool
+STATIC bool
 S_looks_like_bool(pTHX_ const OP *o)
 {
     dVAR;
@@ -4751,6 +4937,11 @@ S_looks_like_bool(pTHX_ const OP *o)
 	    	looks_like_bool(cLOGOPo->op_first)
 	     && looks_like_bool(cLOGOPo->op_first->op_sibling));
 
+	case OP_NULL:
+	    return (
+		o->op_flags & OPf_KIDS
+	    && looks_like_bool(cUNOPo->op_first));
+
 	case OP_ENTERSUB:
 
 	case OP_NOT:	case OP_XOR:
@@ -4842,6 +5033,12 @@ void
 Perl_cv_undef(pTHX_ CV *cv)
 {
     dVAR;
+
+    DEBUG_X(PerlIO_printf(Perl_debug_log,
+	  "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
+	    PTR2UV(cv), PTR2UV(PL_comppad))
+    );
+
 #ifdef USE_ITHREADS
     if (CvFILE(cv) && !CvISXSUB(cv)) {
 	/* for XSUBs CvFILE point directly to static memory; __FILE__ */
@@ -4899,7 +5096,7 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
 
 	if (gv)
 	    gv_efullname3(name = sv_newmortal(), gv, NULL);
-	sv_setpv(msg, "Prototype mismatch:");
+	sv_setpvs(msg, "Prototype mismatch:");
 	if (name)
 	    Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
 	if (SvPOK(cv))
@@ -4968,6 +5165,9 @@ Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
     dVAR;
     SV *sv = NULL;
 
+    if (PL_madskills)
+	return NULL;
+
     if (!o)
 	return NULL;
 
@@ -5072,11 +5272,11 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	= (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
 	   || PL_madskills)
 	? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
-    const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : NULL;
+    const char * const name = o ? SvPV_nolen_const(cSVOPo->op_sv) : NULL;
 
     if (proto) {
 	assert(proto->op_type == OP_CONST);
-	ps = SvPVx_const(((SVOP*)proto)->op_sv, ps_len);
+	ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
     }
     else
 	ps = NULL;
@@ -5119,9 +5319,9 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    sv_setpvn((SV*)gv, ps, ps_len);
 	else
 	    sv_setiv((SV*)gv, -1);
+
 	SvREFCNT_dec(PL_compcv);
 	cv = PL_compcv = NULL;
-	PL_sub_generation++;
 	goto done;
     }
 
@@ -5183,8 +5383,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 			&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
 		{
 		    const line_t oldline = CopLINE(PL_curcop);
-		    if (PL_copline != NOLINE)
-			CopLINE_set(PL_curcop, PL_copline);
+		    if (PL_parser && PL_parser->copline != NOLINE)
+			CopLINE_set(PL_curcop, PL_parser->copline);
 		    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
 			CvCONST(cv) ? "Constant subroutine %s redefined"
 				    : "Subroutine %s redefined", name);
@@ -5215,7 +5415,13 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    GvCV(gv) = NULL;
 	    cv = newCONSTSUB(NULL, name, const_sv);
 	}
-	PL_sub_generation++;
+        mro_method_changed_in( /* sub Foo::Bar () { 123 } */
+            (CvGV(cv) && GvSTASH(CvGV(cv)))
+                ? GvSTASH(CvGV(cv))
+                : CvSTASH(cv)
+                    ? CvSTASH(cv)
+                    : PL_curstash
+        );
 	if (PL_madskills)
 	    goto install_block;
 	op_free(block);
@@ -5298,7 +5504,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 		}
 	    }
 	    GvCVGEN(gv) = 0;
-	    PL_sub_generation++;
+            mro_method_changed_in(GvSTASH(gv)); /* sub Foo::bar { (shift)+1 } */
 	}
     }
     CvGV(cv) = gv;
@@ -5308,7 +5514,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     if (ps)
 	sv_setpvn((SV*)cv, ps, ps_len);
 
-    if (PL_error_count) {
+    if (PL_parser && PL_parser->error_count) {
 	op_free(block);
 	block = NULL;
 	if (name) {
@@ -5368,9 +5574,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
 
     if (name || aname) {
-	const char *s;
-	const char * const tname = (name ? name : aname);
-
 	if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
 	    SV * const sv = newSV(0);
 	    SV * const tmpstr = sv_newmortal();
@@ -5382,7 +5585,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 			   CopFILE(PL_curcop),
 			   (long)PL_subline, (long)CopLINE(PL_curcop));
 	    gv_efullname3(tmpstr, gv, NULL);
-	    hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr), SvCUR(tmpstr), sv, 0);
+	    (void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
+		    SvCUR(tmpstr), sv, 0);
 	    hv = GvHVn(db_postponed);
 	    if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
 		CV * const pcv = GvCV(db_postponed);
@@ -5396,24 +5600,33 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    }
 	}
 
-	if ((s = strrchr(tname,':')))
-	    s++;
-	else
-	    s = tname;
+	if (name && ! (PL_parser && PL_parser->error_count))
+	    process_special_blocks(name, gv, cv);
+    }
 
-	if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
-	    goto done;
+  done:
+    if (PL_parser)
+	PL_parser->copline = NOLINE;
+    LEAVE_SCOPE(floor);
+    return cv;
+}
 
-	if (strEQ(s, "BEGIN") && !PL_error_count) {
+STATIC void
+S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+			 CV *const cv)
+{
+    const char *const colon = strrchr(fullname,':');
+    const char *const name = colon ? colon + 1 : fullname;
+
+    if (*name == 'B') {
+	if (strEQ(name, "BEGIN")) {
 	    const I32 oldscope = PL_scopestack_ix;
 	    ENTER;
 	    SAVECOPFILE(&PL_compiling);
 	    SAVECOPLINE(&PL_compiling);
 
-	    if (!PL_beginav)
-		PL_beginav = newAV();
 	    DEBUG_x( dump_sub(gv) );
-	    av_push(PL_beginav, (SV*)cv);
+	    Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
 	    GvCV(gv) = 0;		/* cv has been hijacked */
 	    call_list(oldscope, PL_beginav);
 
@@ -5421,51 +5634,47 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 	    CopHINTS_set(&PL_compiling, PL_hints);
 	    LEAVE;
 	}
-	else if (strEQ(s, "END") && !PL_error_count) {
-	    if (!PL_endav)
-		PL_endav = newAV();
-	    DEBUG_x( dump_sub(gv) );
-	    av_unshift(PL_endav, 1);
-	    av_store(PL_endav, 0, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
-	    /* It's never too late to run a unitcheck block */
-	    if (!PL_unitcheckav)
-		PL_unitcheckav = newAV();
-	    DEBUG_x( dump_sub(gv) );
-	    av_unshift(PL_unitcheckav, 1);
-	    av_store(PL_unitcheckav, 0, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "CHECK") && !PL_error_count) {
-	    if (!PL_checkav)
-		PL_checkav = newAV();
-	    DEBUG_x( dump_sub(gv) );
-	    if (PL_main_start && ckWARN(WARN_VOID))
-		Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
-	    av_unshift(PL_checkav, 1);
-	    av_store(PL_checkav, 0, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "INIT") && !PL_error_count) {
-	    if (!PL_initav)
-		PL_initav = newAV();
-	    DEBUG_x( dump_sub(gv) );
-	    if (PL_main_start && ckWARN(WARN_VOID))
-		Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
-	    av_push(PL_initav, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
+	else
+	    return;
+    } else {
+	if (*name == 'E') {
+	    if strEQ(name, "END") {
+		DEBUG_x( dump_sub(gv) );
+		Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
+	    } else
+		return;
+	} else if (*name == 'U') {
+	    if (strEQ(name, "UNITCHECK")) {
+		/* It's never too late to run a unitcheck block */
+		Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
+	    }
+	    else
+		return;
+	} else if (*name == 'C') {
+	    if (strEQ(name, "CHECK")) {
+		if (PL_main_start && ckWARN(WARN_VOID))
+		    Perl_warner(aTHX_ packWARN(WARN_VOID),
+				"Too late to run CHECK block");
+		Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
+	    }
+	    else
+		return;
+	} else if (*name == 'I') {
+	    if (strEQ(name, "INIT")) {
+		if (PL_main_start && ckWARN(WARN_VOID))
+		    Perl_warner(aTHX_ packWARN(WARN_VOID),
+				"Too late to run INIT block");
+		Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
+	    }
+	    else
+		return;
+	} else
+	    return;
+	DEBUG_x( dump_sub(gv) );
+	GvCV(gv) = 0;		/* cv has been hijacked */
     }
-
-  done:
-    PL_copline = NOLINE;
-    LEAVE_SCOPE(floor);
-    return cv;
 }
 
-/* XXX unsafe for threads if eval_owner isn't held */
 /*
 =for apidoc newCONSTSUB
 
@@ -5492,8 +5701,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
 
     ENTER;
 
+    if (IN_PERL_RUNTIME) {
+	/* at runtime, it's not safe to manipulate PL_curcop: it may be
+	 * an op shared between threads. Use a non-shared COP for our
+	 * dirty work */
+	 SAVEVPTR(PL_curcop);
+	 PL_curcop = &PL_compiling;
+    }
     SAVECOPLINE(PL_curcop);
-    CopLINE_set(PL_curcop, PL_copline);
+    CopLINE_set(PL_curcop, PL_parser ? PL_parser->copline : NOLINE);
 
     SAVEHINTS();
     PL_hints &= ~HINT_BLOCK_SCOPE;
@@ -5606,8 +5822,8 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
 			const char *redefined_name = HvNAME_get(stash);
 			if ( strEQ(redefined_name,"autouse") ) {
 			    const line_t oldline = CopLINE(PL_curcop);
-			    if (PL_copline != NOLINE)
-				CopLINE_set(PL_curcop, PL_copline);
+			    if (PL_parser && PL_parser->copline != NOLINE)
+				CopLINE_set(PL_curcop, PL_parser->copline);
 			    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
 					CvCONST(cv) ? "Constant subroutine %s redefined"
 						    : "Subroutine %s redefined"
@@ -5625,12 +5841,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
     if (cv)				/* must reuse cv if autoloaded */
 	cv_undef(cv);
     else {
-	cv = (CV*)newSV(0);
-	sv_upgrade((SV *)cv, SVt_PVCV);
+	cv = (CV*)newSV_type(SVt_PVCV);
 	if (name) {
 	    GvCV(gv) = cv;
 	    GvCVGEN(gv) = 0;
-	    PL_sub_generation++;
+            mro_method_changed_in(GvSTASH(gv)); /* newXS */
 	}
     }
     CvGV(cv) = gv;
@@ -5640,51 +5855,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
     CvISXSUB_on(cv);
     CvXSUB(cv) = subaddr;
 
-    if (name) {
-	const char *s = strrchr(name,':');
-	if (s)
-	    s++;
-	else
-	    s = name;
-
-	if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
-	    goto done;
-
-	if (strEQ(s, "BEGIN")) {
-	    if (!PL_beginav)
-		PL_beginav = newAV();
-	    av_push(PL_beginav, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "END")) {
-	    if (!PL_endav)
-		PL_endav = newAV();
-	    av_unshift(PL_endav, 1);
-	    av_store(PL_endav, 0, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "CHECK")) {
-	    if (!PL_checkav)
-		PL_checkav = newAV();
-	    if (PL_main_start && ckWARN(WARN_VOID))
-		Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
-	    av_unshift(PL_checkav, 1);
-	    av_store(PL_checkav, 0, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-	else if (strEQ(s, "INIT")) {
-	    if (!PL_initav)
-		PL_initav = newAV();
-	    if (PL_main_start && ckWARN(WARN_VOID))
-		Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
-	    av_push(PL_initav, (SV*)cv);
-	    GvCV(gv) = 0;		/* cv has been hijacked */
-	}
-    }
+    if (name)
+	process_special_blocks(name, gv, cv);
     else
 	CvANON_on(cv);
 
-done:
     return cv;
 }
 
@@ -5714,8 +5889,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     if ((cv = GvFORM(gv))) {
 	if (ckWARN(WARN_REDEFINE)) {
 	    const line_t oldline = CopLINE(PL_curcop);
-	    if (PL_copline != NOLINE)
-		CopLINE_set(PL_curcop, PL_copline);
+	    if (PL_parser && PL_parser->copline != NOLINE)
+		CopLINE_set(PL_curcop, PL_parser->copline);
 	    Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
 			o ? "Format %"SVf" redefined"
 			: "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
@@ -5742,7 +5917,8 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
 #else
     op_free(o);
 #endif
-    PL_copline = NOLINE;
+    if (PL_parser)
+	PL_parser->copline = NOLINE;
     LEAVE_SCOPE(floor);
 #ifdef PERL_MAD
     return pegop;
@@ -6083,8 +6259,11 @@ Perl_ck_eval(pTHX_ OP *o)
     }
     o->op_targ = (PADOFFSET)PL_hints;
     if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
-	/* Store a copy of %^H that pp_entereval can pick up */
-	OP *hhop = newSVOP(OP_CONST, 0,
+	/* Store a copy of %^H that pp_entereval can pick up.
+	   OPf_SPECIAL flags the opcode as being for this purpose,
+	   so that it in turn will return a copy at every
+	   eval.*/
+	OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
 			   (SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
 	cUNOPo->op_first->op_sibling = hhop;
 	o->op_private |= OPpEVAL_HAS_HH;
@@ -6131,7 +6310,8 @@ Perl_ck_exists(pTHX_ OP *o)
 	OP * const kid = cUNOPo->op_first;
 	if (kid->op_type == OP_ENTERSUB) {
 	    (void) ref(kid, o->op_type);
-	    if (kid->op_type != OP_RV2CV && !PL_error_count)
+	    if (kid->op_type != OP_RV2CV
+			&& !(PL_parser && PL_parser->error_count))
 		Perl_croak(aTHX_ "%s argument is not a subroutine name",
 			    OP_DESC(o));
 	    o->op_private |= OPpEXISTS_SUB;
@@ -6647,7 +6827,7 @@ Perl_ck_grep(pTHX_ OP *o)
     PADOFFSET offset;
 
     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
-    /* don't allocate gwop here, as we may leak it if PL_error_count > 0 */
+    /* don't allocate gwop here, as we may leak it if PL_parser->error_count > 0 */
 
     if (o->op_flags & OPf_STACKED) {
 	OP* k;
@@ -6668,7 +6848,7 @@ Perl_ck_grep(pTHX_ OP *o)
     else
 	scalar(kid);
     o = ck_fun(o);
-    if (PL_error_count)
+    if (PL_parser && PL_parser->error_count)
 	return o;
     kid = cLISTOPo->op_first->op_sibling;
     if (kid->op_type != OP_NULL)
@@ -6768,6 +6948,22 @@ Perl_ck_defined(pTHX_ OP *o)		/* 19990527 MJD */
 }
 
 OP *
+Perl_ck_readline(pTHX_ OP *o)
+{
+    if (!(o->op_flags & OPf_KIDS)) {
+	OP * const newop
+	    = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv));
+#ifdef PERL_MAD
+	op_getmad(o,newop,'O');
+#else
+	op_free(o);
+#endif
+	return newop;
+    }
+    return o;
+}
+
+OP *
 Perl_ck_rfun(pTHX_ OP *o)
 {
     const OPCODE type = o->op_type;
@@ -6835,12 +7031,16 @@ Perl_ck_smartmatch(pTHX_ OP *o)
 OP *
 Perl_ck_sassign(pTHX_ OP *o)
 {
+    dVAR;
     OP * const kid = cLISTOPo->op_first;
     /* has a disposable target? */
     if ((PL_opargs[kid->op_type] & OA_TARGLEX)
 	&& !(kid->op_flags & OPf_STACKED)
 	/* Cannot steal the second time! */
-	&& !(kid->op_private & OPpTARGET_MY))
+	&& !(kid->op_private & OPpTARGET_MY)
+	/* Keep the full thing for madskills */
+	&& !PL_madskills
+	)
     {
 	OP * const kkid = kid->op_sibling;
 
@@ -6853,13 +7053,8 @@ Perl_ck_sassign(pTHX_ OP *o)
 	    /* Now we do not need PADSV and SASSIGN. */
 	    kid->op_sibling = o->op_sibling;	/* NULL */
 	    cLISTOPo->op_first = NULL;
-#ifdef PERL_MAD
-	    op_getmad(o,kid,'O');
-	    op_getmad(kkid,kid,'M');
-#else
 	    op_free(o);
 	    op_free(kkid);
-#endif
 	    kid->op_private |= OPpTARGET_MY;	/* Used for context settings */
 	    return kid;
 	}
@@ -6869,9 +7064,27 @@ Perl_ck_sassign(pTHX_ OP *o)
 	if (kkid->op_type == OP_PADSV
 		&& (kkid->op_private & OPpLVAL_INTRO)
 		&& SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
-	    o->op_private |= OPpASSIGN_STATE;
+	    const PADOFFSET target = kkid->op_targ;
+	    OP *const other = newOP(OP_PADSV,
+				    kkid->op_flags
+				    | ((kkid->op_private & ~OPpLVAL_INTRO) << 8));
+	    OP *const first = newOP(OP_NULL, 0);
+	    OP *const nullop = newCONDOP(0, first, o, other);
+	    OP *const condop = first->op_next;
 	    /* hijacking PADSTALE for uninitialized state variables */
-	    SvPADSTALE_on(PAD_SVl(kkid->op_targ));
+	    SvPADSTALE_on(PAD_SVl(target));
+
+	    condop->op_type = OP_ONCE;
+	    condop->op_ppaddr = PL_ppaddr[OP_ONCE];
+	    condop->op_targ = target;
+	    other->op_targ = target;
+
+	    /* Because we change the type of the op here, we will skip the
+	       assinment binop->op_last = binop->op_first->op_sibling; at the
+	       end of Perl_newBINOP(). So need to do it here. */
+	    cBINOPo->op_last = cBINOPo->op_first->op_sibling;
+
+	    return nullop;
 	}
     }
     return o;
@@ -6951,8 +7164,18 @@ Perl_ck_open(pTHX_ OP *o)
 		o->op_private |= OPpOPEN_OUT_CRLF;
 	}
     }
-    if (o->op_type == OP_BACKTICK)
+    if (o->op_type == OP_BACKTICK) {
+	if (!(o->op_flags & OPf_KIDS)) {
+	    OP * const newop = newUNOP(OP_BACKTICK, 0, newDEFSVOP());
+#ifdef PERL_MAD
+	    op_getmad(o,newop,'O');
+#else
+	    op_free(o);
+#endif
+	    return newop;
+	}
 	return o;
+    }
     {
 	 /* In case of three-arg dup open remove strictness
 	  * from the last arg if it is a bareword. */
@@ -7001,6 +7224,8 @@ Perl_ck_require(pTHX_ OP *o)
 	    SV * const sv = kid->op_sv;
 	    U32 was_readonly = SvREADONLY(sv);
 	    char *s;
+	    STRLEN len;
+	    const char *end;
 
 	    if (was_readonly) {
 		if (SvFAKE(sv)) {
@@ -7012,14 +7237,17 @@ Perl_ck_require(pTHX_ OP *o)
 		}
 	    }   
 
-	    for (s = SvPVX(sv); *s; s++) {
+	    s = SvPVX(sv);
+	    len = SvCUR(sv);
+	    end = s + len;
+	    for (; s < end; s++) {
 		if (*s == ':' && s[1] == ':') {
-		    const STRLEN len = strlen(s+2)+1;
 		    *s = '/';
-		    Move(s+2, s+1, len, char);
-		    SvCUR_set(sv, SvCUR(sv) - 1);
+		    Move(s+2, s+1, end - s - 1, char);
+		    --end;
 		}
 	    }
+	    SvEND_set(sv, end);
 	    sv_catpvs(sv, ".pm");
 	    SvFLAGS(sv) |= was_readonly;
 	}
@@ -7330,10 +7558,11 @@ Perl_ck_join(pTHX_ OP *o)
     if (kid && kid->op_type == OP_MATCH) {
 	if (ckWARN(WARN_SYNTAX)) {
             const REGEXP *re = PM_GETRE(kPMOP);
-	    const char *pmstr = re ? re->precomp : "STRING";
+	    const char *pmstr = re ? RX_PRECOMP(re) : "STRING";
+	    const STRLEN len = re ? RX_PRELEN(re) : 6;
 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-			"/%s/ should probably be written as \"%s\"",
-			pmstr, pmstr);
+			"/%.*s/ should probably be written as \"%.*s\"",
+			(int)len, pmstr, (int)len, pmstr);
 	}
     }
     return ck_fun(o);
@@ -7376,26 +7605,6 @@ Perl_ck_subr(pTHX_ OP *o)
 		    proto = SvPV((SV*)cv, len);
 		    proto_end = proto + len;
 		}
-		if (CvASSERTION(cv)) {
-		    U32 asserthints = 0;
-		    HV *const hinthv = GvHV(PL_hintgv);
-		    if (hinthv) {
-			SV **svp = hv_fetchs(hinthv, "assertions", FALSE);
-			if (svp && *svp)
-			    asserthints = SvUV(*svp);
-		    }
-		    if (asserthints & HINT_ASSERTING) {
-			if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
-			    o->op_private |= OPpENTERSUB_DB;
-		    }
-		    else {
-			delete_op = 1;
-			if (!(asserthints & HINT_ASSERTIONSSEEN) && ckWARN(WARN_ASSERTIONS)) {
-			    Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
-					"Impossible to activate assertion call");
-			}
-		    }
-		}
 	    }
 	}
     }
@@ -7413,6 +7622,10 @@ Perl_ck_subr(pTHX_ OP *o)
 	o->op_private |= OPpENTERSUB_DB;
     while (o2 != cvop) {
 	OP* o3;
+	if (PL_madskills && o2->op_type == OP_STUB) {
+	    o2 = o2->op_sibling;
+	    continue;
+	}
 	if (PL_madskills && o2->op_type == OP_NULL)
 	    o3 = ((UNOP*)o2)->op_first;
 	else
@@ -7679,6 +7892,27 @@ Perl_ck_substr(pTHX_ OP *o)
     return o;
 }
 
+OP *
+Perl_ck_each(pTHX_ OP *o)
+{
+
+    OP *kid = cLISTOPo->op_first;
+
+    if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
+	const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
+	    : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+	o->op_type = new_type;
+	o->op_ppaddr = PL_ppaddr[new_type];
+    }
+    else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
+	       || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
+	       )) {
+	bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
+	return o;
+    }
+    return ck_fun(o);
+}
+
 /* A peephole optimizer.  We visit the ops in the order they're to execute.
  * See the comments at the top of this file for more details about when
  * peep() is called */
@@ -7697,13 +7931,15 @@ Perl_peep(pTHX_ register OP *o)
     for (; o; o = o->op_next) {
 	if (o->op_opt)
 	    break;
+	/* By default, this op has now been optimised. A couple of cases below
+	   clear this again.  */
+	o->op_opt = 1;
 	PL_op = o;
 	switch (o->op_type) {
 	case OP_SETSTATE:
 	case OP_NEXTSTATE:
 	case OP_DBSTATE:
 	    PL_curcop = ((COP*)o);		/* for warnings */
-	    o->op_opt = 1;
 	    break;
 
 	case OP_CONST:
@@ -7746,14 +7982,13 @@ Perl_peep(pTHX_ register OP *o)
 		o->op_targ = ix;
 	    }
 #endif
-	    o->op_opt = 1;
 	    break;
 
 	case OP_CONCAT:
 	    if (o->op_next && o->op_next->op_type == OP_STRINGIFY) {
 		if (o->op_next->op_private & OPpTARGET_MY) {
 		    if (o->op_flags & OPf_STACKED) /* chained concats */
-			goto ignore_optimization;
+			break; /* ignore_optimization */
 		    else {
 			/* assert(PL_opargs[o->op_type] & OA_TARGLEX); */
 			o->op_targ = o->op_next->op_targ;
@@ -7763,12 +7998,9 @@ Perl_peep(pTHX_ register OP *o)
 		}
 		op_null(o->op_next);
 	    }
-	  ignore_optimization:
-	    o->op_opt = 1;
 	    break;
 	case OP_STUB:
 	    if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
-		o->op_opt = 1;
 		break; /* Scalar stub must produce undef.  List stub is noop */
 	    }
 	    goto nothin;
@@ -7784,20 +8016,17 @@ Perl_peep(pTHX_ register OP *o)
 	       has already occurred. This doesn't fix the real problem,
 	       though (See 20010220.007). AMS 20010719 */
 	    /* op_seq functionality is now replaced by op_opt */
-	    if (oldop && o->op_next) {
-		oldop->op_next = o->op_next;
-		continue;
-	    }
-	    break;
+	    o->op_opt = 0;
+	    /* FALL THROUGH */
 	case OP_SCALAR:
 	case OP_LINESEQ:
 	case OP_SCOPE:
-	  nothin:
+	nothin:
 	    if (oldop && o->op_next) {
 		oldop->op_next = o->op_next;
+		o->op_opt = 0;
 		continue;
 	    }
-	    o->op_opt = 1;
 	    break;
 
 	case OP_PADAV:
@@ -7834,7 +8063,6 @@ Perl_peep(pTHX_ register OP *o)
 			o->op_flags |= OPf_SPECIAL;
 		    o->op_type = OP_AELEMFAST;
 		}
-    		o->op_opt = 1;
 		break;
 	    }
 
@@ -7871,7 +8099,6 @@ Perl_peep(pTHX_ register OP *o)
 		op_null(o->op_next);
 	    }
 
-	    o->op_opt = 1;
 	    break;
 
 	case OP_MAPWHILE:
@@ -7884,7 +8111,7 @@ Perl_peep(pTHX_ register OP *o)
 	case OP_DORASSIGN:
 	case OP_COND_EXPR:
 	case OP_RANGE:
-	    o->op_opt = 1;
+	case OP_ONCE:
 	    while (cLOGOP->op_other->op_type == OP_NULL)
 		cLOGOP->op_other = cLOGOP->op_other->op_next;
 	    peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
@@ -7892,7 +8119,6 @@ Perl_peep(pTHX_ register OP *o)
 
 	case OP_ENTERLOOP:
 	case OP_ENTERITER:
-	    o->op_opt = 1;
 	    while (cLOOP->op_redoop->op_type == OP_NULL)
 		cLOOP->op_redoop = cLOOP->op_redoop->op_next;
 	    peep(cLOOP->op_redoop);
@@ -7904,18 +8130,16 @@ Perl_peep(pTHX_ register OP *o)
 	    peep(cLOOP->op_lastop);
 	    break;
 
-	case OP_QR:
-	case OP_MATCH:
 	case OP_SUBST:
-	    o->op_opt = 1;
-	    while (cPMOP->op_pmreplstart &&
-		   cPMOP->op_pmreplstart->op_type == OP_NULL)
-		cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
-	    peep(cPMOP->op_pmreplstart);
+	    assert(!(cPMOP->op_pmflags & PMf_ONCE));
+	    while (cPMOP->op_pmstashstartu.op_pmreplstart &&
+		   cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
+		cPMOP->op_pmstashstartu.op_pmreplstart
+		    = cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
+	    peep(cPMOP->op_pmstashstartu.op_pmreplstart);
 	    break;
 
 	case OP_EXEC:
-	    o->op_opt = 1;
 	    if (o->op_next && o->op_next->op_type == OP_NEXTSTATE
 		&& ckWARN(WARN_SYNTAX))
 	    {
@@ -7942,8 +8166,6 @@ Perl_peep(pTHX_ register OP *o)
 	    const char *key = NULL;
 	    STRLEN keylen;
 
-	    o->op_opt = 1;
-
 	    if (((BINOP*)o)->op_last->op_type != OP_CONST)
 		break;
 
@@ -8070,8 +8292,6 @@ Perl_peep(pTHX_ register OP *o)
 
 	    /* make @a = sort @a act in-place */
 
-	    o->op_opt = 1;
-
 	    oright = cUNOPx(oright)->op_sibling;
 	    if (!oright)
 		break;
@@ -8162,7 +8382,6 @@ Perl_peep(pTHX_ register OP *o)
 	    OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
 	    OP *gvop = NULL;
 	    LISTOP *enter, *exlist;
-	    o->op_opt = 1;
 
 	    enter = (LISTOP *) o->op_next;
 	    if (!enter)
@@ -8253,14 +8472,7 @@ Perl_peep(pTHX_ register OP *o)
 	    UNOP *refgen, *rv2cv;
 	    LISTOP *exlist;
 
-	    /* I do not understand this, but if o->op_opt isn't set to 1,
-	       various tests in ext/B/t/bytecode.t fail with no readily
-	       apparent cause.  */
-
-	    o->op_opt = 1;
-
-
-	    if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
+	    if ((o->op_flags & OPf_WANT) != OPf_WANT_VOID)
 		break;
 
 	    if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
@@ -8300,8 +8512,11 @@ Perl_peep(pTHX_ register OP *o)
 	}
 
 	
-	default:
-	    o->op_opt = 1;
+	case OP_QR:
+	case OP_MATCH:
+	    if (!(cPMOP->op_pmflags & PMf_ONCE)) {
+		assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
+	    }
 	    break;
 	}
 	oldop = o;
@@ -8309,7 +8524,7 @@ Perl_peep(pTHX_ register OP *o)
     LEAVE;
 }
 
-char*
+const char*
 Perl_custom_op_name(pTHX_ const OP* o)
 {
     dVAR;
@@ -8329,7 +8544,7 @@ Perl_custom_op_name(pTHX_ const OP* o)
     return SvPV_nolen(HeVAL(he));
 }
 
-char*
+const char*
 Perl_custom_op_desc(pTHX_ const OP* o)
 {
     dVAR;