Introduce target-runtime parameter for 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.

* am/bootstrap.am: Update for new file list.

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			\
@@ -122,6 +119,11 @@ SOURCES =					\
   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	\
+						\
   ice-9/and-let-star.scm			\
   ice-9/arrays.scm				\
   ice-9/atomic.scm				\

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)
+  '())

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)

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)

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)

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)
@@ -47,6 +44,7 @@
   #:use-module (language cps type-fold)
   #:use-module (language cps verify)
   #:use-module (system base optimize)
+  #:use-module (system base target)
   #:export (optimize-higher-order-cps
             optimize-first-order-cps
             cps-optimizations
@@ -122,6 +120,11 @@
 (define (cps-optimizations)
   (available-optimizations 'cps))
 
+(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
   ;; being separated into SCCs.  We should fix this to not be the case,
@@ -132,7 +135,7 @@
   (set! exp (convert-closures exp))
   (optimize-first-order-cps exp opts))
 
-(define (select-opts-for-optimization-level optimization-level opts all-opts)
+(define (select-optimizations optimization-level opts all-opts)
   (define (kw-arg-ref args kw default)
     (match (memq kw args)
       ((_ val . _) val)
@@ -145,16 +148,9 @@
        (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
               (lp all-opts))))))
 
-(define (make-backend-cps-lowerer optimization-level opts)
-  (lambda (exp env)
-    (add-loop-instrumentation
-     (reify-primitives
-      (lower-primcalls exp)))))
-
 (define (make-cps-lowerer optimization-level opts)
   (define generic-opts
-    (select-opts-for-optimization-level 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)

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
@@ -157,6 +159,14 @@
   "Return the vendor name of the target platform."
   (triplet-vendor (target-type)))
 
+(define target-runtime
+  (make-parameter
+   'guile-vm
+   (lambda (val)
+     "Determine what kind of virtual machine we are targetting.  Usually this
+is @code{guile-vm} when generating bytecode for Guile's virtual machine."
+     val)))
+
 (define (target-os)
   "Return the operating system name of the target platform."
   (triplet-os (target-type)))