Commit | Line | Data |
---|---|---|
b3523093 AW |
1 | ;;; Functional name maps |
2 | ;;; Copyright (C) 2014 Free Software Foundation, Inc. | |
3 | ;;; | |
4 | ;;; This library is free software: you can redistribute it and/or modify | |
5 | ;;; it under the terms of the GNU Lesser General Public License as | |
6 | ;;; published by the Free Software Foundation, either version 3 of the | |
7 | ;;; License, or (at your option) any later version. | |
8 | ;;; | |
9 | ;;; This library is distributed in the hope that it will be useful, but | |
10 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
11 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
12 | ;;; Lesser General Public License for more details. | |
13 | ;;; | |
14 | ;;; You should have received a copy of the GNU Lesser General Public | |
15 | ;;; License along with this program. If not, see | |
16 | ;;; <http://www.gnu.org/licenses/>. | |
17 | ||
18 | ;;; Commentary: | |
19 | ;;; | |
20 | ;;; Some CPS passes need to perform a flow analysis in which every | |
21 | ;;; program point has an associated map over some set of labels or | |
22 | ;;; variables. The naive way to implement this is with an array of | |
23 | ;;; arrays, but this has N^2 complexity, and it really can hurt us. | |
24 | ;;; | |
25 | ;;; Instead, this module provides a functional map that can share space | |
26 | ;;; between program points, reducing the amortized space complexity of | |
27 | ;;; the representations down to O(n log n). Adding entries to the | |
28 | ;;; mapping and lookup are O(log n). Intersection and union between | |
29 | ;;; intmaps that share state are fast, too. | |
30 | ;;; | |
31 | ;;; Code: | |
32 | ||
33 | (define-module (language cps intmap) | |
34 | #:use-module (srfi srfi-9) | |
35 | #:use-module (ice-9 match) | |
36 | #:export (empty-intmap | |
37 | intmap? | |
38 | intmap-add | |
39 | intmap-remove | |
40 | intmap-ref | |
41 | intmap-next | |
42 | intmap-union | |
43 | intmap-intersect)) | |
44 | ||
45 | ;; Persistent sparse intmaps. | |
46 | ||
47 | (define-syntax-rule (define-inline name val) | |
48 | (define-syntax name (identifier-syntax val))) | |
49 | ||
50 | (define-inline *branch-bits* 4) | |
51 | (define-inline *branch-size* (ash 1 *branch-bits*)) | |
52 | (define-inline *branch-mask* (1- *branch-size*)) | |
53 | ||
54 | (define-record-type <intmap> | |
55 | (make-intmap min shift root) | |
56 | intmap? | |
57 | (min intmap-min) | |
58 | (shift intmap-shift) | |
59 | (root intmap-root)) | |
60 | ||
61 | (define (new-branch) | |
62 | (make-vector *branch-size* #f)) | |
63 | (define (clone-branch-and-set branch i elt) | |
64 | (let ((new (new-branch))) | |
65 | (when branch (vector-move-left! branch 0 *branch-size* new 0)) | |
66 | (vector-set! new i elt) | |
67 | new)) | |
68 | (define (branch-empty? branch) | |
69 | (let lp ((i 0)) | |
70 | (or (= i *branch-size*) | |
71 | (and (not (vector-ref branch i)) | |
72 | (lp (1+ i)))))) | |
73 | ||
74 | (define (round-down min shift) | |
75 | (logand min (lognot (1- (ash 1 shift))))) | |
76 | ||
77 | (define empty-intmap (make-intmap 0 0 #f)) | |
78 | ||
79 | (define (add-level min shift root) | |
80 | (let* ((shift* (+ shift *branch-bits*)) | |
81 | (min* (round-down min shift*)) | |
82 | (idx (logand (ash (- min min*) (- shift)) | |
83 | *branch-mask*))) | |
84 | (make-intmap min* shift* (clone-branch-and-set #f idx root)))) | |
85 | ||
86 | (define (make-intmap/prune min shift root) | |
87 | (if (zero? shift) | |
88 | (make-intmap min shift root) | |
89 | (let lp ((i 0) (elt #f)) | |
90 | (cond | |
91 | ((< i *branch-size*) | |
92 | (if (vector-ref root i) | |
93 | (if elt | |
94 | (make-intmap min shift root) | |
95 | (lp (1+ i) i)) | |
96 | (lp (1+ i) elt))) | |
97 | (elt | |
98 | (let ((shift (- shift *branch-bits*))) | |
99 | (make-intmap/prune (+ min (ash elt shift)) | |
100 | shift | |
101 | (vector-ref root elt)))) | |
102 | ;; Shouldn't be reached... | |
103 | (else empty-intmap))))) | |
104 | ||
105 | (define (intmap-add bs i val meet) | |
106 | (define (adjoin i shift root) | |
107 | (cond | |
108 | ((zero? shift) | |
109 | (cond | |
110 | ((eq? root val) root) | |
111 | ((not root) val) | |
112 | (else (meet root val)))) | |
113 | (else | |
114 | (let* ((shift (- shift *branch-bits*)) | |
115 | (idx (logand (ash i (- shift)) *branch-mask*)) | |
116 | (node (and root (vector-ref root idx))) | |
117 | (new-node (adjoin i shift node))) | |
118 | (if (eq? node new-node) | |
119 | root | |
120 | (clone-branch-and-set root idx new-node)))))) | |
121 | (match bs | |
122 | (($ <intmap> min shift root) | |
123 | (cond | |
124 | ((not val) (intmap-remove bs i)) | |
125 | ((not root) | |
126 | ;; Add first element. | |
127 | (make-intmap i 0 val)) | |
128 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
129 | ;; Add element to map; level will not change. | |
130 | (let ((old-root root) | |
131 | (root (adjoin (- i min) shift root))) | |
132 | (if (eq? root old-root) | |
133 | bs | |
134 | (make-intmap min shift root)))) | |
135 | ((< i min) | |
136 | ;; Rebuild the tree by unioning two intmaps. | |
137 | (intmap-union (intmap-add empty-intmap i val error) bs error)) | |
138 | (else | |
139 | ;; Add a new level and try again. | |
140 | (intmap-add (add-level min shift root) i val error)))))) | |
141 | ||
142 | (define (intmap-remove bs i) | |
143 | (define (remove i shift root) | |
144 | (cond | |
145 | ((zero? shift) #f) | |
146 | (else | |
147 | (let* ((shift (- shift *branch-bits*)) | |
148 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
149 | (cond | |
150 | ((vector-ref root idx) | |
151 | => (lambda (node) | |
152 | (let ((new-node (remove i shift node))) | |
153 | (if (eq? node new-node) | |
154 | root | |
155 | (let ((root (clone-branch-and-set root idx new-node))) | |
156 | (and (or new-node (not (branch-empty? root))) | |
157 | root)))))) | |
158 | (else root)))))) | |
159 | (match bs | |
160 | (($ <intmap> min shift root) | |
161 | (cond | |
162 | ((not root) bs) | |
163 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
164 | ;; Add element to map; level will not change. | |
165 | (let ((old-root root) | |
166 | (root (remove (- i min) shift root))) | |
167 | (if (eq? root old-root) | |
168 | bs | |
169 | (make-intmap/prune min shift root)))) | |
170 | (else bs))))) | |
171 | ||
172 | (define (intmap-ref bs i) | |
173 | (match bs | |
174 | (($ <intmap> min shift root) | |
175 | (and (<= min i) (< i (+ min (ash 1 shift))) | |
176 | (let ((i (- i min))) | |
177 | (let lp ((node root) (shift shift)) | |
178 | (and node | |
179 | (if (= shift *branch-bits*) | |
180 | (vector-ref node (logand i *branch-mask*)) | |
181 | (let* ((shift (- shift *branch-bits*)) | |
182 | (idx (logand (ash i (- shift)) | |
183 | *branch-mask*))) | |
184 | (lp (vector-ref node idx) shift)))))))))) | |
185 | ||
186 | (define (intmap-next bs i) | |
187 | (define (visit-branch node shift i) | |
188 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
189 | (and (< idx *branch-size*) | |
190 | (or (visit-node (vector-ref node idx) shift i) | |
191 | (let ((inc (ash 1 shift))) | |
192 | (lp (+ (round-down i shift) inc) (1+ idx))))))) | |
193 | (define (visit-node node shift i) | |
194 | (and node | |
195 | (if (zero? shift) | |
196 | i | |
197 | (visit-branch node (- shift *branch-bits*) i)))) | |
198 | (match bs | |
199 | (($ <intmap> min shift root) | |
200 | (let ((i (if (and i (< min i)) | |
201 | (- i min) | |
202 | 0))) | |
203 | (and (< i (ash 1 shift)) | |
204 | (let ((i (visit-node root shift i))) | |
205 | (and i (+ min i)))))))) | |
206 | ||
207 | (define (intmap-union a b meet) | |
208 | ;; Union A and B from index I; the result will be fresh. | |
209 | (define (union-branches/fresh shift a b i fresh) | |
210 | (let lp ((i 0)) | |
211 | (cond | |
212 | ((< i *branch-size*) | |
213 | (let* ((a-child (vector-ref a i)) | |
214 | (b-child (vector-ref b i))) | |
215 | (vector-set! fresh i (union shift a-child b-child)) | |
216 | (lp (1+ i)))) | |
217 | (else fresh)))) | |
218 | ;; Union A and B from index I; the result may be eq? to A. | |
219 | (define (union-branches/a shift a b i) | |
220 | (let lp ((i i)) | |
221 | (cond | |
222 | ((< i *branch-size*) | |
223 | (let* ((a-child (vector-ref a i)) | |
224 | (b-child (vector-ref b i))) | |
225 | (if (eq? a-child b-child) | |
226 | (lp (1+ i)) | |
227 | (let ((child (union shift a-child b-child))) | |
228 | (cond | |
229 | ((eq? a-child child) | |
230 | (lp (1+ i))) | |
231 | (else | |
232 | (let ((result (clone-branch-and-set a i child))) | |
233 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
234 | (else a)))) | |
235 | ;; Union A and B; the may could be eq? to either. | |
236 | (define (union-branches shift a b) | |
237 | (let lp ((i 0)) | |
238 | (cond | |
239 | ((< i *branch-size*) | |
240 | (let* ((a-child (vector-ref a i)) | |
241 | (b-child (vector-ref b i))) | |
242 | (if (eq? a-child b-child) | |
243 | (lp (1+ i)) | |
244 | (let ((child (union shift a-child b-child))) | |
245 | (cond | |
246 | ((eq? a-child child) | |
247 | (union-branches/a shift a b (1+ i))) | |
248 | ((eq? b-child child) | |
249 | (union-branches/a shift b a (1+ i))) | |
250 | (else | |
251 | (let ((result (clone-branch-and-set a i child))) | |
252 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
253 | ;; Seems they are the same but not eq?. Odd. | |
254 | (else a)))) | |
255 | (define (union shift a-node b-node) | |
256 | (cond | |
257 | ((not a-node) b-node) | |
258 | ((not b-node) a-node) | |
259 | ((eq? a-node b-node) a-node) | |
260 | ((zero? shift) (meet a-node b-node)) | |
261 | (else (union-branches (- shift *branch-bits*) a-node b-node)))) | |
262 | (match (cons a b) | |
263 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
264 | (cond | |
265 | ((not (= b-shift a-shift)) | |
266 | ;; Hoist the map with the lowest shift to meet the one with the | |
267 | ;; higher shift. | |
268 | (if (< b-shift a-shift) | |
269 | (intmap-union a (add-level b-min b-shift b-root) meet) | |
270 | (intmap-union (add-level a-min a-shift a-root) b meet))) | |
271 | ((not (= b-min a-min)) | |
272 | ;; Nodes at the same shift but different minimums will cover | |
273 | ;; disjoint ranges (due to the round-down call on min). Hoist | |
274 | ;; both until they cover the same range. | |
275 | (intmap-union (add-level a-min a-shift a-root) | |
276 | (add-level b-min b-shift b-root) | |
277 | meet)) | |
278 | (else | |
279 | ;; At this point, A and B cover the same range. | |
280 | (let ((root (union a-shift a-root b-root))) | |
281 | (cond | |
282 | ((eq? root a-root) a) | |
283 | ((eq? root b-root) b) | |
284 | (else (make-intmap a-min a-shift root))))))))) | |
285 | ||
286 | (define (intmap-intersect a b meet) | |
287 | ;; Intersect A and B from index I; the result will be fresh. | |
288 | (define (intersect-branches/fresh shift a b i fresh) | |
289 | (let lp ((i 0)) | |
290 | (cond | |
291 | ((< i *branch-size*) | |
292 | (let* ((a-child (vector-ref a i)) | |
293 | (b-child (vector-ref b i))) | |
294 | (vector-set! fresh i (intersect shift a-child b-child)) | |
295 | (lp (1+ i)))) | |
296 | ((branch-empty? fresh) #f) | |
297 | (else fresh)))) | |
298 | ;; Intersect A and B from index I; the result may be eq? to A. | |
299 | (define (intersect-branches/a shift a b i) | |
300 | (let lp ((i i)) | |
301 | (cond | |
302 | ((< i *branch-size*) | |
303 | (let* ((a-child (vector-ref a i)) | |
304 | (b-child (vector-ref b i))) | |
305 | (if (eq? a-child b-child) | |
306 | (lp (1+ i)) | |
307 | (let ((child (intersect shift a-child b-child))) | |
308 | (cond | |
309 | ((eq? a-child child) | |
310 | (lp (1+ i))) | |
311 | (else | |
312 | (let ((result (clone-branch-and-set a i child))) | |
313 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
314 | (else a)))) | |
315 | ;; Intersect A and B; the may could be eq? to either. | |
316 | (define (intersect-branches shift a b) | |
317 | (let lp ((i 0)) | |
318 | (cond | |
319 | ((< i *branch-size*) | |
320 | (let* ((a-child (vector-ref a i)) | |
321 | (b-child (vector-ref b i))) | |
322 | (if (eq? a-child b-child) | |
323 | (lp (1+ i)) | |
324 | (let ((child (intersect shift a-child b-child))) | |
325 | (cond | |
326 | ((eq? a-child child) | |
327 | (intersect-branches/a shift a b (1+ i))) | |
328 | ((eq? b-child child) | |
329 | (intersect-branches/a shift b a (1+ i))) | |
330 | (else | |
331 | (let ((result (clone-branch-and-set a i child))) | |
332 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
333 | ;; Seems they are the same but not eq?. Odd. | |
334 | (else a)))) | |
335 | (define (intersect shift a-node b-node) | |
336 | (cond | |
337 | ((or (not a-node) (not b-node)) #f) | |
338 | ((eq? a-node b-node) a-node) | |
339 | ((zero? shift) (meet a-node b-node)) | |
340 | (else (intersect-branches (- shift *branch-bits*) a-node b-node)))) | |
341 | ||
342 | (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?) | |
343 | (cond | |
344 | ((<= lo-shift hi-shift) | |
345 | ;; If LO has a lower shift and a lower min, it is disjoint. If | |
346 | ;; it has the same shift and a different min, it is also | |
347 | ;; disjoint. | |
348 | empty-intmap) | |
349 | (else | |
350 | (let* ((lo-shift (- lo-shift *branch-bits*)) | |
351 | (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) | |
352 | (if (>= lo-idx *branch-size*) | |
353 | ;; HI has a lower shift, but it not within LO. | |
354 | empty-intmap | |
355 | (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) | |
356 | lo-shift | |
357 | (vector-ref lo-root lo-idx)))) | |
358 | (if lo-is-a? | |
359 | (intmap-intersect lo hi meet) | |
360 | (intmap-intersect hi lo meet)))))))) | |
361 | ||
362 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) | |
363 | (let ((hi (make-intmap min | |
364 | (- hi-shift *branch-bits*) | |
365 | (vector-ref hi-root 0)))) | |
366 | (if lo-is-a? | |
367 | (intmap-intersect lo hi meet) | |
368 | (intmap-intersect hi lo meet)))) | |
369 | ||
370 | (match (cons a b) | |
371 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
372 | (cond | |
373 | ((< a-min b-min) | |
374 | (different-mins a-min a-shift a-root b-min b-shift b #t)) | |
375 | ((< b-min a-min) | |
376 | (different-mins b-min b-shift b-root a-min a-shift a #f)) | |
377 | ((< a-shift b-shift) | |
378 | (different-shifts-same-min b-min b-shift b-root a #t)) | |
379 | ((< b-shift a-shift) | |
380 | (different-shifts-same-min a-min a-shift a-root b #f)) | |
381 | (else | |
382 | ;; At this point, A and B cover the same range. | |
383 | (let ((root (intersect a-shift a-root b-root))) | |
384 | (cond | |
385 | ((eq? root a-root) a) | |
386 | ((eq? root b-root) b) | |
387 | (else (make-intmap/prune a-min a-shift root))))))))) |