mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 03:30:27 +02:00
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.
This commit is contained in:
Andy Wingo
parent
74f14562a6
commit
d1cf892880
13 changed files with 96 additions and 5 deletions
|
|
@ -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",
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -314,6 +314,7 @@
|
|||
quo
|
||||
rem
|
||||
mod
|
||||
inexact
|
||||
sqrt
|
||||
abs
|
||||
floor
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue