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)))))) (($ 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 (($ _ (? constructor-primitive? name)) (cond @@ -1305,6 +1305,31 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-end result exp) result))))) + (($ _ _ _ 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) + (($ 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 --- 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)