;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011 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
#:export (fix-letrec!))
;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
-;; Efficient Implementation of Scheme’s Recursive Binding Construct", by
+;; Efficient Implementation of Scheme's Recursive Binding Construct", by
;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
(define fix-fold
(make-tree-il-folder unref ref set simple lambda complex))
-(define (simple-expression? x bound-vars)
+(define (simple-expression? x bound-vars simple-primitive?)
(record-case x
((<void>) #t)
((<const>) #t)
((<lexical-ref> gensym)
(not (memq gensym bound-vars)))
((<conditional> test consequent alternate)
- (and (simple-expression? test bound-vars)
- (simple-expression? consequent bound-vars)
- (simple-expression? alternate bound-vars)))
+ (and (simple-expression? test bound-vars simple-primitive?)
+ (simple-expression? consequent bound-vars simple-primitive?)
+ (simple-expression? alternate bound-vars simple-primitive?)))
((<sequence> exps)
- (and-map (lambda (x) (simple-expression? x bound-vars))
+ (and-map (lambda (x) (simple-expression? x bound-vars simple-primitive?))
exps))
((<application> proc args)
(and (primitive-ref? proc)
- (effect-free-primitive? (primitive-ref-name proc))
- (and-map (lambda (x) (simple-expression? x bound-vars))
+ (simple-primitive? (primitive-ref-name proc))
+ ;; FIXME: check arity?
+ (and-map (lambda (x)
+ (simple-expression? x bound-vars simple-primitive?))
args)))
(else #f)))
simple
lambda*
complex))
- ((<letrec> vars)
- (values (append vars unref)
+ ((<letrec> gensyms)
+ (values (append gensyms unref)
ref
set
simple
lambda*
complex))
- ((<let> vars)
- (values (append vars unref)
+ ((<let> gensyms)
+ (values (append gensyms unref)
ref
set
simple
(values unref ref set simple lambda* complex))))
(lambda (x unref ref set simple lambda* complex)
(record-case x
- ((<letrec> (orig-vars vars) vals)
- (let lp ((vars orig-vars) (vals vals)
+ ((<letrec> in-order? (orig-gensyms gensyms) vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
- (values unref
+ ((null? gensyms)
+ ;; 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)
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
- s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) unref)
+ ;; See above note about unref and letrec*.
+ (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)
+ s l c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((lambda? (car vals))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
- ((simple-expression? (car vals) orig-vars)
- (lp (cdr vars) (cdr vals)
- (cons (car vars) s) l c))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
+ ((simple-expression?
+ (car vals) orig-gensyms
+ (if in-order?
+ effect+exception-free-primitive?
+ effect-free-primitive?))
+ ;; For letrec*, we can't consider e.g. `car' to be
+ ;; "simple", as it could raise an exception. Hence
+ ;; effect+exception-free-primitive? above.
+ (lp (cdr gensyms) (cdr vals)
+ (cons (car gensyms) s) l c))
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
- ((<let> (orig-vars vars) vals)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
+ ((<let> (orig-gensyms gensyms) vals)
;; The point is to compile let-bound lambdas as
;; efficiently as we do letrec-bound lambdas, so
;; we use the same algorithm for analyzing the
- ;; vars. There is no problem recursing into the
+ ;; gensyms. There is no problem recursing into the
;; bindings after the let, because all variables
;; have been renamed.
- (let lp ((vars orig-vars) (vals vals)
+ (let lp ((gensyms orig-gensyms) (vals vals)
(s '()) (l '()) (c '()))
(cond
- ((null? vars)
+ ((null? gensyms)
(values unref
ref
set
(append s simple)
(append l lambda*)
(append c complex)))
- ((memq (car vars) unref)
- (lp (cdr vars) (cdr vals)
+ ((memq (car gensyms) unref)
+ (lp (cdr gensyms) (cdr vals)
s l c))
- ((memq (car vars) set)
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c)))
+ ((memq (car gensyms) set)
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c)))
((and (lambda? (car vals))
- (not (memq (car vars) set)))
- (lp (cdr vars) (cdr vals)
- s (cons (car vars) l) c))
+ (not (memq (car gensyms) set)))
+ (lp (cdr gensyms) (cdr vals)
+ s (cons (car gensyms) l) c))
;; There is no difference between simple and
;; complex, for the purposes of let. Just lump
;; them all into complex.
(else
- (lp (cdr vars) (cdr vals)
- s l (cons (car vars) c))))))
+ (lp (cdr gensyms) (cdr vals)
+ s l (cons (car gensyms) c))))))
(else
(values unref ref set simple lambda* complex))))
'()
(make-sequence #f (list exp (make-void #f)))
x))
- ((<letrec> src names vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<letrec> src in-order? 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)
- (map (lambda (v) (assq v binds))
- (lset-intersection eq? vars 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*))
;; The right-hand-sides of the unreferenced
;; bindings, for effect.
(map caddr u)
- (if (null? c)
- ;; No complex bindings, just emit the body.
- (list body)
- (list
- ;; Evaluate the the "complex" bindings, in a `let' to
- ;; indicate that order doesn't matter, and bind to
- ;; their variables.
- (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))))
- ;; Finally, the body.
- body)))))))))
+ (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 "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 vars vals body)
- (let ((binds (map list vars names vals)))
+ ((<let> src names gensyms vals body)
+ (let ((binds (map list gensyms names vals)))
(define (lookup set)
(map (lambda (v) (assq v binds))
- (lset-intersection eq? vars set)))
+ (lset-intersection eq? gensyms set)))
(let ((u (lookup unref))
(l (lookup lambda*))
(c (lookup complex)))
(else x)))
x)))
+
+;;; Local Variables:
+;;; eval: (put 'record-case 'scheme-indent-function 1)
+;;; End:
HCoop / bpt / guile.git / blobdiff