mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-31 01:10:24 +02:00
Code Activity

Adapt visit-prompt-control-flow to use intsets.

Browse source 
* module/language/cps/dfg.scm (compute-reachable): Use intsets.
  (compute-interval): Adapt.
  (visit-prompt-control-flow): Adapt.
This commit is contained in:
Andy Wingo 2014-07-03 09:20:11 +02:00
parent c1a41f96b4
commit e9808c14d7
1 changed files with 44 additions and 55 deletions
Download patch file Download diff file Expand all files Collapse all files

99
module/language/cps/dfg.scm
View file

@ -41,6 +41,7 @@
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (language cps) #:use-module (language cps)
#:use-module (language cps intset)
#:export (build-cont-table #:export (build-cont-table
lookup-cont lookup-cont
@ -139,48 +140,39 @@
"Compute and return the continuations that may be reached if flow "Compute and return the continuations that may be reached if flow
reaches a continuation N. Returns a vector of bitvectors, whose first reaches a continuation N. Returns a vector of bitvectors, whose first
index corresponds to MIN-LABEL, and so on." index corresponds to MIN-LABEL, and so on."
(let (;; Vector of bitvectors, indicating that continuation N can (let (;; Vector of intsets, indicating that continuation N can
;; reach a set M... ;; reach a set M...
(reachable (make-vector label-count #f))) (reachable (make-vector label-count #f)))
(define (label->idx label) (- label min-label)) (define (label->idx label) (- label min-label))
;; All continuations are reachable from themselves.
(let lp ((n 0))
(when (< n label-count)
(let ((bv (make-bitvector label-count #f)))
(bitvector-set! bv n #t)
(vector-set! reachable n bv)
(lp (1+ n)))))
;; Iterate labels backwards, to converge quickly. ;; Iterate labels backwards, to converge quickly.
(let ((tmp (make-bitvector label-count #f))) (let lp ((label (+ min-label label-count)) (changed? #f))
(define (add-reachable! succ) (cond
(bit-set*! tmp (vector-ref reachable (label->idx succ)) #t)) ((= label min-label)
(let lp ((label (+ min-label label-count)) (changed? #f)) (if changed?
(cond (lp (+ min-label label-count) #f)
((= label min-label) reachable))
(if changed? (else
(lp (+ min-label label-count) #f) (let* ((label (1- label))
reachable)) (idx (label->idx label))
(else (old (vector-ref reachable idx))
(let* ((label (1- label)) (new (fold (lambda (succ set)
(idx (label->idx label))) (cond
(bitvector-fill! tmp #f) ((vector-ref reachable (label->idx succ))
(visit-cont-successors => (lambda (succ-set)
(case-lambda (intset-union set succ-set)))
(() #t) (else set)))
((succ0) (add-reachable! succ0)) (or (vector-ref reachable idx)
((succ0 succ1) (add-reachable! succ0) (add-reachable! succ1))) (intset-add empty-intset label))
(lookup-cont label dfg)) (visit-cont-successors list
(bitvector-set! tmp idx #t) (lookup-cont label dfg)))))
(bit-set*! tmp (vector-ref reachable idx) #f) (cond
(cond ((eq? old new)
((bit-position #t tmp 0) (lp label changed?))
(bit-set*! (vector-ref reachable idx) tmp #t) (else
(lp label #t)) (vector-set! reachable idx new)
(else (lp label #t)))))))))
(lp label changed?))))))))))
(define (find-prompts dfg min-label label-count) (define (find-prompts dfg min-label label-count)
"Find the prompts in DFG between MIN-LABEL and MIN-LABEL + "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
@ -201,19 +193,17 @@ pairs."
(define (compute-interval reachable min-label label-count start end) (define (compute-interval reachable min-label label-count start end)
"Compute and return the set of continuations that may be reached from "Compute and return the set of continuations that may be reached from
START, inclusive, but not reached by END, exclusive. Returns a START, inclusive, but not reached by END, exclusive. Returns an
bitvector." intset."
(let ((body (make-bitvector label-count #f))) (intset-subtract (vector-ref reachable (- start min-label))
(bit-set*! body (vector-ref reachable (- start min-label)) #t) (vector-ref reachable (- end min-label))))
(bit-set*! body (vector-ref reachable (- end min-label)) #f)
body))
(define (find-prompt-bodies dfg min-label label-count) (define (find-prompt-bodies dfg min-label label-count)
"Find all the prompts in DFG from the LABEL-COUNT continuations "Find all the prompts in DFG from the LABEL-COUNT continuations
starting at MIN-LABEL, and compute the set of continuations that is starting at MIN-LABEL, and compute the set of continuations that is
reachable from the prompt bodies but not from the corresponding handler. reachable from the prompt bodies but not from the corresponding handler.
Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is a Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
bitvector." intset."
(match (find-prompts dfg min-label label-count) (match (find-prompts dfg min-label label-count)
(() '()) (() '())
(((prompt . handler) ...) (((prompt . handler) ...)
@ -246,7 +236,7 @@ body continuation in the prompt."
(for-each (for-each
(match-lambda (match-lambda
((prompt handler body) ((prompt handler body)
(define (out-or-back-edge? n) (define (out-or-back-edge? label)
;; Most uses of visit-prompt-control-flow don't need every body ;; Most uses of visit-prompt-control-flow don't need every body
;; continuation, and would be happy getting called only for ;; continuation, and would be happy getting called only for
;; continuations that postdominate the rest of the body. Unless ;; continuations that postdominate the rest of the body. Unless
@ -259,16 +249,15 @@ body continuation in the prompt."
;; not continue to the pop if it never terminates. The pop could ;; not continue to the pop if it never terminates. The pop could
;; even be removed by DCE, in that case. ;; even be removed by DCE, in that case.
(or-map (lambda (succ) (or-map (lambda (succ)
(let ((succ (label->idx succ))) (or (not (intset-ref body succ))
(or (not (bitvector-ref body succ)) (<= succ label)))
(<= succ n)))) (lookup-successors label dfg)))
(lookup-successors (idx->label n) dfg))) (let lp ((label min-label))
(let lp ((n 0)) (let ((label (intset-next body label)))
(let ((n (bit-position #t body n))) (when label
(when n (when (or complete? (out-or-back-edge? label))
(when (or complete? (out-or-back-edge? n)) (f prompt handler label))
(f prompt handler (idx->label n))) (lp (1+ label)))))))
(lp (1+ n)))))))
(find-prompt-bodies dfg min-label label-count))) (find-prompt-bodies dfg min-label label-count)))
(define (analyze-reverse-control-flow fun dfg min-label label-count) (define (analyze-reverse-control-flow fun dfg min-label label-count)