wingo pushed a commit to branch master
in repository guile.
commit cd4d4e70c5aa70be6ac650111b753deb36569fde
Author: Andy Wingo <wi...@pobox.com>
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
