mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

Simplify lowering of branching primcalls to CPS

Browse source 
* module/language/tree-il/compile-cps.scm (canonicalize, convert):
  Simplify handling of branching primcalls so that `convert' only ever
  sees branching primcalls in a test context.
This commit is contained in:
Andy Wingo 2017-10-29 11:47:44 +01:00
parent b4db70854b
commit 587842d874
1 changed files with 29 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

58
module/language/tree-il/compile-cps.scm
View file

@ -521,35 +521,6 @@
($continue k src ($primcall 'equal? args))))
(build-term ($continue kf* src
($branch kt ($primcall 'eqv? args))))))))
((branching-primitive? name)
(let ()
(define (reify-primcall cps kt kf args)
(if (heap-type-predicate? name)
(with-cps cps
(letk kt* ($kargs () ()
($continue kf src
($branch kt ($primcall name args)))))
(build-term ($continue kf src
($branch kt* ($primcall 'heap-object? args)))))
(with-cps cps
(build-term ($continue kf src
($branch kt ($primcall name args)))))))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(let$ k (adapt-arity k src 1))
(letk kt ($kargs () () ($continue k src ($const #t))))
(letk kf ($kargs () () ($continue k src ($const #f))))
($ (reify-primcall kt kf args)))))))
((and (eq? name 'not) (match args ((_) #t) (_ #f)))
(convert-args cps args
(lambda (cps args)
(with-cps cps
(let$ k (adapt-arity k src 1))
(letk kt ($kargs () () ($continue k src ($const #f))))
(letk kf ($kargs () () ($continue k src ($const #t))))
(build-term ($continue kt src
($branch kf ($primcall 'false? args))))))))
((and (eq? name 'list)
(and-map (match-lambda
((or ($ <const>)
@ -998,9 +969,38 @@ integer."
(optimize x e opts))
(define (canonicalize exp)
(define (reduce-conditional exp)
(match exp
(($ <conditional> src
($ <conditional> _ test ($ <const> _ t) ($ <const> _ f))
consequent alternate)
(cond
((and t (not f))
(reduce-conditional (make-conditional src test consequent alternate)))
((and (not t) f)
(reduce-conditional (make-conditional src test alternate consequent)))
(else
exp)))
(_ exp)))
(post-order
(lambda (exp)
(match exp
(($ <conditional>)
(reduce-conditional exp))
(($ <primcall> src (? branching-primitive? name) args)
;; No need to reduce because test is not reducible: reifying
;; #t/#f is the right thing.
(make-conditional src exp
(make-const src #t)
(make-const src #f)))
(($ <primcall> src 'not (x))
(reduce-conditional
(make-conditional src x
(make-const src #f)
(make-const src #t))))
(($ <primcall> src 'vector
(and args
((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))