diff options
author | Andy Wingo <wingo@pobox.com> | 2023-06-22 09:20:25 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2023-06-22 16:01:44 +0200 |
commit | eb6d5abcbe7a33cb673c778da3d535cb1f540659 (patch) | |
tree | cd93c5bb16b0455845813bddd3268af1ac51fd88 | |
parent | a5b245d2d00719d35741112a0bab14ade119b176 (diff) | |
download | guile-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.scm | 31 | ||||
-rw-r--r-- | 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 @@ -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 |