mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

Instruction explosion for f64->scm

Browse source 
* module/language/cps/reify-primitives.scm (reify-primitives): Reify
  f64->scm via low-level operations.
This commit is contained in:
Andy Wingo 2018-04-10 20:37:28 +02:00
parent c109fa7eb8
commit 997ecae1df
1 changed files with 33 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

33
module/language/cps/reify-primitives.scm
View file

@ -31,6 +31,8 @@
#:use-module (language cps with-cps) #:use-module (language cps with-cps)
#:use-module (language cps intmap) #:use-module (language cps intmap)
#:use-module (language bytecode) #:use-module (language bytecode)
#:use-module (system base target)
#:use-module (system base types internal)
#:export (reify-primitives)) #:export (reify-primitives))
(define (module-box cps src module name public? bound? val-proc) (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)))) ($ $continue k src ($ $primcall 'call-thunk/no-inline #f (proc))))
(with-cps cps (with-cps cps
(setk label ($kargs names vars ($continue k src ($call proc ())))))) (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 (($ $kargs names vars
($ $continue k src ($ $primcall 'u64->scm/unlikely #f (u64)))) ($ $continue k src ($ $primcall 'u64->scm/unlikely #f (u64))))
(with-cps cps (with-cps cps