This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VAX: code changes for VAX floats
authorJarkko Hietaniemi <jhi@iki.fi>
Sun, 26 Jun 2016 02:14:41 +0000 (22:14 -0400)
committerJarkko Hietaniemi <jhi@iki.fi>
Sat, 2 Jul 2016 00:43:12 +0000 (20:43 -0400)
Mainly to avoid Inf and NaN, which VAX does does not have.

There is something like Inf called "excess" but that is
a deadly exception, seems to manifest itself in vax-netbsd
either as a SIGFPE or SIGSEGV (pretty much untrappable at
least from Perl level).

The range of VAX floats is different from IEEE.

There is positive zero, but no negative zero.

numeric.c
perl.h
pp_pack.c
sv.c

index f645502..5fc3df3 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -1138,7 +1138,7 @@ S_mulexp10(NV value, I32 exponent)
      * a hammer.  Therefore we need to catch potential overflows before
      * it's too late. */
 
-#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS)) && defined(NV_MAX_10_EXP)
+#if ((defined(VMS) && !defined(_IEEE_FP)) || defined(_UNICOS) || defined(DOUBLE_IS_VAX_FLOAT)) && defined(NV_MAX_10_EXP)
     STMT_START {
        const NV exp_v = log10(value);
        if (exponent >= NV_MAX_10_EXP || exponent + exp_v >= NV_MAX_10_EXP)
@@ -1185,7 +1185,11 @@ S_mulexp10(NV value, I32 exponent)
            result *= power;
 #ifdef FP_OVERFLOWS_TO_ZERO
             if (result == 0)
+# ifdef NV_INF
                 return value < 0 ? -NV_INF : NV_INF;
+# else
+                return value < 0 ? -FLT_MAX : FLT_MAX;
+# endif
 #endif
            /* Floating point exceptions are supposed to be turned off,
             *  but if we're obviously done, don't risk another iteration.  
@@ -1247,6 +1251,7 @@ Perl_my_atof(pTHX_ const char* s)
     return x;
 }
 
+#if defined(NV_INF) || defined(NV_NAN)
 
 #ifdef USING_MSVC6
 #  pragma warning(push)
@@ -1276,8 +1281,6 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value
         /* If still here, we didn't have either NV_INF or NV_NAN,
          * and can try falling back to native strtod/strtold.
          *
-         * (Though, are our NV_INF or NV_NAN ever not defined?)
-         *
          * The native interface might not recognize all the possible
          * inf/nan strings Perl recognizes.  What we can try
          * is to try faking the input.  We will try inf/-inf/nan
@@ -1286,36 +1289,44 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value
             const char* fake = NULL;
             char* endp;
             NV nv;
+#ifdef NV_INF
             if ((infnan & IS_NUMBER_INFINITY)) {
                 fake = ((infnan & IS_NUMBER_NEG)) ? "-inf" : "inf";
             }
-            else if ((infnan & IS_NUMBER_NAN)) {
+#endif
+#ifdef NV_NAN
+            if ((infnan & IS_NUMBER_NAN)) {
                 fake = "nan";
             }
+#endif
             assert(fake);
             nv = Perl_strtod(fake, &endp);
             if (fake != endp) {
+#ifdef NV_INF
                 if ((infnan & IS_NUMBER_INFINITY)) {
-#ifdef Perl_isinf
+#  ifdef Perl_isinf
                     if (Perl_isinf(nv))
                         *value = nv;
-#else
+#  else
                     /* last resort, may generate SIGFPE */
                     *value = Perl_exp((NV)1e9);
                     if ((infnan & IS_NUMBER_NEG))
                         *value = -*value;
-#endif
+#  endif
                     return (char*)p; /* p, not endp */
                 }
-                else if ((infnan & IS_NUMBER_NAN)) {
-#ifdef Perl_isnan
+#endif
+#ifdef NV_NAN
+                if ((infnan & IS_NUMBER_NAN)) {
+#  ifdef Perl_isnan
                     if (Perl_isnan(nv))
                         *value = nv;
-#else
+#  else
                     /* last resort, may generate SIGFPE */
                     *value = Perl_log((NV)-1.0);
-#endif
+#  endif
                     return (char*)p; /* p, not endp */
+#endif
                 }
             }
         }
@@ -1327,6 +1338,8 @@ S_my_atof_infnan(pTHX_ const char* s, bool negative, const char* send, NV* value
 #  pragma warning(pop)
 #endif
 
+#endif /* if defined(NV_INF) || defined(NV_NAN) */
+
 char*
 Perl_my_atof2(pTHX_ const char* orig, NV* value)
 {
diff --git a/perl.h b/perl.h
index a1dae95..3cb9739 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5736,6 +5736,12 @@ EXTCONST bool PL_valid_types_NV_set[];
  * Also, do NOT try doing NV_NAN based on NV_INF and trying (NV_INF-NV_INF).
  * Though logically correct, some compilers (like Visual C 2003)
  * falsely misoptimize that to zero (x-x is always zero, right?)
+ *
+ * Finally, note that not all floating point formats define Inf (or NaN).
+ * For the infinity a large number may be used instead.  Operations that
+ * under the IEEE floating point would return Inf or NaN may return
+ * either large numbers (positive or negative), or they may cause
+ * a floating point exception or some other fault.
  */
 
 /* The quadmath literals are anon structs which -Wc++-compat doesn't like. */
@@ -6743,6 +6749,14 @@ extern void moncontrol(int);
 #define PERL_PV_PRETTY_DUMP  PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
 #define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE|PERL_PV_ESCAPE_NONASCII
 
+#if DOUBLEKIND == DOUBLE_IS_VAX_F_FLOAT || \
+    DOUBLEKIND == DOUBLE_IS_VAX_D_FLOAT || \
+    DOUBLEKIND == DOUBLE_IS_VAX_G_FLOAT
+#  define DOUBLE_IS_VAX_FLOAT
+#else
+#  define DOUBLE_IS_IEEE_FORMAT
+#endif
+
 #if DOUBLEKIND == DOUBLE_IS_IEEE_754_32_BIT_LITTLE_ENDIAN || \
     DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_LITTLE_ENDIAN || \
     DOUBLEKIND == DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN
@@ -6760,11 +6774,23 @@ extern void moncontrol(int);
 #  define DOUBLE_MIX_ENDIAN
 #endif
 
+/* Even though the VAX formats are kind of little-endian,
+ * they are not really fully little-endian like Intel IEEE,
+ * but neither they are really IEEE-mixed endian like the
+ * mixed-endian ARM IEEE formats (with swapped bytes).
+ * The VAX format ultimately come from PDP. */
+
+#ifdef DOUBLE_IS_VAX_FLOAT
+#  define DOUBLE_VAX_ENDIAN
+#endif
+
+#ifdef DOUBLE_IS_IEEE_FORMAT
 /* All the basic IEEE formats have the implicit bit,
  * except for the 80-bit extended formats, which will undef this. */
-#define NV_IMPLICIT_BIT
+#  define NV_IMPLICIT_BIT
+#endif
 
-#ifdef LONG_DOUBLEKIND
+#if defined(LONG_DOUBLEKIND) && LONG_DOUBLEKIND != LONG_DOUBLE_IS_DOUBLE
 
 #  if LONG_DOUBLEKIND == LONG_DOUBLE_IS_IEEE_754_128_BIT_LITTLE_ENDIAN || \
       LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_LITTLE_ENDIAN || \
@@ -6818,6 +6844,9 @@ extern void moncontrol(int);
 #  ifdef DOUBLE_MIX_ENDIAN
 #    define NV_MIX_ENDIAN
 #  endif
+#  ifdef DOUBLE_VAX_ENDIAN
+#    define NV_VAX_ENDIAN
+#  endif
 #elif NVSIZE == LONG_DOUBLESIZE
 #  ifdef LONGDOUBLE_LITTLE_ENDIAN
 #    define NV_LITTLE_ENDIAN
@@ -6830,6 +6859,13 @@ extern void moncontrol(int);
 #  endif
 #endif
 
+#ifdef DOUBLE_IS_IEEE_FORMAT
+#  define DOUBLE_HAS_INF
+#  define DOUBLE_HAS_NAN
+#endif
+
+#ifdef DOUBLE_HAS_NAN
+
 /* NaNs (not-a-numbers) can carry payload bits, in addition to
  * "nan-ness".  Part of the payload is the quiet/signaling bit.
  * To back up a bit (harhar):
@@ -6980,6 +7016,8 @@ extern void moncontrol(int);
 #  elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE
 #    define NV_NAN_QS_BYTE_OFFSET 5 /* bytes 3 2 1 0 7 6 5 4 (MSB 7) */
 #  else
+/* For example the VAX formats should never
+ * get here because they do not have NaN. */
 #    error "Unexpected double format"
 #  endif
 #endif
@@ -7182,6 +7220,9 @@ extern void moncontrol(int);
 #    error "Unexpected double format"
 #  endif
 #endif
+
+#endif /* DOUBLE_HAS_NAN */
+
 /*
 
    (KEEP THIS LAST IN perl.h!)
index f6964c3..891d2e2 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2674,7 +2674,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                NV anv;
                fromstr = NEXTFROM;
                anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
                /* IEEE fp overflow shenanigans are unavailable on VAX and optional
                 * on Alpha; fake it if we don't have them.
                 */
@@ -2684,15 +2684,17 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                    afloat = -FLT_MAX;
                else afloat = (float)anv;
 # else
-#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
+#  if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
                if(Perl_isnan(anv))
                    afloat = (float)NV_NAN;
                else
-#endif
+#  endif
+#  ifdef NV_INF
                 /* a simple cast to float is undefined if outside
                  * the range of values that can be represented */
                afloat = (float)(anv >  FLT_MAX ?  NV_INF :
                                  anv < -FLT_MAX ? -NV_INF : anv);
+#  endif
 # endif
                 PUSH_VAR(utf8, cur, afloat, needs_swap);
            }
@@ -2703,7 +2705,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
                NV anv;
                fromstr = NEXTFROM;
                anv = SvNV(fromstr);
-# if defined(VMS) && !defined(_IEEE_FP)
+# if (defined(VMS) && !defined(_IEEE_FP)) || defined(DOUBLE_IS_VAX_FLOAT)
                /* IEEE fp overflow shenanigans are unavailable on VAX and optional
                 * on Alpha; fake it if we don't have them.
                 */
diff --git a/sv.c b/sv.c
index 2ceec5a..1e294dd 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -2097,15 +2097,19 @@ S_sv_setnv(pTHX_ SV* sv, int numtype)
 {
     bool pok = cBOOL(SvPOK(sv));
     bool nok = FALSE;
+#ifdef NV_INF
     if ((numtype & IS_NUMBER_INFINITY)) {
         SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -NV_INF : NV_INF);
         nok = TRUE;
-    }
-    else if ((numtype & IS_NUMBER_NAN)) {
+    } else
+#endif
+#ifdef NV_NAN
+    if ((numtype & IS_NUMBER_NAN)) {
         SvNV_set(sv, NV_NAN);
         nok = TRUE;
-    }
-    else if (pok) {
+    } else
+#endif
+    if (pok) {
         SvNV_set(sv, Atof(SvPVX_const(sv)));
         /* Purposefully no true nok here, since we don't want to blow
          * away the possible IOK/UV of an existing sv. */