[Guile-commits] branch master updated: Tree-IL lowerer only loads needed optimizations

[Andy Wingo]

This is an automated email from the git hooks/post-receive script.

wingo pushed a commit to branch master
in repository guile.

The following commit(s) were added to refs/heads/master by this push:
     new 2c07a32  Tree-IL lowerer only loads needed optimizations
2c07a32 is described below

commit 2c07a32ad85d6fce8a0e09bb457e7ff1885b4615
Author: Andy Wingo <address@hidden>
AuthorDate: Thu May 14 10:24:08 2020 +0200

    Tree-IL lowerer only loads needed optimizations
    
    * module/language/tree-il/optimize.scm (make-optimizer): New procedure,
      to compute an optimizer given options, lazily loading optimization
      modules.
      (optimize): Use make-optimizer.
      (make-lowerer): Use make-optimizer, so as to only load needed
      optimizations.  Speeds up bootstrap times.
---
 module/language/tree-il/optimize.scm | 76 ++++++++++++++++++------------------
 1 file changed, 39 insertions(+), 37 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 4fc75b6..5efc7ee 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -19,43 +19,46 @@
 ;;; Code:
 
 (define-module (language tree-il optimize)
-  #:use-module (language tree-il)
-  #:use-module (language tree-il debug)
-  #:use-module (language tree-il eta-expand)
-  #:use-module (language tree-il fix-letrec)
-  #:use-module (language tree-il letrectify)
-  #:use-module (language tree-il peval)
-  #:use-module (language tree-il primitives)
   #:use-module (ice-9 match)
+  ;; FIXME: Perhaps allow bootstrap builds to skip fix-letrec, because
+  ;; it imports intset, intmap, etc.
+  #:use-module (language tree-il fix-letrec)
   #:use-module (system base optimize)
   #:export (optimize
             make-lowerer
             tree-il-optimizations))
 
-(define *debug?* #f)
-
-(define (maybe-verify x)
-  (if *debug?*
-      (verify-tree-il x)
-      x))
+(define (make-optimizer opts)
+  (define-syntax lookup
+    (syntax-rules ()
+      ((lookup kw id)
+       (lookup kw id id))
+      ((lookup kw submodule proc)
+       (and (assq-ref opts kw)
+            (module-ref (resolve-interface '(language tree-il submodule))
+                        'proc)))))
+  (let ((verify     (or (lookup #:verify-tree-il? debug verify-tree-il)
+                        (lambda (exp) exp)))
+        (resolve    (lookup #:resolve-primitives? primitives 
resolve-primitives))
+        (expand     (lookup #:expand-primitives? primitives expand-primitives))
+        (letrectify (lookup #:letrectify? letrectify))
+        (seal?      (assq-ref opts #:seal-private-bindings?))
+        (peval      (lookup #:partial-eval? peval))
+        (eta-expand (lookup #:eta-expand? eta-expand)))
+    (define-syntax-rule (run-pass! (proc exp arg ...))
+      (when proc (set! exp (verify (proc exp arg ...)))))
+    (lambda (exp env)
+      (verify exp)
+      (run-pass! (resolve exp env))
+      (run-pass! (expand exp))
+      (run-pass! (letrectify exp))
+      (run-pass! (fix-letrec exp))
+      (run-pass! (peval exp env))
+      (run-pass! (eta-expand exp))
+      exp)))
 
 (define (optimize x env opts)
-  (define-syntax-rule (run-pass pass kw)
-    (when (assq-ref opts kw)
-      (set! x (maybe-verify (pass x)))))
-  (define (resolve* x) (resolve-primitives x env))
-  (define (peval* x) (peval x env))
-  (define (letrectify* x)
-    (let ((seal? (assq-ref opts #:seal-private-bindings?)))
-      (letrectify x #:seal-private-bindings? seal?)))
-  (maybe-verify x)
-  (run-pass resolve*           #:resolve-primitives?)
-  (run-pass expand-primitives  #:expand-primitives?)
-  (run-pass letrectify*        #:letrectify?)
-  (set! x (fix-letrec x))
-  (run-pass peval*             #:partial-eval?)
-  (run-pass eta-expand         #:eta-expand?)
-  x)
+  ((make-optimizer opts) x env))
 
 (define (tree-il-optimizations)
   (available-optimizations 'tree-il))
@@ -66,11 +69,10 @@
       ((_ val . _) val)
       (_ default)))
   (define (enabled-for-level? level) (<= level optimization-level))
-  (let ((opts (let lp ((all-opts (tree-il-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)
-      (optimize exp env opts))))
+  (make-optimizer
+   (let lp ((all-opts (tree-il-optimizations)))
+     (match all-opts
+       (() '())
+       (((kw level) . all-opts)
+        (acons kw (kw-arg-ref opts kw (enabled-for-level? level))
+               (lp all-opts)))))))