diff options
-rw-r--r-- | module/language/tree-il/optimize.scm | 159 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 111 |
2 files changed, 180 insertions, 90 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index a8447b159..1af55a130 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -509,18 +509,6 @@ it does not handle <fix> and <let-values>, it should be called before ;((? bytevector?) (make-const src exp)) (_ #f)))) - (define (maybe-unconst orig new) - ;; If NEW is a constant, change it to a non-constant if need be. - ;; Expressions that build a mutable object, such as `(list 1 2)', - ;; must not be replaced by a constant; this procedure "undoes" the - ;; change from `(list 1 2)' to `'(1 2)'. - (match new - (($ <const> src (? mutable? value)) - (if (equal? new orig) - new - (or (make-value-construction src value) orig))) - (_ new))) - (catch 'match-error (lambda () (let loop ((exp exp) @@ -539,7 +527,7 @@ it does not handle <fix> and <let-values>, it should be called before (define (for-effect exp) (loop exp env counter 'effect)) (define (for-tail exp) - (maybe-unconst exp (loop exp env counter ctx))) + (loop exp env counter ctx)) (if counter (record-effort! counter)) @@ -623,19 +611,15 @@ it does not handle <fix> and <let-values>, it should be called before (make-sequence src (list exp (make-void #f))))) (begin (record-residual-lexical-reference! gensym) - (make-lexical-set src name gensym - (maybe-unconst exp - (for-value exp)))))) + (make-lexical-set src name gensym (for-value exp))))) (($ <let> src names gensyms vals body) - (let* ((vals* (map for-operand vals)) - (vals (map maybe-unconst vals vals*)) - (body* (loop body - (fold vhash-consq env gensyms vals) - counter - ctx)) - (body (maybe-unconst body body*))) + (let* ((vals (map for-operand vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) (cond - ((const? body*) + ((const? body) (for-tail (make-sequence src (append vals (list body))))) ((and (lexical-ref? body) (memq (lexical-ref-gensym body) gensyms)) @@ -670,15 +654,13 @@ it does not handle <fix> and <let-values>, it should be called before ;; Things could be done more precisely when IN-ORDER? but ;; it's OK not to do it---at worst we lost an optimization ;; opportunity. - (let* ((vals* (map for-operand vals)) - (vals (map maybe-unconst vals vals*)) - (body* (loop body - (fold vhash-consq env gensyms vals) - counter - ctx)) - (body (maybe-unconst body body*))) - (if (and (const? body*) - (every constant-expression? vals*)) + (let* ((vals (map for-operand vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) + (if (and (const? body) + (every constant-expression? vals)) body (let*-values (((stripped) (remove @@ -694,20 +676,18 @@ it does not handle <fix> and <let-values>, it should be called before (make-letrec src in-order? names gensyms vals body)))))) (($ <fix> src names gensyms vals body) (let* ((vals (map for-operand vals)) - (body* (loop body - (fold vhash-consq env gensyms vals) - counter - ctx)) - (body (maybe-unconst body body*))) - (if (and (const? body*) - (every constant-expression? vals)) + (body (loop body + (fold vhash-consq env gensyms vals) + counter + ctx))) + (if (const? body) body (make-fix src names gensyms vals body)))) (($ <let-values> lv-src producer consumer) ;; Peval the producer, then try to inline the consumer into ;; the producer. If that succeeds, peval again. Otherwise ;; reconstruct the let-values, pevaling the consumer. - (let ((producer (maybe-unconst producer (for-value producer)))) + (let ((producer (for-value producer))) (or (match consumer (($ <lambda-case> src req #f #f #f () gensyms body #f) (cond @@ -717,18 +697,13 @@ it does not handle <fix> and <let-values>, it should be called before (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ <dynwind> src winder body unwinder) - (make-dynwind src - (maybe-unconst winder (for-value winder)) - (for-tail body) - (maybe-unconst unwinder (for-value unwinder)))) + (make-dynwind src (for-value winder) (for-tail body) + (for-value unwinder))) (($ <dynlet> src fluids vals body) - (make-dynlet src - (map maybe-unconst fluids (map for-value fluids)) - (map maybe-unconst vals (map for-value vals)) + (make-dynlet src (map for-value fluids) (map for-value vals) (for-tail body))) (($ <dynref> src fluid) - (make-dynref src - (maybe-unconst fluid (for-value fluid)))) + (make-dynref src (for-value fluid))) (($ <toplevel-ref> src (? effect-free-primitive? name)) (if (local-toplevel? name) exp @@ -739,14 +714,11 @@ it does not handle <fix> and <let-values>, it should be called before (($ <module-ref>) exp) (($ <module-set> src mod name public? exp) - (make-module-set src mod name public? - (maybe-unconst exp (for-value exp)))) + (make-module-set src mod name public? (for-value exp))) (($ <toplevel-define> src name exp) - (make-toplevel-define src name - (maybe-unconst exp (for-value exp)))) + (make-toplevel-define src name (for-value exp))) (($ <toplevel-set> src name exp) - (make-toplevel-set src name - (maybe-unconst exp (for-value exp)))) + (make-toplevel-set src name (for-value exp))) (($ <primitive-ref>) (case ctx ((effect) (make-void #f)) @@ -776,6 +748,59 @@ it does not handle <fix> and <let-values>, it should be called before ;; todo: augment the global env with specialized functions (let ((proc (loop orig-proc env counter 'operator))) (match proc + (($ <primitive-ref> _ (? constructor-primitive? name)) + (case ctx + ((effect test) + (let ((exp (for-value exp)) + (res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (match (for-value exp) + (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs)) + (for-tail + (make-sequence src (list x xs res)))) + (($ <application> _ ($ <primitive-ref> _ 'list) elts) + (for-tail + (make-sequence src (append elts (list res))))) + (($ <application> _ ($ <primitive-ref> _ 'vector) elts) + (for-tail + (make-sequence src (append elts (list res))))) + (_ exp)))) + (else + (match (cons name (map for-value orig-args)) + (('cons head tail) + (let ((tail (for-value tail))) + (match tail + (($ <const> src ()) + (make-application src (make-primitive-ref #f 'list) + (list head))) + (($ <application> src ($ <primitive-ref> _ 'list) elts) + (make-application src (make-primitive-ref #f 'list) + (cons head elts))) + (_ (make-application src proc + (list head tail)))))) + + (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) + (for-tail (make-sequence src (list tail head)))) + (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) + (for-tail (make-sequence src (list head tail)))) + + (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) + (for-tail (make-sequence src (append tail (list head))))) + (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) + (for-tail (make-sequence + src + (list head + (make-application + src (make-primitive-ref #f 'list) tail))))) + + (('car ($ <const> src (head . tail))) + (for-tail (make-const src head))) + (('cdr ($ <const> src (head . tail))) + (for-tail (make-const src tail))) + + ((_ . args) + (make-application src proc args)))))) (($ <primitive-ref> _ (? effect-free-primitive? name)) (let ((args (map for-value orig-args))) (if (every const? args) ; only simple constants @@ -794,10 +819,8 @@ it does not handle <fix> and <let-values>, it should be called before (else (make-values src (map (cut make-const src <>) values)))) - (make-application src proc - (map maybe-unconst orig-args args)))) - (make-application src proc - (map maybe-unconst orig-args args))))) + (make-application src proc args))) + (make-application src proc args)))) (($ <lambda> _ _ ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) ;; Simple case: no rest, no keyword arguments. @@ -810,8 +833,7 @@ it does not handle <fix> and <let-values>, it should be called before ((or (< nargs nreq) (> nargs (+ nreq nopt))) ;; An error, or effecting arguments. (make-application src (for-value orig-proc) - (map maybe-unconst orig-args - (map for-value orig-args)))) + (map for-value orig-args))) ((and=> (find-counter key counter) counter-recursive?) ;; A recursive call. Process again in tail context. (loop (make-let src (append req (or opt '())) @@ -833,8 +855,7 @@ it does not handle <fix> and <let-values>, it should be called before (k (make-application src (for-value orig-proc) - (map maybe-unconst orig-args - (map for-value orig-args))))))) + (map for-value orig-args)))))) (loop (make-let src (append req (or opt '())) gensyms (append orig-args @@ -860,9 +881,8 @@ it does not handle <fix> and <let-values>, it should be called before ($ <lambda>) ($ <toplevel-ref>) ($ <lexical-ref>)) - (make-application src (maybe-unconst orig-proc proc) - (map maybe-unconst orig-args - (map for-value orig-args)))) + (make-application src proc + (map for-value orig-args))) ;; In practice, this is the clause that stops peval: ;; module-ref applications (produced by macros, @@ -878,10 +898,9 @@ it does not handle <fix> and <let-values>, it should be called before (make-lambda src meta (for-value body))))) (($ <lambda-case> src req opt rest kw inits gensyms body alt) (make-lambda-case src req opt rest kw - (map maybe-unconst inits - (map for-value inits)) + (map for-value inits) gensyms - (maybe-unconst body (for-tail body)) + (for-tail body) (and alt (for-tail alt)))) (($ <sequence> src exps) (let lp ((exps exps) (effects '())) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index a913541ac..6299f14d4 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -650,20 +650,27 @@ (const 3)) (pass-if-peval - ;; First order, coalesced. + ;; First order, coalesced, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) - (const (0 1 2 3 4 5))) + (apply (primitive list) + (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) (pass-if-peval - ;; First order, coalesced, mutability preserved. - (define mutable - (cons 0 (cons 1 (cons 2 (list 3 4 5))))) - (define mutable - ;; This must not be a constant. - (apply (primitive list) - (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))) - - ;; These two tests doesn't work any more because we changed the way we + ;; First order, coalesced, mutability preserved. + (cons 0 (cons 1 (cons 2 (list 3 4 5)))) + ;; This must not be a constant. + (apply (primitive list) + (const 0) (const 1) (const 2) (const 3) (const 4) (const 5))) + + (pass-if-peval + ;; First order, coalesced, immutability preserved. + (cons 0 (cons 1 (cons 2 '(3 4 5)))) + (apply (primitive cons) (const 0) + (apply (primitive cons) (const 1) + (apply (primitive cons) (const 2) + (const (3 4 5)))))) + + ;; These two tests doesn't work any more because we changed the way we ;; deal with constants -- now the algorithm will see a construction as ;; being bound to the lexical, so it won't propagate it. It can't ;; even propagate it in the case that it is only referenced once, @@ -746,12 +753,18 @@ (apply (primitive car) (lexical r _)))))))) + ;; Static sums. (pass-if-peval - ;; Mutability preserved. - (define mutable - ((lambda (x y z) (list x y z)) 1 2 3)) - (define mutable - (apply (primitive list) (const 1) (const 2) (const 3)))) + (let loop ((l '(1 2 3 4)) (sum 0)) + (if (null? l) + sum + (loop (cdr l) (+ sum (car l))))) + (const 10)) + + (pass-if-peval + ;; Mutability preserved. + ((lambda (x y z) (list x y z)) 1 2 3) + (apply (primitive list) (const 1) (const 2) (const 3))) (pass-if-peval ;; Don't propagate effect-free expressions that operate on mutable @@ -1084,14 +1097,15 @@ (apply (primitive +) (lexical bar _) (lexical bar _))))) (pass-if-peval - ;; Fresh objects are not turned into constants. + ;; Fresh objects are not turned into constants, nor are constants + ;; turned into fresh objects. (let* ((c '(2 3)) (x (cons 1 c)) (y (cons 0 x))) y) - (let (x) (_) ((apply (primitive list) (const 1) (const 2) (const 3))) + (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3)))) (apply (primitive cons) (const 0) (lexical x _)))) - + (pass-if-peval ;; Bindings mutated. (let ((x 2)) @@ -1181,7 +1195,64 @@ (g (lambda (x) (h (1+ x)))) (h (lambda (x) (f x)))) (f 0)) - (letrec _ . _))) + (letrec _ . _)) + + (pass-if-peval + ;; Constant folding: cons + (begin (cons 1 2) #f) + (const #f)) + + (pass-if-peval + ;; Constant folding: cons + (begin (cons (foo) 2) #f) + (begin (apply (toplevel foo)) (const #f))) + + (pass-if-peval + ;; Constant folding: cons + (if (cons 0 0) 1 2) + (const 1)) + + (pass-if-peval + ;; Constant folding: car+cons + (car (cons 1 0)) + (const 1)) + + (pass-if-peval + ;; Constant folding: cdr+cons + (cdr (cons 1 0)) + (const 0)) + + (pass-if-peval + ;; Constant folding: car+cons, impure + (car (cons 1 (bar))) + (begin (apply (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+cons, impure + (cdr (cons (bar) 0)) + (begin (apply (toplevel bar)) (const 0))) + + (pass-if-peval + ;; Constant folding: car+list + (car (list 1 0)) + (const 1)) + + (pass-if-peval + ;; Constant folding: cdr+list + (cdr (list 1 0)) + (apply (primitive list) (const 0))) + + (pass-if-peval + ;; Constant folding: car+list, impure + (car (list 1 (bar))) + (begin (apply (toplevel bar)) (const 1))) + + (pass-if-peval + ;; Constant folding: cdr+list, impure + (cdr (list (bar) 0)) + (begin (apply (toplevel bar)) (apply (primitive list) (const 0)))) + + ) (with-test-prefix "tree-il-fold" |