diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 75e1694cd..d7320059a 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) @@ -3157,13 +3165,14 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, do { \ scm_t_uint8 dst, idx, src; \ scm_t_signed_bits i; \ - SCM bv, scm_idx, val; \ + SCM bv, scm_idx; \ + double val; \ type *float_ptr; \ \ UNPACK_8_8_8 (op, dst, idx, src); \ - bv = SP_REF (dst); \ - scm_idx = SP_REF (idx); \ - val = SP_REF (src); \ + bv = SP_REF (dst); \ + scm_idx = SP_REF (idx); \ + val = SP_REF_F64 (src); \ VM_VALIDATE_BYTEVECTOR (bv, "bv-" #stem "-set!"); \ i = SCM_I_INUM (scm_idx); \ float_ptr = (type *) (SCM_BYTEVECTOR_CONTENTS (bv) + i); \ @@ -3172,11 +3181,12 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp, && (i >= 0) \ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \ && (ALIGNED_P (float_ptr, type)))) \ - *float_ptr = scm_to_double (val); \ + *float_ptr = val; \ else \ { \ + SCM boxed = scm_from_double (val); \ SYNC_IP (); \ - scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, val); \ + scm_bytevector_ ## fn_stem ## _native_set_x (bv, scm_idx, boxed); \ } \ NEXT (1); \ } while (0) 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 fc23e1691..8a2cc86d3 100644 --- a/module/language/cps/types.scm +++ b/module/language/cps/types.scm @@ -740,8 +740,8 @@ minimum, and maximum." (define-bytevector-accessors bv-s32-ref bv-s32-set! &exact-integer 4 -inf.0 +inf.0) (define-bytevector-accessors bv-u64-ref bv-u64-set! &exact-integer 8 0 +inf.0) (define-bytevector-accessors bv-s64-ref bv-s64-set! &exact-integer 8 -inf.0 +inf.0) -(define-bytevector-accessors bv-f32-ref bv-f32-set! &real 4 -inf.0 +inf.0) -(define-bytevector-accessors bv-f64-ref bv-f64-set! &real 8 -inf.0 +inf.0) +(define-bytevector-accessors bv-f32-ref bv-f32-set! &f64 4 -inf.0 +inf.0) +(define-bytevector-accessors bv-f64-ref bv-f64-set! &f64 8 -inf.0 +inf.0) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index 0664b2c4d..393b0a8f9 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -555,6 +555,33 @@ ($ (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)))) + (define (unbox-arg cps arg have-arg) + (with-cps cps + (letv f64) + (let$ body (have-arg f64)) + (letk kunboxed ($kargs ('f64) (f64) ,body)) + (build-term + ($continue kunboxed src ($primcall 'scm->f64 (arg)))))) + (define (unbox-args cps args have-args) + (case instruction + ((bv-f32-set! bv-f64-set!) + (match args + ((bv idx val) + (unbox-arg cps val + (lambda (cps val) + (have-args cps (list bv idx val))))))) + (else (have-args cps args)))) (convert-args cps args (lambda (cps args) ;; Tree-IL primcalls are sloppy, in that it could be @@ -566,10 +593,14 @@ ((out . in) (if (= in (length args)) (with-cps cps - (let$ k (adapt-arity k src out)) - (build-term - ($continue k src - ($primcall instruction args)))) + (let$ k (box+adapt-arity k src out)) + ($ (unbox-args + args + (lambda (cps args) + (with-cps cps + (build-term + ($continue k src + ($primcall instruction args)))))))) (with-cps cps (letv prim) (letk kprim ($kargs ('prim) (prim) 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)