summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/cps/effects-analysis.scm3
-rw-r--r--module/language/cps/types.scm17
-rw-r--r--module/language/tree-il/compile-cps.scm9
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
@@ -450,23 +450,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>)