diff options
-rw-r--r-- | module/language/tree-il/optimize.scm | 39 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 24 |
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))) |