diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index 8d626ea8e..b96e80104 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -318,11 +318,10 @@ it does not handle and , it should be called before (define (const*? x) (or (const? x) (lambda? x) (void? x))) - (define (pure-expression? x) - ;; Return true if X is pure---i.e., if it is known to have no - ;; effects and does not allocate storage for a mutable object. - ;; Note: is not "pure" because it loads a module as a - ;; side-effect. + (define (constant-expression? x) + ;; Return true if X is constant---i.e., if it is known to have no + ;; effects, does not allocate storage for a mutable object, and does + ;; not access mutable data (like `car' or toplevel references). (let loop ((x x)) (match x (($ ) #t) @@ -331,9 +330,7 @@ it does not handle and , it should be called before (($ _ req opt rest kw inits _ body alternate) (and (every loop inits) (loop body) (loop alternate))) (($ ) #t) - (($ ) #t) (($ ) #t) - (($ _ fluid) (loop fluid)) (($ _ condition subsequent alternate) (and (loop condition) (loop subsequent) (loop alternate))) (($ _ ($ _ name) args) @@ -447,7 +444,7 @@ it does not handle and , it should be called before ((effect) (make-void #f)) (else (let ((val (lookup gensym))) - (if (pure-expression? val) + (if (constant-expression? val) (case ctx ;; fixme: cache this? it is a divergence from ;; O(n). @@ -616,7 +613,7 @@ it does not handle and , it should be called before (nreq (length req)) (nopt (if opt (length opt) 0))) (if (and (>= nargs nreq) (<= nargs (+ nreq nopt)) - (every pure-expression? args)) + (every constant-expression? args)) (let* ((params (append args (drop inits diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index b6418832b..3040d7458 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -776,16 +776,23 @@ (const 2) (toplevel top)) (const 3))) - (apply (primitive +) ; (f something 2) - (apply (primitive *) - (toplevel something) - (toplevel top)) + (apply (lexical f _) ; (f something 2) + ;; This arg is not const, so the lambda does not + ;; fold. We will fix this in the future when we + ;; inline lambda to `let'. That will offer the + ;; possibility of creating a lexical binding for + ;; `something', to preserve the order of effects. + (toplevel something) (const 2))))) (pass-if-peval ;; First order, with lambda inlined & specialized 3 times. (let ((f (lambda (x y) (if (> x 0) y x)))) - (+ (f -1 x) (f 2 y) (f z y))) + (+ (f -1 0) + (f 1 0) + (f -1 y) + (f 2 y) + (f z y))) (let (f) (_) ((lambda (_) (lambda-case @@ -794,8 +801,12 @@ (lexical y _) (lexical x _)))))) (apply (primitive +) - (const -1) ; (f -1 x) - (toplevel y) ; (f 2 y) + (const -1) ; (f -1 0) + (const 0) ; (f 1 0) + (apply (lexical f _) ; (f -1 y) + (const -1) (toplevel y)) + (apply (lexical f _) ; (f 2 y) + (const 2) (toplevel y)) (apply (lexical f _) ; (f z y) (toplevel z) (toplevel y))))) @@ -821,6 +832,17 @@ (fibo 7)) (const 13)) + (pass-if-peval + ;; Don't propagate toplevel references, as intervening expressions + ;; could alter their bindings. + (let ((x top)) + (foo) + x) + (let (x) (_) ((toplevel top)) + (begin + (apply (toplevel foo)) + (lexical x _)))) + (pass-if-peval ;; Higher order. ((lambda (f x) @@ -895,49 +917,35 @@ (apply (primitive -) (lexical x2 _) (const 1)))))))) (pass-if "inlined lambdas are alpha-renamed" - ;; In this example, the two anonymous lambdas are inlined more than - ;; once; thus, they should use different gensyms for their - ;; arguments, because the variable allocation process assumes - ;; globally unique gensyms. + ;; In this example, `make-adder' is inlined more than once; thus, + ;; they should use different gensyms for their arguments, because + ;; the various optimization passes assume uniquely-named variables. ;; ;; Bug reported at ;; and ;; . (pmatch (unparse-tree-il (peval (compile - '(let ((f (lambda (g x) - (+ (g x) (g (+ x 1)))))) - (f (lambda (x0) (* x0 x0)) y)) + '(let ((make-adder + (lambda (x) (lambda (y) (+ x y))))) + (cons (make-adder 1) (make-adder 2))) #:to 'tree-il))) - ((let (f) (_) - ((lambda ((name . f)) - (lambda-case - (((g x) #f #f #f () (_ _)) - (apply (primitive +) - (apply (lexical g _) (lexical x _)) - (apply (lexical g _) - (apply (primitive +) - (lexical x _) (const 1)))))))) - (apply (primitive +) - (apply (lambda () - (lambda-case - (((x0) #f #f #f () (,gensym1)) - (apply (primitive *) - (lexical x0 ,ref1a) - (lexical x0 ,ref1b))))) - (toplevel y)) - (apply (lambda () - (lambda-case - (((x0) #f #f #f () (,gensym2)) - (apply (primitive *) - (lexical x0 ,ref2a) - (lexical x0 ,ref2b))))) - (apply (primitive +) - (toplevel y) (const 1))))) - (and (eq? gensym1 ref1a) - (eq? gensym1 ref1b) - (eq? gensym2 ref2a) - (eq? gensym2 ref2b) + ((let (make-adder) (_) (_) + (apply (primitive cons) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym1)) + (apply (primitive +) + (const 1) + (lexical y ,ref1))))) + (lambda () + (lambda-case + (((y) #f #f #f () (,gensym2)) + (apply (primitive +) + (const 2) + (lexical y ,ref2))))))) + (and (eq? gensym1 ref1) + (eq? gensym2 ref2) (not (eq? gensym1 gensym2)))) (_ #f))) @@ -1017,22 +1025,24 @@ (pass-if-peval ;; 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))) - (let (g) (_) - ((lambda _ ; g - (lambda-case - (((x y) #f #f #f () (_ _)) - (apply (primitive +) (lexical x _) (lexical y _)))))) - (let (f) (_) - ((lambda _ ; f - (lambda-case - (((g x) #f #f #f () (_ _)) - (apply (lexical g _) (lexical x _) (lexical x _)))))) - (apply (primitive +) - (apply (lexical g _) (toplevel foo) (toplevel foo)) - (apply (lexical g _) (toplevel bar) (toplevel bar)))))) + (let ((foo top-foo) (bar top-bar)) + (let* ((g (lambda (x y) (+ x y))) + (f (lambda (g x) (g x x)))) + (+ (f g foo) (f g bar)))) + (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar)) + (let (g) (_) + ((lambda _ ; g + (lambda-case + (((x y) #f #f #f () (_ _)) + (apply (primitive +) (lexical x _) (lexical y _)))))) + (let (f) (_) + ((lambda _ ; f + (lambda-case + (((g x) #f #f #f () (_ _)) + (apply (lexical g _) (lexical x _) (lexical x _)))))) + (apply (primitive +) + (apply (lexical g _) (lexical foo _) (lexical foo _)) + (apply (lexical g _) (lexical bar _) (lexical bar _))))))) (pass-if-peval ;; Fresh objects are not turned into constants. @@ -1100,12 +1110,14 @@ (pass-if-peval ;; Recursion on the 2nd argument is fully evaluated. - (let loop ((x x) (y 10)) - (if (> y 0) - (loop x (1- y)) - (foo x y))) - (letrec (loop) (_) (_) - (apply (toplevel foo) (toplevel x) (const 0)))) + (let ((x (top))) + (let loop ((x x) (y 10)) + (if (> y 0) + (loop x (1- y)) + (foo x y)))) + (let (x) (_) ((apply (toplevel top))) + (letrec (loop) (_) (_) + (apply (toplevel foo) (lexical x _) (const 0))))) (pass-if-peval ;; Inlining aborted when residual code contains recursive calls.