diff options
author | Andy Wingo <wingo@pobox.com> | 2019-09-01 20:40:14 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2019-09-01 20:46:04 +0200 |
commit | d1cf8928802843a14c53f2a2de55bf01e75e2662 (patch) | |
tree | 22b5f290b8c5f3a60f8241068dda424eee045f88 | |
parent | 74f14562a65c34929176a290a5a9c421b1854046 (diff) | |
download | guile-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.c | 1 | ||||
-rw-r--r-- | libguile/intrinsics.h | 1 | ||||
-rw-r--r-- | libguile/jit.c | 9 | ||||
-rw-r--r-- | libguile/vm-engine.c | 16 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 2 | ||||
-rw-r--r-- | module/language/cps/reify-primitives.scm | 1 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 2 | ||||
-rw-r--r-- | module/language/cps/specialize-numbers.scm | 9 | ||||
-rw-r--r-- | module/language/cps/type-fold.scm | 37 | ||||
-rw-r--r-- | module/language/cps/types.scm | 14 | ||||
-rw-r--r-- | module/language/tree-il/cps-primitives.scm | 1 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 4 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 4 |
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) |