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 (ice-9 format)
40 #:use-module (srfi srfi-1)
41 #:use-module (srfi srfi-9)
42 #:use-module (srfi srfi-26)
43 #:use-module (language cps)
44 #:use-module (language cps intset)
45 #:export (build-cont-table
54 with-fresh-name-state-from-dfg
63 find-defining-expression
65 continuation-bound-in?
67 constant-needs-allocation?
74 ;; Data flow analysis.
75 compute-live-variables
76 dfa-k-idx dfa-k-sym dfa-k-count dfa-k-in dfa-k-out
77 dfa-var-idx dfa-var-sym dfa-var-count
80 ;; These definitions are here because currently we don't do cross-module
81 ;; inlining. They can be removed once that restriction is gone.
82 (define-inlinable (for-each f l)
84 (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
85 (let for-each1 ((l l))
88 (for-each1 (cdr l)))))
90 (define-inlinable (for-each/2 f l1 l2)
91 (unless (= (length l1) (length l2))
92 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
94 (let for-each2 ((l1 l1) (l2 l2))
97 (for-each2 (cdr l1) (cdr l2)))))
99 (define (build-cont-table fun)
100 (let ((max-k (fold-conts (lambda (k cont max-k) (max k max-k))
102 (fold-conts (lambda (k cont table)
103 (vector-set! table k cont)
105 (make-vector (1+ max-k) #f)
108 ;; Data-flow graph for CPS: both for values and continuations.
109 (define-record-type $dfg
110 (make-dfg conts preds defs uses scopes scope-levels
111 min-label max-label label-count
112 min-var max-var var-count)
114 ;; vector of label -> $kargs, etc
115 (conts dfg-cont-table)
116 ;; vector of label -> (pred-label ...)
118 ;; vector of var -> def-label
120 ;; vector of var -> (use-label ...)
122 ;; vector of label -> label
124 ;; vector of label -> int
125 (scope-levels dfg-scope-levels)
127 (min-label dfg-min-label)
128 (max-label dfg-max-label)
129 (label-count dfg-label-count)
131 (min-var dfg-min-var)
132 (max-var dfg-max-var)
133 (var-count dfg-var-count))
135 (define-inlinable (vector-push! vec idx val)
136 (let ((v vec) (i idx))
137 (vector-set! v i (cons val (vector-ref v i)))))
139 (define (compute-reachable dfg min-label label-count)
140 "Compute and return the continuations that may be reached if flow
141 reaches a continuation N. Returns a vector of intsets, whose first
142 index corresponds to MIN-LABEL, and so on."
143 (let (;; Vector of intsets, indicating that continuation N can
145 (reachable (make-vector label-count #f)))
147 (define (label->idx label) (- label min-label))
149 ;; Iterate labels backwards, to converge quickly.
150 (let lp ((label (+ min-label label-count)) (changed? #f))
154 (lp (+ min-label label-count) #f)
157 (let* ((label (1- label))
158 (idx (label->idx label))
159 (old (vector-ref reachable idx))
160 (new (fold (lambda (succ set)
162 ((vector-ref reachable (label->idx succ))
163 => (lambda (succ-set)
164 (intset-union set succ-set)))
166 (or (vector-ref reachable idx)
167 (intset-add empty-intset label))
168 (visit-cont-successors list
169 (lookup-cont label dfg)))))
174 (vector-set! reachable idx new)
175 (lp label #t)))))))))
177 (define (find-prompts dfg min-label label-count)
178 "Find the prompts in DFG between MIN-LABEL and MIN-LABEL +
179 LABEL-COUNT, and return them as a list of PROMPT-LABEL, HANDLER-LABEL
181 (let lp ((label min-label) (prompts '()))
183 ((= label (+ min-label label-count))
186 (match (lookup-cont label dfg)
187 (($ $kargs names syms body)
188 (match (find-expression body)
189 (($ $prompt escape? tag handler)
190 (lp (1+ label) (acons label handler prompts)))
191 (_ (lp (1+ label) prompts))))
192 (_ (lp (1+ label) prompts)))))))
194 (define (compute-interval reachable min-label label-count start end)
195 "Compute and return the set of continuations that may be reached from
196 START, inclusive, but not reached by END, exclusive. Returns an
198 (intset-subtract (vector-ref reachable (- start min-label))
199 (vector-ref reachable (- end min-label))))
201 (define (find-prompt-bodies dfg min-label label-count)
202 "Find all the prompts in DFG from the LABEL-COUNT continuations
203 starting at MIN-LABEL, and compute the set of continuations that is
204 reachable from the prompt bodies but not from the corresponding handler.
205 Returns a list of PROMPT, HANDLER, BODY lists, where the BODY is an
207 (match (find-prompts dfg min-label label-count)
209 (((prompt . handler) ...)
210 (let ((reachable (compute-reachable dfg min-label label-count)))
211 (map (lambda (prompt handler)
212 ;; FIXME: It isn't correct to use all continuations
213 ;; reachable from the prompt, because that includes
214 ;; continuations outside the prompt body. This point is
215 ;; moot if the handler's control flow joins with the the
216 ;; body, as is usually but not always the case.
218 ;; One counter-example is when the handler contifies an
219 ;; infinite loop; in that case we compute a too-large
220 ;; prompt body. This error is currently innocuous, but we
221 ;; should fix it at some point.
223 ;; The fix is to end the body at the corresponding "pop"
225 (let ((body (compute-interval reachable min-label label-count
227 (list prompt handler body)))
230 (define* (visit-prompt-control-flow dfg min-label label-count f #:key complete?)
231 "For all prompts in DFG in the range [MIN-LABEL, MIN-LABEL +
232 LABEL-COUNT), invoke F with arguments PROMPT, HANDLER, and BODY for each
233 body continuation in the prompt."
234 (define (label->idx label) (- label min-label))
235 (define (idx->label idx) (+ idx min-label))
238 ((prompt handler body)
239 (define (out-or-back-edge? label)
240 ;; Most uses of visit-prompt-control-flow don't need every body
241 ;; continuation, and would be happy getting called only for
242 ;; continuations that postdominate the rest of the body. Unless
243 ;; you pass #:complete? #t, we only invoke F on continuations
244 ;; that can leave the body, or on back-edges in loops.
246 ;; You would think that looking for the final "pop" primcall
247 ;; would be sufficient, but that is incorrect; it's possible for
248 ;; a loop in the prompt body to be contified, and that loop need
249 ;; not continue to the pop if it never terminates. The pop could
250 ;; even be removed by DCE, in that case.
251 (or-map (lambda (succ)
252 (or (not (intset-ref body succ))
254 (lookup-successors label dfg)))
255 (let lp ((label min-label))
256 (let ((label (intset-next body label)))
258 (when (or complete? (out-or-back-edge? label))
259 (f prompt handler label))
261 (find-prompt-bodies dfg min-label label-count)))
263 (define (analyze-reverse-control-flow fun dfg min-label label-count)
264 (define (compute-reverse-control-flow-order ktail dfg)
265 (let ((label-map (make-vector label-count #f))
267 (define (label->idx label) (- label min-label))
268 (define (idx->label idx) (+ idx min-label))
270 (let visit ((k ktail))
271 ;; Mark this label as visited.
272 (vector-set! label-map (label->idx k) #t)
273 (for-each (lambda (k)
274 ;; Visit predecessors unless they are already visited.
275 (unless (vector-ref label-map (label->idx k))
277 (lookup-predecessors k dfg))
278 ;; Add to reverse post-order chain.
279 (vector-set! label-map (label->idx k) next)
282 (let lp ((n 0) (head next))
284 ;; Add nodes that are not reachable from the tail.
285 (let lp ((n n) (m label-count))
286 (unless (= n label-count)
287 (let find-unvisited ((m (1- m)))
288 (if (vector-ref label-map m)
289 (find-unvisited (1- m))
291 (vector-set! label-map m n)
293 ;; Pop the head off the chain, give it its
294 ;; reverse-post-order numbering, and continue.
295 (let ((next (vector-ref label-map (label->idx head))))
296 (vector-set! label-map (label->idx head) n)
301 (define (convert-successors k-map)
302 (define (idx->label idx) (+ idx min-label))
303 (define (renumber label)
304 (vector-ref k-map (- label min-label)))
305 (let ((succs (make-vector (vector-length k-map) #f)))
307 (when (< n (vector-length succs))
308 (vector-set! succs (vector-ref k-map n)
310 (lookup-successors (idx->label n) dfg)))
315 (($ $cont kfun ($ $kfun src meta self ($ $cont ktail tail)))
316 (let* ((k-map (compute-reverse-control-flow-order ktail dfg))
317 (succs (convert-successors k-map)))
318 ;; Any expression in the prompt body could cause an abort to
319 ;; the handler. This code adds links from every block in the
320 ;; prompt body to the handler. This causes all values used
321 ;; by the handler to be seen as live in the prompt body, as
323 (visit-prompt-control-flow
324 dfg min-label label-count
325 (lambda (prompt handler body)
326 (define (renumber label)
327 (vector-ref k-map (- label min-label)))
328 (vector-push! succs (renumber body) (renumber handler))))
330 (values k-map succs)))))
332 (define (compute-idoms dfg min-label label-count)
333 (define preds (dfg-preds dfg))
334 (define (label->idx label) (- label min-label))
335 (define (idx->label idx) (+ idx min-label))
336 (define (idx->dfg-idx idx) (- (idx->label idx) (dfg-min-label dfg)))
337 (let ((idoms (make-vector label-count #f)))
338 (define (common-idom d0 d1)
339 ;; We exploit the fact that a reverse post-order is a topological
340 ;; sort, and so the idom of a node is always numerically less than
344 ((< d0 d1) (common-idom d0 (vector-ref idoms (label->idx d1))))
345 (else (common-idom (vector-ref idoms (label->idx d0)) d1))))
346 (define (compute-idom preds)
347 (define (has-idom? pred)
348 (vector-ref idoms (label->idx pred)))
353 (let lp ((idom pred) (preds preds))
357 (lp (if (has-idom? pred)
358 (common-idom idom pred)
361 (compute-idom preds)))))
362 ;; This is the iterative O(n^2) fixpoint algorithm, originally from
363 ;; Allen and Cocke ("Graph-theoretic constructs for program flow
364 ;; analysis", 1972). See the discussion in Cooper, Harvey, and
365 ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
366 (let iterate ((n 0) (changed? #f))
369 (let ((idom (vector-ref idoms n))
370 (idom* (compute-idom (vector-ref preds (idx->dfg-idx n)))))
373 (iterate (1+ n) changed?))
375 (vector-set! idoms n idom*)
376 (iterate (1+ n) #t)))))
381 ;; Compute a vector containing, for each node, a list of the nodes that
382 ;; it immediately dominates. These are the "D" edges in the DJ tree.
383 (define (compute-dom-edges idoms min-label)
384 (define (label->idx label) (- label min-label))
385 (define (idx->label idx) (+ idx min-label))
386 (let ((doms (make-vector (vector-length idoms) '())))
388 (when (< n (vector-length idoms))
389 (let ((idom (vector-ref idoms n)))
390 (vector-push! doms (label->idx idom) (idx->label n)))
394 ;; There used to be some loop detection code here, but it bitrotted.
395 ;; We'll need it again eventually but for now it can be found in the git
398 ;; Data-flow analysis.
399 (define-record-type $dfa
400 (make-dfa min-label min-var var-count in out)
402 ;; Minimum label in this function.
403 (min-label dfa-min-label)
404 ;; Minimum var in this function.
405 (min-var dfa-min-var)
406 ;; Var count in this function.
407 (var-count dfa-var-count)
408 ;; Vector of k-idx -> intset
410 ;; Vector of k-idx -> intset
413 (define (dfa-k-idx dfa k)
414 (- k (dfa-min-label dfa)))
416 (define (dfa-k-sym dfa idx)
417 (+ idx (dfa-min-label dfa)))
419 (define (dfa-k-count dfa)
420 (vector-length (dfa-in dfa)))
422 (define (dfa-var-idx dfa var)
423 (let ((idx (- var (dfa-min-var dfa))))
424 (unless (< -1 idx (dfa-var-count dfa))
425 (error "var out of range" var))
428 (define (dfa-var-sym dfa idx)
429 (unless (< -1 idx (dfa-var-count dfa))
430 (error "idx out of range" idx))
431 (+ idx (dfa-min-var dfa)))
433 (define (dfa-k-in dfa idx)
434 (vector-ref (dfa-in dfa) idx))
436 (define (dfa-k-out dfa idx)
437 (vector-ref (dfa-out dfa) idx))
439 (define (compute-live-variables fun dfg)
440 ;; Compute the maximum fixed point of the data-flow constraint problem.
442 ;; This always completes, as the graph is finite and the in and out sets
443 ;; are complete semi-lattices. If the graph is reducible and the blocks
444 ;; are sorted in reverse post-order, this completes in a maximum of LC +
445 ;; 2 iterations, where LC is the loop connectedness number. See Hecht
446 ;; and Ullman, "Analysis of a simple algorithm for global flow
447 ;; problems", POPL 1973, or the recent summary in "Notes on graph
448 ;; algorithms used in optimizing compilers", Offner 2013.
449 (define (compute-maximum-fixed-point preds inv outv killv genv)
450 (define (fold f seed l)
451 (if (null? l) seed (fold f (f (car l) seed) (cdr l))))
452 (let lp ((n 0) (changed? #f))
454 ((< n (vector-length preds))
455 (let* ((in (vector-ref inv n))
457 (fold (lambda (pred set)
459 ((vector-ref outv pred)
462 (intset-union set out)
466 (vector-ref preds n))
470 (let ((out* (fold (lambda (gen set)
471 (intset-add set gen))
472 (fold (lambda (kill set)
473 (intset-remove set kill))
475 (vector-ref killv n))
476 (vector-ref genv n))))
477 (vector-set! inv n in*)
478 (vector-set! outv n out*)
483 (unless (and (= (vector-length (dfg-uses dfg)) (dfg-var-count dfg))
484 (= (vector-length (dfg-cont-table dfg)) (dfg-label-count dfg)))
485 (error "function needs renumbering"))
486 (let* ((min-label (dfg-min-label dfg))
487 (nlabels (dfg-label-count dfg))
488 (min-var (dfg-min-var dfg))
489 (nvars (dfg-var-count dfg))
490 (usev (make-vector nlabels '()))
491 (defv (make-vector nlabels '()))
492 (live-in (make-vector nlabels #f))
493 (live-out (make-vector nlabels #f)))
496 (analyze-reverse-control-flow fun dfg min-label nlabels))
497 (lambda (k-map succs)
498 (define (var->idx var) (- var min-var))
499 (define (idx->var idx) (+ idx min-var))
500 (define (label->idx label)
501 (vector-ref k-map (- label min-label)))
503 ;; Initialize defv and usev.
504 (let ((defs (dfg-defs dfg))
505 (uses (dfg-uses dfg)))
507 (when (< n (vector-length defs))
508 (let ((def (vector-ref defs n)))
510 (error "internal error -- var array not packed"))
511 (for-each (lambda (def)
512 (vector-push! defv (label->idx def) n))
513 (lookup-predecessors def dfg))
514 (for-each (lambda (use)
515 (vector-push! usev (label->idx use) n))
519 ;; Liveness is a reverse data-flow problem, so we give
520 ;; compute-maximum-fixed-point a reversed graph, swapping in for
521 ;; out, usev for defv, and using successors instead of
522 ;; predecessors. Continuation 0 is ktail.
523 (compute-maximum-fixed-point succs live-out live-in defv usev)
525 ;; Now rewrite the live-in and live-out sets to be indexed by
526 ;; (LABEL - MIN-LABEL).
527 (let ((live-in* (make-vector nlabels #f))
528 (live-out* (make-vector nlabels #f)))
530 (when (< idx nlabels)
531 (let ((dfa-idx (vector-ref k-map idx)))
532 (vector-set! live-in* idx (vector-ref live-in dfa-idx))
533 (vector-set! live-out* idx (vector-ref live-out dfa-idx))
536 (make-dfa min-label min-var nvars live-in* live-out*))))))
538 (define (print-dfa dfa)
540 (($ $dfa min-label min-var var-count in out)
541 (define (print-var-set bv)
543 (let ((n (intset-next bv n)))
545 (format #t " ~A" (+ n min-var))
548 (when (< n (vector-length in))
549 (format #t "~A:\n" (+ n min-label))
551 (print-var-set (vector-ref in n))
554 (print-var-set (vector-ref out n))
558 (define (compute-label-and-var-ranges fun global?)
561 (define-syntax-rule (do-fold make-cont-folder)
562 ((make-cont-folder min-label max-label label-count
563 min-var max-var var-count)
565 min-label max-label label-count
566 min-var max-var var-count)
567 (let ((min-label (min* label min-label))
568 (max-label (max label max-label)))
569 (define (visit-letrec body min-var max-var var-count)
571 (($ $letk conts body)
572 (visit-letrec body min-var max-var var-count))
573 (($ $letrec names vars funs body)
575 (cond (min-var (fold min min-var vars))
576 ((pair? vars) (fold min (car vars) (cdr vars)))
578 (fold max max-var vars)
579 (+ var-count (length vars))))
580 (($ $continue) (values min-var max-var var-count))))
582 (($ $kargs names vars body)
586 (visit-letrec body min-var max-var var-count)
587 (values min-var max-var var-count)))
588 (lambda (min-var max-var var-count)
589 (values min-label max-label (1+ label-count)
590 (cond (min-var (fold min min-var vars))
591 ((pair? vars) (fold min (car vars) (cdr vars)))
593 (fold max max-var vars)
594 (+ var-count (length vars))))))
595 (($ $kfun src meta self)
596 (values min-label max-label (1+ label-count)
597 (min* self min-var) (max self max-var) (1+ var-count)))
598 (_ (values min-label max-label (1+ label-count)
599 min-var max-var var-count)))))
603 (do-fold make-global-cont-folder)
604 (do-fold make-local-cont-folder)))
606 (define* (compute-dfg fun #:key (global? #t))
607 (call-with-values (lambda () (compute-label-and-var-ranges fun global?))
608 (lambda (min-label max-label label-count min-var max-var var-count)
609 (when (or (zero? label-count) (zero? var-count))
610 (error "internal error (no vars or labels for fun?)"))
611 (let* ((nlabels (- (1+ max-label) min-label))
612 (nvars (- (1+ max-var) min-var))
613 (conts (make-vector nlabels #f))
614 (preds (make-vector nlabels '()))
615 (defs (make-vector nvars #f))
616 (uses (make-vector nvars '()))
617 (scopes (make-vector nlabels #f))
618 (scope-levels (make-vector nlabels #f)))
619 (define (var->idx var) (- var min-var))
620 (define (label->idx label) (- label min-label))
622 (define (add-def! var def-k)
623 (vector-set! defs (var->idx var) def-k))
624 (define (add-use! var use-k)
625 (vector-push! uses (var->idx var) use-k))
627 (define* (declare-block! label cont parent
631 (label->idx parent)))))
632 (vector-set! conts (label->idx label) cont)
633 (vector-set! scopes (label->idx label) parent)
634 (vector-set! scope-levels (label->idx label) level))
636 (define (link-blocks! pred succ)
637 (vector-push! preds (label->idx succ) pred))
639 (define (visit-cont cont label)
641 (($ $kargs names syms body)
642 (for-each (cut add-def! <> label) syms)
643 (visit-term body label))
644 (($ $kreceive arity k)
645 (link-blocks! label k))))
647 (define (visit-term term label)
649 (($ $letk (($ $cont k cont) ...) body)
650 ;; Set up recursive environment before visiting cont bodies.
651 (for-each/2 (lambda (cont k)
652 (declare-block! k cont label))
654 (for-each/2 visit-cont cont k)
655 (visit-term body label))
656 (($ $letrec names syms funs body)
658 (error "$letrec should not be present when building a local DFG"))
659 (for-each (cut add-def! <> label) syms)
660 (for-each (lambda (fun)
665 (visit-term body label))
666 (($ $continue k src exp)
667 (link-blocks! label k)
668 (visit-exp exp label))))
670 (define (visit-exp exp label)
672 (add-use! sym label))
674 ((or ($ $void) ($ $const) ($ $prim) ($ $closure)) #f)
677 (for-each use! args))
678 (($ $callk k proc args)
680 (for-each use! args))
681 (($ $primcall name args)
682 (for-each use! args))
684 (link-blocks! label kt)
685 (visit-exp exp label))
687 (for-each use! args))
688 (($ $prompt escape? tag handler)
690 (link-blocks! label handler))
695 (define (visit-clause clause kfun)
699 (and clause ($ $kclause arity ($ $cont kbody body)
701 (declare-block! kclause clause kfun)
702 (link-blocks! kfun kclause)
704 (declare-block! kbody body kclause)
705 (link-blocks! kclause kbody)
707 (visit-cont body kbody)
708 (visit-clause alternate kfun))))
710 (define (visit-fun fun)
714 ($ $kfun src meta self ($ $cont ktail tail) clause)))
715 (declare-block! kfun cont #f 0)
717 (declare-block! ktail tail kfun)
718 (visit-clause clause kfun))))
722 (make-dfg conts preds defs uses scopes scope-levels
723 min-label max-label label-count
724 min-var max-var var-count)))))
726 (define* (dump-dfg dfg #:optional (port (current-output-port)))
727 (let ((min-label (dfg-min-label dfg))
728 (min-var (dfg-min-var dfg)))
729 (define (label->idx label) (- label min-label))
730 (define (idx->label idx) (+ idx min-label))
731 (define (var->idx var) (- var min-var))
732 (define (idx->var idx) (+ idx min-var))
734 (let lp ((label (dfg-min-label dfg)))
735 (when (<= label (dfg-max-label dfg))
736 (let ((cont (vector-ref (dfg-cont-table dfg) (label->idx label))))
738 (unless (equal? (lookup-predecessors label dfg) (list (1- label)))
740 (format port "k~a:~8t" label)
742 (($ $kreceive arity k)
743 (format port "$kreceive ~a k~a\n" arity k))
744 (($ $kfun src meta self tail clause)
745 (format port "$kfun ~a ~a v~a\n" src meta self))
747 (format port "$ktail\n"))
748 (($ $kclause arity ($ $cont kbody) alternate)
749 (format port "$kclause ~a k~a" arity kbody)
752 (($ $cont kalt) (format port " -> k~a" kalt)))
754 (($ $kargs names vars term)
756 (format port "v~a[~a]~:{ v~a[~a]~}: "
757 (car vars) (car names) (map list (cdr vars) (cdr names))))
758 (match (find-call term)
759 (($ $continue kf src ($ $branch kt exp))
762 (($ $primcall name args)
763 (format port "(~a~{ v~a~})" name args))
765 (format port "v~a" arg)))
766 (format port " k~a k~a\n" kt kf))
767 (($ $continue k src exp)
769 (($ $void) (format port "void"))
770 (($ $const val) (format port "const ~@y" val))
771 (($ $prim name) (format port "prim ~a" name))
772 (($ $fun free ($ $cont kbody)) (format port "fun k~a" kbody))
773 (($ $closure label nfree) (format port "closure k~a (~a free)" label nfree))
774 (($ $call proc args) (format port "call~{ v~a~}" (cons proc args)))
775 (($ $callk k proc args) (format port "callk k~a~{ v~a~}" k (cons proc args)))
776 (($ $primcall name args) (format port "~a~{ v~a~}" name args))
777 (($ $values args) (format port "values~{ v~a~}" args))
778 (($ $prompt escape? tag handler) (format port "prompt ~a v~a k~a" escape? tag handler)))
779 (unless (= k (1+ label))
780 (format port " -> k~a" k))
784 (define-syntax-rule (with-fresh-name-state-from-dfg dfg body ...)
785 (parameterize ((label-counter (1+ (dfg-max-label dfg)))
786 (var-counter (1+ (dfg-max-var dfg))))
789 (define (lookup-cont label dfg)
790 (let ((res (vector-ref (dfg-cont-table dfg) (- label (dfg-min-label dfg)))))
792 (error "Unknown continuation!" label))
795 (define (lookup-predecessors k dfg)
796 (vector-ref (dfg-preds dfg) (- k (dfg-min-label dfg))))
798 (define (lookup-successors k dfg)
799 (let ((cont (vector-ref (dfg-cont-table dfg) (- k (dfg-min-label dfg)))))
800 (visit-cont-successors list cont)))
802 (define (lookup-def var dfg)
803 (vector-ref (dfg-defs dfg) (- var (dfg-min-var dfg))))
805 (define (lookup-uses var dfg)
806 (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg))))
808 (define (lookup-block-scope k dfg)
809 (vector-ref (dfg-scopes dfg) (- k (dfg-min-label dfg))))
811 (define (lookup-scope-level k dfg)
812 (vector-ref (dfg-scope-levels dfg) (- k (dfg-min-label dfg))))
814 (define (find-defining-term sym dfg)
815 (match (lookup-predecessors (lookup-def sym dfg) dfg)
817 (lookup-cont def-exp-k dfg))
820 (define (find-call term)
822 (($ $kargs names syms body) (find-call body))
823 (($ $letk conts body) (find-call body))
824 (($ $letrec names syms funs body) (find-call body))
825 (($ $continue) term)))
827 (define (call-expression call)
829 (($ $continue k src exp) exp)))
831 (define (find-expression term)
832 (call-expression (find-call term)))
834 (define (find-defining-expression sym dfg)
835 (match (find-defining-term sym dfg)
839 (term (find-expression term))))
841 (define (find-constant-value sym dfg)
842 (match (find-defining-expression sym dfg)
845 (($ $continue k src ($ $void))
846 (values #t *unspecified*))
850 (define (constant-needs-allocation? var val dfg)
851 (define (immediate-u8? val)
852 (and (integer? val) (exact? val) (<= 0 val 255)))
854 (define (find-exp term)
856 (($ $kargs names vars body) (find-exp body))
857 (($ $letk conts body) (find-exp body))
862 (match (find-expression (lookup-cont use dfg))
866 (($ $primcall 'free-ref (closure slot))
868 (($ $primcall 'free-set! (closure slot value))
869 (or (eq? var closure) (eq? var value)))
870 (($ $primcall 'cache-current-module! (mod . _))
872 (($ $primcall 'cached-toplevel-box _)
874 (($ $primcall 'cached-module-box _)
876 (($ $primcall 'resolve (name bound?))
878 (($ $primcall 'make-vector/immediate (len init))
880 (($ $primcall 'vector-ref/immediate (v i))
882 (($ $primcall 'vector-set!/immediate (v i x))
883 (or (eq? var v) (eq? var x)))
884 (($ $primcall 'allocate-struct/immediate (vtable nfields))
886 (($ $primcall 'struct-ref/immediate (s n))
888 (($ $primcall 'struct-set!/immediate (s n x))
889 (or (eq? var s) (eq? var x)))
890 (($ $primcall 'builtin-ref (idx))
893 (vector-ref (dfg-uses dfg) (- var (dfg-min-var dfg)))))
895 (define (continuation-scope-contains? scope-k k dfg)
896 (let ((scope-level (lookup-scope-level scope-k dfg)))
899 (and (< scope-level (lookup-scope-level k dfg))
900 (lp (lookup-block-scope k dfg)))))))
902 (define (continuation-bound-in? k use-k dfg)
903 (continuation-scope-contains? (lookup-block-scope k dfg) use-k dfg))
905 (define (variable-free-in? var k dfg)
906 (or-map (lambda (use)
907 (continuation-scope-contains? k use dfg))
908 (lookup-uses var dfg)))
910 ;; A continuation is a control point if it has multiple predecessors, or
911 ;; if its single predecessor does not have a single successor.
912 (define (control-point? k dfg)
913 (match (lookup-predecessors k dfg)
915 (let ((cont (vector-ref (dfg-cont-table dfg)
916 (- pred (dfg-min-label dfg)))))
917 (visit-cont-successors (case-lambda
924 (define (lookup-bound-syms k dfg)
925 (match (lookup-cont k dfg)
926 (($ $kargs names syms body)