summaryrefslogtreecommitdiff
path: root/module/language/tree-il/cse.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/tree-il/cse.scm')
-rw-r--r--module/language/tree-il/cse.scm77
1 files changed, 36 insertions, 41 deletions
diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index b8e722967..40f6419e2 100644
--- a/module/language/tree-il/cse.scm
+++ b/module/language/tree-il/cse.scm
@@ -149,8 +149,7 @@
(define (boolean-valued-expression? x ctx)
(match x
- (($ <application> _
- ($ <primitive-ref> _ (? boolean-valued-primitive?))) #t)
+ (($ <primcall> _ (? boolean-valued-primitive?)) #t)
(($ <const> _ (? boolean?)) #t)
(_ (eq? ctx 'test))))
@@ -163,9 +162,8 @@
(($ <primitive-ref>) #t)
(($ <module-ref>) #t)
(($ <toplevel-ref>) #t)
- (($ <application> _
- ($ <primitive-ref> _ (? singly-valued-primitive?))) #t)
- (($ <application> _ ($ <primitive-ref> _ 'values) (val)) #t)
+ (($ <primcall> _ (? singly-valued-primitive?)) #t)
+ (($ <primcall> _ 'values (val)) #t)
(($ <lambda>) #t)
(_ (eq? ctx 'value))))
@@ -188,17 +186,13 @@
(make-const src #f))
(($ <conditional> src test consequent alternate)
(make-conditional src test (negate consequent ctx) (negate alternate ctx)))
- (($ <application> _ ($ <primitive-ref> _ 'not)
+ (($ <primcall> _ 'not
((and x (? (cut boolean-valued-expression? <> ctx)))))
x)
- (($ <application> src
- ($ <primitive-ref> _ (and pred (? negate-primitive)))
- args)
- (make-application src
- (make-primitive-ref #f (negate-primitive pred))
- args))
+ (($ <primcall> src (and pred (? negate-primitive)) args)
+ (make-primcall src (negate-primitive pred) args))
(_
- (make-application #f (make-primitive-ref #f 'not) (list exp)))))
+ (make-primcall #f 'not (list exp)))))
(define (hasher n)
@@ -267,7 +261,7 @@
exp
(make-const src (not (not val)))))
;; For (not FOO), try to prove FOO, then negate the result.
- (($ <application> src ($ <primitive-ref> _ 'not) (exp*))
+ (($ <primcall> src 'not (exp*))
(match (find-dominating-test exp* effects db)
(($ <const> _ val)
(log 'inferring exp (not val))
@@ -449,12 +443,19 @@
((consumer db**) (visit consumer (concat db* db) env ctx)))
(return (make-let-values src producer consumer)
(concat db** db*))))
- (($ <dynwind> src winder body unwinder)
- (let*-values (((pre db*) (visit winder db env 'value))
- ((body db**) (visit body (concat db* db) env ctx))
- ((post db***) (visit unwinder db env 'value)))
- (return (make-dynwind src pre body post)
- (concat db* (concat db** db***)))))
+ (($ <dynwind> src winder pre body post unwinder)
+ (let*-values (((winder db*) (visit winder db env 'value))
+ ((db**) db*)
+ ((unwinder db*) (visit unwinder db env 'value))
+ ((db**) (concat db* db**))
+ ((pre db*) (visit pre (concat db** db) env 'effect))
+ ((db**) (concat db* db**))
+ ((body db*) (visit body (concat db** db) env ctx))
+ ((db**) (concat db* db**))
+ ((post db*) (visit post (concat db** db) env 'effect))
+ ((db**) (concat db* db**)))
+ (return (make-dynwind src winder pre body post unwinder)
+ db**)))
(($ <dynlet> src fluids vals body)
(let*-values (((fluids db*) (parallel-visit fluids db env 'value))
((vals db**) (parallel-visit vals db env 'value))
@@ -503,7 +504,7 @@
;; (if FOO A A) => (begin FOO A)
(($ <conditional> src _
($ <const> _ a) ($ <const> _ (? (cut equal? a <>))))
- (visit (make-sequence #f (list test (make-const #f a)))
+ (visit (make-seq #f test (make-const #f a))
db env ctx))
;; (if FOO #t #f) => FOO for boolean-valued FOO.
(($ <conditional> src
@@ -528,10 +529,13 @@
(c
(return c (intersection (concat db++ db+) (concat db-- db-)))))))
- (($ <application> src proc args)
+ (($ <primcall> src primitive args)
+ (let*-values (((args db*) (parallel-visit args db env 'value)))
+ (return (make-primcall src primitive args) db*)))
+ (($ <call> src proc args)
(let*-values (((proc db*) (visit proc db env 'value))
((args db**) (parallel-visit args db env 'value)))
- (return (make-application src proc args)
+ (return (make-call src proc args)
(concat db** db*))))
(($ <lambda> src meta body)
(let*-values (((body _) (visit body (control-flow-boundary db)
@@ -546,24 +550,15 @@
(values #f #f))))
(return (make-lambda-case src req opt rest kw inits gensyms body alt)
(if alt vlist-null db*))))
- (($ <sequence> src exps)
- (let lp ((in exps) (out '()) (db* vlist-null))
- (match in
- ((last)
- (let*-values (((last db**) (visit last (concat db* db) env ctx)))
- (if (null? out)
- (return last (concat db** db*))
- (return (make-sequence src (reverse (cons last out)))
- (concat db** db*)))))
- ((head . rest)
- (let*-values (((head db**) (visit head (concat db* db) env 'effect)))
- (cond
- ((sequence? head)
- (lp (append (sequence-exps head) rest) out db*))
- ((void? head)
- (lp rest out db*))
- (else
- (lp rest (cons head out) (concat db** db*)))))))))
+ (($ <seq> src head tail)
+ (let*-values (((head db*) (visit head db env 'effect)))
+ (cond
+ ((void? head)
+ (visit tail db env ctx))
+ (else
+ (let*-values (((tail db**) (visit tail (concat db* db) env ctx)))
+ (values (make-seq src head tail)
+ (concat db** db*)))))))
(($ <prompt> src tag body handler)
(let*-values (((tag db*) (visit tag db env 'value))
((body _) (visit body (concat db* db) env ctx))