diff options
Diffstat (limited to 'module/language/tree-il/cse.scm')
-rw-r--r-- | module/language/tree-il/cse.scm | 77 |
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)) |