Not fixing ‘letrec*’

Not fixing ‘letrec*’

[Ludovic Courtès]

[-- Attachment #1: Type: text/plain, Size: 1179 bytes --]

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---


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 2603 bytes --]

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


[-- Attachment #3: Type: text/plain, Size: 110 bytes --]


OK to commit?

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

Thanks,
Ludo’.

Re: Not fixing ‘letrec*’

[Ludovic Courtès]

Hi,

I’ve pushed a variant of this patch.

Thanks,
Ludo’.

Re: Not fixing ‘letrec*’

[Andy Wingo]

On Sun 06 Mar 2011 23:27, ludo@gnu.org (Ludovic Courtès) writes:

> I’ve pushed a variant of this patch.

Sorry for the delay in responding.  There was actually a more general
fix.  I pushed the following on top of your patch:

commit df1297956211b7353155c9b54d7e9c22d05ce493
Author: Andy Wingo <wingo@pobox.com>
Date:   Wed Mar 9 22:37:53 2011 +0100

    fix-letrec tweaks
    
    * module/language/tree-il/fix-letrec.scm (partition-vars): Previously,
      for letrec* we treated all unreferenced vars as complex, because of
      orderings of effects that could arise in their definitions.  But we
      can actually keep simple and lambda vars as unreferenced, as their
      initializers cannot cause side effects.
      (fix-letrec!): Remove letrec* -> letrec code, as it's unneeded.

diff --git a/module/language/tree-il/fix-letrec.scm b/module/language/tree-il/fix-letrec.scm
index ee8beb2..3d7db27 100644
--- a/module/language/tree-il/fix-letrec.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -96,9 +96,10 @@
                                 (s '()) (l '()) (c '()))
                          (cond
                           ((null? gensyms)
-                           ;; Unreferenced vars are still complex for letrec*.
-                           ;; We need to update our algorithm to "Fixing letrec
-                           ;; reloaded" to fix this.
+                           ;; 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)
@@ -109,7 +110,11 @@
                                    (append c complex)))
                           ((memq (car gensyms) unref)
                            ;; See above note about unref and letrec*.
-                           (if in-order?
+                           (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)

-- 
http://wingolog.org/