Merge commit 'f66cbb99ee096186837536885d3436bb334df34d'

[bpt/guile.git] / module / language / tree-il / cse.scm

diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm
index 3d8a7f8..a7edcbe 100644 (file)
--- 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))))
 
@@ -173,17 +172,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 (bailout? exp)
@@ -310,7 +305,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))
@@ -471,12 +466,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))
@@ -525,7 +527,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
@@ -550,10 +552,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)
@@ -568,24 +573,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))