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