summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2019-09-01 20:40:14 +0200
committerAndy Wingo <wingo@pobox.com>2019-09-01 20:46:04 +0200
commitd1cf8928802843a14c53f2a2de55bf01e75e2662 (patch)
tree22b5f290b8c5f3a60f8241068dda424eee045f88
parent74f14562a65c34929176a290a5a9c421b1854046 (diff)
downloadguile-d1cf8928802843a14c53f2a2de55bf01e75e2662.tar.gz
Optimize fixnum or s64 -> f64 conversions
* libguile/intrinsics.c (scm_bootstrap_intrinsics): * libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Add "inexact" intrinsic. * libguile/jit.c (compile_s64_to_f64): New compiler. * libguile/vm-engine.c (s64->f64): New instruction. * module/language/cps/effects-analysis.scm (heap-numbers-equal?): * module/language/cps/reify-primitives.scm (compute-known-primitives): * module/language/cps/slot-allocation.scm (compute-var-representations): * module/language/cps/specialize-numbers.scm (fixnum->f64): (specialize-operations): * module/language/cps/type-fold.scm (scm->f64, inexact): * module/language/cps/types.scm (inexact, s64->f64): * module/language/tree-il/cps-primitives.scm (exact->inexact): * module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*effect-free-primitives*): * module/system/vm/assembler.scm: Recognize exact->inexact as a primitive, and optimize it. Add compiler support for new "inexact" and "s64->f64" primcalls.
-rw-r--r--libguile/intrinsics.c1
-rw-r--r--libguile/intrinsics.h1
-rw-r--r--libguile/jit.c9
-rw-r--r--libguile/vm-engine.c16
-rw-r--r--module/language/cps/effects-analysis.scm2
-rw-r--r--module/language/cps/reify-primitives.scm1
-rw-r--r--module/language/cps/slot-allocation.scm2
-rw-r--r--module/language/cps/specialize-numbers.scm9
-rw-r--r--module/language/cps/type-fold.scm37
-rw-r--r--module/language/cps/types.scm14
-rw-r--r--module/language/tree-il/cps-primitives.scm1
-rw-r--r--module/language/tree-il/primitives.scm4
-rw-r--r--module/system/vm/assembler.scm4
13 files changed, 96 insertions, 5 deletions
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index a9b2d983b..de0375950 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -564,6 +564,7 @@ scm_bootstrap_intrinsics (void)
scm_vm_intrinsics.allocate_pointerless_words = allocate_pointerless_words;
scm_vm_intrinsics.allocate_pointerless_words_with_freelist =
allocate_pointerless_words_with_freelist;
+ scm_vm_intrinsics.inexact = scm_exact_to_inexact;
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index d8c69267e..275a13aca 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -188,6 +188,7 @@ typedef uint32_t* scm_t_vcode_intrinsic;
M(f64_from_f64_f64, fatan2, "fatan2", FATAN2) \
M(scm_from_thread_sz, allocate_pointerless_words, "allocate-pointerless-words", ALLOCATE_POINTERLESS_WORDS) \
M(scm_from_thread_sz, allocate_pointerless_words_with_freelist, "allocate-pointerless-words/freelist", ALLOCATE_POINTERLESS_WORDS_WITH_FREELIST) \
+ M(scm_from_scm, inexact, "inexact", INEXACT) \
/* Add new intrinsics here; also update scm_bootstrap_intrinsics. */
enum scm_vm_intrinsic
diff --git a/libguile/jit.c b/libguile/jit.c
index f1c7a4941..a05734f6d 100644
--- a/libguile/jit.c
+++ b/libguile/jit.c
@@ -4287,6 +4287,15 @@ compile_f64_set (scm_jit_state *j, uint8_t ptr, uint8_t idx, uint8_t v)
jit_stxr_d (j->jit, T0, T1, JIT_F0);
}
+static void
+compile_s64_to_f64 (scm_jit_state *j, uint16_t dst, uint16_t src)
+{
+ emit_sp_ref_s64 (j, T0, src);
+ jit_extr_d (j->jit, JIT_F0, T0);
+ record_fpr_clobber (j, JIT_F0);
+ emit_sp_set_f64 (j, dst, JIT_F0);
+}
+
#define UNPACK_8_8_8(op,a,b,c) \
do \
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 6b1e20d47..8c42ecee5 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3314,7 +3314,21 @@ VM_NAME (scm_thread *thread)
NEXT (1);
}
- VM_DEFINE_OP (159, unused_159, NULL, NOP)
+ /* s64->f64 dst:12 src:12
+ *
+ * Convert an s64 value to a double-precision floating-point value.
+ */
+ VM_DEFINE_OP (159, s64_to_f64, "s64->f64", DOP1 (X8_S12_S12))
+ {
+ uint16_t dst, src;
+
+ UNPACK_12_12 (op, dst, src);
+
+ SP_SET_F64 (dst, (double) SP_REF_S64 (src));
+
+ NEXT (1);
+ }
+
VM_DEFINE_OP (160, unused_160, NULL, NOP)
VM_DEFINE_OP (161, unused_161, NULL, NOP)
VM_DEFINE_OP (162, unused_162, NULL, NOP)
diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index 03a8feac6..080c798d2 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -522,6 +522,8 @@ the LABELS that are clobbered by the effects of LABEL."
((quo . _) &type-check)
((rem . _) &type-check)
((mod . _) &type-check)
+ ((inexact _) &type-check)
+ ((s64->f64 _))
((complex? _) &type-check)
((real? _) &type-check)
((rational? _) &type-check)
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 8165fb2f0..eb14c8b1f 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -314,6 +314,7 @@
quo
rem
mod
+ inexact
sqrt
abs
floor
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 497df7a23..61a220711 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -754,7 +754,7 @@ are comparable with eqv?. A tmp slot may be used."
(($ $values (arg))
(intmap-add representations var
(intmap-ref representations arg)))
- (($ $primcall (or 'scm->f64 'load-f64
+ (($ $primcall (or 'scm->f64 'load-f64 's64->f64
'f32-ref 'f64-ref
'fadd 'fsub 'fmul 'fdiv 'fsqrt 'fabs
'ffloor 'fceiling
diff --git a/module/language/cps/specialize-numbers.scm b/module/language/cps/specialize-numbers.scm
index 2ef44050d..7f7a70a09 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -122,6 +122,13 @@
(define-simple-primcall scm->f64)
(define-simple-primcall f64->scm)
+(define (fixnum->f64 cps k src fx)
+ (with-cps cps
+ (letv s64)
+ (letk kcvt ($kargs ('s64) (s64)
+ ($continue k src ($primcall 's64->f64 #f (s64)))))
+ ($ (untag-fixnum kcvt src fx))))
+
(define (specialize-unop cps k src op param a unbox-a box-result)
(with-cps cps
(letv a* result)
@@ -433,7 +440,7 @@ BITS indicating the significant bits needed for a variable. BITS may be
(if (fixnum-operand? arg) tag-fixnum/unlikely s64->scm/unlikely))
(define (unbox-f64 arg)
;; Could be more precise here.
- scm->f64)
+ (if (fixnum-operand? arg) fixnum->f64 scm->f64))
(define (box-s64 result)
(if (fixnum-result? result) tag-fixnum s64->scm))
(define (box-u64 result)
diff --git a/module/language/cps/type-fold.scm b/module/language/cps/type-fold.scm
index 405806626..25354ad6a 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -422,6 +422,43 @@
(else
(with-cps cps #f))))
+(define-unary-primcall-reducer (scm->f64 cps k src constant arg type min max)
+ (cond
+ ((and (type<=? type &exact-integer)
+ (<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
+ (with-cps cps
+ (letv s64)
+ (letk ks64 ($kargs ('s64) (s64)
+ ($continue k src
+ ($primcall 's64->f64 #f (s64)))))
+ (build-term
+ ($continue ks64 src
+ ($primcall 'untag-fixnum #f (arg))))))
+ (else
+ (with-cps cps #f))))
+
+(define-unary-primcall-reducer (inexact cps k src constant arg type min max)
+ (cond
+ ((and (type<=? type &exact-integer)
+ (<= (target-most-negative-fixnum) min max (target-most-positive-fixnum)))
+ (with-cps cps
+ (letv s64 f64)
+ (letk kf64 ($kargs ('f64) (f64)
+ ($continue k src
+ ($primcall 'f64->scm #f (f64)))))
+ (letk ks64 ($kargs ('s64) (s64)
+ ($continue kf64 src
+ ($primcall 's64->f64 #f (s64)))))
+ (build-term
+ ($continue ks64 src
+ ($primcall 'untag-fixnum #f (arg))))))
+ ((type<=? type &flonum)
+ (with-cps cps
+ (build-term
+ ($continue k src ($primcall 'values #f (arg))))))
+ (else
+ (with-cps cps #f))))
+
;;
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 0a06eb0b9..f4d05f582 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -856,6 +856,20 @@ minimum, and maximum."
(define-type-inferrer/param (load-f64 param result)
(define! result &f64 param param))
+(define-type-checker (inexact scm)
+ (check-type scm &number -inf.0 +inf.0))
+(define-type-inferrer (inexact scm result)
+ (restrict! scm &number -inf.0 +inf.0)
+ (let* ((in (logand (&type &number)))
+ (out (if (type<=? in &real)
+ &flonum
+ (logior &flonum &complex))))
+ (define! result out (&min scm) (&max scm))))
+
+(define-type-checker (s64->f64 s64) #t)
+(define-type-inferrer (s64->f64 s64 result)
+ (define! result &f64 (&min s64) (&max s64)))
+
(define-type-checker (f64->scm f64)
#t)
(define-type-inferrer (f64->scm f64 result)
diff --git a/module/language/tree-il/cps-primitives.scm b/module/language/tree-il/cps-primitives.scm
index e5c2544ee..8534599fa 100644
--- a/module/language/tree-il/cps-primitives.scm
+++ b/module/language/tree-il/cps-primitives.scm
@@ -87,6 +87,7 @@
(define-cps-primitive (quotient quo) 2 1)
(define-cps-primitive (remainder rem) 2 1)
(define-cps-primitive (modulo mod) 2 1)
+(define-cps-primitive (exact->inexact inexact) 1 1)
(define-cps-primitive sqrt 1 1)
(define-cps-primitive abs 1 1)
(define-cps-primitive floor 1 1)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index cb1145ebd..550921787 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -47,7 +47,7 @@
eq? eqv? equal?
memq memv
= < > <= >= zero? positive? negative?
- + * - / 1- 1+ quotient remainder modulo
+ + * - / 1- 1+ quotient remainder modulo exact->inexact
ash logand logior logxor lognot logtest logbit?
sqrt abs floor ceiling sin cos tan asin acos atan
not
@@ -171,7 +171,7 @@
eq? eqv? equal?
= < > <= >= zero? positive? negative?
ash logand logior logxor lognot logtest logbit?
- + * - / 1- 1+ sqrt abs quotient remainder modulo
+ + * - / 1- 1+ sqrt abs quotient remainder modulo exact->inexact
floor ceiling sin cos tan asin acos atan
not
pair? null? nil? list?
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index a09e5f600..da8060ab6 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -106,6 +106,8 @@
emit-untag-char
emit-tag-char
+ emit-s64->f64
+
emit-throw
(emit-throw/value* . emit-throw/value)
(emit-throw/value+data* . emit-throw/value+data)
@@ -199,6 +201,7 @@
emit-quo
emit-rem
emit-mod
+ emit-inexact
emit-abs
emit-sqrt
emit-floor
@@ -1405,6 +1408,7 @@ returned instead."
(define-scm<-scm-scm-intrinsic quo)
(define-scm<-scm-scm-intrinsic rem)
(define-scm<-scm-scm-intrinsic mod)
+(define-scm<-scm-intrinsic inexact)
(define-scm<-scm-intrinsic abs)
(define-scm<-scm-intrinsic sqrt)
(define-scm<-scm-intrinsic floor)