[Guile-commits] 08/13: Add f32-ref, f64-ref lowering procs

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 1b955b01c37c5d762daeaa09311a5a0f52491f4d
Author: Andy Wingo <address@hidden>
Date:   Mon Jan 15 20:51:00 2018 +0100

    Add f32-ref, f64-ref lowering procs
    
    * module/language/tree-il/compile-cps.scm (bytevector-ref-converter):
      Take kind as tag, not boolean.  Support floats.  Adapt and add
      lowerers for float-ref procedures.
---
 module/language/tree-il/compile-cps.scm | 82 ++++++++++++++++++---------------
 1 file changed, 46 insertions(+), 36 deletions(-)

diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 7e0ef91..4d57329 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -716,31 +716,38 @@
               ($primcall 'word-ref/immediate '(bytevector . 1) (bv)))))
     ($ (ensure-bytevector klen src op pred bv))))
 
-(define (bytevector-ref-converter scheme-name ptr-op width signed?)
+(define (bytevector-ref-converter scheme-name ptr-op width kind)
   (define tag
-    (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
-        (if signed?
-            (lambda (cps k src val)
-              (with-cps cps
-                (build-term
-                  ($continue k src ($primcall 'tag-fixnum #f (val))))))
-            (lambda (cps k src val)
-              (with-cps cps
-                (letv s)
-                (letk kcvt
-                      ($kargs ('s) (s)
-                        ($continue k src ($primcall 'tag-fixnum #f (s)))))
-                (build-term
-                  ($continue kcvt src ($primcall 'u64->s64 #f (val)))))))
-        (if signed?
-            (lambda (cps k src val)
-              (with-cps cps
-                (build-term
-                  ($continue k src ($primcall 's64->scm #f (val))))))
-            (lambda (cps k src val)
-              (with-cps cps
-                (build-term
-                  ($continue k src ($primcall 'u64->scm #f (val)))))))))
+    (match kind
+      ('unsigned
+       (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
+           (lambda (cps k src val)
+             (with-cps cps
+               (letv s)
+               (letk kcvt
+                     ($kargs ('s) (s)
+                       ($continue k src ($primcall 'tag-fixnum #f (s)))))
+               (build-term
+                 ($continue kcvt src ($primcall 'u64->s64 #f (val))))))
+           (lambda (cps k src val)
+             (with-cps cps
+               (build-term
+                 ($continue k src ($primcall 'u64->scm #f (val))))))))
+      ('signed
+       (if (< (ash 1 (* width 8)) (target-most-positive-fixnum))
+           (lambda (cps k src val)
+             (with-cps cps
+               (build-term
+                 ($continue k src ($primcall 'tag-fixnum #f (val))))))
+           (lambda (cps k src val)
+             (with-cps cps
+               (build-term
+                 ($continue k src ($primcall 's64->scm #f (val))))))))
+      ('float
+       (lambda (cps k src val)
+         (with-cps cps
+           (build-term
+             ($continue k src ($primcall 'f64->scm #f (val)))))))))
   (lambda (cps k src op param bv idx)
     (prepare-bytevector-access
      cps src scheme-name 'bytevector? bv idx width
@@ -754,23 +761,25 @@
              ($primcall ptr-op 'bytevector (bv ptr uidx)))))))))
 
 (define-syntax-rule (define-bytevector-ref-converter
-                      cps-name scheme-name op width signed?)
+                      cps-name scheme-name op width kind)
   (define-primcall-converter cps-name
-    (bytevector-ref-converter 'scheme-name 'op width signed?)))
+    (bytevector-ref-converter 'scheme-name 'op width 'kind)))
 (define-syntax-rule (define-bytevector-ref-converters (cvt ...) ...)
   (begin
     (define-bytevector-ref-converter cvt ...)
     ...))
 
 (define-bytevector-ref-converters
-  (bv-u8-ref  bytevector-u8-ref         u8-ref  1 #f)
-  (bv-u16-ref bytevector-u16-native-ref u16-ref 2 #f)
-  (bv-u32-ref bytevector-u32-native-ref u32-ref 4 #f)
-  (bv-u64-ref bytevector-u64-native-ref u64-ref 8 #f)
-  (bv-s8-ref  bytevector-s8-ref         s8-ref  1 #t)
-  (bv-s16-ref bytevector-s16-native-ref s16-ref 2 #t)
-  (bv-s32-ref bytevector-s32-native-ref s32-ref 4 #t)
-  (bv-s64-ref bytevector-s64-native-ref s64-ref 8 #t))
+  (bv-u8-ref  bytevector-u8-ref                 u8-ref  1 unsigned)
+  (bv-u16-ref bytevector-u16-native-ref         u16-ref 2 unsigned)
+  (bv-u32-ref bytevector-u32-native-ref         u32-ref 4 unsigned)
+  (bv-u64-ref bytevector-u64-native-ref         u64-ref 8 unsigned)
+  (bv-s8-ref  bytevector-s8-ref                 s8-ref  1 signed)
+  (bv-s16-ref bytevector-s16-native-ref         s16-ref 2 signed)
+  (bv-s32-ref bytevector-s32-native-ref         s32-ref 4 signed)
+  (bv-s64-ref bytevector-s64-native-ref         s64-ref 8 signed)
+  (bv-f32-ref bytevector-ieee-single-native-ref f32-ref 4 float)
+  (bv-f64-ref bytevector-ieee-double-native-ref f64-ref 8 float))
 
 (define-primcall-converters
   (char->integer scm >u64)
@@ -783,8 +792,9 @@
   (struct-ref scm u64 >scm) (struct-set! scm u64 scm)
 
   (bv-length scm >u64)
-  (bv-f32-ref scm u64 >f64) (bv-f32-set! scm u64 f64)
-  (bv-f64-ref scm u64 >f64) (bv-f64-set! scm u64 f64)
+
+  (bv-f32-set! scm u64 f64)
+  (bv-f64-set! scm u64 f64)
 
   (bv-u8-set! scm u64 u64)
   (bv-u16-set! scm u64 u64)