From 997ecae1dfdb87b589a25f1a9cc52b94a86145a0 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 10 Apr 2018 20:37:28 +0200
Subject: [PATCH] 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 84d75caf3..c1ebd1cf3 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)
@@ -269,6 +271,37 @@
           ($ $continue k src ($ $primcall 'call-thunk/no-inline #f (proc))))
        (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