diff options
author | Andy Wingo <wingo@pobox.com> | 2015-10-28 18:35:20 +0000 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-10-28 18:35:20 +0000 |
commit | 7d97f0ebcfa9a9a4e7edb1cb89af56630e25ec36 (patch) | |
tree | 875910c80dc2c65b18a89915fce38c6baf835c80 | |
parent | 5bbc47b06d9e236b8a2fa2d92cdc8234bc037838 (diff) | |
download | guile-7d97f0ebcfa9a9a4e7edb1cb89af56630e25ec36.tar.gz |
bv-f32-ref and bv-f64-ref return raw f64 values
* module/language/tree-il/compile-cps.scm (convert): Box results of
bv-f32-ref and bv-f64-ref.
* libguile/vm-engine.c (bv-f32-ref, bv-f64-ref): Results are raw.
* module/system/vm/assembler.scm (emit-scm->f64, emit-f64->scm):
Export.
* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/types.scm: Add support for scm->f64 and f64->scm.
* module/language/cps/slot-allocation.scm (compute-var-representations):
Add cases for primops returning raw values.
-rw-r--r-- | libguile/vm-engine.c | 14 | ||||
-rw-r--r-- | module/language/cps/compile-bytecode.scm | 4 | ||||
-rw-r--r-- | module/language/cps/effects-analysis.scm | 5 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 4 | ||||
-rw-r--r-- | module/language/cps/types.scm | 18 | ||||
-rw-r--r-- | module/language/tree-il/compile-cps.scm | 13 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 2 |
7 files changed, 53 insertions, 7 deletions
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 75e1694cd..82ae1c0cb 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -3032,14 +3032,22 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, i = SCM_I_INUM (idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ \ - SYNC_IP (); \ if (SCM_LIKELY (SCM_I_INUMP (idx) \ && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ - RETURN (scm_from_double (*float_ptr)); \ + { \ + SP_SET_F64 (dst, *float_ptr); \ + NEXT (1); \ + } \ else \ - RETURN (scm_bytevector_ ## fn_stem ## _native_ref (bv, idx)); \ + { \ + SCM val; \ + SYNC_IP (); \ + val = scm_bytevector_ ## fn_stem ## _native_ref (bv, idx); \ + SP_SET_F64 (dst, scm_to_double (val)); \ + NEXT (1); \ + } \ } while (0) VM_DEFINE_OP (116, bv_u8_ref, "bv-u8-ref", OP1 (X8_S8_S8_S8) | OP_DST) diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm index 96200a83d..49b684cc4 100644 --- a/module/language/cps/compile-bytecode.scm +++ b/module/language/cps/compile-bytecode.scm @@ -181,6 +181,10 @@ (constant n))) (($ $primcall 'builtin-ref (name)) (emit-builtin-ref asm (from-sp dst) (constant name))) + (($ $primcall 'scm->f64 (src)) + (emit-scm->f64 asm (from-sp dst) (from-sp (slot src)))) + (($ $primcall 'f64->scm (src)) + (emit-f64->scm asm (from-sp dst) (from-sp (slot src)))) (($ $primcall 'bv-u8-ref (bv idx)) (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv)) (from-sp (slot idx)))) diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm index 778855de5..3542a1e74 100644 --- a/module/language/cps/effects-analysis.scm +++ b/module/language/cps/effects-analysis.scm @@ -351,6 +351,11 @@ is or might be a read or a write to the same location as A." ((string->number _) (&read-object &string) &type-check) ((string-length s) &type-check)) +;; Unboxed floats. +(define-primitive-effects + ((scm->f64 _) &type-check) + ((f64->scm _))) + ;; Bytevectors. (define-primitive-effects ((bytevector-length _) &type-check) diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index ad4e524e7..6fc2a5399 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -790,9 +790,7 @@ are comparable with eqv?. A tmp slot may be used." (($ $values (arg)) (intmap-add representations var (intmap-ref representations arg))) - ;; FIXME: Placeholder for as-yet-unwritten primitive - ;; operations that define unboxed f64 values. - (($ $primcall 'scm->f64) + (($ $primcall (or 'scm->f64 'bv-f32-ref 'bv-f64-ref)) (intmap-add representations var 'f64)) (_ (intmap-add representations var 'scm)))) diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm index 55cde2744..74b5d48de 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -673,6 +673,24 @@ minimum, and maximum." ;;; +;;; Unboxed double-precision floating-point numbers. +;;; + +(define-type-checker (scm->f64 scm) + (check-type scm &real -inf.0 +inf.0)) +(define-type-inferrer (scm->f64 scm result) + (restrict! scm &flonum -inf.0 +inf.0) + (define! result &flonum (&min scm) (&max scm))) + +(define-type-checker (f64->scm f64) + #t) +(define-type-inferrer (f64->scm f64 result) + (define! result &flonum (&min f64) (&max f64))) + + + + +;;; ;;; Bytevectors. ;;; diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 0664b2c4d..88e729852 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -555,6 +555,17 @@ ($ (lp args ktail))))))))))) ((prim-instruction name) => (lambda (instruction) + (define (box+adapt-arity cps k src out) + (case instruction + ((bv-f32-ref bv-f64-ref) + (with-cps cps + (letv f64) + (let$ k (adapt-arity k src out)) + (letk kbox ($kargs ('f64) (f64) + ($continue k src ($primcall 'f64->scm (f64))))) + kbox)) + (else + (adapt-arity cps k src out)))) (convert-args cps args (lambda (cps args) ;; Tree-IL primcalls are sloppy, in that it could be @@ -566,7 +577,7 @@ ((out . in) (if (= in (length args)) (with-cps cps - (let$ k (adapt-arity k src out)) + (let$ k (box+adapt-arity k src out)) (build-term ($continue k src ($primcall instruction args)))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index dd96709e5..9cb04bbed 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -155,6 +155,8 @@ (emit-struct-set!* . emit-struct-set!) (emit-class-of* . emit-class-of) emit-make-array + (emit-scm->f64* . emit-scm->f64) + (emit-f64->scm* . emit-f64->scm) (emit-bv-u8-ref* . emit-bv-u8-ref) (emit-bv-s8-ref* . emit-bv-s8-ref) (emit-bv-u16-ref* . emit-bv-u16-ref) |