peval: Use the right scope when replacing a lambda by a lexical-ref.

* module/language/tree-il/optimize.scm (peval)[maybe-unlambda]: New
  procedures.
  Use it to de-duplicate named lambdas.  This fixes the scoping bug
  described at <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.

* test-suite/tests/tree-il.test ("partial evaluation"): Add tests to
  reproduce the bug.

diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 4453df3..104c4c2 100644 (file)
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -174,6 +174,22 @@ it should be called before `fix-letrec'."
            (or (make-value-construction src value) orig)))
       (_ new)))
 
+  (define (maybe-unlambda orig new env)
+    ;; If NEW is a named lambda and ORIG is what it looked like before
+    ;; partial evaluation, then attempt to replace NEW with a lexical
+    ;; ref, to avoid code duplication.
+    (match new
+      (($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
+          ($ <lambda-case> _ req opt rest kw inits gensyms body))
+       ;; Look for NEW in the current environment, starting from the
+       ;; outermost frame.
+       (or (any (lambda (x)
+                  (and (equal? (cdr x) new)
+                       (make-lexical-ref src name (car x))))
+                (vlist-fold cons '() env))        ; todo: optimize
+           new))
+      (_ new)))
+
   (catch 'match-error
     (lambda ()
       (let loop ((exp   exp)
@@ -245,12 +261,15 @@ it should be called before `fix-letrec'."
                  (make-conditional src condition
                                    (loop subsequent env calls)
                                    (loop alternate env calls)))))
-          (($ <application> src proc* orig-args)
+          (($ <application> src orig-proc orig-args)
            ;; todo: augment the global env with specialized functions
-           (let* ((proc  (loop proc* env calls))
+           (let* ((proc  (loop orig-proc env calls))
+                  (proc* (maybe-unlambda orig-proc proc env))
                   (args  (map (cut loop <> env calls) orig-args))
-                  (args* (map maybe-unconst orig-args args))
-                  (app   (make-application src proc args*)))
+                  (args* (map (cut maybe-unlambda <> <> env)
+                              orig-args
+                              (map maybe-unconst orig-args args)))
+                  (app   (make-application src proc* args*)))
              ;; If at least one of ARGS is static (to avoid infinite
              ;; inlining) and this call hasn't already been expanded
              ;; before (to avoid infinite recursion), then expand it
@@ -294,17 +313,7 @@ it should be called before `fix-letrec'."
                    (($ <toplevel-ref>)
                     app))
 
-                 ;; There are no constant arguments, so don't substitute
-                 ;; lambdas---i.e., prefer (lexical f) over an inline
-                 ;; copy of `f'.
-                 (let ((proc (if (lambda? proc) proc* proc))
-                       (args (map (lambda (raw evaled)
-                                    (if (lambda? evaled)
-                                        raw
-                                        evaled))
-                                  orig-args
-                                  args)))
-                   (make-application src proc args)))))
+                 app)))
           (($ <lambda> src meta body)
            (make-lambda src meta (loop body env calls)))
           (($ <lambda-case> src req opt rest kw inits gensyms body alt)

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index a8a5e33..6b3cb02 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -799,6 +799,28 @@
      35)
     (const 42))
 
+  (pass-if-peval
+    ;; Higher order.
+    ((lambda (f) (f x)) (lambda (x) x))
+    (apply (lambda ()
+             (lambda-case
+              (((x) #f #f #f () (_))
+               (lexical x _))))
+           (toplevel x)))
+
+  (pass-if-peval
+    ;; Bug reported at
+    ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+    (let ((fold (lambda (f g) (f (g top)))))
+      (fold 1+ (lambda (x) x)))
+    (let (fold) (_) (_)
+         (apply (primitive 1+)
+                (apply (lambda ()
+                         (lambda-case
+                          (((x) #f #f #f () (_))
+                           (lexical x _))))
+                       (toplevel top)))))
+
   (pass-if-peval
     ;; Higher order, mutually recursive procedures.
     (letrec ((even? (lambda (x)
@@ -874,7 +896,7 @@
            (apply (primitive list) (const 1) (const 2) (const 3))))
 
   (pass-if-peval
-    ;; Procedure only called with non-constant args is not inlined.
+    ;; Procedure only called with dynamic args is not inlined.
     (let* ((g (lambda (x y) (+ x y)))
            (f (lambda (g x) (g x x))))
       (+ (f g foo) (f g bar)))