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

Simplify prompt slot allocation now that bailouts can't continue

Browse source 
* module/language/cps/slot-allocation.scm (add-prompt-control-flow-edges):
  Simplify now that bailouts don't continue.
This commit is contained in:
Andy Wingo 2018-01-03 18:30:13 +01:00
parent ad55ee83c3
commit 8248649966
1 changed files with 14 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

35
module/language/cps/slot-allocation.scm
View file

@ -224,27 +224,20 @@ body continuation in the prompt."
((zero? level) labels)
((intset-ref labels label) labels)
(else
(match (intmap-ref conts label)
;; fixme: remove me?
(($ $ktail)
;; Possible for bailouts; never reached and not part of
;; prompt body.
labels)
(cont
(let ((labels (intset-add! labels label)))
(match cont
(($ $kreceive arity k) (visit-cont k level labels))
(($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
(visit-cont k (1+ level) labels))
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
(visit-cont k (1- level) labels))
(($ $kargs names syms ($ $continue k src exp))
(visit-cont k level labels))
(($ $kargs names syms ($ $branch kf kt))
(visit-cont kf level (visit-cont kt level labels)))
(($ $kargs names syms ($ $prompt k kh src escape? tag))
(visit-cont kh level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $throw)) labels))))))))))
(let ((labels (intset-add! labels label)))
(match (intmap-ref conts label)
(($ $kreceive arity k) (visit-cont k level labels))
(($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
(visit-cont k (1+ level) labels))
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
(visit-cont k (1- level) labels))
(($ $kargs names syms ($ $continue k src exp))
(visit-cont k level labels))
(($ $kargs names syms ($ $branch kf kt))
(visit-cont kf level (visit-cont kt level labels)))
(($ $kargs names syms ($ $prompt k kh src escape? tag))
(visit-cont kh level (visit-cont k (1+ level) labels)))
(($ $kargs names syms ($ $throw)) labels))))))))
(define (visit-prompt label handler succs)
(let ((body (compute-prompt-body label)))
(define (out-or-back-edge? label)