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 | |
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 | ||
33ab2838 AW |
105 | (define (meet-error old new) |
106 | (error "Multiple differing values and no meet procedure defined" old new)) | |
107 | ||
108 | (define* (intmap-add bs i val #:optional (meet meet-error)) | |
b3523093 AW |
109 | (define (adjoin i shift root) |
110 | (cond | |
111 | ((zero? shift) | |
112 | (cond | |
113 | ((eq? root val) root) | |
114 | ((not root) val) | |
115 | (else (meet root val)))) | |
116 | (else | |
117 | (let* ((shift (- shift *branch-bits*)) | |
118 | (idx (logand (ash i (- shift)) *branch-mask*)) | |
119 | (node (and root (vector-ref root idx))) | |
120 | (new-node (adjoin i shift node))) | |
121 | (if (eq? node new-node) | |
122 | root | |
123 | (clone-branch-and-set root idx new-node)))))) | |
124 | (match bs | |
125 | (($ <intmap> min shift root) | |
126 | (cond | |
4296c36e AW |
127 | ((< i 0) |
128 | ;; The power-of-two spanning trick doesn't work across 0. | |
129 | (error "Intmaps can only map non-negative integers." i)) | |
b3523093 AW |
130 | ((not val) (intmap-remove bs i)) |
131 | ((not root) | |
132 | ;; Add first element. | |
133 | (make-intmap i 0 val)) | |
134 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
135 | ;; Add element to map; level will not change. | |
136 | (let ((old-root root) | |
137 | (root (adjoin (- i min) shift root))) | |
138 | (if (eq? root old-root) | |
139 | bs | |
140 | (make-intmap min shift root)))) | |
141 | ((< i min) | |
142 | ;; Rebuild the tree by unioning two intmaps. | |
143 | (intmap-union (intmap-add empty-intmap i val error) bs error)) | |
144 | (else | |
145 | ;; Add a new level and try again. | |
146 | (intmap-add (add-level min shift root) i val error)))))) | |
147 | ||
148 | (define (intmap-remove bs i) | |
149 | (define (remove i shift root) | |
150 | (cond | |
151 | ((zero? shift) #f) | |
152 | (else | |
153 | (let* ((shift (- shift *branch-bits*)) | |
154 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
155 | (cond | |
156 | ((vector-ref root idx) | |
157 | => (lambda (node) | |
158 | (let ((new-node (remove i shift node))) | |
159 | (if (eq? node new-node) | |
160 | root | |
161 | (let ((root (clone-branch-and-set root idx new-node))) | |
162 | (and (or new-node (not (branch-empty? root))) | |
163 | root)))))) | |
164 | (else root)))))) | |
165 | (match bs | |
166 | (($ <intmap> min shift root) | |
167 | (cond | |
168 | ((not root) bs) | |
169 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
170 | ;; Add element to map; level will not change. | |
171 | (let ((old-root root) | |
172 | (root (remove (- i min) shift root))) | |
173 | (if (eq? root old-root) | |
174 | bs | |
175 | (make-intmap/prune min shift root)))) | |
176 | (else bs))))) | |
177 | ||
178 | (define (intmap-ref bs i) | |
179 | (match bs | |
180 | (($ <intmap> min shift root) | |
ef7a71b7 AW |
181 | (if (zero? shift) |
182 | (and (= i min) root) | |
183 | (and (<= min i) (< i (+ min (ash 1 shift))) | |
184 | (let ((i (- i min))) | |
185 | (let lp ((node root) (shift shift)) | |
186 | (and node | |
187 | (if (= shift *branch-bits*) | |
188 | (vector-ref node (logand i *branch-mask*)) | |
189 | (let* ((shift (- shift *branch-bits*)) | |
190 | (idx (logand (ash i (- shift)) | |
191 | *branch-mask*))) | |
192 | (lp (vector-ref node idx) shift))))))))))) | |
b3523093 AW |
193 | |
194 | (define (intmap-next bs i) | |
195 | (define (visit-branch node shift i) | |
196 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
197 | (and (< idx *branch-size*) | |
198 | (or (visit-node (vector-ref node idx) shift i) | |
199 | (let ((inc (ash 1 shift))) | |
200 | (lp (+ (round-down i shift) inc) (1+ idx))))))) | |
201 | (define (visit-node node shift i) | |
202 | (and node | |
203 | (if (zero? shift) | |
204 | i | |
205 | (visit-branch node (- shift *branch-bits*) i)))) | |
206 | (match bs | |
207 | (($ <intmap> min shift root) | |
208 | (let ((i (if (and i (< min i)) | |
209 | (- i min) | |
210 | 0))) | |
211 | (and (< i (ash 1 shift)) | |
212 | (let ((i (visit-node root shift i))) | |
213 | (and i (+ min i)))))))) | |
214 | ||
33ab2838 | 215 | (define* (intmap-union a b #:optional (meet meet-error)) |
b3523093 AW |
216 | ;; Union A and B from index I; the result will be fresh. |
217 | (define (union-branches/fresh shift a b i fresh) | |
218 | (let lp ((i 0)) | |
219 | (cond | |
220 | ((< i *branch-size*) | |
221 | (let* ((a-child (vector-ref a i)) | |
222 | (b-child (vector-ref b i))) | |
223 | (vector-set! fresh i (union shift a-child b-child)) | |
224 | (lp (1+ i)))) | |
225 | (else fresh)))) | |
226 | ;; Union A and B from index I; the result may be eq? to A. | |
227 | (define (union-branches/a shift a b i) | |
228 | (let lp ((i i)) | |
229 | (cond | |
230 | ((< i *branch-size*) | |
231 | (let* ((a-child (vector-ref a i)) | |
232 | (b-child (vector-ref b i))) | |
233 | (if (eq? a-child b-child) | |
234 | (lp (1+ i)) | |
235 | (let ((child (union shift a-child b-child))) | |
236 | (cond | |
237 | ((eq? a-child child) | |
238 | (lp (1+ i))) | |
239 | (else | |
240 | (let ((result (clone-branch-and-set a i child))) | |
241 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
242 | (else a)))) | |
243 | ;; Union A and B; the may could be eq? to either. | |
244 | (define (union-branches shift a b) | |
245 | (let lp ((i 0)) | |
246 | (cond | |
247 | ((< i *branch-size*) | |
248 | (let* ((a-child (vector-ref a i)) | |
249 | (b-child (vector-ref b i))) | |
250 | (if (eq? a-child b-child) | |
251 | (lp (1+ i)) | |
252 | (let ((child (union shift a-child b-child))) | |
253 | (cond | |
254 | ((eq? a-child child) | |
255 | (union-branches/a shift a b (1+ i))) | |
256 | ((eq? b-child child) | |
257 | (union-branches/a shift b a (1+ i))) | |
258 | (else | |
259 | (let ((result (clone-branch-and-set a i child))) | |
260 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
261 | ;; Seems they are the same but not eq?. Odd. | |
262 | (else a)))) | |
263 | (define (union shift a-node b-node) | |
264 | (cond | |
265 | ((not a-node) b-node) | |
266 | ((not b-node) a-node) | |
267 | ((eq? a-node b-node) a-node) | |
268 | ((zero? shift) (meet a-node b-node)) | |
269 | (else (union-branches (- shift *branch-bits*) a-node b-node)))) | |
270 | (match (cons a b) | |
271 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
272 | (cond | |
273 | ((not (= b-shift a-shift)) | |
274 | ;; Hoist the map with the lowest shift to meet the one with the | |
275 | ;; higher shift. | |
276 | (if (< b-shift a-shift) | |
277 | (intmap-union a (add-level b-min b-shift b-root) meet) | |
278 | (intmap-union (add-level a-min a-shift a-root) b meet))) | |
279 | ((not (= b-min a-min)) | |
280 | ;; Nodes at the same shift but different minimums will cover | |
281 | ;; disjoint ranges (due to the round-down call on min). Hoist | |
282 | ;; both until they cover the same range. | |
283 | (intmap-union (add-level a-min a-shift a-root) | |
284 | (add-level b-min b-shift b-root) | |
285 | meet)) | |
286 | (else | |
287 | ;; At this point, A and B cover the same range. | |
288 | (let ((root (union a-shift a-root b-root))) | |
289 | (cond | |
290 | ((eq? root a-root) a) | |
291 | ((eq? root b-root) b) | |
292 | (else (make-intmap a-min a-shift root))))))))) | |
293 | ||
33ab2838 | 294 | (define* (intmap-intersect a b #:optional (meet meet-error)) |
b3523093 AW |
295 | ;; Intersect A and B from index I; the result will be fresh. |
296 | (define (intersect-branches/fresh shift a b i fresh) | |
297 | (let lp ((i 0)) | |
298 | (cond | |
299 | ((< i *branch-size*) | |
300 | (let* ((a-child (vector-ref a i)) | |
301 | (b-child (vector-ref b i))) | |
302 | (vector-set! fresh i (intersect shift a-child b-child)) | |
303 | (lp (1+ i)))) | |
304 | ((branch-empty? fresh) #f) | |
305 | (else fresh)))) | |
306 | ;; Intersect A and B from index I; the result may be eq? to A. | |
307 | (define (intersect-branches/a shift a b i) | |
308 | (let lp ((i i)) | |
309 | (cond | |
310 | ((< i *branch-size*) | |
311 | (let* ((a-child (vector-ref a i)) | |
312 | (b-child (vector-ref b i))) | |
313 | (if (eq? a-child b-child) | |
314 | (lp (1+ i)) | |
315 | (let ((child (intersect shift a-child b-child))) | |
316 | (cond | |
317 | ((eq? a-child child) | |
318 | (lp (1+ i))) | |
319 | (else | |
320 | (let ((result (clone-branch-and-set a i child))) | |
321 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
322 | (else a)))) | |
323 | ;; Intersect A and B; the may could be eq? to either. | |
324 | (define (intersect-branches shift a b) | |
325 | (let lp ((i 0)) | |
326 | (cond | |
327 | ((< i *branch-size*) | |
328 | (let* ((a-child (vector-ref a i)) | |
329 | (b-child (vector-ref b i))) | |
330 | (if (eq? a-child b-child) | |
331 | (lp (1+ i)) | |
332 | (let ((child (intersect shift a-child b-child))) | |
333 | (cond | |
334 | ((eq? a-child child) | |
335 | (intersect-branches/a shift a b (1+ i))) | |
336 | ((eq? b-child child) | |
337 | (intersect-branches/a shift b a (1+ i))) | |
338 | (else | |
339 | (let ((result (clone-branch-and-set a i child))) | |
340 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
341 | ;; Seems they are the same but not eq?. Odd. | |
342 | (else a)))) | |
343 | (define (intersect shift a-node b-node) | |
344 | (cond | |
345 | ((or (not a-node) (not b-node)) #f) | |
346 | ((eq? a-node b-node) a-node) | |
347 | ((zero? shift) (meet a-node b-node)) | |
348 | (else (intersect-branches (- shift *branch-bits*) a-node b-node)))) | |
349 | ||
350 | (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?) | |
351 | (cond | |
352 | ((<= lo-shift hi-shift) | |
353 | ;; If LO has a lower shift and a lower min, it is disjoint. If | |
354 | ;; it has the same shift and a different min, it is also | |
355 | ;; disjoint. | |
356 | empty-intmap) | |
357 | (else | |
358 | (let* ((lo-shift (- lo-shift *branch-bits*)) | |
359 | (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) | |
e21dae43 AW |
360 | (cond |
361 | ((>= lo-idx *branch-size*) | |
362 | ;; HI has a lower shift, but it not within LO. | |
363 | empty-intmap) | |
364 | ((vector-ref lo-root lo-idx) | |
365 | => (lambda (lo-root) | |
366 | (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) | |
367 | lo-shift | |
368 | lo-root))) | |
369 | (if lo-is-a? | |
370 | (intmap-intersect lo hi meet) | |
371 | (intmap-intersect hi lo meet))))) | |
372 | (else empty-intmap)))))) | |
b3523093 AW |
373 | |
374 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) | |
e21dae43 AW |
375 | (cond |
376 | ((vector-ref hi-root 0) | |
377 | => (lambda (hi-root) | |
378 | (let ((hi (make-intmap min | |
379 | (- hi-shift *branch-bits*) | |
380 | hi-root))) | |
381 | (if lo-is-a? | |
382 | (intmap-intersect lo hi meet) | |
383 | (intmap-intersect hi lo meet))))) | |
384 | (else empty-intmap))) | |
b3523093 AW |
385 | |
386 | (match (cons a b) | |
387 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
388 | (cond | |
389 | ((< a-min b-min) | |
390 | (different-mins a-min a-shift a-root b-min b-shift b #t)) | |
391 | ((< b-min a-min) | |
392 | (different-mins b-min b-shift b-root a-min a-shift a #f)) | |
393 | ((< a-shift b-shift) | |
394 | (different-shifts-same-min b-min b-shift b-root a #t)) | |
395 | ((< b-shift a-shift) | |
396 | (different-shifts-same-min a-min a-shift a-root b #f)) | |
397 | (else | |
398 | ;; At this point, A and B cover the same range. | |
399 | (let ((root (intersect a-shift a-root b-root))) | |
400 | (cond | |
401 | ((eq? root a-root) a) | |
402 | ((eq? root b-root) b) | |
403 | (else (make-intmap/prune a-min a-shift root))))))))) |