summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/fix-letrec.scm141
-rw-r--r--test-suite/tests/tree-il.test13
2 files changed, 94 insertions, 60 deletions
diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index 8d4b2391b..ee8beb2e6 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
;;; transformation of letrec into simpler forms
-;; Copyright (C) 2009, 2010 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
@@ -190,64 +190,83 @@
x))
((<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)
- (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))))))))))
+ (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> src names gensyms vals body)
(let ((binds (map list gensyms names vals)))
@@ -271,3 +290,7 @@
(else x)))
x)))
+
+;;; Local Variables:
+;;; eval: (put 'record-case 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 76c825dd1..8ea244343 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -363,7 +363,18 @@
(lexical #t #t set 1)
(lexical #t #t ref 0)
(lexical #t #t ref 1)
- (call add 2) (call return 1) (unbind))))
+ (call add 2) (call return 1) (unbind)))
+
+ ;; simple bindings in letrec* -> equivalent to letrec
+ (assert-tree-il->glil
+ (letrec* (x y) (xx yy) ((const 1) (const 2))
+ (lexical y yy))
+ (program () (std-prelude 0 1 #f) (label _)
+ (const 2)
+ (bind (y #f 0)) ;; X is removed, and Y is unboxed
+ (lexical #t #f set 0)
+ (lexical #t #f ref 0)
+ (call return 1) (unbind))))
(with-test-prefix "lambda"
(assert-tree-il->glil