mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Run fix-letrec before peval

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2019-08-13 13:59:14 +02:00
parent 615430874f
commit cd4d4e70c5
2 changed files with 6 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

5
module/language/tree-il/optimize.scm
View file

@ -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)))

37
module/language/tree-il/peval.scm
View file

@ -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,29 +974,12 @@ 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
;; to elide aliases, because we can't sensibly reduce something
;; like (letrec ((a b) (b a)) a).
(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 (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))
@ -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