mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-14 17:50:22 +02:00
Code Activity

DRAFT: Change f64->scm into an intrinsic.

Browse source
This commit is contained in:
Mark H Weaver 2019-06-05 22:23:46 -04:00
parent 87f32999b9
commit de42f12099
7 changed files with 56 additions and 33 deletions
Download patch file Download diff file Expand all files Collapse all files

2
module/language/cps/compile-bytecode.scm
View file

@ -217,6 +217,8 @@
(emit-scm->f64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'load-f64 val ())
(emit-load-f64 asm (from-sp dst) val))
(($ $primcall 'f64->scm #f (src))
(emit-f64->scm asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64 #f (src))
(emit-scm->u64 asm (from-sp dst) (from-sp (slot src))))
(($ $primcall 'scm->u64/truncate #f (src))

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

@ -323,7 +323,7 @@
string->symbol
symbol->keyword
class-of
scm->f64
scm->f64 f64->scm
s64->u64 s64->scm scm->s64
u64->s64 u64->scm scm->u64 scm->u64/truncate
wind unwind
@ -368,37 +368,6 @@
($ $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