Unicode::Normalize no-go with miniperl.

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index e8fd4ae..352a629 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1019,11 +1019,19 @@ S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
  *
  * If the LHS element is a 'my' declaration' and has a refcount of 1, then
  * it can't be common and can be skipped.
+ *
+ * On DEBUGGING builds it takes an extra boolean, fake. If true, it means
+ * that we thought we didn't need to call S_aassign_copy_common(), but we
+ * have anyway for sanity checking. If we find we need to copy, then panic.
  */
 
 PERL_STATIC_INLINE void
 S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
-        SV **firstrelem, SV **lastrelem)
+        SV **firstrelem, SV **lastrelem
+#ifdef DEBUGGING
+        , bool fake
+#endif
+)
 {
     dVAR;
     SV **relem;
@@ -1036,14 +1044,13 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
     assert(firstlelem < lastlelem); /* at least 2 LH elements */
     assert(firstrelem < lastrelem); /* at least 2 RH elements */
 
+
+    lelem = firstlelem;
     /* we never have to copy the first RH element; it can't be corrupted
      * by assigning something to the corresponding first LH element.
      * So this scan does in a loop: mark LHS[N]; test RHS[N+1]
      */
-    firstrelem++;
-
-    lelem = firstlelem;
-    relem = firstrelem;
+    relem = firstrelem + 1;
 
     for (; relem <= lastrelem; relem++) {
         SV *svr;
@@ -1093,6 +1100,15 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
 
         if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
 
+#ifdef DEBUGGING
+            if (fake) {
+                /* op_dump(PL_op); */
+                Perl_croak(aTHX_
+                    "panic: aassign skipped needed copy of common RH elem %"
+                        UVuf, (UV)(relem - firstrelem));
+            }
+#endif
+
             TAINT_NOT; /* Each item is independent */
 
             /* Dear TODO test in t/op/sort.t, I love you.
@@ -1158,6 +1174,12 @@ PP(pp_aassign)
     SSize_t i;
     int magic;
     U32 lval;
+    /* PL_delaymagic is restored by JUMPENV_POP on dieing, so we
+     * only need to save locally, not on the save stack */
+    U16 old_delaymagic = PL_delaymagic;
+#ifdef DEBUGGING
+    bool fake = 0;
+#endif
 
     PL_delaymagic = DM_DELAY;          /* catch simultaneous items */
 
@@ -1184,9 +1206,24 @@ PP(pp_aassign)
         else {
           do_scan:
             S_aassign_copy_common(aTHX_
-                        firstlelem, lastlelem, firstrelem, lastrelem);
+                        firstlelem, lastlelem, firstrelem, lastrelem
+#ifdef DEBUGGING
+                        , fake
+#endif
+            );
+        }
+    }
+#ifdef DEBUGGING
+    else {
+        /* on debugging builds, do the scan even if we've concluded we
+         * don't need to, then panic if we find commonality. Note that the
+         * scanner assumes at least 2 elements */
+        if (firstlelem < lastlelem && firstrelem < lastrelem) {
+            fake = 1;
+            goto do_scan;
         }
     }
+#endif
 
     gimme = GIMME_V;
     lval = (gimme == G_ARRAY) ? (PL_op->op_flags & OPf_MOD || LVRET) : 0;
@@ -1241,7 +1278,9 @@ PP(pp_aassign)
             }
 
             av_clear(ary);
-           av_extend(ary, lastrelem - relem);
+           if (relem <= lastrelem)
+                av_extend(ary, lastrelem - relem);
+
            i = 0;
            while (relem <= lastrelem) {        /* gobble up all the rest */
                SV **didstore;
@@ -1509,7 +1548,7 @@ PP(pp_aassign)
         PERL_UNUSED_VAR(tmp_egid);
 #endif
     }
-    PL_delaymagic = 0;
+    PL_delaymagic = old_delaymagic;
 
     if (gimme == G_VOID)
        SP = firstrelem - 1;
@@ -1928,6 +1967,7 @@ Perl_do_readline(pTHX)
        XPUSHs(sv);
        if (type == OP_GLOB) {
            const char *t1;
+           Stat_t statbuf;
 
            if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
                char * const tmps = SvEND(sv) - 1;
@@ -1943,7 +1983,7 @@ Perl_do_readline(pTHX)
                if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
 #endif
                        break;
-           if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
+           if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
                (void)POPs;             /* Unmatched wildcard?  Chuck it... */
                continue;
            }
@@ -3015,7 +3055,8 @@ PP(pp_subst)
            }
            if (once)
                break;
-       } while (CALLREGEXEC(rx, s, strend, orig, s == m,
+       } while (CALLREGEXEC(rx, s, strend, orig,
+                             s == m,    /* Yields minend of 0 or 1 */
                             TARG, NULL,
                     REXEC_NOT_FIRST|REXEC_IGNOREPOS|REXEC_FAIL_ON_UNDERFLOW));
        sv_catpvn_nomg_maybeutf8(dstr, s, strend - s, DO_UTF8(TARG));
@@ -3103,15 +3144,8 @@ PP(pp_grepwhile)
        (void)POPMARK;                          /* pop dst */
        SP = PL_stack_base + POPMARK;           /* pop original mark */
        if (gimme == G_SCALAR) {
-           if (PL_op->op_private & OPpGREP_LEX) {
-               SV* const sv = sv_newmortal();
-               sv_setiv(sv, items);
-               PUSHs(sv);
-           }
-           else {
                dTARGET;
                XPUSHi(items);
-           }
        }
        else if (gimme == G_ARRAY)
            SP += items;
@@ -3129,10 +3163,7 @@ PP(pp_grepwhile)
            PL_tmps_floor++;
        }
        SvTEMP_off(src);
-       if (PL_op->op_private & OPpGREP_LEX)
-           PAD_SVl(PL_op->op_targ) = src;
-       else
-           DEFSV_set(src);
+       DEFSV_set(src);
 
        RETURNOP(cLOGOP->op_other);
     }
@@ -3400,7 +3431,8 @@ PP(pp_entersub)
        SAVETMPS;
        if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
            !CvLVALUE(cv)))
-           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+            DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
+                SVfARG(cv_name(cv, NULL, 0)));
        /* warning must come *after* we fully set up the context
         * stuff so that __WARN__ handlers can safely dounwind()
         * if they want to
@@ -3421,7 +3453,8 @@ PP(pp_entersub)
               & PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
              ) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
            !CvLVALUE(cv)))
-           DIE(aTHX_ "Can't modify non-lvalue subroutine call");
+            DIE(aTHX_ "Can't modify non-lvalue subroutine call of &%"SVf,
+                SVfARG(cv_name(cv, NULL, 0)));
 
        if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
            /* Need to copy @_ to stack. Alternative may be to