mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

fix-letrec tweaks

Browse source 
* module/language/tree-il/fix-letrec.scm (partition-vars): Previously,
  for letrec* we treated all unreferenced vars as complex, because of
  orderings of effects that could arise in their definitions.  But we
  can actually keep simple and lambda vars as unreferenced, as their
  initializers cannot cause side effects.
  (fix-letrec!): Remove letrec* -> letrec code, as it's unneeded.
This commit is contained in:
Andy Wingo 2011-03-09 22:37:53 +01:00
parent 531c9f1dc5
commit df12979562
1 changed files with 68 additions and 81 deletions
Download patch file Download diff file Expand all files Collapse all files

149
module/language/tree-il/fix-letrec.scm
View file

@ -96,9 +96,10 @@
(s '()) (l '()) (c '()))
(cond
((null? gensyms)
;; Unreferenced vars are still complex for letrec*.
;; We need to update our algorithm to "Fixing letrec
;; reloaded" to fix this.
;; Unreferenced complex vars are still
;; complex for letrec*. We need to update
;; our algorithm to "Fixing letrec reloaded"
;; to fix this.
(values (if in-order?
(lset-difference eq? unref c)
unref)
@ -109,7 +110,11 @@
(append c complex)))
((memq (car gensyms) unref)
;; See above note about unref and letrec*.
(if in-order?
(if (and in-order?
(not (lambda? (car vals)))
(not (simple-expression?
(car vals) orig-gensyms
effect+exception-free-primitive?)))
(lp (cdr gensyms) (cdr vals)
s l (cons (car gensyms) c))
(lp (cdr gensyms) (cdr vals)
@ -190,83 +195,65 @@
x))
((<letrec> src in-order? names gensyms vals body)
(if (and in-order?
(every (lambda (x)
(or (lambda? x)
(simple-expression?
x gensyms
effect+exception-free-primitive?)))
vals))
;; If it is a `letrec*', return an equivalent `letrec' when
;; it's possible. This is a hack until we implement the
;; algorithm described in "Fixing Letrec (Reloaded)"
;; (Ghuloum and Dybvig) to allow cases such as
;; (letrec* ((f (lambda () ...))(g (lambda () ...))) ...)
;; or
;; (letrec* ((x 2)(y 3)) y)
;; to be optimized. These can be common when using
;; internal defines.
(fix-letrec!
(make-letrec src #f names gensyms vals body))
(let ((binds (map list gensyms names vals)))
;; The bindings returned by this function need to appear in the same
;; order that they appear in the letrec.
(define (lookup set)
(let lp ((binds binds))
(cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
(c (lookup complex)))
;; Bind "simple" bindings, and locations for complex
;; bindings.
(make-let
src
(append (map cadr s) (map cadr c))
(append (map car s) (map car c))
(append (map caddr s) (map (lambda (x) (make-void #f)) c))
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
src
(append
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(cond
((null? c)
;; No complex bindings, just emit the body.
(list body))
(in-order?
;; For letrec*, assign complex bindings in order, then the
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c)
(caddr c)))
c)
(list body)))
(else
;; Otherwise for plain letrec, evaluate the the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body)))))))))))
(let ((binds (map list gensyms names vals)))
;; The bindings returned by this function need to appear in the same
;; order that they appear in the letrec.
(define (lookup set)
(let lp ((binds binds))
(cond
((null? binds) '())
((memq (caar binds) set)
(cons (car binds) (lp (cdr binds))))
(else (lp (cdr binds))))))
(let ((u (lookup unref))
(s (lookup simple))
(l (lookup lambda*))
(c (lookup complex)))
;; Bind "simple" bindings, and locations for complex
;; bindings.
(make-let
src
(append (map cadr s) (map cadr c))
(append (map car s) (map car c))
(append (map caddr s) (map (lambda (x) (make-void #f)) c))
;; Bind lambdas using the fixpoint operator.
(make-fix
src (map cadr l) (map car l) (map caddr l)
(make-sequence
src
(append
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
(cond
((null? c)
;; No complex bindings, just emit the body.
(list body))
(in-order?
;; For letrec*, assign complex bindings in order, then the
;; body.
(append
(map (lambda (c)
(make-lexical-set #f (cadr c) (car c)
(caddr c)))
c)
(list body)))
(else
;; Otherwise for plain letrec, evaluate the the "complex"
;; bindings, in a `let' to indicate that order doesn't
;; matter, and bind to their variables.
(list
(let ((tmps (map (lambda (x) (gensym)) c)))
(make-let
#f (map cadr c) tmps (map caddr c)
(make-sequence
#f
(map (lambda (x tmp)
(make-lexical-set
#f (cadr x) (car x)
(make-lexical-ref #f (cadr x) tmp)))
c tmps))))
body))))))))))
((<let> src names gensyms vals body)
(let ((binds (map list gensyms names vals)))