+#undef NV_PAYLOAD_DEBUG
+
+/* NOTE: the NaN payload API implementation is hand-rolled, since the
+ * APIs are only proposed ones as of June 2015, so very few, if any,
+ * platforms have implementations yet, so HAS_SETPAYLOAD and such are
+ * unlikely to be helpful.
+ *
+ * XXX - if the core numification wants to actually generate
+ * the nan payload in "nan(123)", and maybe "nans(456)", for
+ * signaling payload", this needs to be moved to e.g. numeric.c
+ * (look for grok_infnan)
+ *
+ * Conversely, if the core stringification wants the nan payload
+ * and/or the nan quiet/signaling distinction, S_getpayload()
+ * from this file needs to be moved, to e.g. sv.c (look for S_infnan_2pv),
+ * and the (trivial) functionality of issignaling() copied
+ * (for generating "NaNS", or maybe even "NaNQ") -- or maybe there
+ * are too many formatting parameters for simple stringification?
+ */
+
+/* While it might make sense for the payload to be UV or IV,
+ * to avoid conversion loss, the proposed ISO interfaces use
+ * a floating point input, which is then truncated to integer,
+ * and only the integer part being used. This is workable,
+ * except for: (1) the conversion loss (2) suboptimal for
+ * 32-bit integer platforms. A workaround API for (2) and
+ * in general for bit-honesty would be an array of integers
+ * as the payload... but the proposed C API does nothing of
+ * the kind. */
+#if NVSIZE == UVSIZE
+# define NV_PAYLOAD_TYPE UV
+#else
+# define NV_PAYLOAD_TYPE NV
+#endif
+
+#ifdef LONGDOUBLE_DOUBLEDOUBLE
+# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE / 2)
+#else
+# define NV_PAYLOAD_SIZEOF_ASSERT(a) assert(sizeof(a) == NVSIZE)
+#endif
+
+static void S_setpayload(NV* nvp, NV_PAYLOAD_TYPE payload, bool signaling)
+{
+ dTHX;
+ static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
+ static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
+ UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
+ int i;
+ NV_PAYLOAD_SIZEOF_ASSERT(m);
+ NV_PAYLOAD_SIZEOF_ASSERT(p);
+ *nvp = NV_NAN;
+ /* Divide the input into the array in "base unsigned integer" in
+ * little-endian order. Note that the integer might be smaller than
+ * an NV (if UV is U32, for example). */
+#if NVSIZE == UVSIZE
+ a[0] = payload; /* The trivial case. */
+#else
+ {
+ NV t1 = c99_trunc(payload); /* towards zero (drop fractional) */
+#ifdef NV_PAYLOAD_DEBUG
+ Perl_warn(aTHX_ "t1 = %"NVgf" (payload %"NVgf")\n", t1, payload);
+#endif
+ if (t1 <= UV_MAX) {
+ a[0] = (UV)t1; /* Fast path, also avoids rounding errors (right?) */
+ } else {
+ /* UVSIZE < NVSIZE or payload > UV_MAX.
+ *
+ * This may happen for example if:
+ * (1) UVSIZE == 32 and common 64-bit double NV
+ * (32-bit system not using -Duse64bitint)
+ * (2) UVSIZE == 64 and the x86-style 80-bit long double NV
+ * (note that here the room for payload is actually the 64 bits)
+ * (3) UVSIZE == 64 and the 128-bit IEEE 764 quadruple NV
+ * (112 bits in mantissa, 111 bits room for payload)
+ *
+ * NOTE: this is very sensitive to correctly functioning
+ * fmod()/fmodl(), and correct casting of big-unsigned-integer to NV.
+ * If these don't work right, especially the low order bits
+ * are in danger. For example Solaris and AIX seem to have issues
+ * here, especially if using 32-bit UVs. */
+ NV t2;
+ for (i = 0, t2 = t1; i < (int)C_ARRAY_LENGTH(a); i++) {
+ a[i] = (UV)Perl_fmod(t2, (NV)UV_MAX);
+ t2 = Perl_floor(t2 / (NV)UV_MAX);
+ }
+ }
+ }
+#endif
+#ifdef NV_PAYLOAD_DEBUG
+ for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
+ Perl_warn(aTHX_ "a[%d] = 0x%"UVxf"\n", i, a[i]);
+ }
+#endif
+ for (i = 0; i < (int)sizeof(p); i++) {
+ if (m[i] && p[i] < sizeof(p)) {
+ U8 s = (p[i] % UVSIZE) << 3;
+ UV u = a[p[i] / UVSIZE] & ((UV)0xFF << s);
+ U8 b = (U8)((u >> s) & m[i]);
+ ((U8 *)(nvp))[i] &= ~m[i]; /* For NaNs with non-zero payload bits. */
+ ((U8 *)(nvp))[i] |= b;
+#ifdef NV_PAYLOAD_DEBUG
+ Perl_warn(aTHX_ "set p[%2d] = %02x (i = %d, m = %02x, s = %2d, b = %02x, u = %08"UVxf")\n", i, ((U8 *)(nvp))[i], i, m[i], s, b, u);
+#endif
+ a[p[i] / UVSIZE] &= ~u;
+ }
+ }
+ if (signaling) {
+ NV_NAN_SET_SIGNALING(nvp);
+ }
+#ifdef USE_LONG_DOUBLE
+# if LONG_DOUBLEKIND == 3 || LONG_DOUBLEKIND == 4
+# if LONG_DOUBLESIZE > 10
+ memset((char *)nvp + 10, '\0', LONG_DOUBLESIZE - 10); /* x86 long double */
+# endif
+# endif
+#endif
+ for (i = 0; i < (int)C_ARRAY_LENGTH(a); i++) {
+ if (a[i]) {
+ Perl_warn(aTHX_ "payload lost bits (%"UVxf")", a[i]);
+ break;
+ }
+ }
+#ifdef NV_PAYLOAD_DEBUG
+ for (i = 0; i < NVSIZE; i++) {
+ PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(nvp))[i]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif
+}
+
+static NV_PAYLOAD_TYPE S_getpayload(NV nv)
+{
+ dTHX;
+ static const U8 m[] = { NV_NAN_PAYLOAD_MASK };
+ static const U8 p[] = { NV_NAN_PAYLOAD_PERM };
+ UV a[(NVSIZE + UVSIZE - 1) / UVSIZE] = { 0 };
+ int i;
+ NV payload;
+ NV_PAYLOAD_SIZEOF_ASSERT(m);
+ NV_PAYLOAD_SIZEOF_ASSERT(p);
+ payload = 0;
+ for (i = 0; i < (int)sizeof(p); i++) {
+ if (m[i] && p[i] < NVSIZE) {
+ U8 s = (p[i] % UVSIZE) << 3;
+ a[p[i] / UVSIZE] |= (UV)(((U8 *)(&nv))[i] & m[i]) << s;
+ }
+ }
+ for (i = (int)C_ARRAY_LENGTH(a) - 1; i >= 0; i--) {
+#ifdef NV_PAYLOAD_DEBUG
+ Perl_warn(aTHX_ "a[%d] = %"UVxf"\n", i, a[i]);
+#endif
+ payload *= UV_MAX;
+ payload += a[i];
+ }
+#ifdef NV_PAYLOAD_DEBUG
+ for (i = 0; i < NVSIZE; i++) {
+ PerlIO_printf(Perl_debug_log, "%02x ", ((U8 *)(&nv))[i]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+#endif
+ return payload;
+}
+
https://perl5.git.perl.org / perl5.git / blobdiff