mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-02 15:40:38 +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

5
module/system/vm/assembler.scm
View file

@ -210,6 +210,7 @@
emit-scm->u64
emit-scm->u64/truncate
emit-scm->s64
emit-f64->scm
emit-u64->scm
emit-s64->scm
emit-wind
@ -1336,6 +1337,9 @@ returned instead."
(define-syntax-rule (define-s64<-scm-intrinsic name)
(define-macro-assembler (name asm dst src)
(emit-call-s64<-scm asm dst src (intrinsic-name->index 'name))))
(define-syntax-rule (define-scm<-f64-intrinsic name)
(define-macro-assembler (name asm dst src)
(emit-call-scm<-f64 asm dst src (intrinsic-name->index 'name))))
(define-syntax-rule (define-scm<-u64-intrinsic name)
(define-macro-assembler (name asm dst src)
(emit-call-scm<-u64 asm dst src (intrinsic-name->index 'name))))
@ -1386,6 +1390,7 @@ returned instead."
(define-u64<-scm-intrinsic scm->u64)
(define-u64<-scm-intrinsic scm->u64/truncate)
(define-s64<-scm-intrinsic scm->s64)
(define-scm<-f64-intrinsic f64->scm)
(define-scm<-u64-intrinsic u64->scm)
(define-scm<-s64-intrinsic s64->scm)
(define-thread-scm-scm-intrinsic wind)