infnan: add nan_signaling_set

diff --git a/embed.fnc b/embed.fnc
index b4944f2..1be794b 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -820,6 +820,7 @@ ApdR        |bool   |grok_numeric_radix|NN const char **sp|NN const char *send
 Apd    |UV     |grok_oct       |NN const char* start|NN STRLEN* len_p|NN I32* flags|NULLOK NV *result
 Apdn   |UV     |grok_atou      |NN const char* pv|NULLOK const char** endptr
 Apd    |U8*    |nan_hibyte|NN NV *nvp|NN U8* mask
+Apd    |void   |nan_signaling_set|NN NV *nvp|bool signaling
 : These are all indirectly referenced by globals.c. This is somewhat annoying.
 p      |int    |magic_clearenv |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_clear_all_env|NN SV* sv|NN MAGIC* mg

diff --git a/embed.h b/embed.h
index d7afa71..330542f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -357,6 +357,7 @@
 #define my_strerror(a)         Perl_my_strerror(aTHX_ a)
 #define my_strftime(a,b,c,d,e,f,g,h,i,j)       Perl_my_strftime(aTHX_ a,b,c,d,e,f,g,h,i,j)
 #define nan_hibyte(a,b)                Perl_nan_hibyte(aTHX_ a,b)
+#define nan_signaling_set(a,b) Perl_nan_signaling_set(aTHX_ a,b)
 #define newANONATTRSUB(a,b,c,d)        Perl_newANONATTRSUB(aTHX_ a,b,c,d)
 #define newANONHASH(a)         Perl_newANONHASH(aTHX_ a)
 #define newANONLIST(a)         Perl_newANONLIST(aTHX_ a)

diff --git a/numeric.c b/numeric.c
index 16717aa..c20c85e 100644 (file)
--- a/numeric.c
+++ b/numeric.c
@@ -583,6 +583,52 @@ Perl_nan_hibyte(NV *nvp, U8* mask)
 }
 
 /*
+=for apidoc nan_signaling_set
+
+Set or unset the NaN signaling-ness.
+
+Of those platforms that differentiate between quiet and signaling
+platforms the majority has the semantics of the most significant bit
+being on meaning quiet NaN, so for signaling we need to clear the bit.
+
+Some platforms (older MIPS, and HPPA) have the opposite
+semantics, and we set the bit for a signaling NaN.
+
+=cut
+*/
+void
+Perl_nan_signaling_set(NV *nvp, bool signaling)
+{
+    U8 mask;
+    U8* hibyte;
+
+    PERL_ARGS_ASSERT_NAN_SIGNALING_SET;
+
+    hibyte = nan_hibyte(nvp, &mask);
+    if (hibyte) {
+        const NV nan = NV_NAN;
+        /* Decent optimizers should make the irrelevant branch to disappear. */
+        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 (signaling) {
+                *hibyte &= ~mask;
+            } else {
+                *hibyte |=  mask;
+            }
+        } else {
+            /* MIPS/HPPA style: the most significant bit of the NaN is on
+             * for a signaling NaN, and off for a quiet NaN. */
+            if (signaling) {
+                *hibyte |=  mask;
+            } else {
+                *hibyte &= ~mask;
+            }
+        }
+    }
+}
+
+/*
 =for apidoc grok_infnan
 
 Helper for grok_number(), accepts various ways of spelling "infinity"

diff --git a/proto.h b/proto.h
index 77a8e7f..0fdceea 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2844,6 +2844,11 @@ PERL_CALLCONV U8*        Perl_nan_hibyte(pTHX_ NV *nvp, U8* mask)
 #define PERL_ARGS_ASSERT_NAN_HIBYTE    \
        assert(nvp); assert(mask)
 
+PERL_CALLCONV void     Perl_nan_signaling_set(pTHX_ NV *nvp, bool signaling)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_NAN_SIGNALING_SET     \
+       assert(nvp)
+
 PERL_CALLCONV OP*      Perl_newANONATTRSUB(pTHX_ I32 floor, OP *proto, OP *attrs, OP *block);
 PERL_CALLCONV OP*      Perl_newANONHASH(pTHX_ OP* o)
                        __attribute__malloc__