1 ;;; Continuation-passing style (CPS) intermediate language (IL)
3 ;; Copyright (C) 2013, 2014, 2015 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 ;;; Helper facilities for working with CPS.
25 (define-module (language cps utils)
26 #:use-module (ice-9 match)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-11)
29 #:use-module (language cps)
30 #:use-module (language cps intset)
31 #:use-module (language cps intmap)
32 #:export (;; Fresh names.
33 label-counter var-counter
35 with-fresh-name-state compute-max-label-and-var
43 invert-bijection invert-partition
49 compute-constant-values
51 compute-reachable-functions
55 compute-reverse-post-order
56 compute-strongly-connected-components
57 compute-sorted-strongly-connected-components
63 (define label-counter (make-parameter #f))
64 (define var-counter (make-parameter #f))
67 (let ((count (or (label-counter)
68 (error "fresh-label outside with-fresh-name-state"))))
69 (label-counter (1+ count))
73 (let ((count (or (var-counter)
74 (error "fresh-var outside with-fresh-name-state"))))
75 (var-counter (1+ count))
78 (define-syntax-rule (let-fresh (label ...) (var ...) body ...)
79 (let* ((label (fresh-label)) ...
80 (var (fresh-var)) ...)
83 (define-syntax-rule (with-fresh-name-state fun body ...)
84 (call-with-values (lambda () (compute-max-label-and-var fun))
85 (lambda (max-label max-var)
86 (parameterize ((label-counter (1+ max-label))
87 (var-counter (1+ max-var)))
90 (define (compute-max-label-and-var conts)
91 (values (or (intmap-prev conts) -1)
92 (intmap-fold (lambda (k cont max-var)
94 (($ $kargs names syms body)
95 (apply max max-var syms))
96 (($ $kfun src meta self)
102 (define-inlinable (fold1 f l s0)
103 (let lp ((l l) (s0 s0))
106 ((elt . l) (lp l (f elt s0))))))
108 (define-inlinable (fold2 f l s0 s1)
109 (let lp ((l l) (s0 s0) (s1 s1))
113 (call-with-values (lambda () (f elt s0 s1))
117 (define (trivial-intset set)
118 "Returns the sole member of @var{set}, if @var{set} has exactly one
119 member, or @code{#f} otherwise."
120 (let ((first (intset-next set)))
122 (not (intset-next set (1+ first)))
125 (define (intmap-map proc map)
127 (intmap-fold (lambda (k v out) (intmap-replace! out k (proc k v)))
131 (define (intmap-keys map)
132 "Return an intset of the keys in @var{map}."
134 (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
136 (define (invert-bijection map)
137 "Assuming the values of @var{map} are integers and are unique, compute
138 a map in which each value maps to its key. If the values are not
139 unique, an error will be signalled."
140 (intmap-fold (lambda (k v out) (intmap-add out v k)) map empty-intmap))
142 (define (invert-partition map)
143 "Assuming the values of @var{map} are disjoint intsets, compute a map
144 in which each member of each set maps to its key. If the values are not
145 disjoint, an error will be signalled."
146 (intmap-fold (lambda (k v* out)
147 (intset-fold (lambda (v out) (intmap-add out v k)) v* out))
150 (define (intset->intmap f set)
152 (intset-fold (lambda (label preds)
153 (intmap-add! preds label (f label)))
156 (define worklist-fold
159 (let lp ((in in) (out out))
160 (if (eq? in empty-intset)
162 (call-with-values (lambda () (f in out)) lp))))
164 (let lp ((in in) (out0 out0) (out1 out1))
165 (if (eq? in empty-intset)
167 (call-with-values (lambda () (f in out0 out1)) lp))))))
174 (if (eq? x x*) x* (lp x*)))))
176 (let lp ((x0 x0) (x1 x1))
177 (call-with-values (lambda () (f x0 x1))
179 (if (and (eq? x0 x0*) (eq? x1 x1*))
183 (define (compute-defining-expressions conts)
184 (define (meet-defining-expressions old new)
185 ;; If there are multiple definitions, punt and
189 (intmap-fold (lambda (label cont defs)
191 (($ $kargs _ _ ($ $continue k src exp))
192 (match (intmap-ref conts k)
193 (($ $kargs (_) (var))
194 (intmap-add! defs var exp meet-defining-expressions))
200 (define (compute-constant-values conts)
202 (intmap-fold (lambda (var exp out)
205 (intmap-add! out var val))
207 (compute-defining-expressions conts)
210 (define (compute-function-body conts kfun)
212 (let visit-cont ((label kfun) (labels empty-intset))
214 ((intset-ref labels label) labels)
216 (let ((labels (intset-add! labels label)))
217 (match (intmap-ref conts label)
218 (($ $kreceive arity k) (visit-cont k labels))
219 (($ $kfun src meta self ktail kclause)
220 (let ((labels (visit-cont ktail labels)))
222 (visit-cont kclause labels)
225 (($ $kclause arity kbody kalt)
227 (visit-cont kalt (visit-cont kbody labels))
228 (visit-cont kbody labels)))
229 (($ $kargs names syms ($ $continue k src exp))
230 (visit-cont k (match exp
232 (visit-cont k labels))
233 (($ $prompt escape? tag k)
234 (visit-cont k labels))
237 (define* (compute-reachable-functions conts #:optional (kfun 0))
238 "Compute a mapping LABEL->LABEL..., where each key is a reachable
239 $kfun and each associated value is the body of the function, as an
241 (define (intset-cons i set) (intset-add set i))
242 (define (visit-fun kfun body to-visit)
244 (lambda (label to-visit)
245 (define (return kfun*) (fold intset-cons to-visit kfun*))
246 (define (return1 kfun) (intset-add to-visit kfun))
247 (define (return0) to-visit)
248 (match (intmap-ref conts label)
249 (($ $kargs _ _ ($ $continue _ _ exp))
251 (($ $fun label) (return1 label))
252 (($ $rec _ _ (($ $fun labels) ...)) (return labels))
253 (($ $closure label nfree) (return1 label))
254 (($ $callk label) (return1 label))
259 (let lp ((to-visit (intset kfun)) (visited empty-intmap))
260 (let ((to-visit (intset-subtract to-visit (intmap-keys visited))))
261 (if (eq? to-visit empty-intset)
266 (lambda (kfun to-visit visited)
267 (let ((body (compute-function-body conts kfun)))
268 (values (visit-fun kfun body to-visit)
269 (intmap-add visited kfun body))))
275 (define* (compute-successors conts #:optional (kfun (intmap-next conts)))
276 (define (visit label succs)
277 (let visit ((label kfun) (succs empty-intmap))
279 (intmap-add! succs label empty-intset))
280 (define (propagate1 succ)
281 (visit succ (intmap-add! succs label (intset succ))))
282 (define (propagate2 succ0 succ1)
283 (let ((succs (intmap-add! succs label (intset succ0 succ1))))
284 (visit succ1 (visit succ0 succs))))
285 (if (intmap-ref succs label (lambda (_) #f))
287 (match (intmap-ref conts label)
288 (($ $kargs names vars ($ $continue k src exp))
290 (($ $branch kt) (propagate2 k kt))
291 (($ $prompt escape? tag handler) (propagate2 k handler))
293 (($ $kreceive arity k)
295 (($ $kfun src meta self tail clause)
297 (propagate2 clause tail)
299 (($ $kclause arity kbody kalt)
301 (propagate2 kbody kalt)
303 (($ $ktail) (propagate0))))))
304 (persistent-intmap (visit kfun empty-intmap)))
306 (define* (compute-predecessors conts kfun #:key
307 (labels (compute-function-body conts kfun)))
308 (define (meet cdr car)
310 (define (add-preds label preds)
311 (define (add-pred k preds)
312 (intmap-add! preds k label meet))
313 (match (intmap-ref conts label)
314 (($ $kreceive arity k)
316 (($ $kfun src meta self ktail kclause)
317 (add-pred ktail (if kclause (add-pred kclause preds) preds)))
320 (($ $kclause arity kbody kalt)
321 (add-pred kbody (if kalt (add-pred kalt preds) preds)))
322 (($ $kargs names syms ($ $continue k src exp))
325 (($ $branch k) (add-pred k preds))
326 (($ $prompt _ _ k) (add-pred k preds))
329 (intset-fold add-preds labels
330 (intset->intmap (lambda (label) '()) labels))))
332 (define (compute-reverse-post-order succs start)
333 "Compute a reverse post-order numbering for a depth-first walk over
334 nodes reachable from the start node."
335 (let visit ((label start) (order '()) (visited empty-intset))
338 (intset-fold (lambda (succ order visited)
339 (if (intset-ref visited succ)
340 (values order visited)
341 (visit succ order visited)))
342 (intmap-ref succs label)
344 (intset-add! visited label)))
345 (lambda (order visited)
346 ;; After visiting successors, add label to the reverse post-order.
347 (values (cons label order) visited)))))
349 (define (invert-graph succs)
350 "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
351 intset of successors, return a graph SUCC->PRED...."
352 (intmap-fold (lambda (pred succs preds)
355 (intmap-add preds succ pred intset-add))
359 (intmap-map (lambda (label _) empty-intset) succs)))
361 (define (compute-strongly-connected-components succs start)
362 "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
363 partitioning the labels into strongly connected components (SCCs)."
364 (let ((preds (invert-graph succs)))
365 (define (visit-scc scc sccs-by-label)
366 (let visit ((label scc) (sccs-by-label sccs-by-label))
367 (if (intmap-ref sccs-by-label label (lambda (_) #f))
370 (intmap-ref preds label)
371 (intmap-add sccs-by-label label scc)))))
373 (lambda (label scc sccs)
374 (let ((labels (intset-add empty-intset label)))
375 (intmap-add sccs scc labels intset-union)))
376 (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
379 (define (compute-sorted-strongly-connected-components edges)
380 "Given a LABEL->SUCCESSOR... graph, return a list of strongly
381 connected components in sorted order."
384 ;; Add a "start" node that links to all nodes in the graph, and then
385 ;; remove it from the result.
387 (if (eq? nodes empty-intset)
389 (1+ (intset-prev nodes))))
392 (compute-strongly-connected-components (intmap-add edges start nodes)
395 (define node-components
396 (intmap-fold (lambda (id nodes out)
397 (intset-fold (lambda (node out) (intmap-add out node id))
401 (define (node-component node)
402 (intmap-ref node-components node))
403 (define (component-successors id nodes)
405 (intset-fold (lambda (node out)
407 (lambda (successor out)
408 (intset-add out (node-component successor)))
409 (intmap-ref edges node)
414 (define component-edges
415 (intmap-map component-successors components))
417 (invert-graph component-edges))
419 (intmap-fold (lambda (id succs out)
420 (if (eq? empty-intset succs)
425 ;; As above, add a "start" node that links to the roots, and remove it
427 (match (compute-reverse-post-order (intmap-add preds start roots) start)
428 (((? (lambda (id) (eqv? id start))) . ids)
429 (map (lambda (id) (intmap-ref components id)) ids))))
431 ;; Precondition: For each function in CONTS, the continuation names are
432 ;; topologically sorted.
433 (define (compute-idoms conts kfun)
434 ;; This is the iterative O(n^2) fixpoint algorithm, originally from
435 ;; Allen and Cocke ("Graph-theoretic constructs for program flow
436 ;; analysis", 1972). See the discussion in Cooper, Harvey, and
437 ;; Kennedy's "A Simple, Fast Dominance Algorithm", 2001.
438 (let ((preds-map (compute-predecessors conts kfun)))
439 (define (compute-idom idoms preds)
440 (define (idom-ref label)
441 (intmap-ref idoms label (lambda (_) #f)))
444 ((pred) pred) ; Shortcut.
446 (define (common-idom d0 d1)
447 ;; We exploit the fact that a reverse post-order is a
448 ;; topological sort, and so the idom of a node is always
449 ;; numerically less than the node itself.
450 (let lp ((d0 d0) (d1 d1))
452 ;; d0 or d1 can be false on the first iteration.
456 ((< d0 d1) (lp d0 (idom-ref d1)))
457 (else (lp (idom-ref d0) d1)))))
458 (fold1 common-idom preds pred))))
459 (define (adjoin-idom label preds idoms)
460 (let ((idom (compute-idom idoms preds)))
461 ;; Don't use intmap-add! here.
462 (intmap-add idoms label idom (lambda (old new) new))))
463 (fixpoint (lambda (idoms)
464 (intmap-fold adjoin-idom preds-map idoms))
467 ;; Compute a vector containing, for each node, a list of the nodes that
468 ;; it immediately dominates. These are the "D" edges in the DJ tree.
469 (define (compute-dom-edges idoms)
470 (define (snoc cdr car) (cons car cdr))
472 (intmap-fold (lambda (label idom doms)
473 (let ((doms (intmap-add! doms label '())))
475 ((< idom 0) doms) ;; No edge to entry.
476 (else (intmap-add! doms idom label snoc)))))
480 (define (intset-pop set)
481 (match (intset-next set)
483 (i (values (intset-remove set i) i))))
485 (define* (solve-flow-equations succs in out kill gen subtract add meet
486 #:optional (worklist (intmap-keys succs)))
487 "Find a fixed point for flow equations for SUCCS, where INIT is the
488 initial state at each node in SUCCS. KILL and GEN are intmaps
489 indicating the state that is killed or defined at every node, and
490 SUBTRACT, ADD, and MEET operates on that state."
491 (define (visit label in out)
492 (let* ((in-1 (intmap-ref in label))
493 (kill-1 (intmap-ref kill label))
494 (gen-1 (intmap-ref gen label))
495 (out-1 (intmap-ref out label))
496 (out-1* (add (subtract in-1 kill-1) gen-1)))
497 (if (eq? out-1 out-1*)
498 (values empty-intset in out)
499 (let ((out (intmap-replace! out label out-1*)))
502 (intset-fold (lambda (succ in changed)
503 (let* ((in-1 (intmap-ref in succ))
504 (in-1* (meet in-1 out-1*)))
507 (values (intmap-replace! in succ in-1*)
508 (intset-add changed succ)))))
509 (intmap-ref succs label) in empty-intset))
511 (values changed in out)))))))
513 (let run ((worklist worklist) (in in) (out out))
514 (call-with-values (lambda () (intset-pop worklist))
515 (lambda (worklist popped)
517 (call-with-values (lambda () (visit popped in out))
518 (lambda (changed in out)
519 (run (intset-union worklist changed) in out)))
520 (values (persistent-intmap in)
521 (persistent-intmap out)))))))