diff options
Diffstat (limited to 'module/language/cps/utils.scm')
-rw-r--r-- | module/language/cps/utils.scm | 34 |
1 files changed, 34 insertions, 0 deletions
diff --git a/module/language/cps/utils.scm b/module/language/cps/utils.scm index e1f5e3a78..c72c04434 100644 --- a/module/language/cps/utils.scm +++ b/module/language/cps/utils.scm @@ -25,6 +25,7 @@ (define-module (language cps utils) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (language cps) #:use-module (language cps intset) #:use-module (language cps intmap) @@ -37,6 +38,7 @@ ;; Graphs. compute-function-body + compute-singly-referenced-labels compute-reachable-functions compute-successors compute-predecessors @@ -48,6 +50,7 @@ intmap-keys invert-bijection invert-partition intset->intmap + intmap-select worklist-fold fixpoint @@ -129,6 +132,37 @@ (($ $throw) labels)))))))))) +(define (compute-singly-referenced-labels conts) + "Compute the set of labels in CONTS that have exactly one +predecessor." + (define (add-ref label cont single multiple) + (define (ref k single multiple) + (if (intset-ref single k) + (values single (intset-add! multiple k)) + (values (intset-add! single k) multiple))) + (define (ref0) (values single multiple)) + (define (ref1 k) (ref k single multiple)) + (define (ref2 k k*) + (if k* + (let-values (((single multiple) (ref k single multiple))) + (ref k* single multiple)) + (ref1 k))) + (match cont + (($ $kreceive arity k) (ref1 k)) + (($ $kfun src meta self ktail kclause) (ref2 ktail kclause)) + (($ $ktail) (ref0)) + (($ $kclause arity kbody kalt) (ref2 kbody kalt)) + (($ $kargs names syms ($ $continue k)) (ref1 k)) + (($ $kargs names syms ($ $branch kf kt)) (ref2 kf kt)) + (($ $kargs names syms ($ $switch kf kt*)) + (fold2 ref (cons kf kt*) single multiple)) + (($ $kargs names syms ($ $prompt k kh)) (ref2 k kh)) + (($ $kargs names syms ($ $throw)) (ref0)))) + (let*-values (((single multiple) (values empty-intset empty-intset)) + ((single multiple) (intmap-fold add-ref conts single multiple))) + (intset-subtract (persistent-intset single) + (persistent-intset multiple)))) + (define* (compute-reachable-functions conts #:optional (kfun 0)) "Compute a mapping LABEL->LABEL..., where each key is a reachable $kfun and each associated value is the body of the function, as an |