1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00

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.
This commit is contained in:
Andy Wingo 2014-07-20 20:19:01 +02:00
parent 44954194c9
commit ae67b159bb
3 changed files with 10 additions and 19 deletions

View file

@ -256,8 +256,7 @@ is or might be a read or a write to the same location as A."
;; Miscellaneous. ;; Miscellaneous.
(define-primitive-effects (define-primitive-effects
((values . _)) ((values . _)))
((not arg)))
;; Generic effect-free predicates. ;; Generic effect-free predicates.
(define-primitive-effects (define-primitive-effects

View file

@ -447,23 +447,6 @@ minimum, and maximum."
;;; we can infer the types of incoming values. ;;; 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))))
;;; ;;;

View file

@ -363,6 +363,15 @@
(kf ($kargs () () ($continue k src ($const #f))))) (kf ($kargs () () ($continue k src ($const #f)))))
($continue kf src ($continue kf src
($branch kt ($primcall name args))))))))) ($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 (eq? name 'list)
(and-map (match-lambda (and-map (match-lambda
((or ($ <const>) ((or ($ <const>)