summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2018-04-10 20:37:28 +0200
committerAndy Wingo <wingo@pobox.com>2018-04-10 20:37:28 +0200
commit997ecae1dfdb87b589a25f1a9cc52b94a86145a0 (patch)
treee69703989ba3db997be45f8912af7939e890205a
parentc109fa7eb810f8059e33dc0234fcebd214921880 (diff)
Instruction explosion for f64->scm
* module/language/cps/reify-primitives.scm (reify-primitives): Reify f64->scm via low-level operations.
-rw-r--r--module/language/cps/reify-primitives.scm33
1 files changed, 33 insertions, 0 deletions
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)
@@ -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