[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 01/01: Optimize fixnum or s64 -> f64 conversions
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 01/01: Optimize fixnum or s64 -> f64 conversions |
|
Date: |
Sun, 1 Sep 2019 14:46:23 -0400 (EDT) |
wingo pushed a commit to branch master
in repository guile.
commit d1cf8928802843a14c53f2a2de55bf01e75e2662
Author: Andy Wingo <address@hidden>
Date: Sun Sep 1 20:40:14 2019 +0200
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.
---
libguile/intrinsics.c | 1 +
libguile/intrinsics.h | 1 +
libguile/jit.c | 9 ++++++++
libguile/vm-engine.c | 16 ++++++++++++-
module/language/cps/effects-analysis.scm | 2 ++
module/language/cps/reify-primitives.scm | 1 +
module/language/cps/slot-allocation.scm | 2 +-
module/language/cps/specialize-numbers.scm | 9 +++++++-
module/language/cps/type-fold.scm | 37 ++++++++++++++++++++++++++++++
module/language/cps/types.scm | 14 +++++++++++
module/language/tree-il/cps-primitives.scm | 1 +
module/language/tree-il/primitives.scm | 4 ++--
module/system/vm/assembler.scm | 4 ++++
13 files changed, 96 insertions(+), 5 deletions(-)
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index a9b2d98..de03759 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 d8c6926..275a13a 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 f1c7a49..a05734f 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 6b1e20d..8c42ece 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 03a8fea..080c798 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 8165fb2..eb14c8b 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 497df7a..61a2207 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 2ef4405..7f7a70a 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 4058066..25354ad 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 0a06eb0..f4d05f5 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 e5c2544..8534599 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 cb1145e..5509217 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 a09e5f6..da8060a 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)