diff options
-rw-r--r-- | module/language/tree-il/fix-letrec.scm | 141 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 13 |
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 |