This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make regen for the IBM/CRAY fp
[perl5.git] / pp_hot.c
index 8f5d82e..ee908c5 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -130,7 +130,7 @@ PP(pp_sassign)
     */
     SV *left = POPs; SV *right = TOPs;
 
-    if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
+    if (PL_op->op_private & OPpASSIGN_BACKWARDS) { /* {or,and,dor}assign */
        SV * const temp = left;
        left = right; right = temp;
     }
@@ -284,8 +284,11 @@ PP(pp_concat)
     }
     else { /* $l .= $r   and   left == TARG */
        if (!SvOK(left)) {
-           if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
-               report_uninit(right);
+            if ((left == right                          /* $l .= $l */
+                 || (PL_op->op_private & OPpTARGET_MY)) /* $l = $l . $r */
+                && ckWARN(WARN_UNINITIALIZED)
+                )
+                report_uninit(left);
            sv_setpvs(left, "");
        }
         else {
@@ -379,7 +382,8 @@ PP(pp_padrange)
                     | (count << SAVE_TIGHT_SHIFT)
                     | SAVEt_CLEARPADRANGE);
         STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
-        assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
+        assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))
+                == (Size_t)base);
         {
             dSS_ADD;
             SS_ADD_UV(payload);
@@ -816,13 +820,30 @@ PP(pp_aelemfast)
     AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
        ? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
     const U32 lval = PL_op->op_flags & OPf_MOD;
-    SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
-    SV *sv = (svp ? *svp : &PL_sv_undef);
+    const I8 key   = (I8)PL_op->op_private;
+    SV** svp;
+    SV *sv;
 
-    if (UNLIKELY(!svp && lval))
-        DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
+    assert(SvTYPE(av) == SVt_PVAV);
 
     EXTEND(SP, 1);
+
+    /* inlined av_fetch() for simple cases ... */
+    if (!SvRMAGICAL(av) && key >= 0 && key <= AvFILLp(av)) {
+        sv = AvARRAY(av)[key];
+        if (sv) {
+            PUSHs(sv);
+            RETURN;
+        }
+    }
+
+    /* ... else do it the hard way */
+    svp = av_fetch(av, key, lval);
+    sv = (svp ? *svp : &PL_sv_undef);
+
+    if (UNLIKELY(!svp && lval))
+        DIE(aTHX_ PL_no_aelem, (int)key);
+
     if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
        mg_get(sv);
     PUSHs(sv);
@@ -839,25 +860,6 @@ PP(pp_join)
     RETURN;
 }
 
-PP(pp_pushre)
-{
-    dSP;
-#ifdef DEBUGGING
-    /*
-     * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
-     * will be enough to hold an OP*.
-     */
-    SV* const sv = sv_newmortal();
-    sv_upgrade(sv, SVt_PVLV);
-    LvTYPE(sv) = '/';
-    Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
-    XPUSHs(sv);
-#else
-    XPUSHs(MUTABLE_SV(PL_op));
-#endif
-    RETURN;
-}
-
 /* Oversized hot code. */
 
 /* also used for: pp_say() */
@@ -2630,8 +2632,14 @@ PP(pp_iter)
     SV **itersvp;
     SV *retsv;
 
+    SV *sv;
+    AV *av;
+    IV ix;
+    IV inc;
+
     cx = CX_CUR();
     itersvp = CxITERVAR(cx);
+    assert(itersvp);
 
     switch (CxTYPE(cx)) {
 
@@ -2714,12 +2722,6 @@ PP(pp_iter)
         break;
     }
 
-    {
-        SV *sv;
-        AV *av;
-        IV ix;
-        IV inc;
-
     case CXt_LOOP_LIST: /* for (1,2,3) */
 
         assert(OPpITER_REVERSED == 2); /* so inc becomes -1 or 1 */
@@ -2784,7 +2786,6 @@ PP(pp_iter)
         *itersvp = sv;
         SvREFCNT_dec(oldsv);
         break;
-    }
 
     default:
        DIE(aTHX_ "panic: pp_iter, type=%u", CxTYPE(cx));
@@ -2800,8 +2801,6 @@ PP(pp_iter)
     *++PL_stack_sp =retsv;
 
     return PL_op->op_next;
-
-
 }
 
 /*
@@ -2895,7 +2894,7 @@ PP(pp_subst)
     STRLEN slen;
     bool doutf8 = FALSE; /* whether replacement is in utf8 */
 #ifdef PERL_ANY_COW
-    bool is_cow;
+    bool was_cow;
 #endif
     SV *nsv = NULL;
     /* known replacement string? */
@@ -2914,24 +2913,25 @@ PP(pp_subst)
 
     SvGETMAGIC(TARG); /* must come before cow check */
 #ifdef PERL_ANY_COW
-    /* Awooga. Awooga. "bool" types that are actually char are dangerous,
-       because they make integers such as 256 "false".  */
-    is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
-#else
-    if (SvIsCOW(TARG))
-       sv_force_normal_flags(TARG,0);
+    /* note that a string might get converted to COW during matching */
+    was_cow = cBOOL(SvIsCOW(TARG));
 #endif
-    if (!(rpm->op_pmflags & PMf_NONDESTRUCT)
-       && (SvREADONLY(TARG)
-           || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
-                 || SvTYPE(TARG) > SVt_PVLV)
-                && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
-       Perl_croak_no_modify();
+    if (!(rpm->op_pmflags & PMf_NONDESTRUCT)) {
+#ifndef PERL_ANY_COW
+       if (SvIsCOW(TARG))
+           sv_force_normal_flags(TARG,0);
+#endif
+       if ((SvREADONLY(TARG)
+               || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
+                     || SvTYPE(TARG) > SVt_PVLV)
+                    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+           Perl_croak_no_modify();
+    }
     PUTBACK;
 
     orig = SvPV_nomg(TARG, len);
     /* note we don't (yet) force the var into being a string; if we fail
-     * to match, we leave as-is; on successful match howeverm, we *will*
+     * to match, we leave as-is; on successful match however, we *will*
      * coerce into a string, then repeat the match */
     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV || SvVOK(TARG))
        force_on_match = 1;
@@ -2993,10 +2993,7 @@ PP(pp_subst)
        if (DO_UTF8(TARG) && !doutf8) {
             nsv = sv_newmortal();
             SvSetSV(nsv, dstr);
-            if (IN_ENCODING)
-                 sv_recode_to_utf8(nsv, _get_encoding());
-            else
-                 sv_utf8_upgrade(nsv);
+            sv_utf8_upgrade(nsv);
             c = SvPV_const(nsv, clen);
             doutf8 = TRUE;
        }
@@ -3016,7 +3013,7 @@ PP(pp_subst)
     /* can do inplace substitution? */
     if (c
 #ifdef PERL_ANY_COW
-       && !is_cow
+       && !was_cow
 #endif
         && (I32)clen <= RX_MINLENRET(rx)
         && (  once
@@ -3029,6 +3026,7 @@ PP(pp_subst)
     {
 
 #ifdef PERL_ANY_COW
+        /* string might have got converted to COW since we set was_cow */
        if (SvIsCOW(TARG)) {
          if (!force_on_match)
            goto have_a_cow;
@@ -3174,13 +3172,7 @@ PP(pp_subst)
              first = FALSE;
            }
            else {
-               if (IN_ENCODING) {
-                   if (!nsv) nsv = sv_newmortal();
-                   sv_copypv(nsv, repl);
-                   if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
-                   sv_catsv(dstr, nsv);
-               }
-               else sv_catsv(dstr, repl);
+               sv_catsv(dstr, repl);
                if (UNLIKELY(SvTAINTED(repl)))
                    rxtainted |= SUBST_TAINT_REPL;
            }
@@ -3624,6 +3616,8 @@ Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
 }
 
 
+/* also tail-called by pp_return */
+
 PP(pp_leavesub)
 {
     U8 gimme;
@@ -3783,6 +3777,7 @@ PP(pp_entersub)
 
     /* these two fields are in a union. If they ever become separate,
      * we have to test for both of them being null below */
+    assert(cv);
     assert((void*)&CvROOT(cv) == (void*)&CvXSUB(cv));
     while (UNLIKELY(!CvROOT(cv))) {
        GV* autogv;
@@ -3804,7 +3799,10 @@ PP(pp_entersub)
        else {
           try_autoload:
            autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
-                                  GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
+                                     (GvNAMEUTF8(gv) ? SVf_UTF8 : 0)
+                                    |(PL_op->op_flags & OPf_REF
+                                       ? GV_AUTOLOAD_ISMETHOD
+                                       : 0));
             cv = autogv ? GvCV(autogv) : NULL;
        }
        if (!cv) {
@@ -3913,6 +3911,7 @@ PP(pp_entersub)
     }
     else {
        SSize_t markix = TOPMARK;
+        bool is_scalar;
 
         ENTER;
         /* pretend we did the ENTER earlier */
@@ -3975,12 +3974,16 @@ PP(pp_entersub)
        }
        /* Do we need to open block here? XXXX */
 
+        /* calculate gimme here as PL_op might get changed and then not
+         * restored until the LEAVE further down */
+        is_scalar = (GIMME_V == G_SCALAR);
+
        /* CvXSUB(cv) must not be NULL because newXS() refuses NULL xsub address */
        assert(CvXSUB(cv));
        CvXSUB(cv)(aTHX_ cv);
 
        /* Enforce some sanity in scalar context. */
-       if (GIMME_V == G_SCALAR) {
+       if (is_scalar) {
             SV **svp = PL_stack_base + markix + 1;
             if (svp != PL_stack_sp) {
                 *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
@@ -4005,6 +4008,28 @@ Perl_sub_crush_depth(pTHX_ CV *cv)
     }
 }
 
+
+
+/* like croak, but report in context of caller */
+
+void
+Perl_croak_caller(const char *pat, ...)
+{
+    dTHX;
+    va_list args;
+    const PERL_CONTEXT *cx = caller_cx(0, NULL);
+
+    /* make error appear at call site */
+    assert(cx);
+    PL_curcop = cx->blk_oldcop;
+
+    va_start(args, pat);
+    vcroak(pat, &args);
+    NOT_REACHED; /* NOTREACHED */
+    va_end(args);
+}
+
+
 PP(pp_aelem)
 {
     dSP;