[Guile-commits] 01/02: Run fix-letrec before peval

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit cd4d4e70c5aa70be6ac650111b753deb36569fde
Author: Andy Wingo <address@hidden>
Date:   Tue Aug 13 13:59:14 2019 +0200

    Run fix-letrec before peval
    
    * module/language/tree-il/optimize.scm (optimize): Change to run
      fix-letrec before peval.  Also, run it unconditionally, so that later
      passes don't have to deal with letrec.
    * module/language/tree-il/peval.scm (build-var-table, peval): Remove
      letrec cases.
---
 module/language/tree-il/optimize.scm |  5 ++---
 module/language/tree-il/peval.scm    | 37 ++++--------------------------------
 2 files changed, 6 insertions(+), 36 deletions(-)

diff --git a/module/language/tree-il/optimize.scm 
b/module/language/tree-il/optimize.scm
index 13b0977..b06ced8 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -49,8 +49,8 @@
   (maybe-verify x)
   (run-pass resolve*           #:resolve-primitives? #t)
   (run-pass expand-primitives  #:expand-primitives?  #t)
+  (set! x (fix-letrec x))
   (run-pass peval*             #:partial-eval?       #t)
-  (run-pass fix-letrec         #:fix-letrec?         #t)
   x)
 
 (define (tree-il-optimizations)
@@ -59,5 +59,4 @@
   ;; will result in a lot of code that will never get optimized nicely.
   '((#:resolve-primitives? 2)
     (#:expand-primitives? 1)
-    (#:partial-eval? 1)
-    (#:fix-letrec? 1)))
+    (#:partial-eval? 1)))
diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index b8a0fe9..e1938e6 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011-2014, 2017 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014, 2017, 2019 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
@@ -144,10 +144,8 @@
         (fold (lambda (name sym res)
                 (vhash-consq sym (make-var name sym 0 #f) res))
               res names gensyms))
-       (($ <letrec> src in-order? names gensyms vals body)
-        (fold (lambda (name sym res)
-                (vhash-consq sym (make-var name sym 0 #f) res))
-              res names gensyms))
+       (($ <letrec>)
+        (error "unexpected letrec"))
        (($ <fix> src names gensyms vals body)
         (fold (lambda (name sym res)
                 (vhash-consq sym (make-var name sym 0 #f) res))
@@ -592,10 +590,6 @@ top-level bindings from ENV and return the resulting 
expression."
          (let ((body (loop body)))
            (and body
                 (make-let src names gensyms vals body))))
-        (($ <letrec> src in-order? names gensyms vals body)
-         (let ((body (loop body)))
-           (and body
-                (make-letrec src in-order? names gensyms vals body))))
         (($ <fix> src names gensyms vals body)
          (let ((body (loop body)))
            (and body
@@ -980,7 +974,7 @@ top-level bindings from ENV and return the resulting 
expression."
                             (lambda (names gensyms vals body)
                               (if (null? names) (error "what!" names))
                               (make-let src names gensyms vals body)))))))
-      (($ <letrec> src in-order? names gensyms vals body)
+      (($ <fix> src names gensyms vals body)
        ;; Note the difference from the `let' case: here we use letrec*
        ;; so that the `visit' procedure for the new operands closes over
        ;; an environment that includes the operands.  Also we don't try
@@ -993,23 +987,6 @@ top-level bindings from ENV and return the resulting 
expression."
                  (ops (make-bound-operands vars new vals visit))
                  (env* (fold extend-env env gensyms ops))
                  (body* (visit body counter ctx)))
-         (if (and (const? body*) (every constant-expression? vals))
-             ;; We may have folded a loop completely, even though there
-             ;; might be cyclical references between the bound values.
-             ;; Handle this degenerate case specially.
-             body*
-             (prune-bindings ops in-order? body* counter ctx
-                             (lambda (names gensyms vals body)
-                               (make-letrec src in-order?
-                                            names gensyms vals body))))))
-      (($ <fix> src names gensyms vals body)
-       (letrec* ((visit (lambda (exp counter ctx)
-                          (loop exp env* counter ctx)))
-                 (vars (map lookup-var gensyms))
-                 (new (fresh-gensyms vars))
-                 (ops (make-bound-operands vars new vals visit))
-                 (env* (fold extend-env env gensyms ops))
-                 (body* (visit body counter ctx)))
          (if (const? body*)
              body*
              (prune-bindings ops #f body* counter ctx
@@ -1104,12 +1081,6 @@ top-level bindings from ENV and return the resulting 
expression."
             (make-let src* names vars vals
                       (simplify-conditional
                        (make-conditional src body subsequent alternate))))
-           (($ <conditional> src
-               ($ <letrec> src* in-order? names vars vals body)
-               subsequent alternate)
-            (make-letrec src* in-order? names vars vals
-                         (simplify-conditional
-                          (make-conditional src body subsequent alternate))))
            (($ <conditional> src ($ <fix> src* names vars vals body)
                subsequent alternate)
             (make-fix src* names vars vals