Handle letrec*' like letrec' in simple cases.

* module/language/tree-il/fix-letrec.scm (fix-letrec!): When X is a
  `letrec*' with only lambdas and simple expressions, analyze it as if
  it were a `letrec'.
* test-suite/tests/tree-il.test ("letrec"): Add test for
  `(letrec* (x y) (xx yy) ((const 1) (const 2)) (lexical y yy))'.

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,6 +190,24 @@
               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.
@@ -229,7 +247,8 @@
                         ;; body.
                         (append
                          (map (lambda (c)
-                            (make-lexical-set #f (cadr c) (car c) (caddr c)))
+                                (make-lexical-set #f (cadr c) (car c)
+                                                  (caddr c)))
                               c)
                          (list body)))
                        (else
@@ -247,7 +266,7 @@
                                      #f (cadr x) (car x)
                                      (make-lexical-ref #f (cadr x) tmp)))
                                   c tmps))))
-                     body))))))))))
+                         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:

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