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 ($ )