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

$throw is a new kind of CPS term

Browse source 
* module/language/cps.scm ($throw): New term type that doesn't have a
  continuation.  Adapt all callers.  Remove now-unneeded
  "prune-bailouts" pass.
This commit is contained in:
Andy Wingo 2018-01-03 18:25:42 +01:00
parent de5c81b1d1
commit ad55ee83c3
26 changed files with 145 additions and 148 deletions
Download patch file Download diff file Expand all files Collapse all files

18
module/language/cps/cse.scm
View file

@ -116,9 +116,10 @@ false. It could be that both true and false proofs are available."
(match (intmap-ref conts label)
(($ $kargs names vars term)
(match term
(($ $continue k) (propagate1 k))
(($ $continue k) (propagate1 k))
(($ $branch kf kt) (propagate-branch kf kt))
(($ $prompt k kh) (propagate2 k kh))))
(($ $prompt k kh) (propagate2 k kh))
(($ $throw) (propagate0))))
(($ $kreceive arity k)
(propagate1 k))
(($ $kfun src meta self tail clause)
@ -166,8 +167,10 @@ false. It could be that both true and false proofs are available."
(match (intmap-ref conts k)
(($ $kargs names vars) vars)
(_ #f)))
((or ($ $branch) ($ $prompt))
'())))))
(($ $branch)
'())
((or ($ $prompt) ($ $throw))
#f)))))
(compute-function-body conts kfun)))
(define (compute-singly-referenced succs)
@ -219,7 +222,7 @@ false. It could be that both true and false proofs are available."
(($ $values args) #f)))
(($ $branch kf kt src op param args)
(cons* op param (subst-vars var-substs args)))
(($ $prompt) #f)))
((or ($ $prompt) ($ $throw)) #f)))
(define (add-auxiliary-definitions! label var-substs term-key)
(let ((defs (and=> (intmap-ref defs label)
@ -402,7 +405,10 @@ false. It could be that both true and false proofs are available."
($continue k src ,(visit-exp exp))))))
(($ $prompt k kh src escape? tag)
(build-term
($prompt k kh src escape? (subst-var tag))))))
($prompt k kh src escape? (subst-var tag))))
(($ $throw src op param args)
(build-term
($throw src op param ,(map subst-var args))))))
(intmap-map
(lambda (label cont)