[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats).
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats). |
|
Date: |
Thu, 6 Jun 2019 05:37:15 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit f08e08bfac0a90ff7d2d14bf609c26b7f0553573
Author: Mark H Weaver <address@hidden>
Date: Wed Jun 5 15:18:40 2019 -0400
DRAFT: Add immediate fractions (fixrats).
---
libguile/goops.c | 5 ++++-
libguile/numbers.c | 20 ++++++++++++++++-
libguile/numbers.h | 50 +++++++++++++++++++++++++++++++++++++-----
libguile/print.c | 5 ++++-
libguile/scm.h | 5 +++++
module/system/vm/assembler.scm | 40 ++++++++++++++++++++++++++++-----
test-suite/tests/srcprop.test | 2 +-
7 files changed, 112 insertions(+), 15 deletions(-)
diff --git a/libguile/goops.c b/libguile/goops.c
index eb71130..b3d4b01 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 9f9face..853a985 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 0d9253a..2dca854 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 7e05098..0e9a1a3 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 6b229dd..b73fd1a 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 c23a665..7aa7bd5 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 a14cd1e..b22d7a6 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)))
- [Guile-commits] branch wip-new-tagging created (now f08e08b), Mark H. Weaver, 2019/06/06
- [Guile-commits] 01/07: fix typo, Mark H. Weaver, 2019/06/06
- [Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic., Mark H. Weaver, 2019/06/06
- [Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats).,
Mark H. Weaver <=
- [Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc., Mark H. Weaver, 2019/06/06
- [Guile-commits] 06/07: DRAFT: Add immediate floats (iflos)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures., Mark H. Weaver, 2019/06/06
- [Guile-commits] 04/07: WIP: New tagging v8, Mark H. Weaver, 2019/06/06