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