diff options
author | Andy Wingo <wingo@pobox.com> | 2014-07-20 20:19:01 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2014-07-22 12:18:07 +0200 |
commit | ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31 (patch) | |
tree | 178741b2e9ac9e37f2c14ed1ac2547443bf4bf40 | |
parent | 44954194c936bee2f2faa4225480cb9dd2cbdcd8 (diff) | |
download | guile-ae67b159bb40aaa1ebe751e6bc7d92f728ef6b31.tar.gz |
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.
-rw-r--r-- | module/language/cps/effects-analysis.scm | 3 | ||||
-rw-r--r-- | module/language/cps/types.scm | 17 | ||||
-rw-r--r-- | 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 @@ -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>) |