lookup-uses
lookup-predecessors
lookup-successors
+ lookup-block-scope
find-call
call-expression
find-expression
find-defining-expression
find-constant-value
- lift-definition!
continuation-bound-in?
variable-free-in?
constant-needs-allocation?
- dead-after-def?
- dead-after-use?
- branch?
- find-other-branches
- dead-after-branch?
- lookup-bound-syms))
+ control-point?
+ lookup-bound-syms
+
+ ;; Control flow analysis.
+ analyze-control-flow
+ cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
+
+ ;; Data flow analysis.
+ compute-live-variables
+ dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
+ dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
+ print-dfa))
(define (build-cont-table fun)
- (fold-conts (lambda (k src cont table)
+ (fold-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
fun))
(define (build-local-cont-table cont)
- (fold-local-conts (lambda (k src cont table)
+ (fold-local-conts (lambda (k cont table)
(hashq-set! table k cont)
table)
(make-hash-table)
(use-maps dfg-use-maps))
(define-record-type $use-map
- (make-use-map sym def uses)
+ (make-use-map name sym def uses)
use-map?
+ (name use-map-name)
(sym use-map-sym)
(def use-map-def)
(uses use-map-uses set-use-map-uses!))
(define-record-type $block
- (%make-block scope scope-level preds succs idom dom-level loop-header)
+ (%make-block scope scope-level preds succs)
block?
(scope block-scope set-block-scope!)
(scope-level block-scope-level set-block-scope-level!)
(preds block-preds set-block-preds!)
- (succs block-succs set-block-succs!)
- (idom block-idom set-block-idom!)
- (dom-level block-dom-level set-block-dom-level!)
- (loop-header block-loop-header set-block-loop-header!))
+ (succs block-succs set-block-succs!))
(define (make-block scope scope-level)
- (%make-block scope scope-level '() '() #f #f #f))
-
-(define (reverse-post-order k0 blocks)
+ (%make-block scope scope-level '() '()))
+
+;; Some analyses assume that the only relevant set of nodes is the set
+;; that is reachable from some start node. Others need to include nodes
+;; that are reachable from an end node as well, or all nodes in a
+;; function. In that case pass an appropriate implementation of
+;; fold-all-conts, as compute-live-variables does.
+(define* (reverse-post-order k0 get-successors #:optional
+ (fold-all-conts (lambda (f seed) seed)))
(let ((order '())
(visited? (make-hash-table)))
(let visit ((k k0))
(hashq-set! visited? k #t)
- (match (lookup-block k blocks)
- ((and block ($ $block _ _ preds succs))
- (for-each (lambda (k)
- (unless (hashq-ref visited? k)
- (visit k)))
- succs)
- (set! order (cons k order)))))
- order))
-
-(define-inlinable (for-each/enumerate f l)
- (fold (lambda (x n) (f x n) (1+ n)) 0 l))
-
-(define (convert-predecessors order blocks)
- (let* ((len (length order))
- (mapping (make-hash-table))
- (preds-vec (make-vector len #f)))
- (for-each/enumerate
- (cut hashq-set! mapping <> <>)
- order)
- (for-each/enumerate
- (lambda (k n)
- (match (lookup-block k blocks)
- (($ $block _ _ preds)
- (vector-set! preds-vec n
- ;; It's possible for a predecessor to not be in
- ;; the mapping, if the predecessor is not
- ;; reachable from the entry node.
- (filter-map (cut hashq-ref mapping <>) preds)))))
- order)
+ (for-each (lambda (k)
+ (unless (hashq-ref visited? k)
+ (visit k)))
+ (get-successors k))
+ (set! order (cons k order)))
+ (list->vector (fold-all-conts
+ (lambda (k seed)
+ (if (hashq-ref visited? k)
+ seed
+ (begin
+ (hashq-set! visited? k #t)
+ (cons k seed))))
+ order))))
+
+(define (make-block-mapping order)
+ (let ((mapping (make-hash-table)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (hashq-set! mapping (vector-ref order n) n)
+ (lp (1+ n))))
+ mapping))
+
+(define (convert-predecessors order get-predecessors)
+ (let ((preds-vec (make-vector (vector-length order) #f)))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (vector-set! preds-vec n (get-predecessors (vector-ref order n)))
+ (lp (1+ n))))
preds-vec))
-(define (finish-idoms order idoms blocks)
- (let ((order (list->vector order))
- (dom-levels (make-vector (vector-length idoms) #f)))
+;; Control-flow analysis.
+(define-record-type $cfa
+ (make-cfa k-map order preds)
+ cfa?
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map cfa-k-map)
+ ;; Vector of k-idx -> k-sym, in reverse post order
+ (order cfa-order)
+ ;; Vector of k-idx -> list of k-idx
+ (preds cfa-preds))
+
+(define* (cfa-k-idx cfa k
+ #:key (default (lambda (k)
+ (error "unknown k" k))))
+ (or (hashq-ref (cfa-k-map cfa) k)
+ (default k)))
+
+(define (cfa-k-count cfa)
+ (vector-length (cfa-order cfa)))
+
+(define (cfa-k-sym cfa n)
+ (vector-ref (cfa-order cfa) n))
+
+(define (cfa-predecessors cfa n)
+ (vector-ref (cfa-preds cfa) n))
+
+(define* (analyze-control-flow fun dfg #:key reverse?)
+ (define (build-cfa kentry block-succs block-preds)
+ (define (block-accessor accessor)
+ (lambda (k)
+ (accessor (lookup-block k (dfg-blocks dfg)))))
+ (define (reachable-preds mapping accessor)
+ ;; It's possible for a predecessor to not be in the mapping, if
+ ;; the predecessor is not reachable from the entry node.
+ (lambda (k)
+ (filter-map (cut hashq-ref mapping <>)
+ ((block-accessor accessor) k))))
+ (let* ((order (reverse-post-order kentry (block-accessor block-succs)))
+ (k-map (make-block-mapping order))
+ (preds (convert-predecessors order
+ (reachable-preds k-map block-preds))))
+ (make-cfa k-map order preds)))
+ (match fun
+ (($ $fun src meta free
+ ($ $cont kentry
+ (and entry
+ ($ $kentry self ($ $cont ktail tail) clauses))))
+ (if reverse?
+ (build-cfa ktail block-preds block-succs)
+ (build-cfa kentry block-succs block-preds)))))
+
+;; Dominator analysis.
+(define-record-type $dominator-analysis
+ (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
+ dominator-analysis?
+ ;; The corresponding $cfa
+ (cfa dominator-analysis-cfa)
+ ;; Vector of k-idx -> k-idx
+ (idoms dominator-analysis-idoms)
+ ;; Vector of k-idx -> dom-level
+ (dom-levels dominator-analysis-dom-levels)
+ ;; Vector of k-idx -> k-idx or -1
+ (loop-header dominator-analysis-loop-header)
+ ;; Vector of k-idx -> true or false value
+ (irreducible dominator-analysis-irreducible))
+
+(define (compute-dom-levels idoms)
+ (let ((dom-levels (make-vector (vector-length idoms) #f)))
(define (compute-dom-level n)
(or (vector-ref dom-levels n)
(let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
dom-level)))
(vector-set! dom-levels 0 0)
(let lp ((n 0))
- (when (< n (vector-length order))
- (let* ((k (vector-ref order n))
- (idom (vector-ref idoms n))
- (b (lookup-block k blocks)))
- (set-block-idom! b (vector-ref order idom))
- (set-block-dom-level! b (compute-dom-level n))
- (lp (1+ n)))))))
-
-(define (compute-dominator-tree k blocks)
- (let* ((order (reverse-post-order k blocks))
- (preds (convert-predecessors order blocks))
- (idoms (make-vector (vector-length preds) 0)))
+ (when (< n (vector-length idoms))
+ (compute-dom-level n)
+ (lp (1+ n))))
+ dom-levels))
+
+(define (compute-idoms preds)
+ (let ((idoms (make-vector (vector-length preds) 0)))
(define (common-idom d0 d1)
;; We exploit the fact that a reverse post-order is a topological
;; sort, and so the idom of a node is always numerically less than
(iterate (1+ n) #t)))))
(changed?
(iterate 0 #f))
+ (else idoms)))))
+
+(define-inlinable (vector-push! vec idx val)
+ (let ((v vec) (i idx))
+ (vector-set! v i (cons val (vector-ref v i)))))
+
+;; Compute a vector containing, for each node, a list of the nodes that
+;; it immediately dominates. These are the "D" edges in the DJ tree.
+(define (compute-dom-edges idoms)
+ (let ((doms (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length idoms))
+ (let ((idom (vector-ref idoms n)))
+ (vector-push! doms idom n))
+ (lp (1+ n))))
+ doms))
+
+;; Compute a vector containing, for each node, a list of the successors
+;; of that node that are not dominated by that node. These are the "J"
+;; edges in the DJ tree.
+(define (compute-join-edges preds idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((joins (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length preds))
+ (for-each (lambda (pred)
+ (unless (dominates? pred n)
+ (vector-push! joins pred n)))
+ (vector-ref preds n))
+ (lp (1+ n))))
+ joins))
+
+;; Compute a vector containing, for each node, a list of the back edges
+;; to that node. If a node is not the entry of a reducible loop, that
+;; list is empty.
+(define (compute-reducible-back-edges joins idoms)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((back-edges (make-vector (vector-length idoms) '())))
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ (when (dominates? succ n)
+ (vector-push! back-edges succ n)))
+ (vector-ref joins n))
+ (lp (1+ n))))
+ back-edges))
+
+;; Compute the levels in the dominator tree at which there are
+;; irreducible loops, as an integer. If a bit N is set in the integer,
+;; that indicates that at level N in the dominator tree, there is at
+;; least one irreducible loop.
+(define (compute-irreducible-dom-levels doms joins idoms dom-levels)
+ (define (dominates? n1 n2)
+ (or (= n1 n2)
+ (and (< n1 n2)
+ (dominates? n1 (vector-ref idoms n2)))))
+ (let ((pre-order (make-vector (vector-length doms) #f))
+ (last-pre-order (make-vector (vector-length doms) #f))
+ (res 0)
+ (count 0))
+ ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
+ ;; computed from the DJ graph? See Havlak 1997, "Nesting of
+ ;; Reducible and Irreducible Loops".
+ (define (ancestor? a b)
+ (let ((w (vector-ref pre-order a))
+ (v (vector-ref pre-order b)))
+ (and (<= w v)
+ (<= v (vector-ref last-pre-order w)))))
+ ;; Compute depth-first spanning tree of DJ graph.
+ (define (recurse n)
+ (unless (vector-ref pre-order n)
+ (visit n)))
+ (define (visit n)
+ ;; Pre-order visitation index.
+ (vector-set! pre-order n count)
+ (set! count (1+ count))
+ (for-each recurse (vector-ref doms n))
+ (for-each recurse (vector-ref joins n))
+ ;; Pre-order visitation index of last descendant.
+ (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
+
+ (visit 0)
+
+ (let lp ((n 0))
+ (when (< n (vector-length joins))
+ (for-each (lambda (succ)
+ ;; If this join edge is not a loop back edge but it
+ ;; does go to an ancestor on the DFST of the DJ
+ ;; graph, then we have an irreducible loop.
+ (when (and (not (dominates? succ n))
+ (ancestor? succ n))
+ (set! res (logior (ash 1 (vector-ref dom-levels succ))))))
+ (vector-ref joins n))
+ (lp (1+ n))))
+
+ res))
+
+(define (compute-nodes-by-level dom-levels)
+ (let* ((max-level (let lp ((n 0) (max-level 0))
+ (if (< n (vector-length dom-levels))
+ (lp (1+ n) (max (vector-ref dom-levels n) max-level))
+ max-level)))
+ (nodes-by-level (make-vector (1+ max-level) '())))
+ (let lp ((n (1- (vector-length dom-levels))))
+ (when (>= n 0)
+ (vector-push! nodes-by-level (vector-ref dom-levels n) n)
+ (lp (1- n))))
+ nodes-by-level))
+
+;; Collect all predecessors to the back-nodes that are strictly
+;; dominated by the loop header, and mark them as belonging to the loop.
+;; If they already have a loop header, that means they are either in a
+;; nested loop, or they have already been visited already.
+(define (mark-loop-body header back-nodes preds idoms loop-headers)
+ (define (strictly-dominates? n1 n2)
+ (and (< n1 n2)
+ (let ((idom (vector-ref idoms n2)))
+ (or (= n1 idom)
+ (strictly-dominates? n1 idom)))))
+ (define (visit node)
+ (when (strictly-dominates? header node)
+ (cond
+ ((vector-ref loop-headers node) => visit)
(else
- (finish-idoms order idoms blocks))))))
+ (vector-set! loop-headers node header)
+ (for-each visit (vector-ref preds node))))))
+ (for-each visit back-nodes))
+
+(define (mark-irreducible-loops level idoms dom-levels loop-headers)
+ ;; FIXME: Identify strongly-connected components that are >= LEVEL in
+ ;; the dominator tree, and somehow mark them as irreducible.
+ (warn 'irreducible-loops-at-level level))
+
+;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
+;; Technical Memo 98, 1995.
+(define (identify-loops preds idoms dom-levels)
+ (let* ((doms (compute-dom-edges idoms))
+ (joins (compute-join-edges preds idoms))
+ (back-edges (compute-reducible-back-edges joins idoms))
+ (irreducible-levels
+ (compute-irreducible-dom-levels doms joins idoms dom-levels))
+ (loop-headers (make-vector (vector-length preds) #f))
+ (nodes-by-level (compute-nodes-by-level dom-levels)))
+ (let lp ((level (1- (vector-length nodes-by-level))))
+ (when (>= level 0)
+ (for-each (lambda (n)
+ (let ((edges (vector-ref back-edges n)))
+ (unless (null? edges)
+ (mark-loop-body n edges preds idoms loop-headers))))
+ (vector-ref nodes-by-level level))
+ (when (logbit? level irreducible-levels)
+ (mark-irreducible-loops level idoms dom-levels loop-headers))
+ (lp (1- level))))
+ loop-headers))
+
+(define (analyze-dominators cfa)
+ (match cfa
+ (($ $cfa k-map order preds)
+ (let* ((idoms (compute-idoms preds))
+ (dom-levels (compute-dom-levels idoms))
+ (loop-headers (identify-loops preds idoms dom-levels)))
+ (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
+
+
+;; Compute the maximum fixed point of the data-flow constraint problem.
+;;
+;; This always completes, as the graph is finite and the in and out sets
+;; are complete semi-lattices. If the graph is reducible and the blocks
+;; are sorted in reverse post-order, this completes in a maximum of LC +
+;; 2 iterations, where LC is the loop connectedness number. See Hecht
+;; and Ullman, "Analysis of a simple algorithm for global flow
+;; problems", POPL 1973, or the recent summary in "Notes on graph
+;; algorithms used in optimizing compilers", Offner 2013.
+(define (compute-maximum-fixed-point preds inv outv killv genv union?)
+ (define (bitvector-copy! dst src)
+ (bitvector-fill! dst #f)
+ (bit-set*! dst src #t))
+ (define (bitvector-meet! accum src)
+ (bit-set*! accum src union?))
+ (let lp ((n 0) (changed? #f))
+ (cond
+ ((< n (vector-length preds))
+ (let ((in (vector-ref inv n))
+ (out (vector-ref outv n))
+ (kill (vector-ref killv n))
+ (gen (vector-ref genv n)))
+ (let ((out-count (or changed? (bit-count #t out))))
+ (for-each
+ (lambda (pred)
+ (bitvector-meet! in (vector-ref outv pred)))
+ (vector-ref preds n))
+ (bitvector-copy! out in)
+ (for-each (cut bitvector-set! out <> #f) kill)
+ (for-each (cut bitvector-set! out <> #t) gen)
+ (lp (1+ n)
+ (or changed? (not (eqv? out-count (bit-count #t out))))))))
+ (changed?
+ (lp 0 #f)))))
+
+;; Data-flow analysis.
+(define-record-type $dfa
+ (make-dfa k-map order var-map names syms in out)
+ dfa?
+ ;; Hash table mapping k-sym -> k-idx
+ (k-map dfa-k-map)
+ ;; Vector of k-idx -> k-sym
+ (order dfa-order)
+ ;; Hash table mapping var-sym -> var-idx
+ (var-map dfa-var-map)
+ ;; Vector of var-idx -> name
+ (names dfa-names)
+ ;; Vector of var-idx -> var-sym
+ (syms dfa-syms)
+ ;; Vector of k-idx -> bitvector
+ (in dfa-in)
+ ;; Vector of k-idx -> bitvector
+ (out dfa-out))
+
+(define (dfa-k-idx dfa k)
+ (or (hashq-ref (dfa-k-map dfa) k)
+ (error "unknown k" k)))
+
+(define (dfa-k-sym dfa idx)
+ (vector-ref (dfa-order dfa) idx))
+
+(define (dfa-k-count dfa)
+ (vector-length (dfa-order dfa)))
+
+(define (dfa-var-idx dfa var)
+ (or (hashq-ref (dfa-var-map dfa) var)
+ (error "unknown var" var)))
+
+(define (dfa-var-name dfa idx)
+ (vector-ref (dfa-names dfa) idx))
+
+(define (dfa-var-sym dfa idx)
+ (vector-ref (dfa-syms dfa) idx))
+
+(define (dfa-var-count dfa)
+ (vector-length (dfa-syms dfa)))
+
+(define (dfa-k-in dfa idx)
+ (vector-ref (dfa-in dfa) idx))
+
+(define (dfa-k-out dfa idx)
+ (vector-ref (dfa-out dfa) idx))
+
+(define (compute-live-variables fun dfg)
+ (define (make-variable-mapping use-maps)
+ (let ((mapping (make-hash-table))
+ (n 0))
+ (hash-for-each (lambda (sym use-map)
+ (hashq-set! mapping sym n)
+ (set! n (1+ n)))
+ use-maps)
+ (values mapping n)))
+ (define (block-accessor blocks accessor)
+ (lambda (k)
+ (accessor (lookup-block k blocks))))
+ (define (renumbering-accessor mapping blocks accessor)
+ (lambda (k)
+ (map (cut hashq-ref mapping <>)
+ ((block-accessor blocks accessor) k))))
+ (match fun
+ (($ $fun src meta free
+ (and entry
+ ($ $cont kentry ($ $kentry self ($ $cont ktail tail)))))
+ (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
+ (lambda (var-map nvars)
+ (define (fold-all-conts f seed)
+ (fold-local-conts (lambda (k cont seed) (f k seed))
+ seed entry))
+ (let* ((blocks (dfg-blocks dfg))
+ (order (reverse-post-order ktail
+ (block-accessor blocks block-preds)
+ fold-all-conts))
+ (k-map (make-block-mapping order))
+ (succs (convert-predecessors
+ order
+ (renumbering-accessor k-map blocks block-succs)))
+ (syms (make-vector nvars #f))
+ (names (make-vector nvars #f))
+ (usev (make-vector (vector-length order) '()))
+ (defv (make-vector (vector-length order) '()))
+ (live-in (make-vector (vector-length order) #f))
+ (live-out (make-vector (vector-length order) #f)))
+ (define (k->idx k)
+ (or (hashq-ref k-map k) (error "unknown k" k)))
+ ;; Initialize syms, names, defv, and usev.
+ (hash-for-each
+ (lambda (sym use-map)
+ (match use-map
+ (($ $use-map name sym def uses)
+ (let ((v (or (hashq-ref var-map sym)
+ (error "unknown var" sym))))
+ (vector-set! syms v sym)
+ (vector-set! names v name)
+ (for-each (lambda (def)
+ (vector-push! defv (k->idx def) v))
+ ((block-accessor blocks block-preds) def))
+ (for-each (lambda (use)
+ (vector-push! usev (k->idx use) v))
+ uses)))))
+ (dfg-use-maps dfg))
+
+ ;; Initialize live-in and live-out sets.
+ (let lp ((n 0))
+ (when (< n (vector-length live-out))
+ (vector-set! live-in n (make-bitvector nvars #f))
+ (vector-set! live-out n (make-bitvector nvars #f))
+ (lp (1+ n))))
+
+ ;; Liveness is a reverse data-flow problem, so we give
+ ;; compute-maximum-fixed-point a reversed graph, swapping in
+ ;; and out, usev and defv, using successors instead of
+ ;; predecessors, and starting with ktail instead of the
+ ;; entry.
+ (compute-maximum-fixed-point succs live-out live-in defv usev #t)
+
+ (make-dfa k-map order var-map names syms live-in live-out)))))))
+
+(define (print-dfa dfa)
+ (match dfa
+ (($ $dfa k-map order var-map names syms in out)
+ (define (print-var-set bv)
+ (let lp ((n 0))
+ (let ((n (bit-position #t bv n)))
+ (when n
+ (format #t " ~A" (vector-ref syms n))
+ (lp (1+ n))))))
+ (let lp ((n 0))
+ (when (< n (vector-length order))
+ (format #t "~A:\n" (vector-ref order n))
+ (format #t " in:")
+ (print-var-set (vector-ref in n))
+ (newline)
+ (format #t " out:")
+ (print-var-set (vector-ref out n))
+ (newline)
+ (lp (1+ n)))))))
(define (visit-fun fun conts blocks use-maps global?)
- (define (add-def! sym def-k)
+ (define (add-def! name sym def-k)
(unless def-k
(error "Term outside labelled continuation?"))
- (hashq-set! use-maps sym (make-use-map sym def-k '())))
+ (hashq-set! use-maps sym (make-use-map name sym def-k '())))
(define (add-use! sym use-k)
(match (hashq-ref use-maps sym)
(#f (error "Symbol out of scope?" sym))
- ((and use-map ($ $use-map sym def uses))
+ ((and use-map ($ $use-map name sym def uses))
(set-use-map-uses! use-map (cons use-k uses)))))
(define* (declare-block! label cont parent
(let ((pred-block (hashq-ref blocks pred))
(succ-block (hashq-ref blocks succ)))
(unless (and pred-block succ-block)
- (error "internal error"))
+ (error "internal error" pred-block succ-block))
(set-block-succs! pred-block (cons succ (block-succs pred-block)))
(set-block-preds! succ-block (cons pred (block-preds succ-block)))))
(define (visit exp exp-k)
- (define (def! sym)
- (add-def! sym exp-k))
+ (define (def! name sym)
+ (add-def! name sym exp-k))
(define (use! sym)
(add-use! sym exp-k))
(define (use-k! k)
(define (recur exp)
(visit exp exp-k))
(match exp
- (($ $letk (($ $cont k src cont) ...) body)
+ (($ $letk (($ $cont k cont) ...) body)
;; Set up recursive environment before visiting cont bodies.
(for-each (lambda (cont k)
(declare-block! k cont exp-k))
(recur body))
(($ $kargs names syms body)
- (for-each def! syms)
+ (for-each def! names syms)
(recur body))
(($ $kif kt kf)
(($ $letrec names syms funs body)
(unless global?
(error "$letrec should not be present when building a local DFG"))
- (for-each def! syms)
+ (for-each def! names syms)
(for-each (cut visit-fun <> conts blocks use-maps global?) funs)
(visit body exp-k))
- (($ $continue k exp)
+ (($ $continue k src exp)
(use-k! k)
(match exp
- (($ $var sym)
- (use! sym))
-
(($ $call proc args)
(use! proc)
(for-each use! args))
(($ $values args)
(for-each use! args))
- (($ $prompt escape? tag handler)
+ (($ $prompt escape? tag handler pop)
(use! tag)
- (use-k! handler))
+ (use-k! handler)
+ ;; Any continuation in the prompt body could cause an abort to
+ ;; the handler, so in theory we could register the handler as
+ ;; a successor of any block in the prompt body. That would be
+ ;; inefficient, though, besides being a hack. Instead we take
+ ;; advantage of the fact that pop continuation post-dominates
+ ;; the prompt body, so we add a link from there to the
+ ;; handler. This creates a primcall node with multiple
+ ;; successors, which is not quite correct, but it does reflect
+ ;; control flow. It is necessary to ensure that the live
+ ;; variables in the handler are seen as live in the body.
+ (link-blocks! pop handler))
(($ $fun)
(when global?
(_ #f)))))
(match fun
- (($ $fun meta free
- ($ $cont kentry src
+ (($ $fun src meta free
+ ($ $cont kentry
(and entry
- ($ $kentry self ($ $cont ktail _ tail) clauses))))
+ ($ $kentry self ($ $cont ktail tail) clauses))))
(declare-block! kentry entry #f 0)
- (add-def! self kentry)
+ (add-def! #f self kentry)
(declare-block! ktail tail kentry)
(for-each
(match-lambda
- (($ $cont kclause _
- (and clause ($ $kclause arity ($ $cont kbody _ body))))
+ (($ $cont kclause
+ (and clause ($ $kclause arity ($ $cont kbody body))))
(declare-block! kclause clause kentry)
(link-blocks! kentry kclause)
(link-blocks! kclause kbody)
(visit body kbody)))
- clauses)
-
- (compute-dominator-tree kentry blocks))))
+ clauses))))
(define* (compute-dfg fun #:key (global? #t))
(let* ((conts (make-hash-table))
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
def)))))
(define (lookup-uses sym dfg)
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
uses)))))
+(define (lookup-block-scope k dfg)
+ (block-scope (lookup-block k (dfg-blocks dfg))))
+
(define (lookup-predecessors k dfg)
(match (lookup-block k (dfg-blocks dfg))
(($ $block _ _ preds succs) preds)))
(define (call-expression call)
(match call
- (($ $continue k exp) exp)))
+ (($ $continue k src exp) exp)))
(define (find-expression term)
(call-expression (find-call term)))
(match (find-defining-expression sym dfg)
(($ $const val)
(values #t val))
- (($ $continue k ($ $void))
+ (($ $continue k src ($ $void))
(values #t *unspecified*))
(else
(values #f #f))))
(define (constant-needs-allocation? sym val dfg)
+ (define (immediate-u8? val)
+ (and (integer? val) (exact? val) (<= 0 val 255)))
+
(define (find-exp term)
(match term
(($ $kargs names syms body) (find-exp body))
(match dfg
(($ $dfg conts blocks use-maps)
(match (lookup-use-map sym use-maps)
- (($ $use-map _ def uses)
+ (($ $use-map _ _ def uses)
(or-map
(lambda (use)
(match (find-expression (lookup-cont use conts))
(($ $call) #f)
- (($ $values) #f)
+ (($ $values (_ _ . _)) #f)
(($ $primcall 'free-ref (closure slot))
(not (eq? sym slot)))
(($ $primcall 'free-set! (closure slot value))
#f)
(($ $primcall 'resolve (name bound?))
(eq? sym name))
+ (($ $primcall 'make-vector/immediate (len init))
+ (not (eq? sym len)))
+ (($ $primcall 'vector-ref/immediate (v i))
+ (not (eq? sym i)))
+ (($ $primcall 'vector-set!/immediate (v i x))
+ (not (eq? sym i)))
+ (($ $primcall 'allocate-struct/immediate (vtable nfields))
+ (not (eq? sym nfields)))
+ (($ $primcall 'struct-ref/immediate (s n))
+ (not (eq? sym n)))
+ (($ $primcall 'struct-set!/immediate (s n x))
+ (not (eq? sym n)))
+ (($ $primcall 'builtin-ref (idx))
+ #f)
(_ #t)))
uses))))))
(and (< scope-level level)
(lp scope))))))))
-;; FIXME: Splice preds, succs, dom tree.
-(define (lift-definition! k scope-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (let ((scope-level (1+ (lookup-scope-level scope-k blocks))))
- ;; Fix parent scope link of K.
- (match (lookup-block k blocks)
- ((and block ($ $block))
- (set-block-scope! block scope-k)))
- ;; Fix up scope levels of K and all contained scopes.
- (let update-levels! ((k k) (level scope-level))
- (match (lookup-block k blocks)
- ((and block ($ $block))
- (set-block-scope-level! block scope-level)))
- (let lp ((cont (lookup-cont k conts)))
- (match cont
- (($ $letk (($ $cont kid) ...) body)
- (for-each (cut update-levels! <> (1+ scope-level)) kid)
- (lp body))
- (($ $letrec names syms funs body)
- (lp body))
- (_ #t))))))))
-
(define (continuation-bound-in? k use-k dfg)
(match dfg
(($ $dfg conts blocks use-maps)
(or-map (lambda (use)
(continuation-scope-contains? k use blocks))
(match (lookup-use-map var use-maps)
- (($ $use-map sym def uses)
+ (($ $use-map name sym def uses)
uses))))))
-;; Does k1 dominate k2?
-(define (dominates? k1 k2 blocks)
- (match (lookup-block k1 blocks)
- (($ $block _ _ _ _ k1-idom k1-dom-level)
- (match (lookup-block k2 blocks)
- (($ $block _ _ _ _ k2-idom k2-dom-level)
- (cond
- ((> k1-dom-level k2-dom-level) #f)
- ((< k1-dom-level k2-dom-level) (dominates? k1 k2-idom blocks))
- ((= k1-dom-level k2-dom-level) (eqv? k1 k2))))))))
-
-(define (dead-after-def? sym dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- (null? uses))))))
-
-(define (dead-after-use? sym use-k dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- ;; If all other uses dominate this use, it is now dead. There
- ;; are other ways for it to be dead, but this is an
- ;; approximation. A better check would be if the successor
- ;; post-dominates all uses.
- (and-map (cut dominates? <> use-k blocks)
- uses))))))
-
-;; A continuation is a "branch" if all of its predecessors are $kif
-;; continuations.
-(define (branch? k dfg)
- (let ((preds (lookup-predecessors k dfg)))
- (and (not (null? preds))
- (and-map (lambda (k)
- (match (lookup-cont k (dfg-cont-table dfg))
- (($ $kif) #t)
- (_ #f)))
- preds))))
-
-(define (find-other-branches k dfg)
- (map (lambda (kif)
- (match (lookup-cont kif (dfg-cont-table dfg))
- (($ $kif (? (cut eq? <> k)) kf)
- kf)
- (($ $kif kt (? (cut eq? <> k)))
- kt)
- (_ (error "Not all predecessors are branches"))))
- (lookup-predecessors k dfg)))
-
-(define (dead-after-branch? sym branch other-branches dfg)
- (match dfg
- (($ $dfg conts blocks use-maps)
- (match (lookup-use-map sym use-maps)
- (($ $use-map sym def uses)
- (and-map
- (lambda (use-k)
- ;; A symbol is dead after a branch if at least one of the
- ;; other branches dominates a use of the symbol, and all
- ;; other uses of the symbol dominate the test.
- (if (or-map (cut dominates? <> use-k blocks)
- other-branches)
- (not (dominates? branch use-k blocks))
- (dominates? use-k branch blocks)))
- uses))))))
+;; A continuation is a control point if it has multiple predecessors, or
+;; if its single predecessor has multiple successors.
+(define (control-point? k dfg)
+ (match (lookup-predecessors k dfg)
+ ((pred)
+ (match (lookup-successors pred dfg)
+ ((_) #f)
+ (_ #t)))
+ (_ #t)))
(define (lookup-bound-syms k dfg)
(match dfg
HCoop / bpt / guile.git / blobdiff