diff options
Diffstat (limited to 'module/language/cps/cse.scm')
-rw-r--r-- | module/language/cps/cse.scm | 17 |
1 files changed, 16 insertions, 1 deletions
diff --git a/module/language/cps/cse.scm b/module/language/cps/cse.scm index 3cc48cdf7..1966467ec 100644 --- a/module/language/cps/cse.scm +++ b/module/language/cps/cse.scm @@ -114,12 +114,19 @@ false. It could be that both true and false proofs are available." (propagate boolv succ1 (intset-add in (true-idx label))))) (values (append changed0 changed1) boolv))) + (define (propagate* succs) + (fold2 (lambda (succ changed boolv) + (call-with-values (lambda () (propagate boolv succ in)) + (lambda (changed* boolv) + (values (append changed* changed) boolv)))) + succs '() boolv)) (match (intmap-ref conts label) (($ $kargs names vars term) (match term (($ $continue k) (propagate1 k)) (($ $branch kf kt) (propagate-branch kf kt)) + (($ $switch kf kt*) (propagate* (cons kf kt*))) (($ $prompt k kh) (propagate2 k kh)) (($ $throw) (propagate0)))) (($ $kreceive arity k) @@ -179,6 +186,8 @@ false. It could be that both true and false proofs are available." ($kargs names vals ($continue (rename k) src ,exp))) (($ $kargs names vals ($ $branch kf kt src op param args)) ($kargs names vals ($branch (rename kf) (rename kt) src op param args))) + (($ $kargs names vals ($ $switch kf kt* src arg)) + ($kargs names vals ($switch (rename kf) (map rename kt*) src arg))) (($ $kargs names vals ($ $prompt k kh src escape? tag)) ($kargs names vals ($prompt (rename k) (rename kh) src escape? tag))) (($ $kreceive ($ $arity req () rest () #f) kbody) @@ -272,9 +281,12 @@ false. It could be that both true and false proofs are available." (intmap-replace truthy-labels label bool-in))))))) (define (term-successors term) + (define (list->intset ls) + (fold1 (lambda (elt set) (intset-add set elt)) ls empty-intset)) (match term (($ $continue k) (intset k)) (($ $branch kf kt) (intset kf kt)) + (($ $switch kf kt*) (list->intset (cons kf kt*))) (($ $prompt k kh) (intset k kh)) (($ $throw) empty-intset))) @@ -346,6 +358,7 @@ false. It could be that both true and false proofs are available." (match term (($ $continue k src exp) (compute-expr-key exp)) (($ $branch) (compute-branch-key term)) + (($ $switch) #f) (($ $prompt) #f) (($ $throw) #f))) @@ -424,6 +437,8 @@ false. It could be that both true and false proofs are available." (rewrite-term term (($ $branch kf kt src op param args) ($branch kf kt src op param ,(map subst-var args))) + (($ $switch kf kt* src arg) + ($switch kf kt* src (subst-var arg))) (($ $continue k src exp) ($continue k src ,(rename-exp exp))) (($ $prompt k kh src escape? tag) @@ -530,7 +545,7 @@ false. It could be that both true and false proofs are available." ,(visit-exp label exp analysis))))) substs analysis)) - ((or ($ $prompt) ($ $throw)) + ((or ($ $switch) ($ $prompt) ($ $throw)) (values (intmap-add! out label (build-cont ($kargs names vars ,term))) substs analysis))))) |