summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/optimize.scm39
-rw-r--r--test-suite/tests/tree-il.test24
2 files changed, 47 insertions, 16 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index 4453df3a3..104c4c265 100644
--- 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 a8a5e33c4..6b3cb02cc 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -800,6 +800,28 @@
(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)
(or (= 0 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)))