Implement NaN boxing.

On platforms with 64 bit pointers, and therefore 64-bit-wide
TXR values, we can use a representation technique which allows
double floating-point values to be unboxed.

Fixnum integers are reduced from 62 bits to 50, and there is
a little more complexity in the run-time type checking and
dispatch which costs extra cycles.

The support is currently off by default; it must be explicitly
enabled with ./configure --nan-boxing.

* lib.h (NUM_MAX, NUM_MIN, NUM_BIT): Define separately for
NaN boxing.
(TAG_FLNUM, TAG_WIDTH, NAN_TAG_BIT, NAN_TAG_MASK, TAG_BIGMASK,
TAG_BIGSHIFT, NAN_FLNUM_DELTA): New preprocessor symbols.
(enum type, type_t): The FLNUM enumeration constant moves
to just after LIT, so that its value is the same as TAG_FLNUM.
(struct flonum): Does not exist under NaN boxing.
(union obj): No fl member under NaN boxing.
(tag, is_ptr): Separately defined for NaN boxing.
(is_flo): New function under NaN boxing.
(tag_ex): New function. It's like tag, but identifies
floating-point values as TAG_FLNUM. The tag function continues
to map them to TAG_PTR, which is wrong under NaN boxing,
but needed in order not to separately write tons of cases in
the arith.c module.
(type): Use tag_ex, so TAG_FLNUM is handled, if it exists.
(auto_str, static_str, litptr, num_fast, chr, c_n, c_u):
Different definition for NaN boxing.
(c_ch, c_f): New function.
(throw_mismatch): Attribute with NORETURN.
(nao): Separate definition for NaN boxing.

* lib.c (seq_kind_tab): Reorder initializer to follow enum
reordering.
(seq_iter_rewind): use c_n and c_ch functions, since type
checking has been done in those cases. The self parameter
is no longer needed.
(iter_more): use c_ch on CHR object.
(equal): Use c_f accessor to get double value rather than
assuming there is a struct flonum representation.
(stringp): Use tag_ex, otherwise a floating-point number
is identified as TAG_PTR.
(diff, isec, isecp): Don't pass removed self parameter
to seq_iter_rewind.

* arith.c (c_unum, c_dbl_num, c_dbl_unum, plus, minus,
signum, gt, lt, ge, le, numeq, logand, logior,
logxor, logxor_old, bit, bitset, tofloat, toint,
width, c_num, c_fixnum): Extract floating-point value
using c_f accessor. Handle CHR type separately from NUM
because the storage representation is no longer identical;
CHR values have a two bit tag over bits where NUM has
ordinary value bits. NUM is tagged at the NaN level with
the upper 14 bits being 0xFFFC. The remaining 50 bits
are the value.
(flo): Construct unboxed float under NaN boxing by taking
image of double as a 64 bit value, and adding the
delta offset, then casting to the val pointer type.
(c_flo): Separate implementation for NaN boxing.
(integerp, numberp): Use tag_ex.

* buf.c (str_buf, buf_int): Separate CHR and NUM cases,
like in numerous arith.c functions.

* chksum.c (sha256_hash, md5_hash): Use c_ch accessor for
CHR value.

* hash.c (equal_hash, eql_hash): Handle CHR separately. Use
c_f accessor for floating-point value.
(eq_hash): Use tag_ex and handle TAG_FLNUM value under NaN
boxing. Handle CHR separately from NUM.

* ffi.c (ffi_float_put, ffi_double_put, carray_uint, carray_int):
Handle CHR and NUM separately.

* stream.c (formatv): Use c_f accessor.

* configure: disable automatic selection of NaN boxing
on 64 bit platforms, for now.
Add test whether -Wno-strict-aliasing is supported by
the compiler, performed only if NaN boxing is enabled.
We need to disable this warning because it goes off on
the code that reinterprets an integer as a double and
vice versa.

1 files changed, 137 insertions, 17 deletions

diff --git a/lib.h b/lib.h
index f4e24ca6..35a237fa 100644
--- a/lib.h
+++ b/lib.h
@@ -52,18 +52,42 @@ typedef double_uintptr_t dbl_ucnum;
 #define FLEX_ARRAY 1
 #endif
 
-#define TAG_SHIFT 2
-#define TAG_MASK ((convert(cnum, 1) << TAG_SHIFT) - 1)
+#define PTR_BIT (SIZEOF_PTR * CHAR_BIT)
+
 #define TAG_PTR 0
 #define TAG_NUM 1
 #define TAG_CHR 2
 #define TAG_LIT 3
-#define NUM_MAX (INT_PTR_MAX/4)
-#define NUM_MIN (INT_PTR_MIN/4)
 
-#define PTR_BIT (SIZEOF_PTR * CHAR_BIT)
+#if CONFIG_NAN_BOXING
+
+#define TAG_FLNUM 4 /* pseudo-tag */
+#define TAG_WIDTH 2
+#define TAG_PAIR(A, B) ((A) << TAG_WIDTH | (B))
+
+#define NAN_TAG_BIT     14
+#define NAN_TAG_MASK    0xFFFC000000000000U
+#define TAG_BIGMASK     0xFFFF000000000000U
+#define TAG_BIGSHIFT    48
+
+#define NAN_FLNUM_DELTA 0x0004000000000000U
+
+#define NUM_MAX (INT_PTR_MAX >> NAN_TAG_BIT)
+#define NUM_MIN (INT_PTR_MIN >> NAN_TAG_BIT)
+#define NUM_BIT (PTR_BIT - NAN_TAG_BIT)
+
+#else
+
+#define TAG_SHIFT 2
+#define TAG_MASK ((convert(cnum, 1) << TAG_SHIFT) - 1)
+#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
+
+#define NUM_MAX (INT_PTR_MAX >> TAG_SHIFT)
+#define NUM_MIN (INT_PTR_MIN >> TAG_SHIFT)
 #define NUM_BIT (PTR_BIT - TAG_SHIFT)
 
+#endif
+
 #ifdef __GNUC__
 #define NORETURN __attribute__((noreturn))
 #define NOINLINE __attribute__((noinline))
@@ -73,15 +97,14 @@ typedef double_uintptr_t dbl_ucnum;
 #endif
 
 typedef enum type {
-  NIL = TAG_PTR, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, CONS,
-  STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, CPTR, ENV,
-  BGNUM, FLNUM, RNG, BUF, TNOD, DARG, MAXTYPE = DARG
+  NIL = TAG_PTR, NUM = TAG_NUM, CHR = TAG_CHR, LIT = TAG_LIT, FLNUM,
+  CONS, STR, SYM, PKG, FUN, VEC, LCONS, LSTR, COBJ, CPTR, ENV,
+  BGNUM, RNG, BUF, TNOD, DARG, MAXTYPE = DARG
   /* If extending, check TYPE_SHIFT and all ocurrences of MAX_TYPE */
 } type_t;
 
 #define TYPE_SHIFT 5
 #define TYPE_PAIR(A, B) ((A) << TYPE_SHIFT | (B))
-#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
 
 typedef enum functype
 {
@@ -315,10 +338,12 @@ struct bignum {
   mp_int mp;
 };
 
+#if !CONFIG_NAN_BOXING
 struct flonum {
   obj_common;
   double n;
 };
+#endif
 
 struct range {
   obj_common;
@@ -353,7 +378,9 @@ union obj {
   struct cptr cp;
   struct env e;
   struct bignum bn;
+#if !CONFIG_NAN_BOXING
   struct flonum fl;
+#endif
   struct range rn;
   struct buf b;
   struct tnod tn;
@@ -438,15 +465,54 @@ extern const seq_kind_t seq_kind_tab[MAXTYPE+1];
 
 #define SEQ_KIND_PAIR(A, B) ((A) << 3 | (B))
 
+#if CONFIG_NAN_BOXING
+
+INLINE cnum tag(val obj)
+{
+  ucnum word = coerce(ucnum, obj) >> TAG_BIGSHIFT;
+  if (word <= TAG_LIT)
+    return word;
+  if ((word & (NAN_TAG_MASK >> TAG_BIGSHIFT)) == (NAN_TAG_MASK >> TAG_BIGSHIFT))
+    return TAG_NUM;
+  return TAG_PTR;
+}
+
+INLINE cnum tag_ex(val obj)
+{
+  ucnum word = coerce(ucnum, obj) >> TAG_BIGSHIFT;
+  if (word <= TAG_LIT)
+    return word;
+  if ((word & (NAN_TAG_MASK >> TAG_BIGSHIFT)) == (NAN_TAG_MASK >> TAG_BIGSHIFT))
+    return TAG_NUM;
+  return TAG_FLNUM;
+}
+
+INLINE int is_ptr(val obj)
+{
+  return obj && coerce(ucnum, obj) >> TAG_BIGSHIFT == TAG_PTR;
+}
+
+INLINE int is_flo(val obj)
+{
+  ucnum nantag = coerce(ucnum, obj) & NAN_TAG_MASK;
+  return nantag != 0 && nantag != NAN_TAG_MASK;
+}
+
+#else
+
 INLINE cnum tag(val obj) { return coerce(cnum, obj) & TAG_MASK; }
+INLINE cnum tag_ex(val obj) { return tag(obj); }
 INLINE int is_ptr(val obj) { return obj && tag(obj) == TAG_PTR; }
+
+#endif
+
 INLINE int is_num(val obj) { return tag(obj) == TAG_NUM; }
 INLINE int is_chr(val obj) { return tag(obj) == TAG_CHR; }
 INLINE int is_lit(val obj) { return tag(obj) == TAG_LIT; }
 
 INLINE type_t type(val obj)
 {
-  cnum tg = tag(obj);
+  cnum tg = tag_ex(obj);
   return obj ? tg
                ? convert(type_t, tg)
                : obj->t.type
@@ -455,7 +521,7 @@ INLINE type_t type(val obj)
 
 typedef struct wli wchli_t;
 
-#if SIZEOF_WCHAR_T < 4
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
 #define wli_noex(lit) (coerce(const wchli_t *,\
                               convert(const wchar_t *,\
                                       L"\0" L ## lit L"\0" + 1)))
@@ -472,19 +538,31 @@ typedef struct wli wchli_t;
 
 INLINE val auto_str(const wchli_t *str)
 {
+#if CONFIG_NAN_BOXING
+  return coerce(val, coerce(cnum, str) |
+                    (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT));
+#else
   return coerce(val, coerce(cnum, str) | TAG_LIT);
+#endif
 }
 
 INLINE val static_str(const wchli_t *str)
 {
+#if CONFIG_NAN_BOXING
+  return coerce(val, coerce(cnum, str) |
+                    (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT));
+#else
   return coerce(val, coerce(cnum, str) | TAG_LIT);
+#endif
 }
 
 INLINE wchar_t *litptr(val obj)
 {
-#if SIZEOF_WCHAR_T < 4
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
  wchar_t *ret = coerce(wchar_t *, (coerce(cnum, obj) & ~TAG_MASK));
  return (*ret == 0) ? ret + 1 : ret;
+#elif CONFIG_NAN_BOXING
+ return coerce(wchar_t *, coerce(cnum, obj) & ~TAG_BIGMASK);
 #else
  return coerce(wchar_t *, coerce(cnum, obj) & ~TAG_MASK);
 #endif
@@ -492,7 +570,9 @@ INLINE wchar_t *litptr(val obj)
 
 INLINE val num_fast(cnum n)
 {
-#if HAVE_UBSAN
+#if CONFIG_NAN_BOXING
+  return coerce(val, n | NAN_TAG_MASK);
+#elif HAVE_UBSAN
   return coerce(val, (n * (1 << TAG_SHIFT)) | TAG_NUM);
 #else
   return coerce(val, (n << TAG_SHIFT) | TAG_NUM);
@@ -506,25 +586,60 @@ INLINE mp_int *mp(val bign)
 
 INLINE val chr(wchar_t ch)
 {
+#if CONFIG_NAN_BOXING
+  return coerce(val, ch | convert(cnum, TAG_CHR) << TAG_BIGSHIFT);
+#else
   return coerce(val, (convert(cnum, ch) << TAG_SHIFT) | TAG_CHR);
+#endif
+}
+
+INLINE cnum c_ch(val num)
+{
+#if CONFIG_NAN_BOXING
+    return coerce(cnum, num) & ~TAG_BIGMASK;
+#else
+    return coerce(cnum, num) >> TAG_SHIFT;
+#endif
 }
 
 INLINE cnum c_n(val num)
 {
+#if CONFIG_NAN_BOXING
+    cnum n = coerce(cnum, num) & ~NAN_TAG_MASK;
+    return n << NAN_TAG_BIT >> NAN_TAG_BIT;
+#else
     return coerce(cnum, num) >> TAG_SHIFT;
+#endif
 }
 
 INLINE ucnum c_u(val num)
 {
+#if CONFIG_NAN_BOXING
+    return coerce(ucnum, num) & ~NAN_TAG_MASK;
+#else
     return convert(ucnum, coerce(cnum, num) >> TAG_SHIFT);
+#endif
 }
 
-#if SIZEOF_WCHAR_T < 4
+INLINE double c_f(val num)
+{
+#if CONFIG_NAN_BOXING
+  ucnum u = coerce(ucnum, num) - NAN_FLNUM_DELTA;
+  return *coerce(double *, &u);
+#else
+  return num->fl.n;
+#endif
+}
+
+#if SIZEOF_WCHAR_T < 4 && !CONFIG_NAN_BOXING
 #define lit_noex(strlit) coerce(obj_t *,\
                                 coerce(cnum, L"\0" L ## strlit L"\0" + 1) | \
                                 TAG_LIT)
+#elif CONFIG_NAN_BOXING
+#define lit_noex(strlit) coerce(val, coerce(cnum, L ## strlit) |  \
+                                     (coerce(cnum, TAG_LIT) << TAG_BIGSHIFT))
 #else
-#define lit_noex(strlit) coerce(obj_t *, coerce(cnum, L ## strlit) | TAG_LIT)
+#define lit_noex(strlit) coerce(val, coerce(cnum, L ## strlit) | TAG_LIT)
 #endif
 
 #define lit(strlit) lit_noex(strlit)
@@ -610,7 +725,7 @@ val iter_more(val iter);
 val iter_item(val iter);
 val iter_step(val iter);
 val iter_reset(val iter, val obj);
-val throw_mismatch(val self, val obj, type_t);
+NORETURN val throw_mismatch(val self, val obj, type_t);
 INLINE val type_check(val self, val obj, type_t typecode)
 {
   if (type(obj) != typecode)
@@ -1300,7 +1415,12 @@ INLINE val null(val v) { return v ? nil : t; }
 
 #define nilp(o) ((o) == nil)
 
-#define nao coerce(obj_t *, 1 << TAG_SHIFT) /* "not an object" sentinel value. */
+/* "not an object" sentinel value. */
+#if CONFIG_NAN_BOXING
+#define nao coerce(obj_t *, 1)
+#else
+#define nao coerce(obj_t *, 1 << TAG_SHIFT)
+#endif
 
 #define missingp(v) ((v) == colon_k)