summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2023-06-22 09:20:25 +0200
committerAndy Wingo <wingo@pobox.com>2023-06-22 16:01:44 +0200
commiteb6d5abcbe7a33cb673c778da3d535cb1f540659 (patch)
treecd93c5bb16b0455845813bddd3268af1ac51fd88
parenta5b245d2d00719d35741112a0bab14ade119b176 (diff)
downloadguile-eb6d5abcbe7a33cb673c778da3d535cb1f540659.tar.gz
Move f64->scm lowering to lower-primcalls
* 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.
-rw-r--r--module/language/cps/lower-primcalls.scm31
-rw-r--r--module/language/cps/reify-primitives.scm33
2 files changed, 32 insertions, 32 deletions
diff --git a/module/language/cps/lower-primcalls.scm b/module/language/cps/lower-primcalls.scm
index 0b013cc85..f1787b3f2 100644
--- a/module/language/cps/lower-primcalls.scm
+++ b/module/language/cps/lower-primcalls.scm
@@ -566,6 +566,37 @@
($continue k src
($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)
(with-fresh-name-state cps
(persistent-intmap
diff --git a/module/language/cps/reify-primitives.scm b/module/language/cps/reify-primitives.scm
index 5f4241565..7faba6013 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/reify-primitives.scm
@@ -1,6 +1,6 @@
;;; 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
;;;; modify it under the terms of the GNU Lesser General Public
@@ -386,37 +386,6 @@
(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-pointerless-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