From ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sun, 20 Jul 2014 20:19:01 +0200
Subject: [PATCH] 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.
---
 module/language/cps/effects-analysis.scm |  3 +--
 module/language/cps/types.scm            | 17 -----------------
 module/language/tree-il/compile-cps.scm  |  9 +++++++++
 3 files changed, 10 insertions(+), 19 deletions(-)

diff --git a/module/language/cps/effects-analysis.scm b/module/language/cps/effects-analysis.scm
index d59283c40..246b22eb6 100644
--- 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 677f542dd..2a2192540 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -447,23 +447,6 @@ minimum, and maximum."
 ;;; we can infer the types of incoming values.
 
 
-
-
-;;;
-;;; 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))))
-
-
 
 
 ;;;
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index d81a82c85..382231684 100644
--- 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>)