summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-23 12:43:04 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-25 02:54:45 +0200
commit02ebea537fa805c615df44c4228db6a44d74c4b3 (patch)
tree89a18ba8721e40d074f8bb7940e4b1e14bc38c90 /module/language/tree-il/optimize.scm
parentcf82943f9f075248d803b31e19ddb8e933ad35ba (diff)
downloadguile-02ebea537fa805c615df44c4228db6a44d74c4b3.tar.gz
peval: simpler and more precise treatment of mutability
* module/language/tree-il/optimize.scm (peval): The old approach of optimistically producing constants and then de-constifying them at their uses was not only cumbersome but incorrect: it both failed to preserve identity in some cases and failed to retain immutable constant values. Instead, now we only produce constants if they really are constant and immutable. The constant folder has to have a few more algebraic cases to be as effective as it was, to destructure (car (cons _ _)) appropriately. On the plus side, now constructors and deconstructors can handle impure cases more generally. * test-suite/tests/tree-il.test ("partial evaluation"): Add constructor and destructuring tests. Adapt other tests to new expectations.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r--module/language/tree-il/optimize.scm159
1 files changed, 89 insertions, 70 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 '()))