peval can inline let-bound lambdas

* module/language/tree-il/peval.scm (peval): Better inlining of
  complicated operators.

* test-suite/tests/peval.test ("partial evaluation"): Add a couple
  tests.

2 files changed, 39 insertions, 2 deletions

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index a1281fd62..9a409d6d5 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1117,7 +1117,7 @@ top-level bindings from ENV and return the resulting expression."
             (make-application src apply (cons (for-value proc) args))))))
       (($ <application> src orig-proc orig-args)
        ;; todo: augment the global env with specialized functions
-       (let ((proc (visit orig-proc 'operator)))
+       (let revisit-proc ((proc (visit orig-proc 'operator)))
          (match proc
            (($ <primitive-ref> _ (? constructor-primitive? name))
             (cond
@@ -1305,6 +1305,31 @@ top-level bindings from ENV and return the resulting expression."
 
                   (log 'inline-end result exp)
                   result)))))
+           (($ <let> _ _ _ vals _)
+            ;; Attempt to inline `let' in the operator position.
+            ;;
+            ;; We have to re-visit the proc in value mode, since the
+            ;; `let' bindings might have been introduced or renamed,
+            ;; whereas the lambda (if any) in operator position has not
+            ;; been renamed.
+            (if (or (and-map constant-expression? vals)
+                    (and-map constant-expression? orig-args))
+                ;; The arguments and the let-bound values commute.
+                (match (for-value orig-proc)
+                  (($ <let> lsrc names syms vals body)
+                   (log 'inline-let orig-proc)
+                   (for-tail
+                    (make-let lsrc names syms vals
+                              (make-application src body orig-args))))
+                  ;; It's possible for a `let' to go away after the
+                  ;; visit due to the fact that visiting a procedure in
+                  ;; value context will prune unused bindings, whereas
+                  ;; visiting in operator mode can't because it doesn't
+                  ;; traverse through lambdas.  In that case re-visit
+                  ;; the procedure.
+                  (proc (revisit-proc proc)))
+                (make-application src (for-call orig-proc)
+                                  (map for-value orig-args))))
            (_
             (make-application src (for-call orig-proc)
                               (map for-value orig-args))))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 7fae423bd..aa36182cd 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;; 	Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 2009, 2010, 2011, 2012, 2013 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
@@ -830,6 +830,18 @@
              (((x) #f #f #f () (_))
               (apply (toplevel top) (lexical x _)))))))
   
+  (pass-if-peval resolve-primitives
+    ;; The inliner sees through a `let'.
+    ((let ((a 10)) (lambda (b) (* b 2))) 30)
+    (const 60))
+
+  (pass-if-peval
+      ((lambda ()
+         (define (const x) (lambda (_) x))
+         (let ((v #f))
+           ((const #t) v))))
+    (const #t))
+
   (pass-if-peval
    ;; Constant folding: cons of #nil does not make list
    (cons 1 #nil)