From: Andy Wingo <wingo@pobox.com>
Date: Sun, 20 Jul 2014 18:19:01 +0000 (+0200)
Subject: CPS will not see "not" primcalls
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31

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 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
@@ -449,23 +449,6 @@ minimum, and maximum."
 
 
 
-;;;
-;;; 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))))
-
-
-
-
 ;;;
 ;;; Generic effect-free predicates.
 ;;;
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>)