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:
parent
44954194c9
commit
ae67b159bb
3 changed files with 10 additions and 19 deletions
|
@ -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
|
||||||
|
|
|
@ -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))))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
|
|
@ -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>)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue