[Guile-commits] 03/19: Wire in lower-primitives pass

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit a5b245d2d00719d35741112a0bab14ade119b176
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Thu Jun 22 09:30:39 2023 +0200

    Wire in lower-primitives pass
    
    * module/language/cps/optimize.scm (lower-cps/generic): Rename from
    lower-cps; these are the lowerings that apply to everyone.
    (select-opts-for-optimization-level): Factor out of make-cps-lowerer.
    (make-backend-cps-lowerer): New procedure.  For the Guile VM backend, we
    have a few mandatory passes, including the new lower-primitives.
    (make-cps-lowerer): Apply backend-specific lowering pass.
---
 module/language/cps/optimize.scm | 44 ++++++++++++++++++++++++++--------------
 1 file changed, 29 insertions(+), 15 deletions(-)

diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 6c48bc93e..ce8e51f7b 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -1,6 +1,6 @@
 ;;; Continuation-passing style (CPS) intermediate language (IL)
 
-;; Copyright (C) 2013-2018,2020,2021 Free Software Foundation, Inc.
+;; Copyright (C) 2013-2018,2020,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 License as published by
@@ -31,6 +31,7 @@
   #: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)
@@ -121,7 +122,7 @@
 (define (cps-optimizations)
   (available-optimizations 'cps))
 
-(define (lower-cps exp 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,
   ;; and instead move the split-rec pass back to
@@ -129,22 +130,35 @@
   (set! exp (split-rec exp))
   (set! exp (optimize-higher-order-cps exp opts))
   (set! exp (convert-closures exp))
-  (set! exp (optimize-first-order-cps exp opts))
-  (set! exp (reify-primitives exp))
-  (set! exp (add-loop-instrumentation exp))
-  (renumber exp))
+  (optimize-first-order-cps exp opts))
 
-(define (make-cps-lowerer optimization-level opts)
+(define (select-opts-for-optimization-level 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 ((opts (let lp ((all-opts (cps-optimizations)))
-                (match all-opts
-                  (() '())
-                  (((kw level) . all-opts)
-                   (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
-                          (lp all-opts)))))))
-    (lambda (exp env)
-      (lower-cps exp opts))))
+  (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-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)))
+  (define lower-cps/backend
+    (make-backend-cps-lowerer optimization-level opts))
+  (lambda (exp env)
+    (renumber
+     (lower-cps/backend
+      (lower-cps/generic exp generic-opts)
+      env))))