Various updates and fixes to some of the SysV IPC ops and their tests

[perl5.git] / pp_hot.c

diff --git a/pp_hot.c b/pp_hot.c
index 39aef72..0f5e417 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -34,6 +34,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PP_HOT_C
 #include "perl.h"
 #include "EXTERN.h"
 #define PERL_IN_PP_HOT_C
 #include "perl.h"

+#include "regcomp.h"

 
 /* Hot code. */
 
 
 /* Hot code. */
 


@@ -416,7 +417,7 @@ PP(pp_multiconcat)
                                 for ease of testing and setting) */
     /* for each arg, holds the result of an SvPV() call */
     struct multiconcat_svpv {
                                 for ease of testing and setting) */
     /* for each arg, holds the result of an SvPV() call */
     struct multiconcat_svpv {

-        char          *pv;
+        const char   *pv;

         SSize_t       len;
     }
         *targ_chain,         /* chain of slots where targ has appeared on RHS */
         SSize_t       len;
     }
         *targ_chain,         /* chain of slots where targ has appeared on RHS */


@@ -532,7 +533,7 @@ PP(pp_multiconcat)
                 /* an undef value in the presence of warnings may trigger
                  * side affects */
                 goto do_magical;
                 /* an undef value in the presence of warnings may trigger
                  * side affects */
                 goto do_magical;

-            svpv_end->pv = (char*)"";
+            svpv_end->pv = "";

             len = 0;
         }
         else
             len = 0;
         }
         else


@@ -639,7 +640,7 @@ PP(pp_multiconcat)
      *   one set of segment lengths.
      *
      * * If the string has different plain and utf8 representations
      *   one set of segment lengths.
      *
      * * If the string has different plain and utf8 representations

-     *   (e.g. "\x80"), then then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]
+     *   (e.g. "\x80"), then aux[PERL_MULTICONCAT_IX_PLAIN_PV/LEN]]

      *   holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
      *   holds the utf8 rep, and there are 2 sets of segment lengths,
      *   with the utf8 set following after the plain set.
      *   holds the plain rep, while aux[PERL_MULTICONCAT_IX_UTF8_PV/LEN]
      *   holds the utf8 rep, and there are 2 sets of segment lengths,
      *   with the utf8 set following after the plain set.


@@ -686,7 +687,7 @@ PP(pp_multiconcat)
          * calculate how much extra growth is needed for all the chars
          * which will expand to two utf8 bytes.
          * Also, if the growth is non-zero, negate the length to indicate
          * calculate how much extra growth is needed for all the chars
          * which will expand to two utf8 bytes.
          * Also, if the growth is non-zero, negate the length to indicate

-         * that this this is a variant string. Conversely, un-negate the
+         * that this is a variant string. Conversely, un-negate the

          * length on utf8 args (which was only needed to flag non-utf8
          * args in this loop */
         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {
          * length on utf8 args (which was only needed to flag non-utf8
          * args in this loop */
         for (svpv_p = svpv_buf; svpv_p < svpv_end; svpv_p++) {


@@ -1097,15 +1098,20 @@ PP(pp_multiconcat)
 
         SP = toparg - stack_adj + 1;
 
 
         SP = toparg - stack_adj + 1;
 

-        /* Assign result of all RHS concats (left) to LHS (targ).
+        /* Return the result of all RHS concats, unless this op includes
+         * an assign ($lex = x.y.z or expr = x.y.z), in which case copy
+         * to target (which will be $lex or expr).

          * If we are appending, targ will already have been appended to in
          * the loop */
          * If we are appending, targ will already have been appended to in
          * the loop */

-        if (is_append)
-            SvTAINT(targ);
-        else {
+        if (  !is_append
+            && (   (PL_op->op_flags   & OPf_STACKED)
+                || (PL_op->op_private & OPpTARGET_MY))
+        ) {

             sv_setsv(targ, left);
             SvSETMAGIC(targ);
         }
             sv_setsv(targ, left);
             SvSETMAGIC(targ);
         }

+        else
+            targ = left;

         SETs(targ);
         RETURN;
     }
         SETs(targ);
         RETURN;
     }


@@ -1256,14 +1262,20 @@ PP(pp_eq)
 {
     dSP;
     SV *left, *right;
 {
     dSP;
     SV *left, *right;

+    U32 flags_and, flags_or;

 
 

-    tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
+    tryAMAGICbin_MG(eq_amg, AMGf_numeric);

     right = POPs;
     left  = TOPs;
     right = POPs;
     left  = TOPs;

+    flags_and = SvFLAGS(left) & SvFLAGS(right);
+    flags_or  = SvFLAGS(left) | SvFLAGS(right);
+

     SETs(boolSV(
     SETs(boolSV(

-       (SvIOK_notUV(left) && SvIOK_notUV(right))
-       ? (SvIVX(left) == SvIVX(right))
-       : ( do_ncmp(left, right) == 0)
+        ( (flags_and & SVf_IOK) && ((flags_or & SVf_IVisUV) ==0 ) )
+        ?    (SvIVX(left) == SvIVX(right))
+        : (flags_and & SVf_NOK)
+        ?    (SvNVX(left) == SvNVX(right))
+        : ( do_ncmp(left, right) == 0)

     ));
     RETURN;
 }
     ));
     RETURN;
 }


@@ -1430,16 +1442,10 @@ PP(pp_add)
             NV nl = SvNVX(svl);
             NV nr = SvNVX(svr);
 
             NV nl = SvNVX(svl);
             NV nr = SvNVX(svr);
 

-            if (
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
-                !Perl_isnan(nl) && nl == (NV)(il = (IV)nl)
-                && !Perl_isnan(nr) && nr == (NV)(ir = (IV)nr)
-#else
-                nl == (NV)(il = (IV)nl) && nr == (NV)(ir = (IV)nr)
-#endif
-                )
+            if (lossless_NV_to_IV(nl, &il) && lossless_NV_to_IV(nr, &ir)) {

                 /* nothing was lost by converting to IVs */
                 goto do_iv;
                 /* nothing was lost by converting to IVs */
                 goto do_iv;

+            }

             SP--;
             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
             SETs(TARG);
             SP--;
             TARGn(nl + nr, 0); /* args not GMG, so can't be tainted */
             SETs(TARG);


@@ -1521,7 +1527,9 @@ PP(pp_add)
                        auv = aiv;
                        auvok = 1;      /* Now acting as a sign flag.  */
                    } else {
                        auv = aiv;
                        auvok = 1;      /* Now acting as a sign flag.  */
                    } else {

-                       auv = -(UV)aiv;
+                        /* Using 0- here and later to silence bogus warning
+                         * from MS VC */
+                        auv = (UV) (0 - (UV) aiv);

                    }
                }
                a_valid = 1;
                    }
                }
                a_valid = 1;


@@ -1541,7 +1549,7 @@ PP(pp_add)
                    buv = biv;
                    buvok = 1;
                } else
                    buv = biv;
                    buvok = 1;
                } else

-                    buv = -(UV)biv;
+                    buv = (UV) (0 - (UV) biv);

            }
            /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
               else "IV" now, independent of how it came in.
            }
            /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
               else "IV" now, independent of how it came in.


@@ -2070,7 +2078,6 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
 #endif
 )
 {
 #endif
 )
 {

-    dVAR;

     SV **relem;
     SV **lelem;
     SSize_t lcount = lastlelem - firstlelem + 1;
     SV **relem;
     SV **lelem;
     SSize_t lcount = lastlelem - firstlelem + 1;


@@ -2198,7 +2205,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV **lastlelem,
 
 PP(pp_aassign)
 {
 
 PP(pp_aassign)
 {

-    dVAR; dSP;
+    dSP;

     SV **lastlelem = PL_stack_sp;
     SV **lastrelem = PL_stack_base + POPMARK;
     SV **firstrelem = PL_stack_base + POPMARK + 1;
     SV **lastlelem = PL_stack_sp;
     SV **lastrelem = PL_stack_base + POPMARK;
     SV **firstrelem = PL_stack_base + POPMARK + 1;


@@ -2736,8 +2743,8 @@ PP(pp_aassign)
            if (!SvIMMORTAL(lsv)) {
                 sv_set_undef(lsv);
                 SvSETMAGIC(lsv);
            if (!SvIMMORTAL(lsv)) {
                 sv_set_undef(lsv);
                 SvSETMAGIC(lsv);

-                *relem++ = lsv;

             }
             }

+            *relem++ = lsv;

            break;
         } /* switch */
     } /* while */
            break;
         } /* switch */
     } /* while */


@@ -2888,6 +2895,47 @@ PP(pp_qr)
     RETURN;
 }
 
     RETURN;
 }
 

+STATIC bool
+S_are_we_in_Debug_EXECUTE_r(pTHX)
+{
+    /* Given a 'use re' is in effect, does it ask for outputting execution
+     * debug info?
+     *
+     * This is separated from the sole place it's called, an inline function,
+     * because it is the large-ish slow portion of the function */
+
+    DECLARE_AND_GET_RE_DEBUG_FLAGS_NON_REGEX;
+
+    return cBOOL(RE_DEBUG_FLAG(RE_DEBUG_EXECUTE_MASK));
+}
+
+PERL_STATIC_INLINE bool
+S_should_we_output_Debug_r(pTHX_ regexp *prog)
+{
+    PERL_ARGS_ASSERT_SHOULD_WE_OUTPUT_DEBUG_R;
+
+    /* pp_match can output regex debugging info.  This function returns a
+     * boolean as to whether or not it should.
+     *
+     * Under -Dr, it should.  Any reasonable compiler will optimize this bit of
+     * code away on non-debugging builds. */
+    if (UNLIKELY(DEBUG_r_TEST)) {
+        return TRUE;
+    }
+
+    /* If the regex engine is using the non-debugging execution routine, then
+     * no debugging should be output.  Same if the field is NULL that pluggable
+     * engines are not supposed to fill. */
+    if (     LIKELY(prog->engine->exec == &Perl_regexec_flags)
+        || UNLIKELY(prog->engine->op_comp == NULL))
+    {
+        return FALSE;
+    }
+
+    /* Otherwise have to check */
+    return S_are_we_in_Debug_EXECUTE_r(aTHX);
+}
+

 PP(pp_match)
 {
     dSP; dTARG;
 PP(pp_match)
 {
     dSP; dTARG;


@@ -2943,7 +2991,9 @@ PP(pp_match)
         pm->op_pmflags & PMf_USED
 #endif
     ) {
         pm->op_pmflags & PMf_USED
 #endif
     ) {

-        DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
+        if (UNLIKELY(should_we_output_Debug_r(prog))) {
+            PerlIO_printf(Perl_debug_log, "?? already matched once");
+        }

        goto nope;
     }
 
        goto nope;
     }
 


@@ -2965,9 +3015,11 @@ PP(pp_match)
     }
 
     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {
     }
 
     if (RXp_MINLEN(prog) >= 0 && (STRLEN)RXp_MINLEN(prog) > len) {

-        DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match (%"
-                                              UVuf " < %" IVdf ")\n",
-                                              (UV)len, (IV)RXp_MINLEN(prog)));
+        if (UNLIKELY(should_we_output_Debug_r(prog))) {
+            PerlIO_printf(Perl_debug_log,
+                "String shorter than min possible regex match (%zd < %zd)\n",
+                                                        len, RXp_MINLEN(prog));
+        }

        goto nope;
     }
 
        goto nope;
     }
 


@@ -3129,7 +3181,7 @@ Perl_do_readline(pTHX)
            if (IoFLAGS(io) & IOf_ARGV) {
                if (IoFLAGS(io) & IOf_START) {
                    IoLINES(io) = 0;
            if (IoFLAGS(io) & IOf_ARGV) {
                if (IoFLAGS(io) & IOf_START) {
                    IoLINES(io) = 0;

-                   if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
+                   if (av_count(GvAVn(PL_last_in_gv)) == 0) {

                        IoFLAGS(io) &= ~IOf_START;
                        do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
                        SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
                        IoFLAGS(io) &= ~IOf_START;
                        do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
                        SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */


@@ -3268,9 +3320,9 @@ Perl_do_readline(pTHX)
            }
            for (t1 = SvPVX_const(sv); *t1; t1++)
 #ifdef __VMS
            }
            for (t1 = SvPVX_const(sv); *t1; t1++)
 #ifdef __VMS

-               if (strchr("*%?", *t1))
+               if (memCHRs("*%?", *t1))

 #else
 #else

-               if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+               if (memCHRs("$&*(){}[]'\";\\|?<>~`", *t1))

 #endif
                        break;
            if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {
 #endif
                        break;
            if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &statbuf) < 0) {


@@ -3588,7 +3640,7 @@ PP(pp_multideref)
                             IV len;
                             if (!defer)
                                 DIE(aTHX_ PL_no_aelem, elem);
                             IV len;
                             if (!defer)
                                 DIE(aTHX_ PL_no_aelem, elem);

-                            len = av_tindex(av);
+                            len = av_top_index(av);

                             /* Resolve a negative index that falls within
                              * the array.  Leave it negative it if falls
                              * outside the array.  */
                             /* Resolve a negative index that falls within
                              * the array.  Leave it negative it if falls
                              * outside the array.  */


@@ -4612,7 +4664,6 @@ PP(pp_grepwhile)
 void
 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
 {
 void
 Perl_leave_adjust_stacks(pTHX_ SV **from_sp, SV **to_sp, U8 gimme, int pass)
 {

-    dVAR;

     dSP;
     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
     SSize_t nargs;
     dSP;
     SSize_t tmps_base; /* lowest index into tmps stack that needs freeing now */
     SSize_t nargs;


@@ -5341,7 +5392,7 @@ PP(pp_aelem)
            IV len;
            if (!defer)
                DIE(aTHX_ PL_no_aelem, elem);
            IV len;
            if (!defer)
                DIE(aTHX_ PL_no_aelem, elem);

-           len = av_tindex(av);
+           len = av_top_index(av);

            /* Resolve a negative index that falls within the array.  Leave
               it negative it if falls outside the array.  */
            if (elem < 0 && len + elem >= 0)
            /* Resolve a negative index that falls within the array.  Leave
               it negative it if falls outside the array.  */
            if (elem < 0 && len + elem >= 0)