CPS will not see "not" primcalls

* module/language/tree-il/compile-cps.scm (convert): Remove "not"
  primcalls.

* module/language/cps/effects-analysis.scm (values):
* module/language/cps/types.scm: Remove special cases for the "not"
  primcall.

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index d59283c..246b22e 100644 (file)
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -256,8 +256,7 @@ is or might be a read or a write to the same location as A."
 
 ;; Miscellaneous.
 (define-primitive-effects
-  ((values . _))
-  ((not arg)))
+  ((values . _)))
 
 ;; Generic effect-free predicates.
 (define-primitive-effects

diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index 677f542..2a21925 100644 (file)
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -449,23 +449,6 @@ minimum, and maximum."
 
 \f
 
-;;;
-;;; Miscellaneous.
-;;;
-
-(define-simple-type-checker (not &all-types))
-(define-type-inferrer (not val result)
-  (cond
-   ((and (eqv? (&type val) &boolean)
-         (eqv? (&min val) (&max val)))
-    (let ((val (if (zero? (&min val)) 1 0)))
-      (define! result &boolean val val)))
-   (else
-    (define! result &boolean 0 1))))
-
-
-\f
-
 ;;;
 ;;; Generic effect-free predicates.
 ;;;

diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index d81a82c..3822316 100644 (file)
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -363,6 +363,15 @@
                        (kf ($kargs () () ($continue k src ($const #f)))))
                  ($continue kf src
                    ($branch kt ($primcall name args)))))))))
+      ((and (eq? name 'not) (match args ((_) #t) (_ #f)))
+       (convert-args args
+         (lambda (args)
+           (let-fresh (kt kf) ()
+             (build-cps-term
+               ($letk ((kt ($kargs () () ($continue k src ($const #f))))
+                       (kf ($kargs () () ($continue k src ($const #t)))))
+                 ($continue kf src
+                   ($branch kt ($values args)))))))))
       ((and (eq? name 'list)
             (and-map (match-lambda
                       ((or ($ <const>)