1;;; Continuation-passing style (CPS) intermediate language (IL)
2
3;; Copyright (C) 2013-2015, 2017-2020 Free Software Foundation, Inc.
4
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.
9;;;;
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.
14;;;;
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
18
19;;; Commentary:
20;;;
21;;; Helper facilities for working with graphs over intsets and intmaps.
22;;;
23;;; Code:
24
25(define-module (language cps graphs)
26  #:use-module (ice-9 match)
27  #:use-module (srfi srfi-1)
28  #:use-module (language cps intset)
29  #:use-module (language cps intmap)
30  #:export (;; Various utilities.
31            fold1 fold2
32            trivial-intset
33            intmap-map
34            intmap-keys
35            invert-bijection invert-partition
36            intset->intmap
37            intmap-select
38            worklist-fold
39            fixpoint
40
41            ;; Flow analysis.
42            invert-graph
43            compute-reverse-post-order
44            compute-strongly-connected-components
45            compute-sorted-strongly-connected-components
46            solve-flow-equations))
47
48(define-inlinable (fold1 f l s0)
49  (let lp ((l l) (s0 s0))
50    (match l
51      (() s0)
52      ((elt . l) (lp l (f elt s0))))))
53
54(define-inlinable (fold2 f l s0 s1)
55  (let lp ((l l) (s0 s0) (s1 s1))
56    (match l
57      (() (values s0 s1))
58      ((elt . l)
59       (call-with-values (lambda () (f elt s0 s1))
60         (lambda (s0 s1)
61           (lp l s0 s1)))))))
62
63(define (trivial-intset set)
64  "Returns the sole member of @var{set}, if @var{set} has exactly one
65member, or @code{#f} otherwise."
66  (let ((first (intset-next set)))
67    (and first
68         (not (intset-next set (1+ first)))
69         first)))
70
71(define (intmap-map proc map)
72  (persistent-intmap
73   (intmap-fold (lambda (k v out) (intmap-add! out k (proc k v)))
74                map
75                empty-intmap)))
76
77(define (intmap-keys map)
78  "Return an intset of the keys in @var{map}."
79  (persistent-intset
80   (intmap-fold (lambda (k v keys) (intset-add! keys k)) map empty-intset)))
81
82(define (invert-bijection map)
83  "Assuming the values of @var{map} are integers and are unique, compute
84a map in which each value maps to its key.  If the values are not
85unique, an error will be signalled."
86  (persistent-intmap
87   (intmap-fold (lambda (k v out) (intmap-add! out v k)) map empty-intmap)))
88
89(define (invert-partition map)
90  "Assuming the values of @var{map} are disjoint intsets, compute a map
91in which each member of each set maps to its key.  If the values are not
92disjoint, an error will be signalled."
93  (intmap-fold (lambda (k v* out)
94                 (intset-fold (lambda (v out) (intmap-add out v k)) v* out))
95               map empty-intmap))
96
97(define (intset->intmap f set)
98  (persistent-intmap
99   (intset-fold (lambda (label preds)
100                  (intmap-add! preds label (f label)))
101                set empty-intmap)))
102
103(define (intmap-select map set)
104  (persistent-intmap
105   (intset-fold (lambda (label out)
106                  (intmap-add! out label (intmap-ref map label)))
107                set empty-intmap)))
108
109(define worklist-fold
110  (case-lambda
111    ((f in out)
112     (let lp ((in in) (out out))
113       (if (eq? in empty-intset)
114           out
115           (call-with-values (lambda () (f in out)) lp))))
116    ((f in out0 out1)
117     (let lp ((in in) (out0 out0) (out1 out1))
118       (if (eq? in empty-intset)
119           (values out0 out1)
120           (call-with-values (lambda () (f in out0 out1)) lp))))))
121
122(define fixpoint
123  (case-lambda
124    ((f x)
125     (let lp ((x x))
126       (let ((x* (f x)))
127         (if (eq? x x*) x* (lp x*)))))
128    ((f x0 x1)
129     (let lp ((x0 x0) (x1 x1))
130       (call-with-values (lambda () (f x0 x1))
131         (lambda (x0* x1*)
132           (if (and (eq? x0 x0*) (eq? x1 x1*))
133               (values x0* x1*)
134               (lp x0* x1*))))))))
135
136(define (compute-reverse-post-order succs start)
137  "Compute a reverse post-order numbering for a depth-first walk over
138nodes reachable from the start node."
139  (let visit ((label start) (order '()) (visited empty-intset))
140    (call-with-values
141        (lambda ()
142          (intset-fold (lambda (succ order visited)
143                         (if (intset-ref visited succ)
144                             (values order visited)
145                             (visit succ order visited)))
146                       (intmap-ref succs label)
147                       order
148                       (intset-add! visited label)))
149      (lambda (order visited)
150        ;; After visiting successors, add label to the reverse post-order.
151        (values (cons label order) visited)))))
152
153(define (invert-graph succs)
154  "Given a graph PRED->SUCC..., where PRED is a label and SUCC... is an
155intset of successors, return a graph SUCC->PRED...."
156  (intmap-fold (lambda (pred succs preds)
157                 (intset-fold
158                  (lambda (succ preds)
159                    (intmap-add preds succ pred intset-add))
160                  succs
161                  preds))
162               succs
163               (intmap-map (lambda (label _) empty-intset) succs)))
164
165(define (compute-strongly-connected-components succs start)
166  "Given a LABEL->SUCCESSOR... graph, compute a SCC->LABEL... map
167partitioning the labels into strongly connected components (SCCs)."
168  (let ((preds (invert-graph succs)))
169    (define (visit-scc scc sccs-by-label)
170      (let visit ((label scc) (sccs-by-label sccs-by-label))
171        (if (intmap-ref sccs-by-label label (lambda (_) #f))
172            sccs-by-label
173            (intset-fold visit
174                         (intmap-ref preds label)
175                         (intmap-add sccs-by-label label scc)))))
176    (intmap-fold
177     (lambda (label scc sccs)
178       (let ((labels (intset-add empty-intset label)))
179         (intmap-add sccs scc labels intset-union)))
180     (fold visit-scc empty-intmap (compute-reverse-post-order succs start))
181     empty-intmap)))
182
183(define (compute-sorted-strongly-connected-components edges)
184  "Given a LABEL->SUCCESSOR... graph, return a list of strongly
185connected components in sorted order."
186  (define nodes
187    (intmap-keys edges))
188  ;; Add a "start" node that links to all nodes in the graph, and then
189  ;; remove it from the result.
190  (define start
191    (if (eq? nodes empty-intset)
192        0
193        (1+ (intset-prev nodes))))
194  (define components
195    (intmap-remove
196     (compute-strongly-connected-components (intmap-add edges start nodes)
197                                            start)
198     start))
199  (define node-components
200    (intmap-fold (lambda (id nodes out)
201                   (intset-fold (lambda (node out) (intmap-add out node id))
202                                nodes out))
203                 components
204                 empty-intmap))
205  (define (node-component node)
206    (intmap-ref node-components node))
207  (define (component-successors id nodes)
208    (intset-remove
209     (intset-fold (lambda (node out)
210                    (intset-fold
211                     (lambda (successor out)
212                       (intset-add out (node-component successor)))
213                     (intmap-ref edges node)
214                     out))
215                  nodes
216                  empty-intset)
217     id))
218  (define component-edges
219    (intmap-map component-successors components))
220  (define preds
221    (invert-graph component-edges))
222  (define roots
223    (intmap-fold (lambda (id succs out)
224                   (if (eq? empty-intset succs)
225                       (intset-add out id)
226                       out))
227                 component-edges
228                 empty-intset))
229  ;; As above, add a "start" node that links to the roots, and remove it
230  ;; from the result.
231  (match (compute-reverse-post-order (intmap-add preds start roots) start)
232    (((? (lambda (id) (eqv? id start))) . ids)
233     (map (lambda (id) (intmap-ref components id)) ids))))
234
235(define (intset-pop set)
236  (match (intset-next set)
237    (#f (values set #f))
238    (i (values (intset-remove set i) i))))
239
240(define* (solve-flow-equations succs in out kill gen subtract add meet
241                               #:optional (worklist (intmap-keys succs)))
242  "Find a fixed point for flow equations for SUCCS, where INIT is the
243initial state at each node in SUCCS.  KILL and GEN are intmaps
244indicating the state that is killed or defined at every node, and
245SUBTRACT, ADD, and MEET operates on that state."
246  (define (visit label in out)
247    (let* ((in-1 (intmap-ref in label))
248           (kill-1 (intmap-ref kill label))
249           (gen-1 (intmap-ref gen label))
250           (out-1 (intmap-ref out label))
251           (out-1* (add (subtract in-1 kill-1) gen-1)))
252      (if (eq? out-1 out-1*)
253          (values empty-intset in out)
254          (let ((out (intmap-replace! out label out-1*)))
255            (call-with-values
256                (lambda ()
257                  (intset-fold (lambda (succ in changed)
258                                 (let* ((in-1 (intmap-ref in succ))
259                                        (in-1* (meet in-1 out-1*)))
260                                   (if (eq? in-1 in-1*)
261                                       (values in changed)
262                                       (values (intmap-replace! in succ in-1*)
263                                               (intset-add changed succ)))))
264                               (intmap-ref succs label) in empty-intset))
265              (lambda (in changed)
266                (values changed in out)))))))
267
268  (let run ((worklist worklist) (in in) (out out))
269    (call-with-values (lambda () (intset-pop worklist))
270      (lambda (worklist popped)
271        (if popped
272            (call-with-values (lambda () (visit popped in out))
273              (lambda (changed in out)
274                (run (intset-union worklist changed) in out)))
275            (values (persistent-intmap in)
276                    (persistent-intmap out)))))))
277