[Guile-commits] 03/03: Fix optimizers after language lowerer refactor

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit c5da9d65a7e7741535694ddebd8207a76294c922
Author: Andy Wingo <address@hidden>
AuthorDate: Wed May 13 08:59:04 2020 +0200

    Fix optimizers after language lowerer refactor
    
    * module/language/cps/optimize.scm (define-optimizer):
      (optimize-higher-order-cps, optimize-first-order-cps):
      (make-cps-lowerer):
    * module/language/tree-il/optimize.scm (optimize, make-lowerer): In an
      embarrassing bug, after parsing optimization arguments, we were
      aconsing them instead of the expected cons*.  This meant the bootstrap
      was running all Tree-IL optimizations!  Change to have optimizers not
      have defaults and use alists after parsing.
---
 module/language/cps/optimize.scm     | 55 ++++++++++++++++++------------------
 module/language/tree-il/optimize.scm | 25 ++++++++--------
 2 files changed, 39 insertions(+), 41 deletions(-)

diff --git a/module/language/cps/optimize.scm b/module/language/cps/optimize.scm
index 590d2a4..632b2ca 100644
--- a/module/language/cps/optimize.scm
+++ b/module/language/cps/optimize.scm
@@ -48,11 +48,6 @@
             cps-optimizations
             make-cps-lowerer))
 
-(define (kw-arg-ref args kw default)
-  (match (memq kw args)
-    ((_ val . _) val)
-    (_ default)))
-
 (define *debug?* #f)
 
 (define (maybe-verify program)
@@ -60,7 +55,7 @@
       (verify program)
       program))
 
-(define-syntax-rule (define-optimizer optimize (pass kw default) ...)
+(define-syntax-rule (define-optimizer optimize (pass kw) ...)
   (define* (optimize program #:optional (opts '()))
     ;; This series of assignments to `program' used to be a series of
     ;; let* bindings of `program', as you would imagine.  In compiled
@@ -76,7 +71,7 @@
     ;; set!.
     (maybe-verify program)
     (set! program
-      (if (kw-arg-ref opts kw default)
+      (if (assq-ref opts kw)
           (maybe-verify (pass program))
           program))
     ...
@@ -92,30 +87,30 @@
   ;; unconditionally, because closure conversion requires it.  Move the
   ;; pass back here when that's fixed.
   ;;
-  ;; (split-rec #:split-rec? #t)
-  (eliminate-dead-code #:eliminate-dead-code? #t)
-  (prune-top-level-scopes #:prune-top-level-scopes? #t)
-  (simplify #:simplify? #t)
-  (contify #:contify? #t)
-  (simplify #:simplify? #t)
-  (devirtualize-integers #:devirtualize-integers? #t)
-  (peel-loops #:peel-loops? #t)
-  (eliminate-common-subexpressions #:cse? #t)
-  (type-fold #:type-fold? #t)
-  (resolve-self-references #:resolve-self-references? #t)
-  (eliminate-dead-code #:eliminate-dead-code? #t)
-  (simplify #:simplify? #t))
+  ;; (split-rec #:split-rec?)
+  (eliminate-dead-code #:eliminate-dead-code?)
+  (prune-top-level-scopes #:prune-top-level-scopes?)
+  (simplify #:simplify?)
+  (contify #:contify?)
+  (simplify #:simplify?)
+  (devirtualize-integers #:devirtualize-integers?)
+  (peel-loops #:peel-loops?)
+  (eliminate-common-subexpressions #:cse?)
+  (type-fold #:type-fold?)
+  (resolve-self-references #:resolve-self-references?)
+  (eliminate-dead-code #:eliminate-dead-code?)
+  (simplify #:simplify?))
 
 (define-optimizer optimize-first-order-cps
-  (specialize-numbers #:specialize-numbers? #t)
-  (hoist-loop-invariant-code #:licm? #t)
-  (specialize-primcalls #:specialize-primcalls? #t)
-  (eliminate-common-subexpressions #:cse? #t)
-  (eliminate-dead-code #:eliminate-dead-code? #t)
+  (specialize-numbers #:specialize-numbers?)
+  (hoist-loop-invariant-code #:licm?)
+  (specialize-primcalls #:specialize-primcalls?)
+  (eliminate-common-subexpressions #:cse?)
+  (eliminate-dead-code #:eliminate-dead-code?)
   ;; Running simplify here enables rotate-loops to do a better job.
-  (simplify #:simplify? #t)
-  (rotate-loops #:rotate-loops? #t)
-  (simplify #:simplify? #t))
+  (simplify #:simplify?)
+  (rotate-loops #:rotate-loops?)
+  (simplify #:simplify?))
 
 (define (cps-optimizations)
   (available-optimizations 'cps))
@@ -134,6 +129,10 @@
   (renumber exp))
 
 (define (make-cps-lowerer optimization-level 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
diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 6c64e17..4fc75b6 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -32,11 +32,6 @@
             make-lowerer
             tree-il-optimizations))
 
-(define (kw-arg-ref args kw default)
-  (match (memq kw args)
-    ((_ val . _) val)
-    (_ default)))
-
 (define *debug?* #f)
 
 (define (maybe-verify x)
@@ -45,27 +40,31 @@
       x))
 
 (define (optimize x env opts)
-  (define-syntax-rule (run-pass pass kw default)
-    (when (kw-arg-ref opts kw default)
+  (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? (kw-arg-ref opts #:seal-private-bindings? #f)))
+    (let ((seal? (assq-ref opts #:seal-private-bindings?)))
       (letrectify x #:seal-private-bindings? seal?)))
   (maybe-verify x)
-  (run-pass resolve*           #:resolve-primitives? #t)
-  (run-pass expand-primitives  #:expand-primitives?  #t)
-  (run-pass letrectify*        #:letrectify?         #t)
+  (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?       #t)
-  (run-pass eta-expand         #:eta-expand?         #t)
+  (run-pass peval*             #:partial-eval?)
+  (run-pass eta-expand         #:eta-expand?)
   x)
 
 (define (tree-il-optimizations)
   (available-optimizations 'tree-il))
 
 (define (make-lowerer optimization-level 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 (tree-il-optimizations)))
                 (match all-opts