mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

DRAFT: Add immediate floats (iflos).

Browse source
This commit is contained in:
Mark H Weaver 2019-06-06 03:20:09 -04:00
parent de42f12099
commit 10606b8760
13 changed files with 124 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

3
libguile/evalext.c
View file

@ -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:

5
libguile/goops.c
View file

@ -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;

20
libguile/numbers.c
View file

@ -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,

27
libguile/numbers.h
View file

@ -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))

5
libguile/print.c
View file

@ -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))
{

3
libguile/random.c
View file

@ -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;
}
}

1
libguile/scm.h
View file

@ -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: */

16
module/system/base/types.scm
View file

@ -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)

84
module/system/vm/assembler.scm
View file

@ -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)

2
test-suite/standalone/test-conversion.c
View file

@ -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 {

3
test-suite/tests/numbers.test
View file

@ -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

2
test-suite/tests/srcprop.test
View file

@ -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"

2
test-suite/tests/srfi-105.test
View file

@ -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"