In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/33efebe6a5ab2b2152593885ee155259a5bfd3f1?hp=1530afd8d16650b8c823c463ac078ead72dce7fd>
- Log ----------------------------------------------------------------- commit 33efebe6a5ab2b2152593885ee155259a5bfd3f1 Author: David Mitchell <[email protected]> Date: Wed Jun 22 10:59:18 2011 +0100 add do_ncmp fn and make pp_ncmp, pp_eq etc use it Extract most of the body of pp_ncmp() (numeric compare) into a separate function, do_ncmp(), then make the following ops use it: pp_ncmp pp_lt pp_le pp_eq pp_ne pp_ge pp_gt This removes a lot of similar or duplicated code, most of which is dedicated to handling the various combinations of IV verses UV verses NV verses NaN. The various ops first check for, and directly process, the simple and common case of both args being SvIOK_notUV(), and pass the processing on to do_ncmp() otherwise. Benchmarking seems to indicate (but with a lot of noise) that the SvIOK_notUV case is slightly faster than before, and the do_ncmp() branch slightly slower. M embed.fnc M embed.h M pp.c M pp_hot.c M proto.h commit 06c6da524f9e0eae167367edc8fe0150d69893fa Author: David Mitchell <[email protected]> Date: Tue Jun 21 17:32:20 2011 +0100 pp_ncmp: favour the non- Perl_isnan route Currently pp_ncmp(), when comparing two NVs, prefers to check its two args for NaNness first, and if either of them are, then return undef. Only if Perl_isnan isn't defined does it fall back to doing three compares (<, >, =) where if all three fail it returns undef. This is in contrast to the other compare functions (e.g. pp_lt), which only use Perl_isnan if NAN_COMPARE_BROKEN is defined - i.e. they prefer to rely on the '<' (or whatever) test to handle NaNs implicitly. Change pp_ncmp to favour not using Perl_isnan(). This has two advantages: First, speed: in the normal case we replace: two function calls to Perl_isnan plus two comparisons, with: three comparisons. Second, this makes pp_ncmp more similar to the other comparison functions, allowing for code reuse in the future. M pp.c commit 69cb655bad9945c212e3b4016966ad8d90dfae8a Author: David Mitchell <[email protected]> Date: Tue Jun 21 14:40:12 2011 +0100 remove unreachable code from various compare ops All the compare ops (such as pp_le), have an initial: tryAMAGICbin_MG(le_amg, AMGf_numeric); The effect of the AMGf_numeric flag is that, if the le overloading fails, but either of the args on the stack is a reference, then that arg is replaced with a temporary non-ref arg that is either the result of '0+' overloading, or is a UV with the numerical value of the ref's address. So by the time the main body of the op is called, neither arg can be a ref. Thus a whole bunch of nearly identical blocks can be removed, which *used* to handle comparing refs: if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { SP--; SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); RETURN; } M pp.c M pp_hot.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 + embed.h | 1 + pp.c | 598 +++++++++++++------------------------------------------------ pp_hot.c | 78 +------- proto.h | 7 + 5 files changed, 149 insertions(+), 537 deletions(-) diff --git a/embed.fnc b/embed.fnc index d9a888a..41d9cc2 100644 --- a/embed.fnc +++ b/embed.fnc @@ -346,6 +346,8 @@ p |I32 |do_shmio |I32 optype|NN SV** mark|NN SV** sp Ap |void |do_join |NN SV *sv|NN SV *delim|NN SV **mark|NN SV **sp : Used in pp.c and pp_hot.c, prototype generated by regen/opcode.pl : p |OP* |do_kv +: used in pp.c, pp_hot.c +pR |I32 |do_ncmp |NN SV *const left|NN SV *const right Apmb |bool |do_open |NN GV* gv|NN const char* name|I32 len|int as_raw \ |int rawmode|int rawperm|NULLOK PerlIO* supplied_fp Ap |bool |do_open9 |NN GV *gv|NN const char *name|I32 len|int as_raw \ diff --git a/embed.h b/embed.h index e2428c9..6dcaa39 100644 --- a/embed.h +++ b/embed.h @@ -998,6 +998,7 @@ #define do_dump_pad(a,b,c,d) Perl_do_dump_pad(aTHX_ a,b,c,d) #define do_eof(a) Perl_do_eof(aTHX_ a) #define do_execfree() Perl_do_execfree(aTHX) +#define do_ncmp(a,b) Perl_do_ncmp(aTHX_ a,b) #define do_print(a,b) Perl_do_print(aTHX_ a,b) #define do_readline() Perl_do_readline(aTHX) #define do_seek(a,b,c) Perl_do_seek(aTHX_ a,b,c) diff --git a/pp.c b/pp.c index f815d0a..24a34a0 100644 --- a/pp.c +++ b/pp.c @@ -2003,518 +2003,178 @@ PP(pp_right_shift) PP(pp_lt) { dVAR; dSP; + SV *left, *right; + tryAMAGICbin_MG(lt_amg, AMGf_set|AMGf_numeric); -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); - - if (!auvok && !buvok) { /* ## IV < IV ## */ - const IV aiv = SvIVX(TOPm1s); - const IV biv = SvIVX(TOPs); - - SP--; - SETs(boolSV(aiv < biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV < UV ## */ - const UV auv = SvUVX(TOPm1s); - const UV buv = SvUVX(TOPs); - - SP--; - SETs(boolSV(auv < buv)); - RETURN; - } - if (auvok) { /* ## UV < IV ## */ - UV auv; - const IV biv = SvIVX(TOPs); - SP--; - if (biv < 0) { - /* As (a) is a UV, it's >=0, so it cannot be < */ - SETs(&PL_sv_no); - RETURN; - } - auv = SvUVX(TOPs); - SETs(boolSV(auv < (UV)biv)); - RETURN; - } - { /* ## IV < UV ## */ - const IV aiv = SvIVX(TOPm1s); - UV buv; - - if (aiv < 0) { - /* As (b) is a UV, it's >=0, so it must be < */ - SP--; - SETs(&PL_sv_yes); - RETURN; - } - buv = SvUVX(TOPs); - SP--; - SETs(boolSV((UV)aiv < buv)); - RETURN; - } - } - } -#endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) < SvRV(TOPp1s))); - RETURN; - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left < right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) < value)); -#endif - RETURN; - } + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) < SvIVX(right)) + : (do_ncmp(left, right) == -1) + )); + RETURN; } PP(pp_gt) { dVAR; dSP; - tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); - - if (!auvok && !buvok) { /* ## IV > IV ## */ - const IV aiv = SvIVX(TOPm1s); - const IV biv = SvIVX(TOPs); - - SP--; - SETs(boolSV(aiv > biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV > UV ## */ - const UV auv = SvUVX(TOPm1s); - const UV buv = SvUVX(TOPs); - - SP--; - SETs(boolSV(auv > buv)); - RETURN; - } - if (auvok) { /* ## UV > IV ## */ - UV auv; - const IV biv = SvIVX(TOPs); + SV *left, *right; - SP--; - if (biv < 0) { - /* As (a) is a UV, it's >=0, so it must be > */ - SETs(&PL_sv_yes); - RETURN; - } - auv = SvUVX(TOPs); - SETs(boolSV(auv > (UV)biv)); - RETURN; - } - { /* ## IV > UV ## */ - const IV aiv = SvIVX(TOPm1s); - UV buv; - - if (aiv < 0) { - /* As (b) is a UV, it's >=0, so it cannot be > */ - SP--; - SETs(&PL_sv_no); - RETURN; - } - buv = SvUVX(TOPs); - SP--; - SETs(boolSV((UV)aiv > buv)); - RETURN; - } - } - } -#endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) > SvRV(TOPp1s))); - RETURN; - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left > right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) > value)); -#endif - RETURN; - } + tryAMAGICbin_MG(gt_amg, AMGf_set|AMGf_numeric); + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) > SvIVX(right)) + : (do_ncmp(left, right) == 1) + )); + RETURN; } PP(pp_le) { dVAR; dSP; - tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); - - if (!auvok && !buvok) { /* ## IV <= IV ## */ - const IV aiv = SvIVX(TOPm1s); - const IV biv = SvIVX(TOPs); - - SP--; - SETs(boolSV(aiv <= biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV <= UV ## */ - UV auv = SvUVX(TOPm1s); - UV buv = SvUVX(TOPs); - - SP--; - SETs(boolSV(auv <= buv)); - RETURN; - } - if (auvok) { /* ## UV <= IV ## */ - UV auv; - const IV biv = SvIVX(TOPs); + SV *left, *right; - SP--; - if (biv < 0) { - /* As (a) is a UV, it's >=0, so a cannot be <= */ - SETs(&PL_sv_no); - RETURN; - } - auv = SvUVX(TOPs); - SETs(boolSV(auv <= (UV)biv)); - RETURN; - } - { /* ## IV <= UV ## */ - const IV aiv = SvIVX(TOPm1s); - UV buv; - - if (aiv < 0) { - /* As (b) is a UV, it's >=0, so a must be <= */ - SP--; - SETs(&PL_sv_yes); - RETURN; - } - buv = SvUVX(TOPs); - SP--; - SETs(boolSV((UV)aiv <= buv)); - RETURN; - } - } - } -#endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) <= SvRV(TOPp1s))); - RETURN; - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left <= right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) <= value)); -#endif - RETURN; - } + tryAMAGICbin_MG(le_amg, AMGf_set|AMGf_numeric); + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) <= SvIVX(right)) + : (do_ncmp(left, right) <= 0) + )); + RETURN; } PP(pp_ge) { dVAR; dSP; - tryAMAGICbin_MG(ge_amg,AMGf_set|AMGf_numeric); -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - bool auvok = SvUOK(TOPm1s); - bool buvok = SvUOK(TOPs); - - if (!auvok && !buvok) { /* ## IV >= IV ## */ - const IV aiv = SvIVX(TOPm1s); - const IV biv = SvIVX(TOPs); + SV *left, *right; + + tryAMAGICbin_MG(ge_amg, AMGf_set|AMGf_numeric); + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) >= SvIVX(right)) + : ( (do_ncmp(left, right) & 2) == 0) + )); + RETURN; +} - SP--; - SETs(boolSV(aiv >= biv)); - RETURN; - } - if (auvok && buvok) { /* ## UV >= UV ## */ - const UV auv = SvUVX(TOPm1s); - const UV buv = SvUVX(TOPs); +PP(pp_ne) +{ + dVAR; dSP; + SV *left, *right; + + tryAMAGICbin_MG(ne_amg, AMGf_set|AMGf_numeric); + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) != SvIVX(right)) + : (do_ncmp(left, right) != 0) + )); + RETURN; +} - SP--; - SETs(boolSV(auv >= buv)); - RETURN; - } - if (auvok) { /* ## UV >= IV ## */ - UV auv; - const IV biv = SvIVX(TOPs); +/* compare left and right SVs. Returns: + * -1: < + * 0: == + * 1: > + * 2: left or right was a NaN + */ +I32 +Perl_do_ncmp(pTHX_ SV* const left, SV * const right) +{ + dVAR; - SP--; - if (biv < 0) { - /* As (a) is a UV, it's >=0, so it must be >= */ - SETs(&PL_sv_yes); - RETURN; + PERL_ARGS_ASSERT_DO_NCMP; +#ifdef PERL_PRESERVE_IVUV + SvIV_please_nomg(right); + /* Fortunately it seems NaN isn't IOK */ + if (SvIOK(right)) { + SvIV_please_nomg(left); + if (SvIOK(left)) { + if (!SvUOK(left)) { + const IV leftiv = SvIVX(left); + if (!SvUOK(right)) { + /* ## IV <=> IV ## */ + const IV rightiv = SvIVX(right); + return (leftiv > rightiv) - (leftiv < rightiv); } - auv = SvUVX(TOPs); - SETs(boolSV(auv >= (UV)biv)); - RETURN; - } - { /* ## IV >= UV ## */ - const IV aiv = SvIVX(TOPm1s); - UV buv; - - if (aiv < 0) { - /* As (b) is a UV, it's >=0, so a cannot be >= */ - SP--; - SETs(&PL_sv_no); - RETURN; + /* ## IV <=> UV ## */ + if (leftiv < 0) + /* As (b) is a UV, it's >=0, so it must be < */ + return -1; + { + const UV rightuv = SvUVX(right); + return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv); } - buv = SvUVX(TOPs); - SP--; - SETs(boolSV((UV)aiv >= buv)); - RETURN; } - } - } -#endif -#ifndef NV_PRESERVES_UV -#ifdef PERL_PRESERVE_IVUV - else -#endif - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) >= SvRV(TOPp1s))); - RETURN; - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left >= right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) >= value)); -#endif - RETURN; - } -} -PP(pp_ne) -{ - dVAR; dSP; - tryAMAGICbin_MG(ne_amg,AMGf_set|AMGf_numeric); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) != SvRV(TOPp1s))); - RETURN; - } -#endif -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - const bool auvok = SvUOK(TOPm1s); - const bool buvok = SvUOK(TOPs); - - if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ - /* Casting IV to UV before comparison isn't going to matter - on 2s complement. On 1s complement or sign&magnitude - (if we have any of them) it could make negative zero - differ from normal zero. As I understand it. (Need to - check - is negative zero implementation defined behaviour - anyway?). NWC */ - const UV buv = SvUVX(POPs); - const UV auv = SvUVX(TOPs); - - SETs(boolSV(auv != buv)); - RETURN; + if (SvUOK(right)) { + /* ## UV <=> UV ## */ + const UV leftuv = SvUVX(left); + const UV rightuv = SvUVX(right); + return (leftuv > rightuv) - (leftuv < rightuv); } - { /* ## Mixed IV,UV ## */ - IV iv; - UV uv; - - /* != is commutative so swap if needed (save code) */ - if (auvok) { - /* swap. top of stack (b) is the iv */ - iv = SvIVX(TOPs); - SP--; - if (iv < 0) { - /* As (a) is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_yes); - RETURN; - } - uv = SvUVX(TOPs); - } else { - iv = SvIVX(TOPm1s); - SP--; - if (iv < 0) { - /* As (b) is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_yes); - RETURN; - } - uv = SvUVX(*(SP+1)); /* Do I want TOPp1s() ? */ + /* ## UV <=> IV ## */ + { + const IV rightiv = SvIVX(right); + if (rightiv < 0) + /* As (a) is a UV, it's >=0, so it cannot be < */ + return 1; + { + const UV leftuv = SvUVX(left); + return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv); } - SETs(boolSV((UV)iv != uv)); - RETURN; } + /* NOTREACHED */ } } #endif { + NV const rnv = SvNV_nomg(right); + NV const lnv = SvNV_nomg(left); + #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETYES; - SETs(boolSV(left != right)); + if (Perl_isnan(lnv) || Perl_isnan(rnv)) { + return 2; + } + return (lnv > rnv) - (lnv < rnv); #else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) != value)); + if (lnv < rnv) + return -1; + if (lnv > rnv) + return 1; + if (lnv == rnv) + return 0; + return 2; #endif - RETURN; } } + PP(pp_ncmp) { - dVAR; dSP; dTARGET; + dVAR; dSP; + SV *left, *right; + I32 value; tryAMAGICbin_MG(ncmp_amg, AMGf_numeric); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - const UV right = PTR2UV(SvRV(POPs)); - const UV left = PTR2UV(SvRV(TOPs)); - SETi((left > right) - (left < right)); - RETURN; - } -#endif -#ifdef PERL_PRESERVE_IVUV - /* Fortunately it seems NaN isn't IOK */ - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - const bool leftuvok = SvUOK(TOPm1s); - const bool rightuvok = SvUOK(TOPs); - I32 value; - if (!leftuvok && !rightuvok) { /* ## IV <=> IV ## */ - const IV leftiv = SvIVX(TOPm1s); - const IV rightiv = SvIVX(TOPs); - - if (leftiv > rightiv) - value = 1; - else if (leftiv < rightiv) - value = -1; - else - value = 0; - } else if (leftuvok && rightuvok) { /* ## UV <=> UV ## */ - const UV leftuv = SvUVX(TOPm1s); - const UV rightuv = SvUVX(TOPs); - - if (leftuv > rightuv) - value = 1; - else if (leftuv < rightuv) - value = -1; - else - value = 0; - } else if (leftuvok) { /* ## UV <=> IV ## */ - const IV rightiv = SvIVX(TOPs); - if (rightiv < 0) { - /* As (a) is a UV, it's >=0, so it cannot be < */ - value = 1; - } else { - const UV leftuv = SvUVX(TOPm1s); - if (leftuv > (UV)rightiv) { - value = 1; - } else if (leftuv < (UV)rightiv) { - value = -1; - } else { - value = 0; - } - } - } else { /* ## IV <=> UV ## */ - const IV leftiv = SvIVX(TOPm1s); - if (leftiv < 0) { - /* As (b) is a UV, it's >=0, so it must be < */ - value = -1; - } else { - const UV rightuv = SvUVX(TOPs); - if ((UV)leftiv > rightuv) { - value = 1; - } else if ((UV)leftiv < rightuv) { - value = -1; - } else { - value = 0; - } - } - } - SP--; - SETi(value); - RETURN; - } - } -#endif - { - dPOPTOPnnrl_nomg; - I32 value; - -#ifdef Perl_isnan - if (Perl_isnan(left) || Perl_isnan(right)) { - SETs(&PL_sv_undef); - RETURN; - } - value = (left > right) - (left < right); -#else - if (left == right) - value = 0; - else if (left < right) - value = -1; - else if (left > right) - value = 1; - else { + right = POPs; + left = TOPs; + value = do_ncmp(left, right); + if (value == 2) { SETs(&PL_sv_undef); - RETURN; - } -#endif - SETi(value); - RETURN; } + else { + dTARGET; + SETi(value); + } + RETURN; } PP(pp_sle) diff --git a/pp_hot.c b/pp_hot.c index d2e5240..3b97815 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -341,75 +341,17 @@ PP(pp_readline) PP(pp_eq) { dVAR; dSP; + SV *left, *right; + tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric); -#ifndef NV_PRESERVES_UV - if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) { - SP--; - SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s))); - RETURN; - } -#endif -#ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(TOPs); - if (SvIOK(TOPs)) { - /* Unless the left argument is integer in range we are going - to have to use NV maths. Hence only attempt to coerce the - right argument if we know the left is integer. */ - SvIV_please_nomg(TOPm1s); - if (SvIOK(TOPm1s)) { - const bool auvok = SvUOK(TOPm1s); - const bool buvok = SvUOK(TOPs); - - if (auvok == buvok) { /* ## IV == IV or UV == UV ## */ - /* Casting IV to UV before comparison isn't going to matter - on 2s complement. On 1s complement or sign&magnitude - (if we have any of them) it could to make negative zero - differ from normal zero. As I understand it. (Need to - check - is negative zero implementation defined behaviour - anyway?). NWC */ - const UV buv = SvUVX(POPs); - const UV auv = SvUVX(TOPs); - - SETs(boolSV(auv == buv)); - RETURN; - } - { /* ## Mixed IV,UV ## */ - SV *ivp, *uvp; - IV iv; - - /* == is commutative so doesn't matter which is left or right */ - if (auvok) { - /* top of stack (b) is the iv */ - ivp = *SP; - uvp = *--SP; - } else { - uvp = *SP; - ivp = *--SP; - } - iv = SvIVX(ivp); - if (iv < 0) - /* As uv is a UV, it's >0, so it cannot be == */ - SETs(&PL_sv_no); - else - /* we know iv is >= 0 */ - SETs(boolSV((UV)iv == SvUVX(uvp))); - RETURN; - } - } - } -#endif - { -#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - dPOPTOPnnrl_nomg; - if (Perl_isnan(left) || Perl_isnan(right)) - RETSETNO; - SETs(boolSV(left == right)); -#else - dPOPnv_nomg; - SETs(boolSV(SvNV_nomg(TOPs) == value)); -#endif - RETURN; - } + right = POPs; + left = TOPs; + SETs(boolSV( + (SvIOK_notUV(left) && SvIOK_notUV(right)) + ? (SvIVX(left) == SvIVX(right)) + : ( do_ncmp(left, right) == 0) + )); + RETURN; } PP(pp_preinc) diff --git a/proto.h b/proto.h index 8fc49de..984fc80 100644 --- a/proto.h +++ b/proto.h @@ -776,6 +776,13 @@ PERL_CALLCONV void Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC #define PERL_ARGS_ASSERT_DO_MAGIC_DUMP \ assert(file); assert(mg) +PERL_CALLCONV I32 Perl_do_ncmp(pTHX_ SV *const left, SV *const right) + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_DO_NCMP \ + assert(left); assert(right) + PERL_CALLCONV void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, const OP *o) __attribute__nonnull__(pTHX_2); #define PERL_ARGS_ASSERT_DO_OP_DUMP \ -- Perl5 Master Repository
