mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 11:10:25 +02:00
Code Activity

Move f64->scm lowering to lower-primcalls

Browse source 
* module/language/cps/lower-primcalls.scm (f64->scm): Move here...
* module/language/cps/reify-primitives.scm (reify-primitives): from
here.  Seems a more fitting place.
This commit is contained in:
Andy Wingo 2023-06-22 09:20:25 +02:00
parent a5b245d2d0
commit eb6d5abcbe
2 changed files with 32 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/language/cps/lower-primcalls.scm
View file

@ -566,6 +566,37 @@
($continue k src ($continue k src
($primcall 'scm-set!/immediate `(closure . ,pos) (closure val))))))) ($primcall 'scm-set!/immediate `(closure . ,pos) (closure val)))))))
(define-primcall-lowerer (f64->scm cps k src #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 ()))))
(build-term
($continue ktag0 src
($primcall 'allocate-pointerless-words/immediate
`(flonum . ,(match (target-word-size)
(4 4)
(8 2)))
())))))
(define (lower-primcalls cps) (define (lower-primcalls cps)
(with-fresh-name-state cps (with-fresh-name-state cps
(persistent-intmap (persistent-intmap

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

@ -1,6 +1,6 @@
;;; Continuation-passing style (CPS) intermediate language (IL) ;;; Continuation-passing style (CPS) intermediate language (IL)
;; Copyright (C) 2013-2021 Free Software Foundation, Inc. ;; Copyright (C) 2013-2021, 2023 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -385,37 +385,6 @@
($ $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-pointerless-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