DRAFT: Add immediate fractions (fixrats).wip-new-tagging

7 files changed, 112 insertions, 15 deletions

diff --git a/libguile/goops.c b/libguile/goops.c
index eb71130aa..b3d4b0126 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -206,7 +206,10 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
   switch (SCM_ITAG3 (x))
     {
     case scm_tcs_fixnums:
-      return class_integer;
+      if (SCM_I_INUMP (x))
+        return class_integer;
+      else
+        return class_fraction;
 
 #ifdef scm_tcs_iflo
     case scm_tcs_iflo:
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 9f9facef0..853a9853d 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -464,6 +464,24 @@ scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator)
   if (scm_is_eq (denominator, SCM_INUM1))
     return numerator;
 
+  if (SCM_I_INUMP (numerator) && SCM_I_INUMP (denominator)
+      && (SCM_I_INUM (denominator) < ((scm_t_inum) 1 << 53)))  /* assumes 64-bit XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
+    {
+      scm_t_inum nn = SCM_I_INUM (numerator);
+      int neg = (nn < 0);
+      scm_t_bits abs_nn = neg ? -nn : nn;
+      union { double f; uint64_t u; } dd;
+      int rank;
+
+      dd.f = SCM_I_INUM (denominator);
+      rank = (dd.u >> 52) & 63;  /* assumes 64-bit XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX */
+      if ((abs_nn >> (52 - rank)) == 0)
+        return SCM_PACK (scm_fixrat_tag
+                         | (abs_nn << scm_fixrat_tag_size)
+                         | (dd.u << (11 - scm_fixrat_rank_size))
+                         | ((uint64_t) neg << 63));
+    }
+
   return scm_double_cell (scm_tc16_fraction,
 			  SCM_UNPACK (numerator),
 			  SCM_UNPACK (denominator), 0);
@@ -8065,7 +8083,7 @@ scm_product (SCM x, SCM y)
 					   0.0 * SCM_COMPLEX_IMAG (y));
 	  /* we've already handled inexact numbers,
 	     so y must be exact, and we return exact0 */
-	  else if (SCM_NUMP (y))
+	  else if (SCM_NUMBERP (y))
 	    return SCM_INUM0;
 	  else
 	    return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 0d9253af1..2dca854c6 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -167,13 +167,53 @@ typedef long scm_t_inum;
 #define SCM_I_BIG_MPZ(x) (*((mpz_t *) (SCM_CELL_OBJECT_LOC((x),1))))
 #define SCM_BIGP(x) (SCM_HAS_TYP16 (x, scm_tc16_big))
 
-#define SCM_NUMBERP(x) \
-  (SCM_IMP (x) ? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) : SCM_NUMP(x))
+#define SCM_I_FIXRAT_P(x)                                       \
+  ((SCM_UNPACK (x) & scm_fixrat_tag_mask) == scm_fixrat_tag)
+#define SCM_I_FIXRAT_RANK(x)                                    \
+  ((SCM_UNPACK (x) >> (SCM_SIZEOF_UINTPTR_T * 8                 \
+                       - 1 - scm_fixrat_rank_size))             \
+   & ~((scm_t_bits) -1 << scm_fixrat_rank_size))
+
+/* XXX Assumes that any fixrat numerator is an inum, and that doubles
+   are in IEEE-754 binary-64 format.  Verify this. */
+/* XXX Assumes 64-bit word size. */
+#define SCM_I_FIXRAT_DENOMINATOR(x)                             \
+  ((scm_t_inum)                                                 \
+   ((const union { double f; uint64_t u; })                     \
+    { .u = (((SCM_UNPACK (x) >> 5)                              \
+             & 0x3ffffffffffffff)                               \
+            | 0x4000000000000000) } .f))
+#define SCM_I_FIXRAT_NUMERATOR(x)                               \
+  ((SCM_UNPACK (x) >> 63)                                       \
+   ? -(scm_t_inum) ((SCM_UNPACK (x)                             \
+                     & ((scm_t_bits) -1                         \
+                        >> (scm_fixrat_rank_size + 2            \
+                            + SCM_I_FIXRAT_RANK(x))))           \
+                    >> scm_fixrat_tag_size)                     \
+   : (scm_t_inum) ((SCM_UNPACK (x)                              \
+                    & ((scm_t_bits) -1                          \
+                       >> (scm_fixrat_rank_size + 2             \
+                           + SCM_I_FIXRAT_RANK(x))))            \
+                   >> scm_fixrat_tag_size))
+
+#define SCM_NUMBERP(x)                                          \
+  (SCM_IMP (x)                                                  \
+   ? SCM_I_INUMP(x) || SCM_I_IFLO_P (x) || SCM_I_FIXRAT_P(x)    \
+   : SCM_NUMP(x))
 #define SCM_NUMP(x) (SCM_HAS_TYP11 (x, scm_tc11_number))
 
-#define SCM_FRACTIONP(x) (SCM_HAS_TYP16 (x, scm_tc16_fraction))
-#define SCM_FRACTION_NUMERATOR(x) (SCM_CELL_OBJECT_1 (x))
-#define SCM_FRACTION_DENOMINATOR(x) (SCM_CELL_OBJECT_2 (x))
+#define SCM_FRACTIONP(x)                                        \
+  (SCM_IMP (x)                                                  \
+   ? SCM_I_FIXRAT_P (x)                                         \
+   : SCM_HAS_TYP16 (x, scm_tc16_fraction))
+#define SCM_FRACTION_NUMERATOR(x)                               \
+  (SCM_IMP (x)                                                  \
+   ? SCM_I_MAKINUM (SCM_I_FIXRAT_NUMERATOR (x))                 \
+   : SCM_CELL_OBJECT_1 (x))
+#define SCM_FRACTION_DENOMINATOR(x)                             \
+  (SCM_IMP (x)                                                  \
+   ? SCM_I_MAKINUM (SCM_I_FIXRAT_DENOMINATOR (x))               \
+   : SCM_CELL_OBJECT_2 (x))
 
 
 
diff --git a/libguile/print.c b/libguile/print.c
index 7e050989d..0e9a1a38d 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -594,7 +594,10 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
   switch (SCM_ITAG3 (exp))
     {
     case scm_tcs_fixnums:
-      scm_intprint (SCM_I_INUM (exp), 10, port);
+      if (SCM_I_INUMP (exp))
+        scm_intprint (SCM_I_INUM (exp), 10, port);
+      else
+        scm_i_print_fraction (exp, port, pstate);
       break;
 #ifdef scm_tcs_iflo
     case scm_tcs_iflo:
diff --git a/libguile/scm.h b/libguile/scm.h
index 6b229dde6..b73fd1abe 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -440,6 +440,11 @@ typedef uintptr_t scm_t_bits;
 #define scm_fixnum_tag_mask      15
 #define scm_fixnum_tag_size      4
 
+#define scm_fixrat_tag           7
+#define scm_fixrat_tag_mask      15
+#define scm_fixrat_tag_size      4
+#define scm_fixrat_rank_size     6
+
 
 /* Definitions for tc3: */
 
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index c23a665b4..7aa7bd5ac 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -1133,12 +1133,40 @@ immediate, and @code{#f} otherwise."
                                          (+ fixint-max 1 (logand x fixint-max))
                                          x)))
                     (logior (ash fixint-bits fixint-shift) fixint-tag))))))
-        ((and (number? x) (inexact? x) (real? x))
-         (case (asm-word-size asm)
-           ;; TAGS-SENSITIVE
-           ((4) #f)
-           ((8) (pack-iflo x))
-           (else (error "unexpected word size"))))
+        ((and (number? x) (real? x))
+         (cond ((inexact? x)
+                (case (asm-word-size asm)
+                  ;; TAGS-SENSITIVE
+                  ((4) #f)
+                  ((8) (pack-iflo x))
+                  (else (error "unexpected word size"))))
+               ((rational? x)
+                (call-with-values (lambda ()
+                                    (case (asm-word-size asm)
+                                      ;; TAGS-SENSITIVE
+                                      ((4) (values 2 2 5 25))
+                                      ((8) (values 7 4 6 54))
+                                      (else (error "unexpected word size"))))
+                  (lambda (fixrat-tag tag-bits rank-bits data-bits)
+                    (let ((numer (numerator x))
+                          (denom (denominator x)))
+                      (let* ((sign-bit  (if (negative? numer) 1 0))
+                             (numer^    (abs numer))
+                             (numer-len (integer-length numer^))
+                             (denom-len (integer-length denom))
+                             (rank      (- denom-len 2))
+                             (denom^    (- denom (ash 1 (+ rank 1)))))
+                        (and (>= data-bits (+ numer-len denom-len))
+                             (logior fixrat-tag
+                                     (ash (logior numer^
+                                                  (ash (logior denom^
+                                                               (ash (logior rank
+                                                                            (ash sign-bit
+                                                                                 rank-bits))
+                                                                    (+ rank 1)))
+                                                       (- data-bits denom-len)))
+                                          tag-bits))))))))
+               (else #f)))
         (else
          ;; Otherwise, the object will be immediate on the target if and
          ;; only if it is immediate on the host.  Except for integers,
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index a14cd1e44..b22d7a692 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -45,7 +45,7 @@
     (pass-if "null string"     (reads-with-srcprops? "\"\""))
 
     (pass-if "floats"          (reads-with-srcprops? "3.1415e200"))
-    (pass-if "fractions"       (reads-with-srcprops? "1/2"))
+    (pass-if "fractions"       (reads-with-srcprops? "1/111111111111111111111111111111111111"))
     (pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
     (pass-if "bignums"
       (and (reads-with-srcprops? (number->string (1+ most-positive-fixnum)))