summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/tree-il/optimize.scm159
-rw-r--r--test-suite/tests/tree-il.test111
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"