[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 06/07: DRAFT: Add immediate floats (iflos).
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 06/07: DRAFT: Add immediate floats (iflos). |
|
Date: |
Thu, 6 Jun 2019 05:37:14 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit 10606b8760f34865d0319e15cd7dac5403ce4f10
Author: Mark H Weaver <address@hidden>
Date: Thu Jun 6 03:20:09 2019 -0400
DRAFT: Add immediate floats (iflos).
---
libguile/evalext.c | 3 ++
libguile/goops.c | 5 ++
libguile/numbers.c | 20 ++++++--
libguile/numbers.h | 27 ++++++++---
libguile/print.c | 5 ++
libguile/random.c | 3 +-
libguile/scm.h | 1 +
module/system/base/types.scm | 16 ++++++-
module/system/vm/assembler.scm | 84 +++++++++++++++++++++------------
test-suite/standalone/test-conversion.c | 2 +-
test-suite/tests/numbers.test | 3 +-
test-suite/tests/srcprop.test | 2 +-
test-suite/tests/srfi-105.test | 2 +-
13 files changed, 124 insertions(+), 49 deletions(-)
diff --git a/libguile/evalext.c b/libguile/evalext.c
index a9366f6..ef84807 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -67,6 +67,9 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0,
0,
switch (SCM_ITAG3 (obj))
{
case scm_tcs_fixnums:
+#ifdef scm_tcs_iflo
+ case scm_tcs_iflo:
+#endif
/* immediate numbers */
return SCM_BOOL_T;
case scm_tc3_imm24:
diff --git a/libguile/goops.c b/libguile/goops.c
index 17160d4..eb71130 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -208,6 +208,11 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tcs_fixnums:
return class_integer;
+#ifdef scm_tcs_iflo
+ case scm_tcs_iflo:
+ return class_real;
+#endif
+
case scm_tc3_imm24:
if (SCM_CHARP (x))
return class_char;
diff --git a/libguile/numbers.c b/libguile/numbers.c
index d1b4633..9f9face 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -653,14 +653,24 @@ scm_i_fraction2double (SCM z)
static SCM
scm_i_from_double (double val)
{
- SCM z;
+ union { double f64; uint64_t u64; } u;
+ uint64_t bits;
+ SCM result;
- z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double),
"real"));
+ u.f64 = val;
+ bits = u.u64 + 0x1010000000000000;
+ bits = (bits << 4) | (bits >> 60);
+ result = SCM_PACK (bits);
- SCM_SET_CELL_TYPE (z, scm_tc16_real);
- SCM_REAL_VALUE (z) = val;
+ if (!SCM_I_IFLO_P (result))
+ {
+ result = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof
(scm_t_double), "real"));
- return z;
+ SCM_SET_CELL_TYPE (result, scm_tc16_real);
+ ((scm_t_double *) SCM2PTR (result))->real = val;
+ }
+
+ return result;
}
SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
diff --git a/libguile/numbers.h b/libguile/numbers.h
index 0aa3533..0d9253a 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -85,6 +85,15 @@ typedef long scm_t_inum;
#define SCM_NEGFIXABLE(n) ((n) >= SCM_MOST_NEGATIVE_FIXNUM)
#define SCM_FIXABLE(n) (SCM_POSFIXABLE (n) && SCM_NEGFIXABLE (n))
+/* Immediate doubles with exponent <= 255 */
+#define SCM_I_IFLO(x) \
+ ((const union { double _f; uint64_t _u; }) \
+ { ._u = (((SCM_UNPACK (x) >> 4) | (SCM_UNPACK (x) << 60)) \
+ - 0x1010000000000000) } ._f)
+
+#define SCM_I_IFLO_P(x) (((SCM_UNPACK (x) + 2) & 7) > 2)
+#define SCM_MOST_POSITIVE_IFLO 0x1.fffffffffffffp255 /* 1.1579208923731618e77
*/
+#define SCM_MOST_NEGATIVE_IFLO (-SCM_MOST_POSITIVE_IFLO)
#define SCM_INUM0 (SCM_I_MAKINUM (0)) /* A name for 0 */
#define SCM_INUM1 (SCM_I_MAKINUM (1)) /* A name for 1 */
@@ -140,14 +149,17 @@ typedef long scm_t_inum;
#define scm_tc16_complex (scm_tc11_number + (3 << 12))
#define scm_tc16_fraction (scm_tc11_number + (4 << 12))
-#define SCM_INEXACTP(x) \
- (SCM_NIMP (x) \
- && ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex)) \
- == (scm_tc16_real & scm_tc16_complex)))
-#define SCM_REALP(x) (SCM_HAS_TYP16 (x, scm_tc16_real))
+#define SCM_INEXACTP(x) \
+ (SCM_IMP (x) \
+ ? SCM_I_IFLO_P (x) \
+ : ((SCM_TYP16 (x) & ~(scm_tc16_real ^ scm_tc16_complex)) \
+ == (scm_tc16_real & scm_tc16_complex)))
+#define SCM_REALP(x) \
+ (SCM_IMP (x) ? SCM_I_IFLO_P (x) : SCM_HAS_TYP16 (x, scm_tc16_real))
#define SCM_COMPLEXP(x) (SCM_HAS_TYP16 (x, scm_tc16_complex))
-#define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real)
+#define SCM_REAL_VALUE(x) \
+ (SCM_IMP (x) ? SCM_I_IFLO(x) : (((scm_t_double *) SCM2PTR (x))->real))
#define SCM_COMPLEX_REAL(x) (((scm_t_complex *) SCM2PTR (x))->real)
#define SCM_COMPLEX_IMAG(x) (((scm_t_complex *) SCM2PTR (x))->imag)
@@ -155,7 +167,8 @@ 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_I_INUMP(x) || SCM_NUMP(x))
+#define SCM_NUMBERP(x) \
+ (SCM_IMP (x) ? SCM_I_INUMP(x) || SCM_I_IFLO_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))
diff --git a/libguile/print.c b/libguile/print.c
index ce46243..7e05098 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -596,6 +596,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tcs_fixnums:
scm_intprint (SCM_I_INUM (exp), 10, port);
break;
+#ifdef scm_tcs_iflo
+ case scm_tcs_iflo:
+ scm_print_real (exp, port, pstate);
+ break;
+#endif
case scm_tc3_imm24:
if (SCM_CHARP (exp))
{
diff --git a/libguile/random.c b/libguile/random.c
index 6fd567c..a7b9c56 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -552,9 +552,10 @@ vector_scale_x (SCM v, double c)
}
else if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
{
+ SCM cc = scm_from_double (c);
SCM *elts = (SCM *)(handle.writable_elements) + handle.base;
for (i = dims[0].lbnd; i <= ubnd; ++i, elts += inc)
- SCM_REAL_VALUE (*elts) *= c;
+ *elts = scm_product (*elts, cc);
return;
}
}
diff --git a/libguile/scm.h b/libguile/scm.h
index 6c7913f..6b229dd 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -449,6 +449,7 @@ typedef uintptr_t scm_t_bits;
#define scm_tc3_cons 0
#define scm_tc3_imm24 6
#define scm_tcs_fixnums 7
+#define scm_tcs_iflo 1: case 2: case 3: case 4: case 5
/* Definitions for tc4: */
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index 5a9d4d7..ee62a5e 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -348,6 +348,15 @@ TYPE-NUMBER."
(dereference-word backend address)))
address))
+(define (inferior-iflo bits)
+ (let ((dbl-bits (modulo (- (rotate-bit-field bits -4 0 64)
+ (ash 1 60)
+ (ash 1 52))
+ (ash 1 64)))
+ (bv (make-bytevector 8)))
+ (bytevector-u64-native-set! bv 0 dbl-bits)
+ (bytevector-ieee-double-native-ref bv 0)))
+
(define %visited-cells
;; Vhash of mapping addresses of already visited cells to the
;; corresponding inferior object. This is used to detect and represent
@@ -538,7 +547,12 @@ object."
((= %tc16-true) #t)
((= %tc16-unspecified) (if #f #f))
((= %tc16-undefined) (inferior-object 'undefined bits))
- ((= %tc16-eof) (eof-object))))
+ ((= %tc16-eof) (eof-object))
+ ((_ & 7 = 1) (inferior-iflo bits)) ;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ ((_ & 7 = 2) (inferior-iflo bits))
+ ((_ & 7 = 3) (inferior-iflo bits))
+ ((_ & 7 = 4) (inferior-iflo bits))
+ ((_ & 7 = 5) (inferior-iflo bits))))
;;; Local Variables:
;;; eval: (put 'match-scm 'scheme-indent-function 1)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index a45ded8..c23a665 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -58,6 +58,7 @@
#:use-module (srfi srfi-4)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-60)
#:export (make-assembler
(emit-receive* . emit-receive)
@@ -1095,40 +1096,61 @@ lists. This procedure can be called many times before
calling
;;; to the table.
;;;
+(define (double-repl x)
+ (let ((bv (make-bytevector 8)))
+ (bytevector-ieee-double-native-set! bv 0 x)
+ (bytevector-u64-native-ref bv 0)))
+
+;; TAGS-SENSITIVE
+(define (pack-iflo x)
+ (let* ((dbl-bits (double-repl x))
+ (bits (rotate-bit-field (logand (+ (ash 1 60) (ash 1 52) dbl-bits)
+ (lognot (ash -1 64)))
+ 4 0 64)))
+ (and (< 0 (logand bits 7) 6)
+ bits)))
+
(define (immediate-bits asm x)
"Return the bit pattern to write into the buffer if @var{x} is
immediate, and @code{#f} otherwise."
- (if (exact-integer? x)
- ;; Object is an immediate if it is a fixnum on the target.
- (call-with-values (lambda ()
- (case (asm-word-size asm)
- ;; TAGS-SENSITIVE
- ((4) (values #x-40000000
- #x3fffffff
- 1 ;fixint tag
- 1)) ;fixint shift
- ((8) (values #x-800000000000000
- #x7ffffffFFFFFFFF
- 15 ;fixint tag
- 4)) ;fixint shift
- (else (error "unexpected word size"))))
- (lambda (fixint-min fixint-max fixint-tag fixint-shift)
- (and (<= fixint-min x fixint-max)
- (let ((fixint-bits (if (negative? x)
- (+ fixint-max 1 (logand x fixint-max))
- x)))
- (logior (ash fixint-bits fixint-shift) fixint-tag)))))
- ;; Otherwise, the object will be immediate on the target if and
- ;; only if it is immediate on the host. Except for integers,
- ;; which we handle specially above, any immediate value is an
- ;; immediate on both 32-bit and 64-bit targets.
- ;;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
- ;; XXX in the new tagging scheme, the following will rarely if
- ;; ever be sufficient when cross-compiling.
- (let ((bits (object-address x)))
- ;; TAGS-SENSITIVE
- (and (not (= (logand bits 7) %tc3-heap-object))
- bits))))
+ (cond ((exact-integer? x)
+ ;; Object is an immediate if it is a fixnum on the target.
+ (call-with-values (lambda ()
+ (case (asm-word-size asm)
+ ;; TAGS-SENSITIVE
+ ((4) (values #x-40000000
+ #x3fffffff
+ 1 ;fixint tag
+ 1)) ;fixint shift
+ ((8) (values #x-800000000000000
+ #x7ffffffFFFFFFFF
+ 15 ;fixint tag
+ 4)) ;fixint shift
+ (else (error "unexpected word size"))))
+ (lambda (fixint-min fixint-max fixint-tag fixint-shift)
+ (and (<= fixint-min x fixint-max)
+ (let ((fixint-bits (if (negative? x)
+ (+ 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"))))
+ (else
+ ;; Otherwise, the object will be immediate on the target if and
+ ;; only if it is immediate on the host. Except for integers,
+ ;; which we handle specially above, any immediate value is an
+ ;; immediate on both 32-bit and 64-bit targets.
+ ;;
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+ ;; XXX in the new tagging scheme, the following will rarely if
+ ;; ever be sufficient when cross-compiling.
+ (let ((bits (object-address x)))
+ ;; TAGS-SENSITIVE
+ (and (not (= (logand bits 7) %tc3-heap-object))
+ bits)))))
(define-record-type <stringbuf>
(make-stringbuf string)
diff --git a/test-suite/standalone/test-conversion.c
b/test-suite/standalone/test-conversion.c
index 6e3ec6c..5e56d2c 100644
--- a/test-suite/standalone/test-conversion.c
+++ b/test-suite/standalone/test-conversion.c
@@ -867,7 +867,7 @@ test_from_double ()
test_9 (0.1, "0.1");
test_9 (guile_Inf, "+inf.0");
test_9 (-guile_Inf, "-inf.0");
- test_9 (guile_NaN, "+nan.0");
+ /* test_9 (guile_NaN, "+nan.0"); */ /* XXXXXXXXXXXXXXXXXX This test is
not robust, because it compares NaNs with 'eqv?' */
}
typedef struct {
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 59e370e..662327f 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -140,8 +140,9 @@
;; Auxiliary predicate used by test-eqv?
(define (test-real-eqv? x y)
- (cond ((or (exact? x) (nan? x) (inf? x))
+ (cond ((or (exact? x) (inf? x))
(eqv? x y))
+ ((nan? x) (nan? y))
(else (and (inexact? y) (> test-epsilon (abs (- x y)))))))
;; return true if OBJ is a real NaN
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 4afc318..a14cd1e 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -44,7 +44,7 @@
(pass-if "strings" (reads-with-srcprops? "\"hello\""))
(pass-if "null string" (reads-with-srcprops? "\"\""))
- (pass-if "floats" (reads-with-srcprops? "3.1415"))
+ (pass-if "floats" (reads-with-srcprops? "3.1415e200"))
(pass-if "fractions" (reads-with-srcprops? "1/2"))
(pass-if "complex numbers" (reads-with-srcprops? "1+1i"))
(pass-if "bignums"
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
index d212bd0..31fd501 100644
--- a/test-suite/tests/srfi-105.test
+++ b/test-suite/tests/srfi-105.test
@@ -184,7 +184,7 @@
(pass-if "singleton curly-infix list"
(let ((sexp (with-read-options '(curly-infix positions)
(lambda ()
- (read-string " { 1.0 }")))))
+ (read-string " { 1e200 }")))))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 3))))
(pass-if "neoteric expression"
- [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, 2019/06/06
- [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 <=
- [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