[Guile-commits] 20/21: bv-f32-set!, bv-f64-set! take unboxed args

[Andy Wingo]

wingo pushed a commit to branch wip-2.1.2
in repository guile.

commit c09a2f85b6e29e00f9ff115cdc3cf77bead40b31
Author: Andy Wingo <address@hidden>
Date:   Wed Oct 28 22:23:18 2015 +0000

    bv-f32-set!, bv-f64-set! take unboxed args
    
    * module/language/tree-il/compile-cps.scm (convert): Unbox the argument
      to bv-f32-set! and bv-f64-set!.
    
    * libguile/vm-engine.c (bv-f32-set!, bv-f64-set!): Take unboxed
      arguments.
---
 libguile/vm-engine.c                    |   14 ++++++++------
 module/language/tree-il/compile-cps.scm |   26 +++++++++++++++++++++++---
 2 files changed, 31 insertions(+), 9 deletions(-)

diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 82ae1c0..d732005 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3165,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);            \
@@ -3180,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/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 88e7298..393b0a8 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -566,6 +566,22 @@
                    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
@@ -578,9 +594,13 @@
                    (if (= in (length args))
                        (with-cps cps
                          (let$ k (box+adapt-arity k src out))
-                         (build-term
-                           ($continue k src
-                             ($primcall instruction args))))
+                         ($ (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)