infnan: the nan quiet/signaling bit is not enough

diff --git a/numeric.c b/numeric.c
index 18ee1b9..9b1b2ae 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -547,24 +547,20 @@ Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
     return FALSE;
 }
 
     return FALSE;
 }
 

-/* x86 80-bit extended precision mantissa bits:
- *
- * 63 62 61   30387+    pre-387
- * --------   ----      --------
- *  0  0  0   invalid   infinity
- *  0  0  n   invalid   snan
- *  0  1  *   invalid   snan
- *  1  0  0   infinity  snan
- *  1  0  n   snan
- *  1  1  0   qnan (1.#IND)
- *  1  1  n   qnan
- *
- * This means that there are 61 bits for nan payload.
- */
-#if defined(USE_LONG_DOUBLE) && (LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN)
-#  define NV_NAN_BITS 61
-#else
-#  define NV_NAN_BITS (NV_MANT_REAL_DIG - 1)
+#if 0
+/* For debugging. */
+static void
+S_hexdump_nv(NV nv)
+{
+    int i;
+    /* Remember that NVSIZE may include garbage bytes, the most
+     * notable case being the x86 80-bit extended precision long doubles,
+     * which have 6 or 2 unused bytes (NVSIZE = 16 or NVSIZE = 12). */
+    for (i = 0; i < NVSIZE; i++) {
+        PerlIO_printf(Perl_debug_log, "%02x ", ((U8*)&nv)[i]);
+    }
+    PerlIO_printf(Perl_debug_log, "\n");
+}

 #endif
 
 /*
 #endif
 
 /*


@@ -634,7 +630,8 @@ Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
     hibyte = nan_hibyte(nvp, &mask);
     if (hibyte) {
         const NV nan = NV_NAN;
     hibyte = nan_hibyte(nvp, &mask);
     if (hibyte) {
         const NV nan = NV_NAN;

-        /* Decent optimizers should make the irrelevant branch to disappear. */
+        /* Decent optimizers should make the irrelevant branch to disappear.
+         * XXX Configure scan */

         if ((((U8*)&nan)[hibyte - (U8*)nvp] & mask)) {
             /* x86 style: the most significant bit of the NaN is off
              * for a signaling NaN, and on for a quiet NaN. */
         if ((((U8*)&nan)[hibyte - (U8*)nvp] & mask)) {
             /* x86 style: the most significant bit of the NaN is off
              * for a signaling NaN, and on for a quiet NaN. */


@@ -673,20 +670,21 @@ Perl_nan_is_signaling(NV nv)
      * The "7ff" is the exponent.  The most significant bit of the NaN
      * (note: here, not the most significant bit of the byte) is of
      * interest: in the x86 style (also in sparc) the bit on means
      * The "7ff" is the exponent.  The most significant bit of the NaN
      * (note: here, not the most significant bit of the byte) is of
      * interest: in the x86 style (also in sparc) the bit on means

-     * 'quiet', in the mips style the bit off means 'quiet'. */
+     * 'quiet', in the mips/hppa style the bit off means 'quiet'. */

 #ifdef Perl_fp_classify_snan
     return Perl_fp_classify_snan(nv);
 #else
     if (Perl_isnan(nv)) {
         U8 mask;
         U8 *hibyte = nan_hibyte(&nv, &mask);
 #ifdef Perl_fp_classify_snan
     return Perl_fp_classify_snan(nv);
 #else
     if (Perl_isnan(nv)) {
         U8 mask;
         U8 *hibyte = nan_hibyte(&nv, &mask);

-        /* Hoping NV_NAN is a quiet nan - this might be a false hope.
-         * XXX Configure test */
-        const NV nan = NV_NAN;
-        return (*hibyte & mask) != (((U8*)&nan)[hibyte - (U8*)&nv] & mask);
-    } else {
-        return 0;
+        if (hibyte) {
+            /* Hoping NV_NAN is a quiet nan - this might be a false hope.
+             * XXX Configure test */
+            const NV nan = NV_NAN;
+            return (*hibyte & mask) != (((U8*)&nan)[hibyte - (U8*)&nv] & mask);
+        }

     }
     }

+    return 0;

 #endif
 }
 
 #endif
 }
 


@@ -727,6 +725,9 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal
      *
      * C99 nan() is supposed to generate quiet NaNs. */
     int bits = NV_NAN_BITS;
      *
      * C99 nan() is supposed to generate quiet NaNs. */
     int bits = NV_NAN_BITS;

+    U8 mask;
+    U8* hibyte;
+    U8 hibit;

 
     STRLEN i, nvi;
     bool error = FALSE;
 
     STRLEN i, nvi;
     bool error = FALSE;


@@ -736,6 +737,8 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal
     PERL_ARGS_ASSERT_NAN_PAYLOAD_SET;
 
     *nvp = NV_NAN;
     PERL_ARGS_ASSERT_NAN_PAYLOAD_SET;
 
     *nvp = NV_NAN;

+    hibyte = nan_hibyte(nvp, &mask);
+    hibit = *hibyte & mask;

 
 #ifdef NV_BIG_ENDIAN
     nvi = NVSIZE - 1;
 
 #ifdef NV_BIG_ENDIAN
     nvi = NVSIZE - 1;


@@ -766,6 +769,11 @@ Perl_nan_payload_set(pTHX_ NV *nvp, const void *bytes, STRLEN byten, bool signal
         nvi++;
 #endif
     }
         nvi++;
 #endif
     }

+    if (hibit) {
+        *hibyte |=  mask;
+    } else {
+        *hibyte &= ~mask;
+    }

     if (error) {
         Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
                          nan_payload_error);
     if (error) {
         Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
                          nan_payload_error);

diff --git a/perl.h b/perl.h
index cfbadef..b4ac7f5 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4363,6 +4363,38 @@ static const union { unsigned int __i; float __f; } __PL_nan_u =
  * Though IEEE-754-logically correct, some compilers (like Visual C 2003)
  * falsely misoptimize that to zero (x-x is zero, right?) */
 
  * Though IEEE-754-logically correct, some compilers (like Visual C 2003)
  * falsely misoptimize that to zero (x-x is zero, right?) */
 

+/* x86 80-bit extended precision mantissa bits:
+ *
+ * 63 62 61   30387+    pre-387
+ * --------   ----      --------
+ *  0  0  0   invalid   infinity
+ *  0  0  n   invalid   snan
+ *  0  1  *   invalid   snan
+ *  1  0  0   infinity  snan
+ *  1  0  n   snan
+ *  1  1  0   qnan (1.#IND)
+ *  1  1  n   qnan
+ *
+ * This means that there are 61 bits for nan payload.
+ */
+#if defined(USE_LONG_DOUBLE) && (LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN)
+#  define NV_NAN_BITS 61
+#elif defined(__hppa) /* XXX Configure scan */
+#  define NV_NAN_BITS 50 /* qnan: 7f f4 00 00 00 00 00 00 */
+#elif defined(__mips) && UVSIZE == 4 /* IRIX64/MIPS cc -32 */
+#  define NV_NAN_BITS 35 /* qnan: 7f ff 2f 30 00 00 00 00
+                          * +inf: 7f ff 2f 20 00 00 00 00
+                          * -inf: 7f ff 2f 28 00 00 00 00 */
+#else
+#  define NV_NAN_BITS (NV_MANT_REAL_DIG - 1)
+#endif
+/* IRIX64/MIPS cc -64 is something bizarre:
+ * qnan 00 00 0f ff ff ff ae 90
+ * +inf 00 00 0f ff ff ff ae 80
+ * -inf 00 00 0f ff ff ff ae 88
+ * In other words, it doesn't seem to follow any IEEE pattern for infnan,
+ * and even seems more little-endian than big-endian. */
+

 #ifndef __cplusplus
 #  if !defined(WIN32) && !defined(VMS)
 #ifndef crypt
 #ifndef __cplusplus
 #  if !defined(WIN32) && !defined(VMS)
 #ifndef crypt

diff --git a/sv.c b/sv.c
index c3f77e3..adc2fc3 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3257,19 +3257,12 @@ S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char format, char plus, char al
             *s++ = 'n';
             *s++ = 'f';
         } else if (Perl_isnan(nv)) {
             *s++ = 'n';
             *s++ = 'f';
         } else if (Perl_isnan(nv)) {

-            U8 mask;
-            NV payload = nv;
-            U8* hibyte = nan_hibyte(&payload, &mask);

             *s++ = 'N';
             *s++ = 'a';
             *s++ = 'N';
             if (nan_is_signaling(nv)) {
                 *s++ = 's';
             }
             *s++ = 'N';
             *s++ = 'a';
             *s++ = 'N';
             if (nan_is_signaling(nv)) {
                 *s++ = 's';
             }

-            /* Detect and clear the "quiet bit" from the NV copy.
-             * This is done so that in *most* platforms the bit is
-             * skipped and not included in the hexadecimal result. */
-            *hibyte &= ~mask;

             if (alt) {
                 U8 vhex[VHEX_SIZE];
                 U8* vend;
             if (alt) {
                 U8 vhex[VHEX_SIZE];
                 U8* vend;


@@ -3279,10 +3272,13 @@ S_infnan_2pv(NV nv, char* buffer, size_t maxlen, char format, char plus, char al
                 bool upper = isUPPER(format);
                 const char* xdig = PL_hexdigit + (upper ? 16 : 0);
                 char xhex = upper ? 'X' : 'x';
                 bool upper = isUPPER(format);
                 const char* xdig = PL_hexdigit + (upper ? 16 : 0);
                 char xhex = upper ? 'X' : 'x';

+                U8 mask;
+                NV payload = nv;
+                U8* hibyte = nan_hibyte(&payload, &mask);

 
 

-                /* We need to clear the bits of the first
-                 * byte that are not part of the payload. */
-                *hibyte &= (1 << (7 - NV_MANT_REAL_DIG % 8)) - 1;
+                /* Clear the bits that are not part of the payload. */
+                *hibyte &= ~mask;
+                *hibyte &= ((1 << (NV_NAN_BITS % 8)) - 1);

 
                 vend = S_hextract(payload, &exponent, vhex, NULL);
                 S_hextract(payload, &exponent, vhex, vend);
 
                 vend = S_hextract(payload, &exponent, vhex, NULL);
                 S_hextract(payload, &exponent, vhex, vend);