[Guile-commits] 04/19: Move f64->scm lowering to lower-primcalls

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit eb6d5abcbe7a33cb673c778da3d535cb1f540659
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 22 09:20:25 2023 +0200

    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.
---
 module/language/cps/lower-primcalls.scm  | 31 ++++++++++++++++++++++++++++++
 module/language/cps/reify-primitives.scm | 33 +-------------------------------
 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
@@ -385,37 +385,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-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