[Guile-commits] 01/02: Rework backend-specific CPS lowering

[Andy Wingo]

wingo pushed a commit to branch wip-tailify
in repository guile.

commit d99d03039db1622577bd019b2311fc3487924d33
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Jul 4 14:11:27 2023 +0200

    Rework backend-specific CPS lowering
    
    * module/system/base/target.scm (target-runtime): New export.
    * module/language/cps/optimize.scm (make-cps-lowerer): Load a
    backend-specific lowering module dynamically.
    
    * module/language/cps/guile-vm.scm: New module for lowering to Guile's
    VM.
    * module/language/cps/guile-vm/loop-instrumentation.scm:
    * module/language/cps/guile-vm/lower-primcalls.scm:
    * module/language/cps/guile-vm/reify-primitives.scm: Move here, from
    parent dir.
    
    * module/language/cps/hoot.scm: New module for lowering to Wasm/GC via
    Hoot.
    * module/language/cps/guile-vm/tailify.scm:
    * module/language/cps/guile-vm/unify-returns.scm: Move here, from parent
    dir.
    
    * am/bootstrap.am: Update for new file list.
---
 am/bootstrap.am                                    | 14 ++--
 module/language/cps/guile-vm.scm                   | 40 +++++++++++
 .../cps/{ => guile-vm}/loop-instrumentation.scm    |  4 +-
 .../cps/{ => guile-vm}/lower-primcalls.scm         |  2 +-
 .../cps/{ => guile-vm}/reify-primitives.scm        |  2 +-
 module/language/cps/hoot.scm                       | 80 ++++++++++++++++++++++
 module/language/cps/{ => hoot}/tailify.scm         |  2 +-
 module/language/cps/{ => hoot}/unify-returns.scm   |  2 +-
 module/language/cps/optimize.scm                   | 45 ++----------
 module/system/base/target.scm                      | 11 +++
 10 files changed, 151 insertions(+), 51 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 046a37af0..f73724c3f 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -98,12 +98,9 @@ SOURCES =                                    \
   language/cps/intmap.scm                      \
   language/cps/intset.scm                      \
   language/cps/licm.scm                                \
-  language/cps/loop-instrumentation.scm                \
-  language/cps/lower-primcalls.scm             \
   language/cps/optimize.scm                    \
   language/cps/peel-loops.scm                  \
   language/cps/prune-top-level-scopes.scm      \
-  language/cps/reify-primitives.scm            \
   language/cps/renumber.scm                    \
   language/cps/return-types.scm                        \
   language/cps/rotate-loops.scm                        \
@@ -115,15 +112,22 @@ SOURCES =                                 \
   language/cps/specialize-numbers.scm          \
   language/cps/split-rec.scm                   \
   language/cps/switch.scm                      \
-  language/cps/tailify.scm                     \
   language/cps/type-checks.scm                 \
   language/cps/type-fold.scm                   \
   language/cps/types.scm                       \
   language/cps/utils.scm                       \
-  language/cps/unify-returns.scm               \
   language/cps/verify.scm                      \
   language/cps/with-cps.scm                    \
                                                \
+  language/cps/guile-vm.scm                    \
+  language/cps/guile-vm/loop-instrumentation.scm\
+  language/cps/guile-vm/lower-primcalls.scm    \
+  language/cps/guile-vm/reify-primitives.scm   \
+                                               \
+  language/cps/hoot.scm                                \
+  language/cps/hoot/tailify.scm                        \
+  language/cps/hoot/unify-returns.scm          \
+                                               \
   ice-9/and-let-star.scm                       \
   ice-9/arrays.scm                             \
   ice-9/atomic.scm                             \
diff --git a/module/language/cps/guile-vm.scm b/module/language/cps/guile-vm.scm
new file mode 100644
index 000000000..f330128f2
--- /dev/null
+++ b/module/language/cps/guile-vm.scm
@@ -0,0 +1,40 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 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 License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Backend-specific lowering and optimization when targetting Guile's
+;;; bytecode virtual machine.
+;;;
+;;; Code:
+
+(define-module (language cps guile-vm)
+  #:use-module (ice-9 match)
+  #:use-module (language cps guile-vm loop-instrumentation)
+  #:use-module (language cps guile-vm lower-primcalls)
+  #:use-module (language cps guile-vm reify-primitives)
+  #:export (make-lowerer
+            available-optimizations))
+
+(define (make-lowerer optimization-level opts)
+  (lambda (exp env)
+    (add-loop-instrumentation
+     (reify-primitives
+      (lower-primcalls exp)))))
+
+(define (available-optimizations)
+  '())
diff --git a/module/language/cps/loop-instrumentation.scm 
b/module/language/cps/guile-vm/loop-instrumentation.scm
similarity index 94%
rename from module/language/cps/loop-instrumentation.scm
rename to module/language/cps/guile-vm/loop-instrumentation.scm
index 2f5f1fe26..c7ae95a37 100644
--- a/module/language/cps/loop-instrumentation.scm
+++ b/module/language/cps/guile-vm/loop-instrumentation.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2016, 2017, 2018, 2020 Free Software Foundation, Inc.
+;; Copyright (C) 2016, 2017, 2018, 2020, 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
@@ -22,7 +22,7 @@
 ;;;
 ;;; Code:
 
-(define-module (language cps loop-instrumentation)
+(define-module (language cps guile-vm loop-instrumentation)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps utils)
diff --git a/module/language/cps/lower-primcalls.scm 
b/module/language/cps/guile-vm/lower-primcalls.scm
similarity index 99%
rename from module/language/cps/lower-primcalls.scm
rename to module/language/cps/guile-vm/lower-primcalls.scm
index 5a07113be..e0cf19e46 100644
--- a/module/language/cps/lower-primcalls.scm
+++ b/module/language/cps/guile-vm/lower-primcalls.scm
@@ -25,7 +25,7 @@
 ;;;
 ;;; Code:
 
-(define-module (language cps lower-primcalls)
+(define-module (language cps guile-vm lower-primcalls)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps intmap)
diff --git a/module/language/cps/reify-primitives.scm 
b/module/language/cps/guile-vm/reify-primitives.scm
similarity index 99%
rename from module/language/cps/reify-primitives.scm
rename to module/language/cps/guile-vm/reify-primitives.scm
index d970b5b48..ea5ee92a6 100644
--- a/module/language/cps/reify-primitives.scm
+++ b/module/language/cps/guile-vm/reify-primitives.scm
@@ -24,7 +24,7 @@
 ;;;
 ;;; Code:
 
-(define-module (language cps reify-primitives)
+(define-module (language cps guile-vm reify-primitives)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps utils)
diff --git a/module/language/cps/hoot.scm b/module/language/cps/hoot.scm
new file mode 100644
index 000000000..5a4afc7b9
--- /dev/null
+++ b/module/language/cps/hoot.scm
@@ -0,0 +1,80 @@
+;;; Continuation-passing style (CPS) intermediate language (IL)
+
+;; Copyright (C) 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 License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public License
+;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Backend-specific lowering and optimization when targetting the Hoot
+;;; Wasm/GC run-time.
+;;;
+;;; Code:
+
+(define-module (language cps hoot)
+  #:use-module (ice-9 match)
+  #:use-module (language cps dce)
+  #:use-module (language cps simplify)
+  #:use-module (language cps verify)
+  #:use-module (language cps hoot tailify)
+  #:use-module (language cps hoot unify-returns)
+  #:export (make-lowerer
+            available-optimizations))
+
+(define *debug?* #f)
+
+(define (maybe-verify program)
+  (if *debug?*
+      (verify program)
+      program))
+
+(define-syntax-rule (define-optimizer optimize (pass kw) ...)
+  (define* (optimize program #:optional (opts '()))
+    (let* ((program (maybe-verify program))
+           (program (if (assq-ref opts kw)
+                        (maybe-verify (pass program))
+                        program))
+           ...)
+      program)))
+
+(define (available-optimizations)
+  '((#:eliminate-dead-code? 2)
+    (#:simplify? 1)))
+
+(define-optimizer optimize-hoot-backend-cps
+  (eliminate-dead-code #:eliminate-dead-code?)
+  (simplify #:simplify?))
+
+(define (select-optimizations optimization-level opts all-opts)
+  (define (kw-arg-ref args kw default)
+    (match (memq kw args)
+      ((_ val . _) val)
+      (_ default)))
+  (define (enabled-for-level? level) (<= level optimization-level))
+  (let lp ((all-opts all-opts))
+    (match all-opts
+      (() '())
+      (((kw level) . all-opts)
+       (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
+              (lp all-opts))))))
+
+(define (make-lowerer optimization-level opts)
+  (let ((opts (select-optimizations optimization-level opts
+                                    (available-optimizations))))
+    (lambda (exp env)
+      (optimize-hoot-backend-cps
+       (unify-returns
+        (tailify
+         exp))
+       opts))))
diff --git a/module/language/cps/tailify.scm 
b/module/language/cps/hoot/tailify.scm
similarity index 99%
rename from module/language/cps/tailify.scm
rename to module/language/cps/hoot/tailify.scm
index 31cf4581d..9d38df6f6 100644
--- a/module/language/cps/tailify.scm
+++ b/module/language/cps/hoot/tailify.scm
@@ -72,7 +72,7 @@
 ;;;
 ;;; Code:
 
-(define-module (language cps tailify)
+(define-module (language cps hoot tailify)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (ice-9 match)
diff --git a/module/language/cps/unify-returns.scm 
b/module/language/cps/hoot/unify-returns.scm
similarity index 99%
rename from module/language/cps/unify-returns.scm
rename to module/language/cps/hoot/unify-returns.scm
index 57529650f..62121dea2 100644
--- a/module/language/cps/unify-returns.scm
+++ b/module/language/cps/hoot/unify-returns.scm
@@ -50,7 +50,7 @@
 ;;;
 ;;; Code:
 
-(define-module (language cps unify-returns)
+(define-module (language cps hoot unify-returns)
   #:use-module (ice-9 match)
   #:use-module (language cps)
   #:use-module (language cps intmap)
diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 0e544c24e..17c2c42d1 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -30,11 +30,8 @@
   #:use-module (language cps devirtualize-integers)
   #:use-module (language cps elide-arity-checks)
   #:use-module (language cps licm)
-  #:use-module (language cps loop-instrumentation)
-  #:use-module (language cps lower-primcalls)
   #:use-module (language cps peel-loops)
   #:use-module (language cps prune-top-level-scopes)
-  #:use-module (language cps reify-primitives)
   #:use-module (language cps renumber)
   #:use-module (language cps rotate-loops)
   #:use-module (language cps return-types)
@@ -45,8 +42,6 @@
   #:use-module (language cps split-rec)
   #:use-module (language cps switch)
   #:use-module (language cps type-fold)
-  #:use-module (language cps tailify)
-  #:use-module (language cps unify-returns)
   #:use-module (language cps verify)
   #:use-module (system base optimize)
   #:use-module (system base target)
@@ -122,26 +117,13 @@
   (rotate-loops #:rotate-loops?)
   (simplify #:simplify?))
 
-(define-optimizer optimize-hoot-backend-cps
-  (eliminate-dead-code #:eliminate-dead-code?)
-  (simplify #:simplify?))
-
 (define (cps-optimizations)
   (available-optimizations 'cps))
 
-;; For the moment, this is just here.
-(define (hoot-backend-cps-optimizations)
-  '((#:simplify? 1)
-    (#:eliminate-dead-code? 1)))
-
-(define (target-runtime)
-  "Determine what kind of virtual machine we are targetting.  Usually this
-is @code{guile-vm} when generating bytecode for Guile's virtual machine,
-but it can be @code{hoot} when targetting WebAssembly."
-  (if (and (member (target-cpu) '("wasm32" "wasm64"))
-           (equal? (target-os) "hoot"))
-      'hoot
-      'guile-vm))
+(define (make-backend-cps-lowerer optimization-level opts)
+  (let* ((iface (resolve-interface `(language cps ,(target-runtime))))
+         (make-lowerer (module-ref iface 'make-lowerer)))
+    (make-lowerer optimization-level opts)))
 
 (define (lower-cps/generic exp opts)
   ;; FIXME: For now the closure conversion pass relies on $rec instances
@@ -166,26 +148,9 @@ but it can be @code{hoot} when targetting WebAssembly."
        (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
               (lp all-opts))))))
 
-(define (make-backend-cps-lowerer optimization-level opts)
-  (match (target-runtime)
-    ('guile-vm
-     (lambda (exp env)
-       (add-loop-instrumentation
-        (reify-primitives
-         (lower-primcalls exp)))))
-    ('hoot
-     (let ((opts (select-optimizations optimization-level opts
-                                       (hoot-backend-cps-optimizations))))
-       (lambda (exp env)
-         (optimize-hoot-backend-cps
-          (unify-returns
-           (tailify exp))
-          opts))))))
-
 (define (make-cps-lowerer optimization-level opts)
   (define generic-opts
-    (select-optimizations optimization-level opts
-                          (cps-optimizations)))
+    (select-optimizations optimization-level opts (cps-optimizations)))
   (define lower-cps/backend
     (make-backend-cps-lowerer optimization-level opts))
   (lambda (exp env)
diff --git a/module/system/base/target.scm b/module/system/base/target.scm
index 562bf7b51..c605b5b5d 100644
--- a/module/system/base/target.scm
+++ b/module/system/base/target.scm
@@ -26,6 +26,8 @@
 
             target-cpu target-vendor target-os
 
+            target-runtime
+
             target-endianness target-word-size
 
             target-max-size-t
@@ -159,6 +161,15 @@
   "Return the vendor name of the target platform."
   (triplet-vendor (target-type)))
 
+(define (target-runtime)
+  "Determine what kind of virtual machine we are targetting.  Usually this
+is @code{guile-vm} when generating bytecode for Guile's virtual machine,
+but it can be @code{hoot} when targetting WebAssembly."
+  (if (and (member (target-cpu) '("wasm32" "wasm64"))
+           (equal? (target-os) "hoot"))
+      'hoot
+      'guile-vm))
+
 (define (target-os)
   "Return the operating system name of the target platform."
   (triplet-os (target-type)))