[Guile-commits] 04/15: Instruction explosion for f64->scm

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 997ecae1dfdb87b589a25f1a9cc52b94a86145a0
Author: Andy Wingo <address@hidden>
Date:   Tue Apr 10 20:37:28 2018 +0200

    Instruction explosion for f64->scm
    
    * module/language/cps/reify-primitives.scm (reify-primitives): Reify
      f64->scm via low-level operations.
---
 module/language/cps/reify-primitives.scm | 33 ++++++++++++++++++++++++++++++++
 1 file changed, 33 insertions(+)

diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/reify-primitives.scm
index 84d75ca..c1ebd1c 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -31,6 +31,8 @@
   #:use-module (language cps with-cps)
   #:use-module (language cps intmap)
   #:use-module (language bytecode)
+  #:use-module (system base target)
+  #:use-module (system base types internal)
   #:export (reify-primitives))
 
 (define (module-box cps src module name public? bound? val-proc)
@@ -270,6 +272,37 @@
        (with-cps cps
          (setk label ($kargs names vars ($continue k src ($call proc ()))))))
       (($ $kargs names vars
+          ($ $continue k src ($ $primcall 'f64->scm #f (f64))))
+       (with-cps cps
+         (letv scm tag ptr uidx)
+         (letk kdone ($kargs () ()
+                       ($continue k src ($values (scm)))))
+         (letk kinit ($kargs ('uidx) (uidx)
+                       ($continue kdone src
+                         ($primcall 'f64-set! 'flonum (scm ptr uidx f64)))))
+         (letk kidx ($kargs ('ptr) (ptr)
+                      ($continue kinit src ($primcall 'load-u64 0 ()))))
+         (letk kptr ($kargs () ()
+                      ($continue kidx src
+                        ($primcall 'tail-pointer-ref/immediate
+                                   `(flonum . ,(match (target-word-size)
+                                                 (4 2)
+                                                 (8 1)))
+                                   (scm)))))
+         (letk ktag1 ($kargs ('tag) (tag)
+                       ($continue kptr src
+                         ($primcall 'word-set!/immediate '(flonum . 0) (scm 
tag)))))
+         (letk ktag0 ($kargs ('scm) (scm)
+                      ($continue ktag1 src
+                        ($primcall 'load-u64 %tc16-flonum ()))))
+         (setk label ($kargs names vars
+                       ($continue ktag0 src
+                         ($primcall 'allocate-words/immediate
+                                    `(flonum . ,(match (target-word-size)
+                                                  (4 4)
+                                                  (8 2)))
+                                    ()))))))
+      (($ $kargs names vars
           ($ $continue k src ($ $primcall 'u64->scm/unlikely #f (u64))))
        (with-cps cps
          (setk label ($kargs names vars