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