Not fixing ‘letrec*’

[Ludovic Courtès]

Hello!

We don't do “Fix letrec (reloaded)”, so ‘letrec*’ (and thus internal
defines) are compiled sub-optimally:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,c (letrec* ((x 2)(y 3)) y)
Disassembly of #<objcode 1ea7a28>:

   0    (assert-nargs-ee/locals 16)
   2    (make-int8 3)                   ;; 3
   4    (void)
   5    (box 1)
   7    (local-set 0)
   9    (make-int8 2)                   ;; 2
  11    (local-boxed-set 1)
  13    (local-ref 0)
  15    (return)
--8<---------------cut here---------------end--------------->8---

The patch below hacks around it by converting ‘letrec*’ to ‘letrec’ when
all the inits are simple expressions or lambdas:

--8<---------------cut here---------------start------------->8---
scheme@(guile-user)> ,c (letrec* ((x 2)(y 3)) y)
Disassembly of #<objcode 5c1f9a8>:

   0    (assert-nargs-ee/locals 8)      
   2    (make-int8 3)                   ;; 3
   4    (local-set 0)                   
   6    (local-ref 0)                   
   8    (return)                        
--8<---------------cut here---------------end--------------->8---

diff --git a/module/language/tree-il/fix-letrec.scm 
b/module/language/tree-il/fix-letrec.scm
index 8d4b239..2e696e4 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -176,8 +176,34 @@
                   '())))
     (values unref simple lambda* complex)))
 
+(define (maybe-simplify-letrec* x)
+  ;; If X is a `letrec*', return an equivalent `letrec' when it's
+  ;; possible.  This function 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.
+  (post-order!
+   (lambda (x)
+     (record-case 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))
+            (make-letrec src #f names gensyms vals body)
+            x))
+       (else x)))
+   x))
+
 (define (fix-letrec! x)
-  (let-values (((unref simple lambda* complex) (partition-vars x)))
+  (let-values (((unref simple lambda* complex)
+                (partition-vars (maybe-simplify-letrec* x))))
     (post-order!
      (lambda (x)
        (record-case x
@@ -271,3 +297,7 @@
          
          (else x)))
      x)))
+
+;;; Local Variables:
+;;; eval: (put 'record-case 'scheme-indent-function 1)
+;;; End:
        Modified test-suite/tests/tree-il.test
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 76c825d..8ea2443 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

OK to commit?

I *think* ‘effect-free-primitive?’ would be enough above.  WDYT?

Thanks,
Ludo’.