wingo pushed a commit to branch master in repository guile. commit 997ecae1dfdb87b589a25f1a9cc52b94a86145a0 Author: Andy Wingo <wi...@pobox.com> 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