1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014 Free Software Foundation, Inc.
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;;; Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
21 ;;; Many passes rely on a local or global static analysis of a function.
22 ;;; This module implements a simple data-flow graph (DFG) analysis,
23 ;;; tracking the definitions and uses of variables and continuations.
24 ;;; It also builds a table of continuations and scope links, to be able
25 ;;; to easily determine if one continuation is in the scope of another,
26 ;;; and to get to the expression inside a continuation.
28 ;;; Note that the data-flow graph of continuation labels is a
29 ;;; control-flow graph.
31 ;;; We currently don't expose details of the DFG type outside this
32 ;;; module, preferring to only expose accessors. That may change in the
33 ;;; future but it seems to work for now.
37 (define-module (language cps dfg)
38 #:use-module (ice-9 match)
39 #:use-module (srfi srfi-1)
40 #:use-module (srfi srfi-9)
41 #:use-module (srfi srfi-26)
42 #:use-module (language cps)
43 #:export (build-cont-table
44 build-local-cont-table
57 find-defining-expression
59 continuation-bound-in?
61 constant-needs-allocation?
65 ;; Control flow analysis.
67 cfa-k-idx cfa-k-count cfa-k-sym cfa-predecessors
69 ;; Data flow analysis.
70 compute-live-variables
71 dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
72 dfa-var-idx dfa-var-name dfa-var-sym dfa-var-count
75 (define (build-cont-table fun)
76 (fold-conts (lambda (k cont table)
77 (hashq-set! table k cont)
82 (define (build-local-cont-table cont)
83 (fold-local-conts (lambda (k cont table)
84 (hashq-set! table k cont)
89 (define (lookup-cont sym conts)
90 (let ((res (hashq-ref conts sym)))
92 (error "Unknown continuation!" sym (hash-fold acons '() conts)))
95 ;; Data-flow graph for CPS: both for values and continuations.
96 (define-record-type $dfg
97 (make-dfg conts blocks use-maps)
99 ;; hash table of sym -> $kif, $kargs, etc
100 (conts dfg-cont-table)
101 ;; hash table of sym -> $block
103 ;; hash table of sym -> $use-map
104 (use-maps dfg-use-maps))
106 (define-record-type $use-map
107 (make-use-map name sym def uses)
112 (uses use-map-uses set-use-map-uses!))
114 (define-record-type $block
115 (%make-block scope scope-level preds succs)
117 (scope block-scope set-block-scope!)
118 (scope-level block-scope-level set-block-scope-level!)
119 (preds block-preds set-block-preds!)
120 (succs block-succs set-block-succs!))
122 (define (make-block scope scope-level)
123 (%make-block scope scope-level '() '()))
125 ;; Some analyses assume that the only relevant set of nodes is the set
126 ;; that is reachable from some start node. Others need to include nodes
127 ;; that are reachable from an end node as well, or all nodes in a
128 ;; function. In that case pass an appropriate implementation of
129 ;; fold-all-conts, as analyze-control-flow does.
130 (define (reverse-post-order k0 get-successors fold-all-conts)
132 (visited? (make-hash-table)))
134 (hashq-set! visited? k #t)
135 (for-each (lambda (k)
136 (unless (hashq-ref visited? k)
139 (set! order (cons k order)))
140 (list->vector (fold-all-conts
142 (if (hashq-ref visited? k)
145 (hashq-set! visited? k #t)
149 (define (make-block-mapping order)
150 (let ((mapping (make-hash-table)))
152 (when (< n (vector-length order))
153 (hashq-set! mapping (vector-ref order n) n)
157 (define (convert-predecessors order get-predecessors)
158 (let ((preds-vec (make-vector (vector-length order) #f)))
160 (when (< n (vector-length order))
161 (vector-set! preds-vec n (get-predecessors (vector-ref order n)))
165 ;; Control-flow analysis.
166 (define-record-type $cfa
167 (make-cfa k-map order preds)
169 ;; Hash table mapping k-sym -> k-idx
171 ;; Vector of k-idx -> k-sym, in reverse post order
173 ;; Vector of k-idx -> list of k-idx
176 (define* (cfa-k-idx cfa k
177 #:key (default (lambda (k)
178 (error "unknown k" k))))
179 (or (hashq-ref (cfa-k-map cfa) k)
182 (define (cfa-k-count cfa)
183 (vector-length (cfa-order cfa)))
185 (define (cfa-k-sym cfa n)
186 (vector-ref (cfa-order cfa) n))
188 (define (cfa-predecessors cfa n)
189 (vector-ref (cfa-preds cfa) n))
191 (define-inlinable (vector-push! vec idx val)
192 (let ((v vec) (i idx))
193 (vector-set! v i (cons val (vector-ref v i)))))
195 (define (compute-reachable cfa dfg)
196 "Given the forward control-flow analysis in CFA, compute and return
197 the continuations that may be reached if flow reaches a continuation N.
198 Returns a vector of bitvectors. The given CFA should be a forward CFA,
199 for quickest convergence."
200 (let* ((k-count (cfa-k-count cfa))
201 ;; Vector of bitvectors, indicating that continuation N can
203 (reachable (make-vector k-count #f))
204 ;; Vector of lists, indicating that continuation N can directly
205 ;; reach continuations M...
206 (succs (make-vector k-count '())))
208 ;; All continuations are reachable from themselves.
211 (let ((bv (make-bitvector k-count #f)))
212 (bitvector-set! bv n #t)
213 (vector-set! reachable n bv)
216 ;; Initialize successor lists.
219 (for-each (lambda (succ)
220 (vector-push! succs n (cfa-k-idx cfa succ)))
221 (block-succs (lookup-block (cfa-k-sym cfa n)
225 ;; Iterate cfa backwards, to converge quickly.
226 (let ((tmp (make-bitvector k-count #f)))
227 (let lp ((n k-count) (changed? #f))
235 (bitvector-fill! tmp #f)
236 (for-each (lambda (succ)
237 (bit-set*! tmp (vector-ref reachable succ) #t))
238 (vector-ref succs n))
239 (bitvector-set! tmp n #t)
240 (bit-set*! tmp (vector-ref reachable n) #f)
242 ((bit-position #t tmp 0)
243 (bit-set*! (vector-ref reachable n) tmp #t)
246 (lp n changed?))))))))))
248 (define (find-prompts cfa dfg)
249 "Find the prompts in CFA, and return them as a list of PROMPT-INDEX,
250 HANDLER-INDEX pairs."
251 (let lp ((n 0) (prompts '()))
253 ((= n (cfa-k-count cfa))
256 (match (lookup-cont (cfa-k-sym cfa n) (dfg-cont-table dfg))
257 (($ $kargs names syms body)
258 (match (find-expression body)
259 (($ $prompt escape? tag handler)
260 (lp (1+ n) (acons n (cfa-k-idx cfa handler) prompts)))
261 (_ (lp (1+ n) prompts))))
262 (_ (lp (1+ n) prompts)))))))
264 (define (compute-interval cfa dfg reachable start end)
265 "Compute and return the set of continuations that may be reached from
266 START, inclusive, but not reached by END, exclusive. Returns a
268 (let ((body (make-bitvector (cfa-k-count cfa) #f)))
269 (bit-set*! body (vector-ref reachable start) #t)
270 (bit-set*! body (vector-ref reachable end) #f)
273 (define (find-prompt-bodies cfa dfg)
274 "Find all the prompts in CFA, and compute the set of continuations
275 that is reachable from the prompt bodies but not from the corresponding
276 handler. Returns a list of PROMPT, HANDLER, BODY lists, where the BODY
278 (match (find-prompts cfa dfg)
280 (((prompt . handler) ...)
281 (let ((reachable (compute-reachable cfa dfg)))
282 (map (lambda (prompt handler)
283 ;; FIXME: It isn't correct to use all continuations
284 ;; reachable from the prompt, because that includes
285 ;; continuations outside the prompt body. This point is
286 ;; moot if the handler's control flow joins with the the
287 ;; body, as is usually but not always the case.
289 ;; One counter-example is when the handler contifies an
290 ;; infinite loop; in that case we compute a too-large
291 ;; prompt body. This error is currently innocuous, but
292 ;; we should fix it at some point.
294 ;; The fix is to end the body at the corresponding "pop"
296 (let ((body (compute-interval cfa dfg reachable prompt handler)))
297 (list prompt handler body)))
300 (define* (visit-prompt-control-flow cfa dfg f #:key complete?)
301 "For all prompts in CFA, invoke F with arguments PROMPT, HANDLER, and
302 BODY for each body continuation in the prompt."
305 ((prompt handler body)
306 (define (out-or-back-edge? n)
307 ;; Most uses of visit-prompt-control-flow don't need every body
308 ;; continuation, and would be happy getting called only for
309 ;; continuations that postdominate the rest of the body. Unless
310 ;; you pass #:complete? #t, we only invoke F on continuations
311 ;; that can leave the body, or on back-edges in loops.
313 ;; You would think that looking for the final "pop" primcall
314 ;; would be sufficient, but that is incorrect; it's possible for
315 ;; a loop in the prompt body to be contified, and that loop need
316 ;; not continue to the pop if it never terminates. The pop could
317 ;; even be removed by DCE, in that case.
318 (or-map (lambda (succ)
319 (let ((succ (cfa-k-idx cfa succ)))
320 (or (not (bitvector-ref body succ))
322 (block-succs (lookup-block (cfa-k-sym cfa n)
325 (let ((n (bit-position #t body n)))
327 (when (or complete? (out-or-back-edge? n))
328 (f prompt handler n))
330 (find-prompt-bodies cfa dfg)))
332 (define* (analyze-control-flow fun dfg #:key reverse? add-handler-preds?)
333 (define (build-cfa kentry block-succs block-preds forward-cfa)
334 (define (block-accessor accessor)
336 (accessor (lookup-block k (dfg-blocks dfg)))))
337 (define (reachable-preds mapping accessor)
338 ;; It's possible for a predecessor to not be in the mapping, if
339 ;; the predecessor is not reachable from the entry node.
341 (filter-map (cut hashq-ref mapping <>)
342 ((block-accessor accessor) k))))
343 (let* ((order (reverse-post-order
345 (block-accessor block-succs)
348 (let lp ((n (cfa-k-count forward-cfa)) (seed seed))
352 (f (cfa-k-sym forward-cfa (1- n)) seed)))))
353 (lambda (f seed) seed))))
354 (k-map (make-block-mapping order))
355 (preds (convert-predecessors order
356 (reachable-preds k-map block-preds)))
357 (cfa (make-cfa k-map order preds)))
358 (when add-handler-preds?
359 ;; Any expression in the prompt body could cause an abort to the
360 ;; handler. This code adds links from every block in the prompt
361 ;; body to the handler. This causes all values used by the
362 ;; handler to be seen as live in the prompt body, as indeed they
364 (let ((forward-cfa (or forward-cfa cfa)))
365 (visit-prompt-control-flow
367 (lambda (prompt handler body)
369 (if (eq? forward-cfa cfa)
371 (cfa-k-idx cfa (cfa-k-sym forward-cfa n))))
372 (let ((handler (renumber handler))
373 (body (renumber body)))
375 (vector-push! preds body handler)
376 (vector-push! preds handler body)))))))
379 (($ $fun src meta free
382 ($ $kentry self ($ $cont ktail tail) clauses))))
384 (build-cfa ktail block-preds block-succs
385 (analyze-control-flow fun dfg #:reverse? #f
386 #:add-handler-preds? #f))
387 (build-cfa kentry block-succs block-preds #f)))))
389 ;; Dominator analysis.
390 (define-record-type $dominator-analysis
391 (make-dominator-analysis cfa idoms dom-levels loop-header irreducible)
393 ;; The corresponding $cfa
394 (cfa dominator-analysis-cfa)
395 ;; Vector of k-idx -> k-idx
396 (idoms dominator-analysis-idoms)
397 ;; Vector of k-idx -> dom-level
398 (dom-levels dominator-analysis-dom-levels)
399 ;; Vector of k-idx -> k-idx or -1
400 (loop-header dominator-analysis-loop-header)
401 ;; Vector of k-idx -> true or false value
402 (irreducible dominator-analysis-irreducible))
404 (define (compute-dom-levels idoms)
405 (let ((dom-levels (make-vector (vector-length idoms) #f)))
406 (define (compute-dom-level n)
407 (or (vector-ref dom-levels n)
408 (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
409 (vector-set! dom-levels n dom-level)
411 (vector-set! dom-levels 0 0)
413 (when (< n (vector-length idoms))
414 (compute-dom-level n)
418 (define (compute-idoms preds)
419 (let ((idoms (make-vector (vector-length preds) 0)))
420 (define (common-idom d0 d1)
421 ;; We exploit the fact that a reverse post-order is a topological
422 ;; sort, and so the idom of a node is always numerically less than
426 ((< d0 d1) (common-idom d0 (vector-ref idoms d1)))
427 (else (common-idom (vector-ref idoms d0) d1))))
428 (define (compute-idom preds)
432 (let lp ((idom pred) (preds preds))
436 (lp (common-idom idom pred) preds)))))))
437 ;; This is the iterative O(n^2) fixpoint algorithm, originally from
438 ;; Allen and Cocke ("Graph-theoretic constructs for program flow
439 ;; analysis", 1972). See the discussion in Cooper, Harvey, and
440 ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
441 (let iterate ((n 0) (changed? #f))
443 ((< n (vector-length preds))
444 (let ((idom (vector-ref idoms n))
445 (idom* (compute-idom (vector-ref preds n))))
448 (iterate (1+ n) changed?))
450 (vector-set! idoms n idom*)
451 (iterate (1+ n) #t)))))
456 ;; Compute a vector containing, for each node, a list of the nodes that
457 ;; it immediately dominates. These are the "D" edges in the DJ tree.
458 (define (compute-dom-edges idoms)
459 (let ((doms (make-vector (vector-length idoms) '())))
461 (when (< n (vector-length idoms))
462 (let ((idom (vector-ref idoms n)))
463 (vector-push! doms idom n))
467 ;; Compute a vector containing, for each node, a list of the successors
468 ;; of that node that are not dominated by that node. These are the "J"
469 ;; edges in the DJ tree.
470 (define (compute-join-edges preds idoms)
471 (define (dominates? n1 n2)
474 (dominates? n1 (vector-ref idoms n2)))))
475 (let ((joins (make-vector (vector-length idoms) '())))
477 (when (< n (vector-length preds))
478 (for-each (lambda (pred)
479 (unless (dominates? pred n)
480 (vector-push! joins pred n)))
481 (vector-ref preds n))
485 ;; Compute a vector containing, for each node, a list of the back edges
486 ;; to that node. If a node is not the entry of a reducible loop, that
488 (define (compute-reducible-back-edges joins idoms)
489 (define (dominates? n1 n2)
492 (dominates? n1 (vector-ref idoms n2)))))
493 (let ((back-edges (make-vector (vector-length idoms) '())))
495 (when (< n (vector-length joins))
496 (for-each (lambda (succ)
497 (when (dominates? succ n)
498 (vector-push! back-edges succ n)))
499 (vector-ref joins n))
503 ;; Compute the levels in the dominator tree at which there are
504 ;; irreducible loops, as an integer. If a bit N is set in the integer,
505 ;; that indicates that at level N in the dominator tree, there is at
506 ;; least one irreducible loop.
507 (define (compute-irreducible-dom-levels doms joins idoms dom-levels)
508 (define (dominates? n1 n2)
511 (dominates? n1 (vector-ref idoms n2)))))
512 (let ((pre-order (make-vector (vector-length doms) #f))
513 (last-pre-order (make-vector (vector-length doms) #f))
516 ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
517 ;; computed from the DJ graph? See Havlak 1997, "Nesting of
518 ;; Reducible and Irreducible Loops".
519 (define (ancestor? a b)
520 (let ((w (vector-ref pre-order a))
521 (v (vector-ref pre-order b)))
523 (<= v (vector-ref last-pre-order w)))))
524 ;; Compute depth-first spanning tree of DJ graph.
526 (unless (vector-ref pre-order n)
529 ;; Pre-order visitation index.
530 (vector-set! pre-order n count)
531 (set! count (1+ count))
532 (for-each recurse (vector-ref doms n))
533 (for-each recurse (vector-ref joins n))
534 ;; Pre-order visitation index of last descendant.
535 (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
540 (when (< n (vector-length joins))
541 (for-each (lambda (succ)
542 ;; If this join edge is not a loop back edge but it
543 ;; does go to an ancestor on the DFST of the DJ
544 ;; graph, then we have an irreducible loop.
545 (when (and (not (dominates? succ n))
547 (set! res (logior (ash 1 (vector-ref dom-levels succ))))))
548 (vector-ref joins n))
553 (define (compute-nodes-by-level dom-levels)
554 (let* ((max-level (let lp ((n 0) (max-level 0))
555 (if (< n (vector-length dom-levels))
556 (lp (1+ n) (max (vector-ref dom-levels n) max-level))
558 (nodes-by-level (make-vector (1+ max-level) '())))
559 (let lp ((n (1- (vector-length dom-levels))))
561 (vector-push! nodes-by-level (vector-ref dom-levels n) n)
565 ;; Collect all predecessors to the back-nodes that are strictly
566 ;; dominated by the loop header, and mark them as belonging to the loop.
567 ;; If they already have a loop header, that means they are either in a
568 ;; nested loop, or they have already been visited already.
569 (define (mark-loop-body header back-nodes preds idoms loop-headers)
570 (define (strictly-dominates? n1 n2)
572 (let ((idom (vector-ref idoms n2)))
574 (strictly-dominates? n1 idom)))))
576 (when (strictly-dominates? header node)
578 ((vector-ref loop-headers node) => visit)
580 (vector-set! loop-headers node header)
581 (for-each visit (vector-ref preds node))))))
582 (for-each visit back-nodes))
584 (define (mark-irreducible-loops level idoms dom-levels loop-headers)
585 ;; FIXME: Identify strongly-connected components that are >= LEVEL in
586 ;; the dominator tree, and somehow mark them as irreducible.
587 (warn 'irreducible-loops-at-level level))
589 ;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
590 ;; Technical Memo 98, 1995.
591 (define (identify-loops preds idoms dom-levels)
592 (let* ((doms (compute-dom-edges idoms))
593 (joins (compute-join-edges preds idoms))
594 (back-edges (compute-reducible-back-edges joins idoms))
596 (compute-irreducible-dom-levels doms joins idoms dom-levels))
597 (loop-headers (make-vector (vector-length preds) #f))
598 (nodes-by-level (compute-nodes-by-level dom-levels)))
599 (let lp ((level (1- (vector-length nodes-by-level))))
601 (for-each (lambda (n)
602 (let ((edges (vector-ref back-edges n)))
603 (unless (null? edges)
604 (mark-loop-body n edges preds idoms loop-headers))))
605 (vector-ref nodes-by-level level))
606 (when (logbit? level irreducible-levels)
607 (mark-irreducible-loops level idoms dom-levels loop-headers))
611 (define (analyze-dominators cfa)
613 (($ $cfa k-map order preds)
614 (let* ((idoms (compute-idoms preds))
615 (dom-levels (compute-dom-levels idoms))
616 (loop-headers (identify-loops preds idoms dom-levels)))
617 (make-dominator-analysis cfa idoms dom-levels loop-headers #f)))))
620 ;; Compute the maximum fixed point of the data-flow constraint problem.
622 ;; This always completes, as the graph is finite and the in and out sets
623 ;; are complete semi-lattices. If the graph is reducible and the blocks
624 ;; are sorted in reverse post-order, this completes in a maximum of LC +
625 ;; 2 iterations, where LC is the loop connectedness number. See Hecht
626 ;; and Ullman, "Analysis of a simple algorithm for global flow
627 ;; problems", POPL 1973, or the recent summary in "Notes on graph
628 ;; algorithms used in optimizing compilers", Offner 2013.
629 (define (compute-maximum-fixed-point preds inv outv killv genv union?)
630 (define (bitvector-copy! dst src)
631 (bitvector-fill! dst #f)
632 (bit-set*! dst src #t))
633 (define (bitvector-meet! accum src)
634 (bit-set*! accum src union?))
635 (let lp ((n 0) (changed? #f))
637 ((< n (vector-length preds))
638 (let ((in (vector-ref inv n))
639 (out (vector-ref outv n))
640 (kill (vector-ref killv n))
641 (gen (vector-ref genv n)))
642 (let ((out-count (or changed? (bit-count #t out))))
645 (bitvector-meet! in (vector-ref outv pred)))
646 (vector-ref preds n))
647 (bitvector-copy! out in)
648 (for-each (cut bitvector-set! out <> #f) kill)
649 (for-each (cut bitvector-set! out <> #t) gen)
651 (or changed? (not (eqv? out-count (bit-count #t out))))))))
655 ;; Data-flow analysis.
656 (define-record-type $dfa
657 (make-dfa cfa var-map names syms in out)
659 ;; CFA, for its reverse-post-order numbering
661 ;; Hash table mapping var-sym -> var-idx
662 (var-map dfa-var-map)
663 ;; Vector of var-idx -> name
665 ;; Vector of var-idx -> var-sym
667 ;; Vector of k-idx -> bitvector
669 ;; Vector of k-idx -> bitvector
672 (define (dfa-k-idx dfa k)
673 (cfa-k-idx (dfa-cfa dfa) k))
675 (define (dfa-k-sym dfa idx)
676 (cfa-k-sym (dfa-cfa dfa) idx))
678 (define (dfa-k-count dfa)
679 (cfa-k-count (dfa-cfa dfa)))
681 (define (dfa-var-idx dfa var)
682 (or (hashq-ref (dfa-var-map dfa) var)
683 (error "unknown var" var)))
685 (define (dfa-var-name dfa idx)
686 (vector-ref (dfa-names dfa) idx))
688 (define (dfa-var-sym dfa idx)
689 (vector-ref (dfa-syms dfa) idx))
691 (define (dfa-var-count dfa)
692 (vector-length (dfa-syms dfa)))
694 (define (dfa-k-in dfa idx)
695 (vector-ref (dfa-in dfa) idx))
697 (define (dfa-k-out dfa idx)
698 (vector-ref (dfa-out dfa) idx))
700 (define (compute-live-variables fun dfg)
701 (define (make-variable-mapping use-maps)
702 (let ((mapping (make-hash-table))
704 (hash-for-each (lambda (sym use-map)
705 (hashq-set! mapping sym n)
709 (call-with-values (lambda () (make-variable-mapping (dfg-use-maps dfg)))
710 (lambda (var-map nvars)
711 (let* ((cfa (analyze-control-flow fun dfg #:reverse? #t
712 #:add-handler-preds? #t))
713 (syms (make-vector nvars #f))
714 (names (make-vector nvars #f))
715 (usev (make-vector (cfa-k-count cfa) '()))
716 (defv (make-vector (cfa-k-count cfa) '()))
717 (live-in (make-vector (cfa-k-count cfa) #f))
718 (live-out (make-vector (cfa-k-count cfa) #f)))
719 ;; Initialize syms, names, defv, and usev.
721 (lambda (sym use-map)
723 (($ $use-map name sym def uses)
724 (let ((v (or (hashq-ref var-map sym)
725 (error "unknown var" sym))))
726 (vector-set! syms v sym)
727 (vector-set! names v name)
728 (for-each (lambda (def)
729 (vector-push! defv (cfa-k-idx cfa def) v))
730 (block-preds (lookup-block def (dfg-blocks dfg))))
731 (for-each (lambda (use)
732 (vector-push! usev (cfa-k-idx cfa use) v))
736 ;; Initialize live-in and live-out sets.
738 (when (< n (vector-length live-out))
739 (vector-set! live-in n (make-bitvector nvars #f))
740 (vector-set! live-out n (make-bitvector nvars #f))
743 ;; Liveness is a reverse data-flow problem, so we give
744 ;; compute-maximum-fixed-point a reversed graph, swapping in
745 ;; for out, and usev for defv. Note that since we are using
746 ;; a reverse CFA, cfa-preds are actually successors, and
747 ;; continuation 0 is ktail.
748 (compute-maximum-fixed-point (cfa-preds cfa)
749 live-out live-in defv usev #t)
751 (make-dfa cfa var-map names syms live-in live-out)))))
753 (define (print-dfa dfa)
755 (($ $dfa cfa var-map names syms in out)
756 (define (print-var-set bv)
758 (let ((n (bit-position #t bv n)))
760 (format #t " ~A" (vector-ref syms n))
763 (when (< n (cfa-k-count cfa))
764 (format #t "~A:\n" (cfa-k-sym cfa n))
766 (print-var-set (vector-ref in n))
769 (print-var-set (vector-ref out n))
773 (define (visit-fun fun conts blocks use-maps global?)
774 (define (add-def! name sym def-k)
776 (error "Term outside labelled continuation?"))
777 (hashq-set! use-maps sym (make-use-map name sym def-k '())))
779 (define (add-use! sym use-k)
780 (match (hashq-ref use-maps sym)
781 (#f (error "Symbol out of scope?" sym))
782 ((and use-map ($ $use-map name sym def uses))
783 (set-use-map-uses! use-map (cons use-k uses)))))
785 (define* (declare-block! label cont parent
787 (1+ (lookup-scope-level parent blocks))))
788 (hashq-set! conts label cont)
789 (hashq-set! blocks label (make-block parent level)))
791 (define (link-blocks! pred succ)
792 (let ((pred-block (hashq-ref blocks pred))
793 (succ-block (hashq-ref blocks succ)))
794 (unless (and pred-block succ-block)
795 (error "internal error" pred-block succ-block))
796 (set-block-succs! pred-block (cons succ (block-succs pred-block)))
797 (set-block-preds! succ-block (cons pred (block-preds succ-block)))))
799 (define (visit exp exp-k)
800 (define (def! name sym)
801 (add-def! name sym exp-k))
803 (add-use! sym exp-k))
805 (link-blocks! exp-k k))
809 (($ $letk (($ $cont k cont) ...) body)
810 ;; Set up recursive environment before visiting cont bodies.
811 (for-each (lambda (cont k)
812 (declare-block! k cont exp-k))
814 (for-each visit cont k)
817 (($ $kargs names syms body)
818 (for-each def! names syms)
825 (($ $kreceive arity k)
828 (($ $letrec names syms funs body)
830 (error "$letrec should not be present when building a local DFG"))
831 (for-each def! names syms)
832 (for-each (cut visit-fun <> conts blocks use-maps global?) funs)
835 (($ $continue k src exp)
840 (for-each use! args))
842 (($ $callk k proc args)
844 (for-each use! args))
846 (($ $primcall name args)
847 (for-each use! args))
850 (for-each use! args))
852 (($ $prompt escape? tag handler)
858 (visit-fun exp conts blocks use-maps global?)))
863 (($ $fun src meta free
866 ($ $kentry self ($ $cont ktail tail) clauses))))
867 (declare-block! kentry entry #f 0)
868 (add-def! #f self kentry)
870 (declare-block! ktail tail kentry)
875 (and clause ($ $kclause arity ($ $cont kbody body))))
876 (declare-block! kclause clause kentry)
877 (link-blocks! kentry kclause)
879 (declare-block! kbody body kclause)
880 (link-blocks! kclause kbody)
885 (define* (compute-dfg fun #:key (global? #t))
886 (let* ((conts (make-hash-table))
887 (blocks (make-hash-table))
888 (use-maps (make-hash-table)))
889 (visit-fun fun conts blocks use-maps global?)
890 (make-dfg conts blocks use-maps)))
892 (define (lookup-block k blocks)
893 (let ((res (hashq-ref blocks k)))
895 (error "Unknown continuation!" k (hash-fold acons '() blocks)))
898 (define (lookup-scope-level k blocks)
899 (match (lookup-block k blocks)
900 (($ $block _ scope-level) scope-level)))
902 (define (lookup-use-map sym use-maps)
903 (let ((res (hashq-ref use-maps sym)))
905 (error "Unknown lexical!" sym (hash-fold acons '() use-maps)))
908 (define (lookup-def sym dfg)
910 (($ $dfg conts blocks use-maps)
911 (match (lookup-use-map sym use-maps)
912 (($ $use-map name sym def uses)
915 (define (lookup-uses sym dfg)
917 (($ $dfg conts blocks use-maps)
918 (match (lookup-use-map sym use-maps)
919 (($ $use-map name sym def uses)
922 (define (lookup-block-scope k dfg)
923 (block-scope (lookup-block k (dfg-blocks dfg))))
925 (define (lookup-predecessors k dfg)
926 (match (lookup-block k (dfg-blocks dfg))
927 (($ $block _ _ preds succs) preds)))
929 (define (lookup-successors k dfg)
930 (match (lookup-block k (dfg-blocks dfg))
931 (($ $block _ _ preds succs) succs)))
933 (define (find-defining-term sym dfg)
934 (match (lookup-predecessors (lookup-def sym dfg) dfg)
936 (lookup-cont def-exp-k (dfg-cont-table dfg)))
939 (define (find-call term)
941 (($ $kargs names syms body) (find-call body))
942 (($ $letk conts body) (find-call body))
943 (($ $letrec names syms funs body) (find-call body))
944 (($ $continue) term)))
946 (define (call-expression call)
948 (($ $continue k src exp) exp)))
950 (define (find-expression term)
951 (call-expression (find-call term)))
953 (define (find-defining-expression sym dfg)
954 (match (find-defining-term sym dfg)
958 (term (find-expression term))))
960 (define (find-constant-value sym dfg)
961 (match (find-defining-expression sym dfg)
964 (($ $continue k src ($ $void))
965 (values #t *unspecified*))
969 (define (constant-needs-allocation? sym val dfg)
970 (define (immediate-u8? val)
971 (and (integer? val) (exact? val) (<= 0 val 255)))
973 (define (find-exp term)
975 (($ $kargs names syms body) (find-exp body))
976 (($ $letk conts body) (find-exp body))
979 (($ $dfg conts blocks use-maps)
980 (match (lookup-use-map sym use-maps)
981 (($ $use-map _ _ def uses)
984 (match (find-expression (lookup-cont use conts))
988 (($ $primcall 'free-ref (closure slot))
989 (not (eq? sym slot)))
990 (($ $primcall 'free-set! (closure slot value))
991 (not (eq? sym slot)))
992 (($ $primcall 'cache-current-module! (mod . _))
994 (($ $primcall 'cached-toplevel-box _)
996 (($ $primcall 'cached-module-box _)
998 (($ $primcall 'resolve (name bound?))
1000 (($ $primcall 'make-vector/immediate (len init))
1001 (not (eq? sym len)))
1002 (($ $primcall 'vector-ref/immediate (v i))
1004 (($ $primcall 'vector-set!/immediate (v i x))
1006 (($ $primcall 'allocate-struct/immediate (vtable nfields))
1007 (not (eq? sym nfields)))
1008 (($ $primcall 'struct-ref/immediate (s n))
1010 (($ $primcall 'struct-set!/immediate (s n x))
1012 (($ $primcall 'builtin-ref (idx))
1017 (define (continuation-scope-contains? scope-k k blocks)
1018 (let ((scope-level (lookup-scope-level scope-k blocks)))
1021 (match (lookup-block k blocks)
1022 (($ $block scope level)
1023 (and (< scope-level level)
1026 (define (continuation-bound-in? k use-k dfg)
1028 (($ $dfg conts blocks use-maps)
1029 (match (lookup-block k blocks)
1031 (continuation-scope-contains? def-k use-k blocks))))))
1033 (define (variable-free-in? var k dfg)
1035 (($ $dfg conts blocks use-maps)
1036 (or-map (lambda (use)
1037 (continuation-scope-contains? k use blocks))
1038 (match (lookup-use-map var use-maps)
1039 (($ $use-map name sym def uses)
1042 ;; A continuation is a control point if it has multiple predecessors, or
1043 ;; if its single predecessor has multiple successors.
1044 (define (control-point? k dfg)
1045 (match (lookup-predecessors k dfg)
1047 (match (lookup-successors pred dfg)
1052 (define (lookup-bound-syms k dfg)
1054 (($ $dfg conts blocks use-maps)
1055 (match (lookup-cont k conts)
1056 (($ $kargs names syms body)