Commit | Line | Data |
---|---|---|
b3523093 | 1 | ;;; Functional name maps |
33ab2838 | 2 | ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc. |
b3523093 AW |
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 | |
2a24395a | 42 | intmap-prev |
b7668bd9 | 43 | intmap-fold |
b3523093 AW |
44 | intmap-union |
45 | intmap-intersect)) | |
46 | ||
47 | ;; Persistent sparse intmaps. | |
48 | ||
49 | (define-syntax-rule (define-inline name val) | |
50 | (define-syntax name (identifier-syntax val))) | |
51 | ||
cf512e32 | 52 | (define-inline *branch-bits* 5) |
b3523093 AW |
53 | (define-inline *branch-size* (ash 1 *branch-bits*)) |
54 | (define-inline *branch-mask* (1- *branch-size*)) | |
55 | ||
56 | (define-record-type <intmap> | |
57 | (make-intmap min shift root) | |
58 | intmap? | |
59 | (min intmap-min) | |
60 | (shift intmap-shift) | |
61 | (root intmap-root)) | |
62 | ||
63 | (define (new-branch) | |
64 | (make-vector *branch-size* #f)) | |
65 | (define (clone-branch-and-set branch i elt) | |
66 | (let ((new (new-branch))) | |
67 | (when branch (vector-move-left! branch 0 *branch-size* new 0)) | |
68 | (vector-set! new i elt) | |
69 | new)) | |
70 | (define (branch-empty? branch) | |
71 | (let lp ((i 0)) | |
72 | (or (= i *branch-size*) | |
73 | (and (not (vector-ref branch i)) | |
74 | (lp (1+ i)))))) | |
75 | ||
76 | (define (round-down min shift) | |
77 | (logand min (lognot (1- (ash 1 shift))))) | |
78 | ||
79 | (define empty-intmap (make-intmap 0 0 #f)) | |
80 | ||
81 | (define (add-level min shift root) | |
82 | (let* ((shift* (+ shift *branch-bits*)) | |
83 | (min* (round-down min shift*)) | |
84 | (idx (logand (ash (- min min*) (- shift)) | |
85 | *branch-mask*))) | |
86 | (make-intmap min* shift* (clone-branch-and-set #f idx root)))) | |
87 | ||
88 | (define (make-intmap/prune min shift root) | |
89 | (if (zero? shift) | |
90 | (make-intmap min shift root) | |
91 | (let lp ((i 0) (elt #f)) | |
92 | (cond | |
93 | ((< i *branch-size*) | |
94 | (if (vector-ref root i) | |
95 | (if elt | |
96 | (make-intmap min shift root) | |
97 | (lp (1+ i) i)) | |
98 | (lp (1+ i) elt))) | |
99 | (elt | |
100 | (let ((shift (- shift *branch-bits*))) | |
101 | (make-intmap/prune (+ min (ash elt shift)) | |
102 | shift | |
103 | (vector-ref root elt)))) | |
104 | ;; Shouldn't be reached... | |
105 | (else empty-intmap))))) | |
106 | ||
33ab2838 AW |
107 | (define (meet-error old new) |
108 | (error "Multiple differing values and no meet procedure defined" old new)) | |
109 | ||
110 | (define* (intmap-add bs i val #:optional (meet meet-error)) | |
b3523093 AW |
111 | (define (adjoin i shift root) |
112 | (cond | |
113 | ((zero? shift) | |
114 | (cond | |
115 | ((eq? root val) root) | |
116 | ((not root) val) | |
117 | (else (meet root val)))) | |
118 | (else | |
119 | (let* ((shift (- shift *branch-bits*)) | |
120 | (idx (logand (ash i (- shift)) *branch-mask*)) | |
121 | (node (and root (vector-ref root idx))) | |
122 | (new-node (adjoin i shift node))) | |
123 | (if (eq? node new-node) | |
124 | root | |
125 | (clone-branch-and-set root idx new-node)))))) | |
126 | (match bs | |
127 | (($ <intmap> min shift root) | |
128 | (cond | |
4296c36e AW |
129 | ((< i 0) |
130 | ;; The power-of-two spanning trick doesn't work across 0. | |
131 | (error "Intmaps can only map non-negative integers." i)) | |
b3523093 AW |
132 | ((not val) (intmap-remove bs i)) |
133 | ((not root) | |
134 | ;; Add first element. | |
135 | (make-intmap i 0 val)) | |
136 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
137 | ;; Add element to map; level will not change. | |
138 | (let ((old-root root) | |
139 | (root (adjoin (- i min) shift root))) | |
140 | (if (eq? root old-root) | |
141 | bs | |
142 | (make-intmap min shift root)))) | |
143 | ((< i min) | |
144 | ;; Rebuild the tree by unioning two intmaps. | |
145 | (intmap-union (intmap-add empty-intmap i val error) bs error)) | |
146 | (else | |
147 | ;; Add a new level and try again. | |
148 | (intmap-add (add-level min shift root) i val error)))))) | |
149 | ||
150 | (define (intmap-remove bs i) | |
151 | (define (remove i shift root) | |
152 | (cond | |
153 | ((zero? shift) #f) | |
154 | (else | |
155 | (let* ((shift (- shift *branch-bits*)) | |
156 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
157 | (cond | |
158 | ((vector-ref root idx) | |
159 | => (lambda (node) | |
160 | (let ((new-node (remove i shift node))) | |
161 | (if (eq? node new-node) | |
162 | root | |
163 | (let ((root (clone-branch-and-set root idx new-node))) | |
164 | (and (or new-node (not (branch-empty? root))) | |
165 | root)))))) | |
166 | (else root)))))) | |
167 | (match bs | |
168 | (($ <intmap> min shift root) | |
169 | (cond | |
170 | ((not root) bs) | |
171 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
172 | ;; Add element to map; level will not change. | |
173 | (let ((old-root root) | |
174 | (root (remove (- i min) shift root))) | |
175 | (if (eq? root old-root) | |
176 | bs | |
177 | (make-intmap/prune min shift root)))) | |
178 | (else bs))))) | |
179 | ||
180 | (define (intmap-ref bs i) | |
181 | (match bs | |
182 | (($ <intmap> min shift root) | |
ef7a71b7 AW |
183 | (if (zero? shift) |
184 | (and (= i min) root) | |
185 | (and (<= min i) (< i (+ min (ash 1 shift))) | |
186 | (let ((i (- i min))) | |
187 | (let lp ((node root) (shift shift)) | |
188 | (and node | |
189 | (if (= shift *branch-bits*) | |
190 | (vector-ref node (logand i *branch-mask*)) | |
191 | (let* ((shift (- shift *branch-bits*)) | |
192 | (idx (logand (ash i (- shift)) | |
193 | *branch-mask*))) | |
194 | (lp (vector-ref node idx) shift))))))))))) | |
b3523093 | 195 | |
2a24395a | 196 | (define* (intmap-next bs #:optional i) |
b3523093 AW |
197 | (define (visit-branch node shift i) |
198 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
199 | (and (< idx *branch-size*) | |
200 | (or (visit-node (vector-ref node idx) shift i) | |
201 | (let ((inc (ash 1 shift))) | |
202 | (lp (+ (round-down i shift) inc) (1+ idx))))))) | |
203 | (define (visit-node node shift i) | |
204 | (and node | |
205 | (if (zero? shift) | |
206 | i | |
207 | (visit-branch node (- shift *branch-bits*) i)))) | |
208 | (match bs | |
209 | (($ <intmap> min shift root) | |
210 | (let ((i (if (and i (< min i)) | |
211 | (- i min) | |
212 | 0))) | |
213 | (and (< i (ash 1 shift)) | |
214 | (let ((i (visit-node root shift i))) | |
215 | (and i (+ min i)))))))) | |
216 | ||
2a24395a AW |
217 | (define* (intmap-prev bs #:optional i) |
218 | (define (visit-branch node shift i) | |
219 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
220 | (and (<= 0 idx) | |
221 | (or (visit-node (vector-ref node idx) shift i) | |
222 | (lp (1- (round-down i shift)) (1- idx)))))) | |
223 | (define (visit-node node shift i) | |
224 | (and node | |
225 | (if (zero? shift) | |
226 | i | |
227 | (visit-branch node (- shift *branch-bits*) i)))) | |
228 | (match bs | |
229 | (($ <intmap> min shift root) | |
230 | (let* ((i (if (and i (< i (+ min (ash 1 shift)))) | |
231 | (- i min) | |
232 | (1- (ash 1 shift))))) | |
233 | (and (<= 0 i) | |
234 | (let ((i (visit-node root shift i))) | |
235 | (and i (+ min i)))))))) | |
236 | ||
b7668bd9 AW |
237 | (define (intmap-fold f map seed) |
238 | (define (visit-branch node shift min seed) | |
239 | (let ((shift (- shift *branch-bits*))) | |
240 | (if (zero? shift) | |
241 | (let lp ((i 0) (seed seed)) | |
242 | (if (< i *branch-size*) | |
243 | (let ((elt (vector-ref node i))) | |
244 | (lp (1+ i) | |
245 | (if elt | |
246 | (f (+ i min) elt seed) | |
247 | seed))) | |
248 | seed)) | |
249 | (let lp ((i 0) (seed seed)) | |
250 | (if (< i *branch-size*) | |
251 | (let ((elt (vector-ref node i))) | |
252 | (lp (1+ i) | |
253 | (if elt | |
254 | (visit-branch elt shift (+ min (ash i shift)) seed) | |
255 | seed))) | |
256 | seed))))) | |
257 | (match map | |
258 | (($ <intmap> min shift root) | |
259 | (cond | |
260 | ((not root) seed) | |
261 | ((zero? shift) (f min root seed)) | |
262 | (else (visit-branch root shift min seed)))))) | |
263 | ||
33ab2838 | 264 | (define* (intmap-union a b #:optional (meet meet-error)) |
b3523093 AW |
265 | ;; Union A and B from index I; the result will be fresh. |
266 | (define (union-branches/fresh shift a b i fresh) | |
267 | (let lp ((i 0)) | |
268 | (cond | |
269 | ((< i *branch-size*) | |
270 | (let* ((a-child (vector-ref a i)) | |
271 | (b-child (vector-ref b i))) | |
272 | (vector-set! fresh i (union shift a-child b-child)) | |
273 | (lp (1+ i)))) | |
274 | (else fresh)))) | |
275 | ;; Union A and B from index I; the result may be eq? to A. | |
276 | (define (union-branches/a shift a b i) | |
277 | (let lp ((i i)) | |
278 | (cond | |
279 | ((< i *branch-size*) | |
280 | (let* ((a-child (vector-ref a i)) | |
281 | (b-child (vector-ref b i))) | |
282 | (if (eq? a-child b-child) | |
283 | (lp (1+ i)) | |
284 | (let ((child (union shift a-child b-child))) | |
285 | (cond | |
286 | ((eq? a-child child) | |
287 | (lp (1+ i))) | |
288 | (else | |
289 | (let ((result (clone-branch-and-set a i child))) | |
290 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
291 | (else a)))) | |
292 | ;; Union A and B; the may could be eq? to either. | |
293 | (define (union-branches shift a b) | |
294 | (let lp ((i 0)) | |
295 | (cond | |
296 | ((< i *branch-size*) | |
297 | (let* ((a-child (vector-ref a i)) | |
298 | (b-child (vector-ref b i))) | |
299 | (if (eq? a-child b-child) | |
300 | (lp (1+ i)) | |
301 | (let ((child (union shift a-child b-child))) | |
302 | (cond | |
303 | ((eq? a-child child) | |
304 | (union-branches/a shift a b (1+ i))) | |
305 | ((eq? b-child child) | |
306 | (union-branches/a shift b a (1+ i))) | |
307 | (else | |
308 | (let ((result (clone-branch-and-set a i child))) | |
309 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
310 | ;; Seems they are the same but not eq?. Odd. | |
311 | (else a)))) | |
312 | (define (union shift a-node b-node) | |
313 | (cond | |
314 | ((not a-node) b-node) | |
315 | ((not b-node) a-node) | |
316 | ((eq? a-node b-node) a-node) | |
317 | ((zero? shift) (meet a-node b-node)) | |
318 | (else (union-branches (- shift *branch-bits*) a-node b-node)))) | |
319 | (match (cons a b) | |
320 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
321 | (cond | |
322 | ((not (= b-shift a-shift)) | |
323 | ;; Hoist the map with the lowest shift to meet the one with the | |
324 | ;; higher shift. | |
325 | (if (< b-shift a-shift) | |
326 | (intmap-union a (add-level b-min b-shift b-root) meet) | |
327 | (intmap-union (add-level a-min a-shift a-root) b meet))) | |
328 | ((not (= b-min a-min)) | |
329 | ;; Nodes at the same shift but different minimums will cover | |
330 | ;; disjoint ranges (due to the round-down call on min). Hoist | |
331 | ;; both until they cover the same range. | |
332 | (intmap-union (add-level a-min a-shift a-root) | |
333 | (add-level b-min b-shift b-root) | |
334 | meet)) | |
335 | (else | |
336 | ;; At this point, A and B cover the same range. | |
337 | (let ((root (union a-shift a-root b-root))) | |
338 | (cond | |
339 | ((eq? root a-root) a) | |
340 | ((eq? root b-root) b) | |
341 | (else (make-intmap a-min a-shift root))))))))) | |
342 | ||
33ab2838 | 343 | (define* (intmap-intersect a b #:optional (meet meet-error)) |
b3523093 AW |
344 | ;; Intersect A and B from index I; the result will be fresh. |
345 | (define (intersect-branches/fresh shift a b i fresh) | |
346 | (let lp ((i 0)) | |
347 | (cond | |
348 | ((< i *branch-size*) | |
349 | (let* ((a-child (vector-ref a i)) | |
350 | (b-child (vector-ref b i))) | |
351 | (vector-set! fresh i (intersect shift a-child b-child)) | |
352 | (lp (1+ i)))) | |
353 | ((branch-empty? fresh) #f) | |
354 | (else fresh)))) | |
355 | ;; Intersect A and B from index I; the result may be eq? to A. | |
356 | (define (intersect-branches/a shift a b i) | |
357 | (let lp ((i i)) | |
358 | (cond | |
359 | ((< i *branch-size*) | |
360 | (let* ((a-child (vector-ref a i)) | |
361 | (b-child (vector-ref b i))) | |
362 | (if (eq? a-child b-child) | |
363 | (lp (1+ i)) | |
364 | (let ((child (intersect shift a-child b-child))) | |
365 | (cond | |
366 | ((eq? a-child child) | |
367 | (lp (1+ i))) | |
368 | (else | |
369 | (let ((result (clone-branch-and-set a i child))) | |
370 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
371 | (else a)))) | |
372 | ;; Intersect A and B; the may could be eq? to either. | |
373 | (define (intersect-branches shift a b) | |
374 | (let lp ((i 0)) | |
375 | (cond | |
376 | ((< i *branch-size*) | |
377 | (let* ((a-child (vector-ref a i)) | |
378 | (b-child (vector-ref b i))) | |
379 | (if (eq? a-child b-child) | |
380 | (lp (1+ i)) | |
381 | (let ((child (intersect shift a-child b-child))) | |
382 | (cond | |
383 | ((eq? a-child child) | |
384 | (intersect-branches/a shift a b (1+ i))) | |
385 | ((eq? b-child child) | |
386 | (intersect-branches/a shift b a (1+ i))) | |
387 | (else | |
388 | (let ((result (clone-branch-and-set a i child))) | |
389 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
390 | ;; Seems they are the same but not eq?. Odd. | |
391 | (else a)))) | |
392 | (define (intersect shift a-node b-node) | |
393 | (cond | |
394 | ((or (not a-node) (not b-node)) #f) | |
395 | ((eq? a-node b-node) a-node) | |
396 | ((zero? shift) (meet a-node b-node)) | |
397 | (else (intersect-branches (- shift *branch-bits*) a-node b-node)))) | |
398 | ||
399 | (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?) | |
400 | (cond | |
401 | ((<= lo-shift hi-shift) | |
402 | ;; If LO has a lower shift and a lower min, it is disjoint. If | |
403 | ;; it has the same shift and a different min, it is also | |
404 | ;; disjoint. | |
405 | empty-intmap) | |
406 | (else | |
407 | (let* ((lo-shift (- lo-shift *branch-bits*)) | |
408 | (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) | |
e21dae43 AW |
409 | (cond |
410 | ((>= lo-idx *branch-size*) | |
411 | ;; HI has a lower shift, but it not within LO. | |
412 | empty-intmap) | |
413 | ((vector-ref lo-root lo-idx) | |
414 | => (lambda (lo-root) | |
415 | (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) | |
416 | lo-shift | |
417 | lo-root))) | |
418 | (if lo-is-a? | |
419 | (intmap-intersect lo hi meet) | |
420 | (intmap-intersect hi lo meet))))) | |
421 | (else empty-intmap)))))) | |
b3523093 AW |
422 | |
423 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) | |
e21dae43 AW |
424 | (cond |
425 | ((vector-ref hi-root 0) | |
426 | => (lambda (hi-root) | |
427 | (let ((hi (make-intmap min | |
428 | (- hi-shift *branch-bits*) | |
429 | hi-root))) | |
430 | (if lo-is-a? | |
431 | (intmap-intersect lo hi meet) | |
432 | (intmap-intersect hi lo meet))))) | |
433 | (else empty-intmap))) | |
b3523093 AW |
434 | |
435 | (match (cons a b) | |
436 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
437 | (cond | |
438 | ((< a-min b-min) | |
439 | (different-mins a-min a-shift a-root b-min b-shift b #t)) | |
440 | ((< b-min a-min) | |
441 | (different-mins b-min b-shift b-root a-min a-shift a #f)) | |
442 | ((< a-shift b-shift) | |
443 | (different-shifts-same-min b-min b-shift b-root a #t)) | |
444 | ((< b-shift a-shift) | |
445 | (different-shifts-same-min a-min a-shift a-root b #f)) | |
446 | (else | |
447 | ;; At this point, A and B cover the same range. | |
448 | (let ((root (intersect a-shift a-root b-root))) | |
449 | (cond | |
450 | ((eq? root a-root) a) | |
451 | ((eq? root b-root) b) | |
452 | (else (make-intmap/prune a-min a-shift root))))))))) |