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
52 with-fresh-name-state-from-dfg
61 find-defining-expression
63 continuation-bound-in?
65 constant-needs-allocation?
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-sym dfa-var-count
75 ;; These definitions are here because currently we don't do cross-module
76 ;; inlining. They can be removed once that restriction is gone.
77 (define-inlinable (for-each f l)
79 (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
80 (let for-each1 ((l l))
83 (for-each1 (cdr l)))))
85 (define-inlinable (for-each/2 f l1 l2)
86 (unless (= (length l1) (length l2))
87 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
89 (let for-each2 ((l1 l1) (l2 l2))
92 (for-each2 (cdr l1) (cdr l2)))))
94 (define (build-cont-table fun)
95 (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
97 (fold-conts (lambda (k cont table)
98 (vector-set! table k cont)
100 (make-vector (1+ max-k) #f)
103 ;; Data-flow graph for CPS: both for values and continuations.
104 (define-record-type $dfg
105 (make-dfg conts preds defs uses scopes scope-levels
106 min-label max-label label-count
107 min-var max-var var-count)
109 ;; vector of label -> $kif, $kargs, etc
110 (conts dfg-cont-table)
111 ;; vector of label -> (pred-label ...)
113 ;; vector of var -> def-label
115 ;; vector of var -> (use-label ...)
117 ;; vector of label -> label
119 ;; vector of label -> int
120 (scope-levels dfg-scope-levels)
122 (min-label dfg-min-label)
123 (max-label dfg-max-label)
124 (label-count dfg-label-count)
126 (min-var dfg-min-var)
127 (max-var dfg-max-var)
128 (var-count dfg-var-count))
130 (define-inlinable (vector-push! vec idx val)
131 (let ((v vec) (i idx))
132 (vector-set! v i (cons val (vector-ref v i)))))
134 (define (compute-reachable dfg min-label label-count)
135 "Compute and return the continuations that may be reached if flow
136 reaches a continuation N. Returns a vector of bitvectors, whose first
137 index corresponds to MIN-LABEL, and so on."
138 (let (;; Vector of bitvectors, indicating that continuation N can
140 (reachable (make-vector label-count #f)))
142 (define (label->idx label) (- label min-label))
144 ;; All continuations are reachable from themselves.
146 (when (< n label-count)
147 (let ((bv (make-bitvector label-count #f)))
148 (bitvector-set! bv n #t)
149 (vector-set! reachable n bv)
152 ;; Iterate labels backwards, to converge quickly.
153 (let ((tmp (make-bitvector label-count #f)))
154 (define (add-reachable! succ)
155 (bit-set*! tmp (vector-ref reachable (label->idx succ)) #t))
156 (let lp ((label (+ min-label label-count)) (changed? #f))
160 (lp (+ min-label label-count) #f)
163 (let* ((label (1- label))
164 (idx (label->idx label)))
165 (bitvector-fill! tmp #f)
166 (visit-cont-successors
169 ((succ0) (add-reachable! succ0))
170 ((succ0 succ1) (add-reachable! succ0) (add-reachable! succ1)))
171 (lookup-cont label dfg))
172 (bitvector-set! tmp idx #t)
173 (bit-set*! tmp (vector-ref reachable idx) #f)
175 ((bit-position #t tmp 0)
176 (bit-set*! (vector-ref reachable idx) tmp #t)
179 (lp label changed?))))))))))
181 (define (find-prompts dfg min-label label-count)
182 "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
183 LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
185 (let lp ((label min-label) (prompts '()))
187 ((= label (+ min-label label-count))
190 (match (lookup-cont label dfg)
191 (($ $kargs names syms body)
192 (match (find-expression body)
193 (($ $prompt escape? tag handler)
194 (lp (1+ label) (acons label handler prompts)))
195 (_ (lp (1+ label) prompts))))
196 (_ (lp (1+ label) prompts)))))))
198 (define (compute-interval reachable min-label label-count start end)
199 "Compute and return the set of continuations that may be reached from
200 START, inclusive, but not reached by END, exclusive. Returns a
202 (let ((body (make-bitvector label-count #f)))
203 (bit-set*! body (vector-ref reachable (- start min-label)) #t)
204 (bit-set*! body (vector-ref reachable (- end min-label)) #f)
207 (define (find-prompt-bodies dfg min-label label-count)
208 "Find all the prompts in DFG from the LABEL-COUNT continuations
209 starting at MIN-LABEL, and compute the set of continuations that is
210 reachable from the prompt bodies but not from the corresponding handler.
211 Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is a
213 (match (find-prompts dfg min-label label-count)
215 (((prompt . handler) ...)
216 (let ((reachable (compute-reachable dfg min-label label-count)))
217 (map (lambda (prompt handler)
218 ;; FIXME: It isn't correct to use all continuations
219 ;; reachable from the prompt, because that includes
220 ;; continuations outside the prompt body. This point is
221 ;; moot if the handler's control flow joins with the the
222 ;; body, as is usually but not always the case.
224 ;; One counter-example is when the handler contifies an
225 ;; infinite loop; in that case we compute a too-large
226 ;; prompt body. This error is currently innocuous, but we
227 ;; should fix it at some point.
229 ;; The fix is to end the body at the corresponding "pop"
231 (let ((body (compute-interval reachable min-label label-count
233 (list prompt handler body)))
236 (define* (visit-prompt-control-flow dfg min-label label-count f #:key complete?)
237 "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
238 LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
239 body continuation in the prompt."
240 (define (label->idx label) (- label min-label))
241 (define (idx->label idx) (+ idx min-label))
244 ((prompt handler body)
245 (define (out-or-back-edge? n)
246 ;; Most uses of visit-prompt-control-flow don't need every body
247 ;; continuation, and would be happy getting called only for
248 ;; continuations that postdominate the rest of the body. Unless
249 ;; you pass #:complete? #t, we only invoke F on continuations
250 ;; that can leave the body, or on back-edges in loops.
252 ;; You would think that looking for the final "pop" primcall
253 ;; would be sufficient, but that is incorrect; it's possible for
254 ;; a loop in the prompt body to be contified, and that loop need
255 ;; not continue to the pop if it never terminates. The pop could
256 ;; even be removed by DCE, in that case.
257 (or-map (lambda (succ)
258 (let ((succ (label->idx succ)))
259 (or (not (bitvector-ref body succ))
261 (lookup-successors (idx->label n) dfg)))
263 (let ((n (bit-position #t body n)))
265 (when (or complete? (out-or-back-edge? n))
266 (f prompt handler (idx->label n)))
268 (find-prompt-bodies dfg min-label label-count)))
270 (define (analyze-reverse-control-flow fun dfg min-label label-count)
271 (define (compute-reverse-control-flow-order ktail dfg)
272 (let ((order (make-vector label-count #f))
273 (label-map (make-vector label-count #f))
275 (define (label->idx label) (- label min-label))
276 (define (idx->label idx) (+ idx min-label))
278 (let visit ((k ktail))
279 ;; Mark this label as visited.
280 (vector-set! label-map (label->idx k) #t)
281 (for-each (lambda (k)
282 ;; Visit predecessors unless they are already visited.
283 (unless (vector-ref label-map (label->idx k))
285 (lookup-predecessors k dfg))
286 ;; Add to reverse post-order chain.
287 (vector-set! label-map (label->idx k) next)
290 (let lp ((n 0) (head next))
292 ;; Add nodes that are not reachable from the tail.
293 (let lp ((n n) (m label-count))
294 (unless (= n label-count)
295 (let find-unvisited ((m (1- m)))
296 (if (vector-ref label-map m)
297 (find-unvisited (1- m))
299 (vector-set! label-map m n)
301 ;; Pop the head off the chain, give it its
302 ;; reverse-post-order numbering, and continue.
303 (let ((next (vector-ref label-map (label->idx head))))
304 (vector-set! label-map (label->idx head) n)
308 (when (< n label-count)
309 (vector-set! order (vector-ref label-map n) (idx->label n))
312 (values order label-map)))
314 (define (convert-successors k-map)
315 (define (idx->label idx) (+ idx min-label))
316 (define (renumber label)
317 (vector-ref k-map (- label min-label)))
318 (let ((succs (make-vector (vector-length k-map) #f)))
320 (when (< n (vector-length succs))
321 (vector-set! succs (vector-ref k-map n)
323 (lookup-successors (idx->label n) dfg)))
329 ($ $cont kentry ($ $kentry src meta self ($ $cont ktail tail))))
332 (compute-reverse-control-flow-order ktail dfg))
333 (lambda (order k-map)
334 (let ((succs (convert-successors k-map)))
335 ;; Any expression in the prompt body could cause an abort to
336 ;; the handler. This code adds links from every block in the
337 ;; prompt body to the handler. This causes all values used
338 ;; by the handler to be seen as live in the prompt body, as
340 (visit-prompt-control-flow
341 dfg min-label label-count
342 (lambda (prompt handler body)
343 (define (renumber label)
344 (vector-ref k-map (- label min-label)))
345 (vector-push! succs (renumber body) (renumber handler))))
347 (values k-map order succs)))))))
349 ;; Dominator analysis.
350 (define-record-type $dominator-analysis
351 (make-dominator-analysis min-label idoms dom-levels loop-header irreducible)
353 ;; Label corresponding to first entry in idoms, dom-levels, etc
354 (min-label dominator-analysis-min-label)
355 ;; Vector of k-idx -> k-idx
356 (idoms dominator-analysis-idoms)
357 ;; Vector of k-idx -> dom-level
358 (dom-levels dominator-analysis-dom-levels)
359 ;; Vector of k-idx -> k-idx or -1
360 (loop-header dominator-analysis-loop-header)
361 ;; Vector of k-idx -> true or false value
362 (irreducible dominator-analysis-irreducible))
364 (define (compute-dom-levels idoms)
365 (let ((dom-levels (make-vector (vector-length idoms) #f)))
366 (define (compute-dom-level n)
367 (or (vector-ref dom-levels n)
368 (let ((dom-level (1+ (compute-dom-level (vector-ref idoms n)))))
369 (vector-set! dom-levels n dom-level)
371 (vector-set! dom-levels 0 0)
373 (when (< n (vector-length idoms))
374 (compute-dom-level n)
378 (define (compute-idoms preds min-label label-count)
379 (define (label->idx label) (- label min-label))
380 (define (idx->label idx) (+ idx min-label))
381 (let ((idoms (make-vector label-count 0)))
382 (define (common-idom d0 d1)
383 ;; We exploit the fact that a reverse post-order is a topological
384 ;; sort, and so the idom of a node is always numerically less than
388 ((< d0 d1) (common-idom d0 (vector-ref idoms d1)))
389 (else (common-idom (vector-ref idoms d0) d1))))
390 (define (compute-idom preds)
394 (let lp ((idom (label->idx pred)) (preds preds))
398 (lp (common-idom idom (label->idx pred)) preds)))))))
399 ;; This is the iterative O(n^2) fixpoint algorithm, originally from
400 ;; Allen and Cocke ("Graph-theoretic constructs for program flow
401 ;; analysis", 1972). See the discussion in Cooper, Harvey, and
402 ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
403 (let iterate ((n 0) (changed? #f))
406 (let ((idom (vector-ref idoms n))
407 (idom* (compute-idom (vector-ref preds (idx->label n)))))
410 (iterate (1+ n) changed?))
412 (vector-set! idoms n idom*)
413 (iterate (1+ n) #t)))))
418 ;; Compute a vector containing, for each node, a list of the nodes that
419 ;; it immediately dominates. These are the "D" edges in the DJ tree.
420 (define (compute-dom-edges idoms)
421 (let ((doms (make-vector (vector-length idoms) '())))
423 (when (< n (vector-length idoms))
424 (let ((idom (vector-ref idoms n)))
425 (vector-push! doms idom n))
429 ;; Compute a vector containing, for each node, a list of the successors
430 ;; of that node that are not dominated by that node. These are the "J"
431 ;; edges in the DJ tree.
432 (define (compute-join-edges preds min-label idoms)
433 (define (dominates? n1 n2)
436 (dominates? n1 (vector-ref idoms n2)))))
437 (let ((joins (make-vector (vector-length idoms) '())))
439 (when (< n (vector-length idoms))
440 (for-each (lambda (pred)
441 (let ((pred (- pred min-label)))
442 (unless (dominates? pred n)
443 (vector-push! joins pred n))))
444 (vector-ref preds (+ n min-label)))
448 ;; Compute a vector containing, for each node, a list of the back edges
449 ;; to that node. If a node is not the entry of a reducible loop, that
451 (define (compute-reducible-back-edges joins idoms)
452 (define (dominates? n1 n2)
455 (dominates? n1 (vector-ref idoms n2)))))
456 (let ((back-edges (make-vector (vector-length idoms) '())))
458 (when (< n (vector-length joins))
459 (for-each (lambda (succ)
460 (when (dominates? succ n)
461 (vector-push! back-edges succ n)))
462 (vector-ref joins n))
466 ;; Compute the levels in the dominator tree at which there are
467 ;; irreducible loops, as an integer. If a bit N is set in the integer,
468 ;; that indicates that at level N in the dominator tree, there is at
469 ;; least one irreducible loop.
470 (define (compute-irreducible-dom-levels doms joins idoms dom-levels)
471 (define (dominates? n1 n2)
474 (dominates? n1 (vector-ref idoms n2)))))
475 (let ((pre-order (make-vector (vector-length doms) #f))
476 (last-pre-order (make-vector (vector-length doms) #f))
479 ;; Is MAYBE-PARENT an ancestor of N on the depth-first spanning tree
480 ;; computed from the DJ graph? See Havlak 1997, "Nesting of
481 ;; Reducible and Irreducible Loops".
482 (define (ancestor? a b)
483 (let ((w (vector-ref pre-order a))
484 (v (vector-ref pre-order b)))
486 (<= v (vector-ref last-pre-order w)))))
487 ;; Compute depth-first spanning tree of DJ graph.
489 (unless (vector-ref pre-order n)
492 ;; Pre-order visitation index.
493 (vector-set! pre-order n count)
494 (set! count (1+ count))
495 (for-each recurse (vector-ref doms n))
496 (for-each recurse (vector-ref joins n))
497 ;; Pre-order visitation index of last descendant.
498 (vector-set! last-pre-order (vector-ref pre-order n) (1- count)))
503 (when (< n (vector-length joins))
504 (for-each (lambda (succ)
505 ;; If this join edge is not a loop back edge but it
506 ;; does go to an ancestor on the DFST of the DJ
507 ;; graph, then we have an irreducible loop.
508 (when (and (not (dominates? succ n))
510 (set! res (logior (ash 1 (vector-ref dom-levels succ))))))
511 (vector-ref joins n))
516 (define (compute-nodes-by-level dom-levels)
517 (let* ((max-level (let lp ((n 0) (max-level 0))
518 (if (< n (vector-length dom-levels))
519 (lp (1+ n) (max (vector-ref dom-levels n) max-level))
521 (nodes-by-level (make-vector (1+ max-level) '())))
522 (let lp ((n (1- (vector-length dom-levels))))
524 (vector-push! nodes-by-level (vector-ref dom-levels n) n)
528 ;; Collect all predecessors to the back-nodes that are strictly
529 ;; dominated by the loop header, and mark them as belonging to the loop.
530 ;; If they already have a loop header, that means they are either in a
531 ;; nested loop, or they have already been visited already.
532 (define (mark-loop-body header back-nodes preds min-label idoms loop-headers)
533 (define (strictly-dominates? n1 n2)
535 (let ((idom (vector-ref idoms n2)))
537 (strictly-dominates? n1 idom)))))
539 (when (strictly-dominates? header node)
541 ((vector-ref loop-headers node) => visit)
543 (vector-set! loop-headers node header)
544 (for-each (lambda (pred) (visit (- pred min-label)))
545 (vector-ref preds (+ node min-label)))))))
546 (for-each visit back-nodes))
548 (define (mark-irreducible-loops level idoms dom-levels loop-headers)
549 ;; FIXME: Identify strongly-connected components that are >= LEVEL in
550 ;; the dominator tree, and somehow mark them as irreducible.
551 (warn 'irreducible-loops-at-level level))
553 ;; "Identifying Loops Using DJ Graphs" by Sreedhar, Gao, and Lee, ACAPS
554 ;; Technical Memo 98, 1995.
555 (define (identify-loops preds min-label idoms dom-levels)
556 (let* ((doms (compute-dom-edges idoms))
557 (joins (compute-join-edges preds min-label idoms))
558 (back-edges (compute-reducible-back-edges joins idoms))
560 (compute-irreducible-dom-levels doms joins idoms dom-levels))
561 (loop-headers (make-vector (vector-length idoms) #f))
562 (nodes-by-level (compute-nodes-by-level dom-levels)))
563 (let lp ((level (1- (vector-length nodes-by-level))))
565 (for-each (lambda (n)
566 (let ((edges (vector-ref back-edges n)))
567 (unless (null? edges)
568 (mark-loop-body n edges preds min-label
569 idoms loop-headers))))
570 (vector-ref nodes-by-level level))
571 (when (logbit? level irreducible-levels)
572 (mark-irreducible-loops level idoms dom-levels loop-headers))
576 (define (analyze-dominators dfg min-label label-count)
577 (let* ((idoms (compute-idoms (dfg-preds dfg) min-label label-count))
578 (dom-levels (compute-dom-levels idoms))
579 (loop-headers (identify-loops (dfg-preds dfg) min-label idoms dom-levels)))
580 (make-dominator-analysis min-label idoms dom-levels loop-headers #f)))
583 ;; Compute the maximum fixed point of the data-flow constraint problem.
585 ;; This always completes, as the graph is finite and the in and out sets
586 ;; are complete semi-lattices. If the graph is reducible and the blocks
587 ;; are sorted in reverse post-order, this completes in a maximum of LC +
588 ;; 2 iterations, where LC is the loop connectedness number. See Hecht
589 ;; and Ullman, "Analysis of a simple algorithm for global flow
590 ;; problems", POPL 1973, or the recent summary in "Notes on graph
591 ;; algorithms used in optimizing compilers", Offner 2013.
592 (define (compute-maximum-fixed-point preds inv outv killv genv union?)
593 (define (bitvector-copy! dst src)
594 (bitvector-fill! dst #f)
595 (bit-set*! dst src #t))
596 (define (bitvector-meet! accum src)
597 (bit-set*! accum src union?))
598 (let lp ((n 0) (changed? #f))
600 ((< n (vector-length preds))
601 (let ((in (vector-ref inv n))
602 (out (vector-ref outv n))
603 (kill (vector-ref killv n))
604 (gen (vector-ref genv n)))
605 (let ((out-count (or changed? (bit-count #t out))))
608 (bitvector-meet! in (vector-ref outv pred)))
609 (vector-ref preds n))
610 (bitvector-copy! out in)
611 (for-each (cut bitvector-set! out <> #f) kill)
612 (for-each (cut bitvector-set! out <> #t) gen)
614 (or changed? (not (eqv? out-count (bit-count #t out))))))))
618 ;; Data-flow analysis.
619 (define-record-type $dfa
620 (make-dfa min-label k-map k-order min-var var-count in out)
623 (min-label dfa-min-label)
624 ;; Vector of (k - min-label) -> k-idx
626 ;; Vector of k-idx -> k-sym, in (possibly reversed) control-flow order
627 (k-order dfa-k-order)
629 ;; Minimum var in this function.
630 (min-var dfa-min-var)
631 ;; Minimum var in this function.
632 (var-count dfa-var-count)
633 ;; Vector of k-idx -> bitvector
635 ;; Vector of k-idx -> bitvector
638 (define (dfa-k-idx dfa k)
639 (vector-ref (dfa-k-map dfa) (- k (dfa-min-label dfa))))
641 (define (dfa-k-sym dfa idx)
642 (vector-ref (dfa-k-order dfa) idx))
644 (define (dfa-k-count dfa)
645 (vector-length (dfa-k-map dfa)))
647 (define (dfa-var-idx dfa var)
648 (let ((idx (- var (dfa-min-var dfa))))
649 (unless (< -1 idx (dfa-var-count dfa))
650 (error "var out of range" var))
653 (define (dfa-var-sym dfa idx)
654 (unless (< -1 idx (dfa-var-count dfa))
655 (error "idx out of range" idx))
656 (+ idx (dfa-min-var dfa)))
658 (define (dfa-k-in dfa idx)
659 (vector-ref (dfa-in dfa) idx))
661 (define (dfa-k-out dfa idx)
662 (vector-ref (dfa-out dfa) idx))
664 (define (compute-live-variables fun dfg)
665 (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
666 (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
667 (error "function needs renumbering"))
668 (let* ((min-label (dfg-min-label dfg))
669 (nlabels (dfg-label-count dfg))
670 (min-var (dfg-min-var dfg))
671 (nvars (dfg-var-count dfg))
672 (usev (make-vector nlabels '()))
673 (defv (make-vector nlabels '()))
674 (live-in (make-vector nlabels #f))
675 (live-out (make-vector nlabels #f)))
678 (analyze-reverse-control-flow fun dfg min-label nlabels))
679 (lambda (k-map k-order succs)
680 (define (var->idx var) (- var min-var))
681 (define (idx->var idx) (+ idx min-var))
682 (define (label->idx label)
683 (vector-ref k-map (- label min-label)))
685 ;; Initialize defv and usev.
686 (let ((defs (dfg-defs dfg))
687 (uses (dfg-uses dfg)))
689 (when (< n (vector-length defs))
690 (let ((def (vector-ref defs n)))
692 (error "internal error -- var array not packed"))
693 (for-each (lambda (def)
694 (vector-push! defv (label->idx def) n))
695 (lookup-predecessors def dfg))
696 (for-each (lambda (use)
697 (vector-push! usev (label->idx use) n))
701 ;; Initialize live-in and live-out sets.
703 (when (< n (vector-length live-out))
704 (vector-set! live-in n (make-bitvector nvars #f))
705 (vector-set! live-out n (make-bitvector nvars #f))
708 ;; Liveness is a reverse data-flow problem, so we give
709 ;; compute-maximum-fixed-point a reversed graph, swapping in for
710 ;; out, usev for defv, and using successors instead of
711 ;; predecessors. Continuation 0 is ktail.
712 (compute-maximum-fixed-point succs live-out live-in defv usev #t)
714 (make-dfa min-label k-map k-order min-var nvars live-in live-out)))))
716 (define (print-dfa dfa)
718 (($ $dfa min-label k-map k-order min-var var-count in out)
719 (define (print-var-set bv)
721 (let ((n (bit-position #t bv n)))
723 (format #t " ~A" (+ n min-var))
726 (when (< n (vector-length k-order))
727 (format #t "~A:\n" (vector-ref k-order n))
729 (print-var-set (vector-ref in n))
732 (print-var-set (vector-ref out n))
736 (define (visit-fun fun conts preds defs uses scopes scope-levels
737 min-label min-var global?)
738 (define (add-def! var def-k)
739 (vector-set! defs (- var min-var) def-k))
741 (define (add-use! var use-k)
742 (vector-push! uses (- var min-var) use-k))
744 (define* (declare-block! label cont parent
748 (- parent min-label)))))
749 (vector-set! conts (- label min-label) cont)
750 (vector-set! scopes (- label min-label) parent)
751 (vector-set! scope-levels (- label min-label) level))
753 (define (link-blocks! pred succ)
754 (vector-push! preds (- succ min-label) pred))
756 (define (visit exp exp-k)
758 (add-def! sym exp-k))
760 (add-use! sym exp-k))
762 (link-blocks! exp-k k))
766 (($ $letk (($ $cont k cont) ...) body)
767 ;; Set up recursive environment before visiting cont bodies.
768 (for-each/2 (lambda (cont k)
769 (declare-block! k cont exp-k))
771 (for-each/2 visit cont k)
774 (($ $kargs names syms body)
782 (($ $kreceive arity k)
785 (($ $letrec names syms funs body)
787 (error "$letrec should not be present when building a local DFG"))
790 (cut visit-fun <> conts preds defs uses scopes scope-levels
791 min-label min-var global?)
795 (($ $continue k src exp)
800 (for-each use! args))
802 (($ $callk k proc args)
804 (for-each use! args))
806 (($ $primcall name args)
807 (for-each use! args))
810 (for-each use! args))
812 (($ $prompt escape? tag handler)
818 (visit-fun exp conts preds defs uses scopes scope-levels
819 min-label min-var global?)))
827 ($ $kentry src meta self ($ $cont ktail tail) clause))))
828 (declare-block! kentry entry #f 0)
829 (add-def! self kentry)
831 (declare-block! ktail tail kentry)
833 (let lp ((clause clause))
837 (and clause ($ $kclause arity ($ $cont kbody body)
839 (declare-block! kclause clause kentry)
840 (link-blocks! kentry kclause)
842 (declare-block! kbody body kclause)
843 (link-blocks! kclause kbody)
848 (define (compute-label-and-var-ranges fun global?)
851 (define-syntax-rule (do-fold global?)
852 ((make-cont-folder global?
853 min-label max-label label-count
854 min-var max-var var-count)
856 min-label max-label label-count
857 min-var max-var var-count)
858 (let ((min-label (min* label min-label))
859 (max-label (max label max-label)))
860 (define (visit-letrec body min-var max-var var-count)
862 (($ $letk conts body)
863 (visit-letrec body min-var max-var var-count))
864 (($ $letrec names vars funs body)
866 (cond (min-var (fold min min-var vars))
867 ((pair? vars) (fold min (car vars) (cdr vars)))
869 (fold max max-var vars)
870 (+ var-count (length vars))))
871 (($ $continue) (values min-var max-var var-count))))
873 (($ $kargs names vars body)
877 (visit-letrec body min-var max-var var-count)
878 (values min-var max-var var-count)))
879 (lambda (min-var max-var var-count)
880 (values min-label max-label (1+ label-count)
881 (cond (min-var (fold min min-var vars))
882 ((pair? vars) (fold min (car vars) (cdr vars)))
884 (fold max max-var vars)
885 (+ var-count (length vars))))))
886 (($ $kentry src meta self)
887 (values min-label max-label (1+ label-count)
888 (min* self min-var) (max self max-var) (1+ var-count)))
889 (_ (values min-label max-label (1+ label-count)
890 min-var max-var var-count)))))
897 (define* (compute-dfg fun #:key (global? #t))
898 (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
899 (lambda (min-label max-label label-count min-var max-var var-count)
900 (when (or (zero? label-count) (zero? var-count))
901 (error "internal error (no vars or labels for fun?)"))
902 (let* ((nlabels (- (1+ max-label) min-label))
903 (nvars (- (1+ max-var) min-var))
904 (conts (make-vector nlabels #f))
905 (preds (make-vector nlabels '()))
906 (defs (make-vector nvars #f))
907 (uses (make-vector nvars '()))
908 (scopes (make-vector nlabels #f))
909 (scope-levels (make-vector nlabels #f)))
910 (visit-fun fun conts preds defs uses scopes scope-levels
911 min-label min-var global?)
912 (make-dfg conts preds defs uses scopes scope-levels
913 min-label max-label label-count
914 min-var max-var var-count)))))
916 (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
917 (parameterize ((label-counter (1+ (dfg-max-label dfg)))
918 (var-counter (1+ (dfg-max-var dfg))))
921 (define (lookup-cont label dfg)
922 (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
924 (error "Unknown continuation!" label))
927 (define (lookup-predecessors k dfg)
928 (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
930 (define (lookup-successors k dfg)
931 (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
932 (visit-cont-successors list cont)))
934 (define (lookup-def var dfg)
935 (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
937 (define (lookup-uses var dfg)
938 (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
940 (define (lookup-block-scope k dfg)
941 (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
943 (define (lookup-scope-level k dfg)
944 (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
946 (define (find-defining-term sym dfg)
947 (match (lookup-predecessors (lookup-def sym dfg) dfg)
949 (lookup-cont def-exp-k dfg))
952 (define (find-call term)
954 (($ $kargs names syms body) (find-call body))
955 (($ $letk conts body) (find-call body))
956 (($ $letrec names syms funs body) (find-call body))
957 (($ $continue) term)))
959 (define (call-expression call)
961 (($ $continue k src exp) exp)))
963 (define (find-expression term)
964 (call-expression (find-call term)))
966 (define (find-defining-expression sym dfg)
967 (match (find-defining-term sym dfg)
971 (term (find-expression term))))
973 (define (find-constant-value sym dfg)
974 (match (find-defining-expression sym dfg)
977 (($ $continue k src ($ $void))
978 (values #t *unspecified*))
982 (define (constant-needs-allocation? var val dfg)
983 (define (immediate-u8? val)
984 (and (integer? val) (exact? val) (<= 0 val 255)))
986 (define (find-exp term)
988 (($ $kargs names vars body) (find-exp body))
989 (($ $letk conts body) (find-exp body))
994 (match (find-expression (lookup-cont use dfg))
998 (($ $primcall 'free-ref (closure slot))
1000 (($ $primcall 'free-set! (closure slot value))
1001 (or (eq? var closure) (eq? var value)))
1002 (($ $primcall 'cache-current-module! (mod . _))
1004 (($ $primcall 'cached-toplevel-box _)
1006 (($ $primcall 'cached-module-box _)
1008 (($ $primcall 'resolve (name bound?))
1010 (($ $primcall 'make-vector/immediate (len init))
1012 (($ $primcall 'vector-ref/immediate (v i))
1014 (($ $primcall 'vector-set!/immediate (v i x))
1015 (or (eq? var v) (eq? var x)))
1016 (($ $primcall 'allocate-struct/immediate (vtable nfields))
1018 (($ $primcall 'struct-ref/immediate (s n))
1020 (($ $primcall 'struct-set!/immediate (s n x))
1021 (or (eq? var s) (eq? var x)))
1022 (($ $primcall 'builtin-ref (idx))
1025 (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
1027 (define (continuation-scope-contains? scope-k k dfg)
1028 (let ((scope-level (lookup-scope-level scope-k dfg)))
1031 (and (< scope-level (lookup-scope-level k dfg))
1032 (lp (lookup-block-scope k dfg)))))))
1034 (define (continuation-bound-in? k use-k dfg)
1035 (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
1037 (define (variable-free-in? var k dfg)
1038 (or-map (lambda (use)
1039 (continuation-scope-contains? k use dfg))
1040 (lookup-uses var dfg)))
1042 ;; A continuation is a control point if it has multiple predecessors, or
1043 ;; if its single predecessor does not have a single successor.
1044 (define (control-point? k dfg)
1045 (match (lookup-predecessors k dfg)
1047 (let ((cont (vector-ref (dfg-cont-table dfg)
1048 (- pred (dfg-min-label dfg)))))
1049 (visit-cont-successors (case-lambda
1056 (define (lookup-bound-syms k dfg)
1057 (match (lookup-cont k dfg)
1058 (($ $kargs names syms body)