mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +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) (maybe-verify x)
(run-pass resolve* #:resolve-primitives? #t) (run-pass resolve* #:resolve-primitives? #t)
(run-pass expand-primitives #:expand-primitives? #t) (run-pass expand-primitives #:expand-primitives? #t)
(set! x (fix-letrec x))
(run-pass peval* #:partial-eval? #t) (run-pass peval* #:partial-eval? #t)
(run-pass fix-letrec #:fix-letrec? #t)
x) x)
(define (tree-il-optimizations) (define (tree-il-optimizations)
@ -59,5 +59,4 @@
;; will result in a lot of code that will never get optimized nicely. ;; will result in a lot of code that will never get optimized nicely.
'((#:resolve-primitives? 2) '((#:resolve-primitives? 2)
(#:expand-primitives? 1) (#:expand-primitives? 1)
(#:partial-eval? 1) (#:partial-eval? 1)))
(#:fix-letrec? 1)))

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

@ -1,6 +1,6 @@
;;; Tree-IL partial evaluator ;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -144,10 +144,8 @@
(fold (lambda (name sym res) (fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) res)) (vhash-consq sym (make-var name sym 0 #f) res))
res names gensyms)) res names gensyms))
(($ <letrec> src in-order? names gensyms vals body) (($ <letrec>)
(fold (lambda (name sym res) (error "unexpected letrec"))
(vhash-consq sym (make-var name sym 0 #f) res))
res names gensyms))
(($ <fix> src names gensyms vals body) (($ <fix> src names gensyms vals body)
(fold (lambda (name sym res) (fold (lambda (name sym res)
(vhash-consq sym (make-var name sym 0 #f) 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))) (let ((body (loop body)))
(and body (and body
(make-let src names gensyms vals 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) (($ <fix> src names gensyms vals body)
(let ((body (loop body))) (let ((body (loop body)))
(and body (and body
@ -980,29 +974,12 @@ top-level bindings from ENV and return the resulting expression."
(lambda (names gensyms vals body) (lambda (names gensyms vals body)
(if (null? names) (error "what!" names)) (if (null? names) (error "what!" names))
(make-let src names gensyms vals body))))))) (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* ;; Note the difference from the `let' case: here we use letrec*
;; so that the `visit' procedure for the new operands closes over ;; so that the `visit' procedure for the new operands closes over
;; an environment that includes the operands. Also we don't try ;; an environment that includes the operands. Also we don't try
;; to elide aliases, because we can't sensibly reduce something ;; to elide aliases, because we can't sensibly reduce something
;; like (letrec ((a b) (b a)) a). ;; 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) (letrec* ((visit (lambda (exp counter ctx)
(loop exp env* counter ctx))) (loop exp env* counter ctx)))
(vars (map lookup-var gensyms)) (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 (make-let src* names vars vals
(simplify-conditional (simplify-conditional
(make-conditional src body subsequent alternate)))) (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) (($ <conditional> src ($ <fix> src* names vars vals body)
subsequent alternate) subsequent alternate)
(make-fix src* names vars vals (make-fix src* names vars vals