mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +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) ((zero? level) labels)
((intset-ref labels label) labels) ((intset-ref labels label) labels)
(else (else
(match (intmap-ref conts label) (let ((labels (intset-add! labels label)))
;; fixme: remove me? (match (intmap-ref conts label)
(($ $ktail) (($ $kreceive arity k) (visit-cont k level labels))
;; Possible for bailouts; never reached and not part of (($ $kargs names syms ($ $continue k src ($ $primcall 'wind)))
;; prompt body. (visit-cont k (1+ level) labels))
labels) (($ $kargs names syms ($ $continue k src ($ $primcall 'unwind)))
(cont (visit-cont k (1- level) labels))
(let ((labels (intset-add! labels label))) (($ $kargs names syms ($ $continue k src exp))
(match cont (visit-cont k level labels))
(($ $kreceive arity k) (visit-cont k level labels)) (($ $kargs names syms ($ $branch kf kt))
(($ $kargs names syms ($ $continue k src ($ $primcall 'wind))) (visit-cont kf level (visit-cont kt level labels)))
(visit-cont k (1+ level) labels)) (($ $kargs names syms ($ $prompt k kh src escape? tag))
(($ $kargs names syms ($ $continue k src ($ $primcall 'unwind))) (visit-cont kh level (visit-cont k (1+ level) labels)))
(visit-cont k (1- level) labels)) (($ $kargs names syms ($ $throw)) 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) (define (visit-prompt label handler succs)
(let ((body (compute-prompt-body label))) (let ((body (compute-prompt-body label)))
(define (out-or-back-edge? label) (define (out-or-back-edge? label)