In perl.git, the branch smoke-me/ftrapv has been updated <http://perl5.git.perl.org/perl.git/commitdiff/8a7b8d273c07046436d596b4b603c1adbc53a0c2?hp=65c512c3519b68852f64f5e1293cebadee892115>
- Log ----------------------------------------------------------------- commit 8a7b8d273c07046436d596b4b603c1adbc53a0c2 Author: Nicholas Clark <[email protected]> Date: Mon Apr 16 18:16:02 2012 +0200 In pp_pow, avoid special case code for an IV_MIN result. Given that IV_MIN on a twos complement system will always be a (negated) power of two, and powers of two are handled in the NV-based code above, a IV_MIN result can't actually happen. However, by switching the integer result code to the same structure as the basic arithmetic ops, we can handle it as part of the code dealing with regular negative results. Making similar code similar eases maintenance. M pp.c commit d8107d30775cb003111e01d4cffca65560e794ed Author: Nicholas Clark <[email protected]> Date: Mon Apr 16 17:44:28 2012 +0200 Eliminate all (tested) integer overflow code, other than the 'integer' ops. Signed integer overflow is *undefined* behaviour in C. Historically perl has made assumptions in many places that it can get away with it. All tests now pass when perl (other than pp_i.c) is compiled with -ftrapv, which causes gcc to add code to abort() on signed integer overflow. (Tested on a 64 bit system). This eliminates all code annotated as "twos complement assumption", and code which assumes that -iv is safe for all values including IV_MIN. This change adds two inline functions (which behave like macros), NEGATE_IV_AS_UV() and NEGATE_UV_AS_IV(), which negate values between IVs and UVs without triggering undefined behaviour. M perl.h M pp.c M pp_ctl.c M pp_hot.c M sv.c commit c5de02544e8420fd32bca1352dcd2123866fd994 Author: Nicholas Clark <[email protected]> Date: Mon Apr 16 17:22:35 2012 +0200 Add tests to 64bitint.t which negate -9223372036854775808 into a UV. This particular edge case wasn't previously tested at 7 locations in the C code. M t/op/64bitint.t commit 29538d16592d108f275fe7ddf322dcbdb8f03a8f Author: Nicholas Clark <[email protected]> Date: Mon Apr 16 08:43:31 2012 +0200 Break out the integer ops from pp.c into pp_i.c This lets us control the compiler options used for just these ops. M MANIFEST M Makefile.SH M Makefile.micro M plan9/mkfile M pp.c A pp_i.c M vms/descrip_mms.template M win32/Makefile M win32/Makefile.ce M win32/makefile.mk commit 02db9b3d933aa9e245df4c28efe2ff42c0ff051e Author: Nicholas Clark <[email protected]> Date: Mon Apr 16 07:51:49 2012 +0200 In pp_iter, handle end of range at IV_MAX without undefined behaviour. The previous code assumed that incrementing a signed integer value wraps. We're lucky that it has (so far), as it's undefined behaviour in C. So refactor to code which doesn't assume anything. M pp_hot.c ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + Makefile.SH | 4 +- Makefile.micro | 5 +- perl.h | 16 +++ plan9/mkfile | 2 +- pp.c | 296 ++++------------------------------------------ pp_ctl.c | 27 +++-- pp_hot.c | 26 ++-- pp_i.c | 268 +++++++++++++++++++++++++++++++++++++++++ sv.c | 18 ++-- t/op/64bitint.t | 22 ++++ vms/descrip_mms.template | 6 +- win32/Makefile | 1 + win32/Makefile.ce | 2 + win32/makefile.mk | 1 + 15 files changed, 383 insertions(+), 312 deletions(-) create mode 100644 pp_i.c diff --git a/MANIFEST b/MANIFEST index 2be6ea7..0b97174 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4828,6 +4828,7 @@ pp.c Push/Pop code pp_ctl.c Push/Pop code for control flow pp.h Push/Pop code defs pp_hot.c Push/Pop code for heavily used opcodes +pp_i.c Push/Pop code for integer ops pp_pack.c Push/Pop code for pack/unpack pp_proto.h C++ definitions for Push/Pop code pp_sort.c Push/Pop code for sort diff --git a/Makefile.SH b/Makefile.SH index ba5ab79..d0e04b0 100755 --- a/Makefile.SH +++ b/Makefile.SH @@ -464,7 +464,7 @@ h6 = charclass_invlists.h h = $(h1) $(h2) $(h3) $(h4) $(h5) $(h6) c1 = av.c scope.c op.c doop.c doio.c dump.c gv.c hv.c mg.c reentr.c mro.c perl.c -c2 = perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c +c2 = perly.c pp.c pp_i.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c sv.c c3 = taint.c toke.c util.c deb.c run.c universal.c pad.c globals.c keywords.c c4 = perlio.c perlapi.c numeric.c mathoms.c locale.c pp_pack.c pp_sort.c c5 = $(madlysrc) $(mallocsrc) @@ -474,7 +474,7 @@ c = $(c1) $(c2) $(c3) $(c4) $(c5) miniperlmain.c opmini.c perlmini.c obj0 = op$(OBJ_EXT) perl$(OBJ_EXT) obj0mini = perlmini$(OBJ_EXT) opmini$(OBJ_EXT) miniperlmain$(OBJ_EXT) obj1 = $(madlyobj) $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) pad$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) reentr$(OBJ_EXT) mro$(OBJ_EXT) keywords$(OBJ_EXT ... [1 chars truncated] -obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) +obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) pp_i$(OBJ_EXT) obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) mathoms$ ... [62 chars truncated] minindt_obj = $(obj0mini) $(obj1) $(obj2) $(obj3) $(ARCHOBJS) diff --git a/Makefile.micro b/Makefile.micro index 8ce48b4..78fde16 100644 --- a/Makefile.micro +++ b/Makefile.micro @@ -17,7 +17,7 @@ all: microperl O = uav$(_O) udeb$(_O) udoio$(_O) udoop$(_O) udump$(_O) \ uglobals$(_O) ugv$(_O) uhv$(_O) umro$(_O)\ umg$(_O) uperlmain$(_O) uop$(_O) ureentr$(_O) \ - upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) \ + upad$(_O) uperl$(_O) uperlio$(_O) uperly$(_O) upp$(_O) upp_i$(_O) \ upp_ctl$(_O) upp_hot$(_O) upp_sys$(_O) upp_pack$(_O) upp_sort$(_O) \ uregcomp$(_O) uregexec$(_O) urun$(_O) \ uscope$(_O) usv$(_O) utaint$(_O) utoke$(_O) \ @@ -127,6 +127,9 @@ upp_ctl$(_O): $(HE) pp_ctl.c upp_hot$(_O): $(HE) pp_hot.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_hot.c +upp_i(_O): $(HE) pp_i.c + $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_i.c + upp_sys$(_O): $(HE) pp_sys.c $(CC) $(CCFLAGS) -o $@ $(CFLAGS) pp_sys.c diff --git a/perl.h b/perl.h index e532af2..c747e21 100644 --- a/perl.h +++ b/perl.h @@ -5723,6 +5723,22 @@ extern void moncontrol(int); * but also beware since this evaluates its argument twice, so no x++. */ #define PERL_ABS(x) ((x) < 0 ? -(x) : (x)) +PERL_STATIC_INLINE UV +NEGATE_IV_AS_UV(IV what) { + assert (what <= 0); + return (UV)1 + -(what + 1); +} +#define MINUS_IV_MIN NEGATE_IV_AS_UV(IV_MIN) +PERL_STATIC_INLINE UV +NEGATE_UV_AS_IV(UV what) { + /* I don't understand why gcc -fwrapv gets upset if I "inline" this into + the expression below: */ + const UV smaller = what - 1; + assert (what <= MINUS_IV_MIN); + assert (what > 0); + return (-(IV)smaller) - 1; +} + #if defined(__DECC) && defined(__osf__) #pragma message disable (mainparm) /* Perl uses the envp in main(). */ #endif diff --git a/plan9/mkfile b/plan9/mkfile index 8f086b0..2217724 100644 --- a/plan9/mkfile +++ b/plan9/mkfile @@ -35,7 +35,7 @@ ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs POSIX.xs ext_c = ${ext_xs:%.xs=%.c} ext_obj = ${ext_xs:%.xs=%.$O} -obj = av.$O deb.$O doio.$O doop.$O dump.$O globals.$O gv.$O hv.$O locale.$O malloc.$O mathoms.$O mg.$O numeric.$O op.$O pad.$O perlapi.$O perlio.$O perly.$O pp.$O pp_ctl.$O pp_hot.$O pp_pack.$O pp_so ... [115 chars truncated] +obj = av.$O deb.$O doio.$O doop.$O dump.$O globals.$O gv.$O hv.$O locale.$O malloc.$O mathoms.$O mg.$O numeric.$O op.$O pad.$O perlapi.$O perlio.$O perly.$O pp.$O pp_ctl.$O pp_hot.$O pp_i.$O pp_pack. ... [123 chars truncated] OBJS = perl.$O plan9.$O $obj diff --git a/pp.c b/pp.c index ba3ac1f..4d539ad 100644 --- a/pp.c +++ b/pp.c @@ -1124,7 +1124,8 @@ PP(pp_pow) baseuv = iv; baseuok = TRUE; /* effectively it's a UV now */ } else { - baseuv = -iv; /* abs, baseuok == false records sign */ + /* abs, baseuok == false records sign */ + baseuv = NEGATE_IV_AS_UV(iv); } } /* now we have integer ** positive integer. */ @@ -1182,15 +1183,12 @@ PP(pp_pow) } } SP--; - if (baseuok || !odd_power) + if (baseuok || !odd_power || !result) /* answer is positive */ SETu( result ); - else if (result <= (UV)IV_MAX) + else if (result <= MINUS_IV_MIN) /* answer negative, fits in IV */ - SETi( -(IV)result ); - else if (result == (UV)IV_MIN) - /* 2's complement assumption: special case IV_MIN */ - SETi( IV_MIN ); + SETi( NEGATE_UV_AS_IV(result) ); else /* answer negative, doesn't fit */ SETn( -(NV)result ); @@ -1287,7 +1285,8 @@ PP(pp_multiply) alow = aiv; auvok = TRUE; /* effectively it's a UV now */ } else { - alow = -aiv; /* abs, auvok == false records sign */ + /* abs, auvok == false records sign */ + alow = NEGATE_IV_AS_UV(aiv); } } if (buvok) { @@ -1298,7 +1297,8 @@ PP(pp_multiply) blow = biv; buvok = TRUE; /* effectively it's a UV now */ } else { - blow = -biv; /* abs, buvok == false records sign */ + /* abs, buvok == false records sign */ + blow = NEGATE_IV_AS_UV(biv); } } @@ -1315,16 +1315,14 @@ PP(pp_multiply) /* eg 32 bit is at most 0xFFFF * 0xFFFF == 0xFFFE0001 so the unsigned multiply cannot overflow. */ const UV product = alow * blow; - if (auvok == buvok) { + if (auvok == buvok || !product) { /* -ve * -ve or +ve * +ve gives a +ve result. */ SP--; SETu( product ); RETURN; - } else if (product <= (UV)IV_MIN) { - /* 2s complement assumption that (UV)-IV_MIN is correct. */ - /* -ve result, which could overflow an IV */ + } else if (product <= MINUS_IV_MIN) { SP--; - SETi( -(IV)product ); + SETi( NEGATE_UV_AS_IV(product) ); RETURN; } /* else drop to NVs below. */ } else { @@ -1352,16 +1350,14 @@ PP(pp_multiply) product_low += product_middle; if (product_low >= product_middle) { /* didn't overflow */ - if (auvok == buvok) { + if (auvok == buvok || !product_low) { /* -ve * -ve or +ve * +ve gives a +ve result. */ SP--; SETu( product_low ); RETURN; - } else if (product_low <= (UV)IV_MIN) { - /* 2s complement assumption again */ - /* -ve result, which could overflow an IV */ + } else if (product_low <= MINUS_IV_MIN) { SP--; - SETi( -(IV)product_low ); + SETi( NEGATE_UV_AS_IV(product_low) ); RETURN; } /* else drop to NVs below. */ } @@ -1426,7 +1422,7 @@ PP(pp_divide) right_non_neg = TRUE; /* effectively it's a UV now */ } else { - right = -biv; + right = NEGATE_IV_AS_UV(biv); } } /* historically undef()/0 gives a "Use of uninitialized value" @@ -1447,7 +1443,7 @@ PP(pp_divide) left_non_neg = TRUE; /* effectively it's a UV now */ } else { - left = -aiv; + left = NEGATE_IV_AS_UV(aiv);; } } @@ -1529,7 +1525,7 @@ PP(pp_modulo) right = biv; right_neg = FALSE; /* effectively it's a UV now */ } else { - right = -biv; + right = NEGATE_IV_AS_UV(biv); } } } @@ -1561,7 +1557,7 @@ PP(pp_modulo) left = aiv; left_neg = FALSE; /* effectively it's a UV now */ } else { - left = -aiv; + left = NEGATE_IV_AS_UV(aiv);; } } } @@ -1803,8 +1799,8 @@ PP(pp_subtract) if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ - } else { /* 2s complement assumption for IV_MIN */ - auv = (UV)-aiv; + } else { + auv = NEGATE_IV_AS_UV(aiv); } } a_valid = 1; @@ -1860,12 +1856,12 @@ PP(pp_subtract) } if (result_good) { SP--; - if (auvok) + if (auvok || !result) SETu( result ); else { /* Negate result */ - if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + if (result <= MINUS_IV_MIN) + SETi( NEGATE_UV_AS_IV(result) ); else { /* result valid, but out of range for IV. */ SETn( -(NV)result ); @@ -2426,250 +2422,6 @@ PP(pp_complement) } } -/* integer versions of some of the above */ - -PP(pp_i_multiply) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(mult_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - SETi( left * right ); - RETURN; - } -} - -PP(pp_i_divide) -{ - IV num; - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(div_amg, AMGf_assign); - { - dPOPTOPssrl; - IV value = SvIV_nomg(right); - if (value == 0) - DIE(aTHX_ "Illegal division by zero"); - num = SvIV_nomg(left); - - /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ - if (value == -1) - value = - num; - else - value = num / value; - SETi(value); - RETURN; - } -} - -#if defined(__GLIBC__) && IVSIZE == 8 -STATIC -PP(pp_i_modulo_0) -#else -PP(pp_i_modulo) -#endif -{ - /* This is the vanilla old i_modulo. */ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(modulo_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % right ); - RETURN; - } -} - -#if defined(__GLIBC__) && IVSIZE == 8 -STATIC -PP(pp_i_modulo_1) - -{ - /* This is the i_modulo with the workaround for the _moddi3 bug - * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). - * See below for pp_i_modulo. */ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(modulo_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % PERL_ABS(right) ); - RETURN; - } -} - -PP(pp_i_modulo) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(modulo_amg, AMGf_assign); - { - dPOPTOPiirl_nomg; - if (!right) - DIE(aTHX_ "Illegal modulus zero"); - /* The assumption is to use hereafter the old vanilla version... */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - Perl_pp_i_modulo_0; - /* .. but if we have glibc, we might have a buggy _moddi3 - * (at least glicb 2.2.5 is known to have this bug), in other - * words our integer modulus with negative quad as the second - * argument might be broken. Test for this and re-patch the - * opcode dispatch table if that is the case, remembering to - * also apply the workaround so that this first round works - * right, too. See [perl #9402] for more information. */ - { - IV l = 3; - IV r = -10; - /* Cannot do this check with inlined IV constants since - * that seems to work correctly even with the buggy glibc. */ - if (l % r == -3) { - /* Yikes, we have the bug. - * Patch in the workaround version. */ - PL_op->op_ppaddr = - PL_ppaddr[OP_I_MODULO] = - &Perl_pp_i_modulo_1; - /* Make certain we work right this time, too. */ - right = PERL_ABS(right); - } - } - /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ - if (right == -1) - SETi( 0 ); - else - SETi( left % right ); - RETURN; - } -} -#endif - -PP(pp_i_add) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(add_amg, AMGf_assign); - { - dPOPTOPiirl_ul_nomg; - SETi( left + right ); - RETURN; - } -} - -PP(pp_i_subtract) -{ - dVAR; dSP; dATARGET; - tryAMAGICbin_MG(subtr_amg, AMGf_assign); - { - dPOPTOPiirl_ul_nomg; - SETi( left - right ); - RETURN; - } -} - -PP(pp_i_lt) -{ - dVAR; dSP; - tryAMAGICbin_MG(lt_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left < right)); - RETURN; - } -} - -PP(pp_i_gt) -{ - dVAR; dSP; - tryAMAGICbin_MG(gt_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left > right)); - RETURN; - } -} - -PP(pp_i_le) -{ - dVAR; dSP; - tryAMAGICbin_MG(le_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left <= right)); - RETURN; - } -} - -PP(pp_i_ge) -{ - dVAR; dSP; - tryAMAGICbin_MG(ge_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left >= right)); - RETURN; - } -} - -PP(pp_i_eq) -{ - dVAR; dSP; - tryAMAGICbin_MG(eq_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left == right)); - RETURN; - } -} - -PP(pp_i_ne) -{ - dVAR; dSP; - tryAMAGICbin_MG(ne_amg, AMGf_set); - { - dPOPTOPiirl_nomg; - SETs(boolSV(left != right)); - RETURN; - } -} - -PP(pp_i_ncmp) -{ - dVAR; dSP; dTARGET; - tryAMAGICbin_MG(ncmp_amg, 0); - { - dPOPTOPiirl_nomg; - I32 value; - - if (left > right) - value = 1; - else if (left < right) - value = -1; - else - value = 0; - SETi(value); - RETURN; - } -} - -PP(pp_i_negate) -{ - dVAR; dSP; dTARGET; - tryAMAGICun_MG(neg_amg, 0); - { - SV * const sv = TOPs; - IV const i = SvIV_nomg(sv); - SETi(-i); - RETURN; - } -} - /* High falutin' math. */ PP(pp_atan2) diff --git a/pp_ctl.c b/pp_ctl.c index 8f4c103..78ec3b4 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1305,7 +1305,7 @@ PP(pp_flop) SvGETMAGIC(right); if (RANGE_IS_NUMERIC(left,right)) { - register IV i, j; + register IV i; IV max; if ((SvOK(left) && SvNV_nomg(left) < IV_MIN) || (SvOK(right) && SvNV_nomg(right) > IV_MAX)) @@ -1313,15 +1313,22 @@ PP(pp_flop) i = SvIV_nomg(left); max = SvIV_nomg(right); if (max >= i) { - j = max - i + 1; - EXTEND_MORTAL(j); - EXTEND(SP, j); - } - else - j = 0; - while (j--) { - SV * const sv = sv_2mortal(newSViv(i++)); - PUSHs(sv); + IV j = max - i + 1; + if (j) { + EXTEND_MORTAL(j); + EXTEND(SP, j); + + /* Be cafeful not to even *think* about doing i = i + 1; + if we're about to break out of the loop, as i++; is + undefined behaviour when i == IV_MAX, even if i++ is + never looked at. */ + while (1) { + PUSHs(sv_2mortal(newSViv(i))); + if (!--j) + break; + ++i; + } + } } } else { diff --git a/pp_hot.c b/pp_hot.c index 89165d9..637dd2c 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -532,8 +532,8 @@ PP(pp_add) if (aiv >= 0) { auv = aiv; auvok = 1; /* Now acting as a sign flag. */ - } else { /* 2s complement assumption for IV_MIN */ - auv = (UV)-aiv; + } else { + auv = NEGATE_IV_AS_UV(aiv); } } a_valid = 1; @@ -589,12 +589,12 @@ PP(pp_add) } if (result_good) { SP--; - if (auvok) + if (auvok || !result) SETu( result ); else { /* Negate result */ - if (result <= (UV)IV_MIN) - SETi( -(IV)result ); + if (result <= MINUS_IV_MIN) + SETi( NEGATE_UV_AS_IV(result) ); else { /* result valid, but out of range for IV. */ SETn( -(NV)result ); @@ -1891,7 +1891,7 @@ PP(pp_iter) /* don't risk potential race */ if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) { /* safe to reuse old SV */ - sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++); + sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur); } else { @@ -1899,17 +1899,15 @@ PP(pp_iter) * completely new SV for closures/references to work as they * used to */ oldsv = *itersvp; - *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++); + *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur); SvREFCNT_dec(oldsv); } - /* Handle end of range at IV_MAX */ - if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) && - (cx->blk_loop.state_u.lazyiv.end == IV_MAX)) - { - cx->blk_loop.state_u.lazyiv.cur++; - cx->blk_loop.state_u.lazyiv.end++; - } + if (cx->blk_loop.state_u.lazyiv.cur == IV_MAX) { + /* Handle end of range at IV_MAX */ + cx->blk_loop.state_u.lazyiv.end = IV_MIN; + } else + ++cx->blk_loop.state_u.lazyiv.cur; RETPUSHYES; } diff --git a/pp_i.c b/pp_i.c new file mode 100644 index 0000000..b826da2 --- /dev/null +++ b/pp_i.c @@ -0,0 +1,268 @@ +/* pp_i.c + * + * Copyright (C) XXX by Larry Wall and others + * + * You may distribute under the terms of either the GNU General Public + * License or the Artistic License, as specified in the README file. + * + */ + +#include "EXTERN.h" +#define PERL_IN_PP_I_C +#include "perl.h" + +/* integer versions of some of the maths ops. In a separate file, so that we + can control the compiler options used for just these ops. */ + +PP(pp_i_multiply) +{ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(mult_amg, AMGf_assign); + { + dPOPTOPiirl_nomg; + SETi( left * right ); + RETURN; + } +} + +PP(pp_i_divide) +{ + IV num; + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(div_amg, AMGf_assign); + { + dPOPTOPssrl; + IV value = SvIV_nomg(right); + if (value == 0) + DIE(aTHX_ "Illegal division by zero"); + num = SvIV_nomg(left); + + /* avoid FPE_INTOVF on some platforms when num is IV_MIN */ + if (value == -1) + value = - num; + else + value = num / value; + SETi(value); + RETURN; + } +} + +#if defined(__GLIBC__) && IVSIZE == 8 +STATIC +PP(pp_i_modulo_0) +#else +PP(pp_i_modulo) +#endif +{ + /* This is the vanilla old i_modulo. */ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(modulo_amg, AMGf_assign); + { + dPOPTOPiirl_nomg; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % right ); + RETURN; + } +} + +#if defined(__GLIBC__) && IVSIZE == 8 +STATIC +PP(pp_i_modulo_1) + +{ + /* This is the i_modulo with the workaround for the _moddi3 bug + * in (at least) glibc 2.2.5 (the PERL_ABS() the workaround). + * See below for pp_i_modulo. */ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(modulo_amg, AMGf_assign); + { + dPOPTOPiirl_nomg; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % PERL_ABS(right) ); + RETURN; + } +} + +PP(pp_i_modulo) +{ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(modulo_amg, AMGf_assign); + { + dPOPTOPiirl_nomg; + if (!right) + DIE(aTHX_ "Illegal modulus zero"); + /* The assumption is to use hereafter the old vanilla version... */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + Perl_pp_i_modulo_0; + /* .. but if we have glibc, we might have a buggy _moddi3 + * (at least glicb 2.2.5 is known to have this bug), in other + * words our integer modulus with negative quad as the second + * argument might be broken. Test for this and re-patch the + * opcode dispatch table if that is the case, remembering to + * also apply the workaround so that this first round works + * right, too. See [perl #9402] for more information. */ + { + IV l = 3; + IV r = -10; + /* Cannot do this check with inlined IV constants since + * that seems to work correctly even with the buggy glibc. */ + if (l % r == -3) { + /* Yikes, we have the bug. + * Patch in the workaround version. */ + PL_op->op_ppaddr = + PL_ppaddr[OP_I_MODULO] = + &Perl_pp_i_modulo_1; + /* Make certain we work right this time, too. */ + right = PERL_ABS(right); + } + } + /* avoid FPE_INTOVF on some platforms when left is IV_MIN */ + if (right == -1) + SETi( 0 ); + else + SETi( left % right ); + RETURN; + } +} +#endif + +PP(pp_i_add) +{ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(add_amg, AMGf_assign); + { + dPOPTOPiirl_ul_nomg; + SETi( left + right ); + RETURN; + } +} + +PP(pp_i_subtract) +{ + dVAR; dSP; dATARGET; + tryAMAGICbin_MG(subtr_amg, AMGf_assign); + { + dPOPTOPiirl_ul_nomg; + SETi( left - right ); + RETURN; + } +} + +PP(pp_i_lt) +{ + dVAR; dSP; + tryAMAGICbin_MG(lt_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left < right)); + RETURN; + } +} + +PP(pp_i_gt) +{ + dVAR; dSP; + tryAMAGICbin_MG(gt_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left > right)); + RETURN; + } +} + +PP(pp_i_le) +{ + dVAR; dSP; + tryAMAGICbin_MG(le_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left <= right)); + RETURN; + } +} + +PP(pp_i_ge) +{ + dVAR; dSP; + tryAMAGICbin_MG(ge_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left >= right)); + RETURN; + } +} + +PP(pp_i_eq) +{ + dVAR; dSP; + tryAMAGICbin_MG(eq_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left == right)); + RETURN; + } +} + +PP(pp_i_ne) +{ + dVAR; dSP; + tryAMAGICbin_MG(ne_amg, AMGf_set); + { + dPOPTOPiirl_nomg; + SETs(boolSV(left != right)); + RETURN; + } +} + +PP(pp_i_ncmp) +{ + dVAR; dSP; dTARGET; + tryAMAGICbin_MG(ncmp_amg, 0); + { + dPOPTOPiirl_nomg; + I32 value; + + if (left > right) + value = 1; + else if (left < right) + value = -1; + else + value = 0; + SETi(value); + RETURN; + } +} + +PP(pp_i_negate) +{ + dVAR; dSP; dTARGET; + tryAMAGICun_MG(neg_amg, 0); + { + SV * const sv = TOPs; + IV const i = SvIV_nomg(sv); + SETi(-i); + RETURN; + } +} + + +/* + * Local variables: + * c-indentation-style: bsd + * c-basic-offset: 4 + * indent-tabs-mode: t + * End: + * + * ex: set ts=8 sts=4 sw=4 noet: + */ diff --git a/sv.c b/sv.c index 3ac2fd8..d5f18f9 100644 --- a/sv.c +++ b/sv.c @@ -2006,7 +2006,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && (((UV)1 << NV_PRESERVES_UV_BITS) > - (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + (SvIVX(sv) > 0 ? (UV)SvIVX(sv) : NEGATE_IV_AS_UV(SvIVX(sv)))) /* Don't flag it as "accurately an integer" if the number came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ @@ -2103,7 +2103,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) /* This won't turn off the public IOK flag if it was set above */ (void)SvIOKp_on(sv); - if (!(numtype & IS_NUMBER_NEG)) { + if (!(numtype & IS_NUMBER_NEG) || !value) { /* positive */; if (value <= (UV)IV_MAX) { SvIV_set(sv, (IV)value); @@ -2113,9 +2113,8 @@ S_sv_2iuv_common(pTHX_ SV *const sv) SvIsUV_on(sv); } } else { - /* 2s complement assumption */ - if (value <= (UV)IV_MIN) { - SvIV_set(sv, -(IV)value); + if (value <= MINUS_IV_MIN) { + SvIV_set(sv, NEGATE_UV_AS_IV(value)); } else { /* Too negative for an IV. This is a double upgrade, but I'm assuming it will be rare. */ @@ -2551,15 +2550,14 @@ Perl_sv_2nv_flags(pTHX_ register SV *const sv, const I32 flags) SvNOK_on(sv); } else { /* value has been set. It may not be precise. */ - if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) { - /* 2s complement assumption for (UV)IV_MIN */ + if ((numtype & IS_NUMBER_NEG) && (value > MINUS_IV_MIN)) { SvNOK_on(sv); /* Integer is too negative. */ } else { SvNOKp_on(sv); SvIOKp_on(sv); if (numtype & IS_NUMBER_NEG) { - SvIV_set(sv, -(IV)value); + SvIV_set(sv, NEGATE_UV_AS_IV(value)); } else if (value <= (UV)IV_MAX) { SvIV_set(sv, (IV)value); } else { @@ -2688,7 +2686,7 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe uv = iv; sign = 0; } else { - uv = -iv; + uv = NEGATE_IV_AS_UV(iv); sign = 1; } do { @@ -10668,7 +10666,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, esignbuf[esignlen++] = plus; } else { - uv = -iv; + uv = NEGATE_IV_AS_UV(iv); esignbuf[esignlen++] = '-'; } } diff --git a/t/op/64bitint.t b/t/op/64bitint.t index 168d597..eb3b6bc 100644 --- a/t/op/64bitint.t +++ b/t/op/64bitint.t @@ -332,6 +332,28 @@ cmp_ok($q, '==', 1); $q = 0x8000000000000000 % -9223372036854775807; cmp_ok($q, '==', -9223372036854775806); +# These 8 trigger assignments of -(-9223372036854775808) to a UV: +$q = -9223372036854775808 * -1; +cmp_ok($q, '==', 0x8000000000000000); +$q = -1 * -9223372036854775808; +cmp_ok($q, '==', 0x8000000000000000); + +$q = -9223372036854775808 / -1; +cmp_ok($q, '==', 0x8000000000000000); +$q = -9223372036854775808 / -9223372036854775808; +cmp_ok($q, '==', 1); + +$q = -9223372036854775808 % -1; +cmp_ok($q, '==', 0); +$q = -9223372036854775808 % -9223372036854775808; +cmp_ok($q, '==', 0); + +# (although these are actually testing the same assignment): +$q = (-9223372036854775808) ** 0; +cmp_ok($q, '==', 1); +$q = (-9223372036854775808) ** 1; +cmp_ok($q, '==', -9223372036854775808); + { use integer; $q = hex "0x123456789abcdef0"; diff --git a/vms/descrip_mms.template b/vms/descrip_mms.template index 7f0427b..22a9528 100644 --- a/vms/descrip_mms.template +++ b/vms/descrip_mms.template @@ -236,14 +236,14 @@ FULLLIBS2 = $(LIBS2)|$(THRLIBS1)|$(THRLIBS2) c0 = $(MALLOC_C) av.c deb.c doio.c doop.c dump.c globals.c gv.c hv.c mro.c c1 = mg.c locale.c mathoms.c miniperlmain.c numeric.c op.c pad.c perl.c perlapi.c perlio.c -c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c +c2 = perly.c pp.c pp_ctl.c pp_hot.c pp_i.c pp_pack.c pp_sort.c pp_sys.c regcomp.c regexec.c reentr.c c3 = run.c scope.c sv.c taint.c toke.c universal.c utf8.c util.c vms.c keywords.c c = $(c0) $(c1) $(c2) $(c3) obj0 = perl$(O) obj1 = $(MALLOC_O) av$(O) deb$(O) doio$(O) doop$(O) dump$(O) mro$(O) globals$(O) gv$(O) hv$(O) obj2 = keywords$(O) locale$(O) mathoms$(O) mg$(O) miniperlmain$(O) numeric$(O) op$(O) pad$(O) perlapi$(O) perlio$(O) -obj3 = perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) reentr$(O) pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) +obj3 = perly$(O) pp$(O) pp_ctl$(O) pp_hot$(O) pp_i$(O) reentr$(O) pp_pack$(O) pp_sort$(O) pp_sys$(O) regcomp$(O) obj4 = regexec$(O) run$(O) scope$(O) sv$(O) taint$(O) toke$(O) universal$(O) utf8$(O) util$(O) vms$(O) mini_obj = perlmini$(O) $(obj1) $(obj2) $(obj3) $(obj4) @@ -909,6 +909,8 @@ pp_ctl$(O) : pp_ctl.c $(h) $(CC) $(CORECFLAGS) $(MMS$SOURCE) pp_hot$(O) : pp_hot.c $(h) $(CC) $(CORECFLAGS) $(MMS$SOURCE) +pp_i$(O) : pp_i.c $(h) + $(CC) $(CORECFLAGS) $(MMS$SOURCE) pp_pack$(O) : pp_pack.c $(h) $(CC) $(CORECFLAGS) $(MMS$SOURCE) pp_sort$(O) : pp_sort.c $(h) diff --git a/win32/Makefile b/win32/Makefile index d568542..814abe2 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -641,6 +641,7 @@ MICROCORE_SRC = \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ + ..\pp_i.c \ ..\pp_pack.c \ ..\pp_sort.c \ ..\pp_sys.c \ diff --git a/win32/Makefile.ce b/win32/Makefile.ce index ba58a33..13f9700 100644 --- a/win32/Makefile.ce +++ b/win32/Makefile.ce @@ -582,6 +582,7 @@ MICROCORE_SRC = \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ + ..\pp_i.c \ ..\pp_pack.c \ ..\pp_sort.c \ ..\pp_sys.c \ @@ -800,6 +801,7 @@ $(DLLDIR)\perly.obj \ $(DLLDIR)\pp.obj \ $(DLLDIR)\pp_ctl.obj \ $(DLLDIR)\pp_hot.obj \ +$(DLLDIR)\pp_i.obj \ $(DLLDIR)\pp_pack.obj \ $(DLLDIR)\pp_sort.obj \ $(DLLDIR)\pp_sys.obj \ diff --git a/win32/makefile.mk b/win32/makefile.mk index b3aca56..cb6d31e 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -753,6 +753,7 @@ MICROCORE_SRC = \ ..\pp.c \ ..\pp_ctl.c \ ..\pp_hot.c \ + ..\pp_i.c \ ..\pp_pack.c \ ..\pp_sort.c \ ..\pp_sys.c \ -- Perl5 Master Repository
