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) | |
95db5705 | 35 | #:use-module (srfi srfi-18) |
b3523093 AW |
36 | #:use-module (ice-9 match) |
37 | #:export (empty-intmap | |
38 | intmap? | |
95db5705 AW |
39 | transient-intmap? |
40 | persistent-intmap | |
41 | transient-intmap | |
b3523093 | 42 | intmap-add |
95db5705 | 43 | intmap-add! |
b3523093 AW |
44 | intmap-remove |
45 | intmap-ref | |
46 | intmap-next | |
2a24395a | 47 | intmap-prev |
b7668bd9 | 48 | intmap-fold |
b3523093 AW |
49 | intmap-union |
50 | intmap-intersect)) | |
51 | ||
52 | ;; Persistent sparse intmaps. | |
53 | ||
54 | (define-syntax-rule (define-inline name val) | |
55 | (define-syntax name (identifier-syntax val))) | |
56 | ||
95db5705 AW |
57 | ;; FIXME: This should make an actual atomic reference. |
58 | (define-inlinable (make-atomic-reference value) | |
59 | (list value)) | |
60 | (define-inlinable (get-atomic-reference reference) | |
61 | (car reference)) | |
62 | (define-inlinable (set-atomic-reference! reference value) | |
63 | (set-car! reference value)) | |
64 | ||
cf512e32 | 65 | (define-inline *branch-bits* 5) |
b3523093 | 66 | (define-inline *branch-size* (ash 1 *branch-bits*)) |
95db5705 AW |
67 | (define-inline *branch-size-with-edit* (1+ *branch-size*)) |
68 | (define-inline *edit-index* *branch-size*) | |
b3523093 AW |
69 | (define-inline *branch-mask* (1- *branch-size*)) |
70 | ||
71 | (define-record-type <intmap> | |
72 | (make-intmap min shift root) | |
73 | intmap? | |
74 | (min intmap-min) | |
75 | (shift intmap-shift) | |
76 | (root intmap-root)) | |
77 | ||
95db5705 AW |
78 | (define-record-type <transient-intmap> |
79 | (make-transient-intmap min shift root edit) | |
80 | transient-intmap? | |
81 | (min transient-intmap-min set-transient-intmap-min!) | |
82 | (shift transient-intmap-shift set-transient-intmap-shift!) | |
83 | (root transient-intmap-root set-transient-intmap-root!) | |
84 | (edit transient-intmap-edit set-transient-intmap-edit!)) | |
85 | ||
86 | (define-inlinable (new-branch edit) | |
87 | (let ((vec (make-vector *branch-size-with-edit* #f))) | |
88 | (when edit (vector-set! vec *edit-index* edit)) | |
89 | vec)) | |
b3523093 | 90 | (define (clone-branch-and-set branch i elt) |
95db5705 | 91 | (let ((new (new-branch #f))) |
b3523093 AW |
92 | (when branch (vector-move-left! branch 0 *branch-size* new 0)) |
93 | (vector-set! new i elt) | |
94 | new)) | |
95db5705 AW |
95 | (define-inlinable (assert-readable! root-edit) |
96 | (unless (eq? (get-atomic-reference root-edit) (current-thread)) | |
97 | (error "Transient intmap owned by another thread" root-edit))) | |
98 | (define-inlinable (writable-branch branch root-edit) | |
99 | (let ((edit (vector-ref branch *edit-index*))) | |
100 | (if (eq? root-edit edit) | |
101 | branch | |
102 | (clone-branch-and-set branch *edit-index* root-edit)))) | |
b3523093 AW |
103 | (define (branch-empty? branch) |
104 | (let lp ((i 0)) | |
105 | (or (= i *branch-size*) | |
106 | (and (not (vector-ref branch i)) | |
107 | (lp (1+ i)))))) | |
108 | ||
95db5705 | 109 | (define-inlinable (round-down min shift) |
b3523093 AW |
110 | (logand min (lognot (1- (ash 1 shift))))) |
111 | ||
112 | (define empty-intmap (make-intmap 0 0 #f)) | |
113 | ||
114 | (define (add-level min shift root) | |
115 | (let* ((shift* (+ shift *branch-bits*)) | |
116 | (min* (round-down min shift*)) | |
117 | (idx (logand (ash (- min min*) (- shift)) | |
118 | *branch-mask*))) | |
119 | (make-intmap min* shift* (clone-branch-and-set #f idx root)))) | |
120 | ||
121 | (define (make-intmap/prune min shift root) | |
122 | (if (zero? shift) | |
123 | (make-intmap min shift root) | |
124 | (let lp ((i 0) (elt #f)) | |
125 | (cond | |
126 | ((< i *branch-size*) | |
127 | (if (vector-ref root i) | |
128 | (if elt | |
129 | (make-intmap min shift root) | |
130 | (lp (1+ i) i)) | |
131 | (lp (1+ i) elt))) | |
132 | (elt | |
133 | (let ((shift (- shift *branch-bits*))) | |
134 | (make-intmap/prune (+ min (ash elt shift)) | |
135 | shift | |
136 | (vector-ref root elt)))) | |
137 | ;; Shouldn't be reached... | |
138 | (else empty-intmap))))) | |
139 | ||
33ab2838 AW |
140 | (define (meet-error old new) |
141 | (error "Multiple differing values and no meet procedure defined" old new)) | |
142 | ||
95db5705 AW |
143 | (define* (transient-intmap #:optional (source empty-intmap)) |
144 | (match source | |
145 | (($ <transient-intmap> min shift root edit) | |
146 | (assert-readable! edit) | |
147 | source) | |
148 | (($ <intmap> min shift root) | |
149 | (let ((edit (make-atomic-reference (current-thread)))) | |
150 | (make-transient-intmap min shift root edit))))) | |
151 | ||
152 | (define* (persistent-intmap #:optional (source empty-intmap)) | |
153 | (match source | |
154 | (($ <transient-intmap> min shift root edit) | |
155 | (assert-readable! edit) | |
156 | ;; Make a fresh reference, causing any further operations on this | |
157 | ;; transient to clone its root afresh. | |
158 | (set-transient-intmap-edit! source | |
159 | (make-atomic-reference (current-thread))) | |
160 | ;; Clear the reference to the current thread, causing our edited | |
161 | ;; data structures to be persistent again. | |
162 | (set-atomic-reference! edit #f) | |
163 | (if min | |
164 | (make-intmap min shift root) | |
165 | empty-intmap)) | |
166 | (($ <intmap>) | |
167 | source))) | |
168 | ||
169 | (define* (intmap-add! map i val #:optional (meet meet-error)) | |
170 | (define (ensure-branch! root idx) | |
171 | (let ((edit (vector-ref root *edit-index*))) | |
172 | (match (vector-ref root idx) | |
173 | (#f (let ((v (new-branch edit))) | |
174 | (vector-set! root idx v) | |
175 | v)) | |
176 | (v (writable-branch v edit))))) | |
177 | (define (adjoin! i shift root) | |
178 | (let* ((shift (- shift *branch-bits*)) | |
179 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
180 | (cond | |
181 | ((zero? shift) | |
182 | (let ((node (vector-ref root idx))) | |
183 | (unless (eq? node val) | |
184 | (vector-set! root idx (if node (meet node val) val))))) | |
185 | (else | |
186 | (adjoin! i shift (ensure-branch! root idx)))))) | |
187 | (match map | |
188 | (($ <transient-intmap> min shift root edit) | |
189 | (assert-readable! edit) | |
190 | (cond | |
191 | ((< i 0) | |
192 | ;; The power-of-two spanning trick doesn't work across 0. | |
193 | (error "Intmaps can only map non-negative integers." i)) | |
194 | ((not root) | |
195 | (set-transient-intmap-min! map i) | |
196 | (set-transient-intmap-shift! map 0) | |
197 | (set-transient-intmap-root! map val)) | |
198 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
199 | ;; Add element to map; level will not change. | |
200 | (if (zero? shift) | |
201 | (unless (eq? root val) | |
202 | (set-transient-intmap-root! map (meet root val))) | |
203 | (let ((root* (writable-branch root edit))) | |
204 | (unless (eq? root root*) | |
205 | (set-transient-intmap-root! map root*)) | |
206 | (adjoin! (- i min) shift root*)))) | |
207 | (else | |
208 | (let lp ((min min) | |
209 | (shift shift) | |
210 | (root root)) | |
211 | (let* ((shift* (+ shift *branch-bits*)) | |
212 | (min* (round-down min shift*)) | |
213 | (idx (logand (ash (- min min*) (- shift)) | |
214 | *branch-mask*)) | |
215 | (root* (new-branch edit))) | |
216 | (vector-set! root* idx root) | |
217 | (cond | |
218 | ((and (<= min* i) (< i (+ min* (ash 1 shift*)))) | |
219 | (set-transient-intmap-min! map min*) | |
220 | (set-transient-intmap-shift! map shift*) | |
221 | (set-transient-intmap-root! map root*) | |
222 | (adjoin! (- i min*) shift* root*)) | |
223 | (else | |
224 | (lp min* shift* root*))))))) | |
225 | map) | |
226 | (($ <intmap>) | |
227 | (intmap-add! (transient-intmap map) i val meet)))) | |
228 | ||
33ab2838 | 229 | (define* (intmap-add bs i val #:optional (meet meet-error)) |
b3523093 AW |
230 | (define (adjoin i shift root) |
231 | (cond | |
232 | ((zero? shift) | |
233 | (cond | |
234 | ((eq? root val) root) | |
235 | ((not root) val) | |
236 | (else (meet root val)))) | |
237 | (else | |
238 | (let* ((shift (- shift *branch-bits*)) | |
239 | (idx (logand (ash i (- shift)) *branch-mask*)) | |
240 | (node (and root (vector-ref root idx))) | |
241 | (new-node (adjoin i shift node))) | |
242 | (if (eq? node new-node) | |
243 | root | |
244 | (clone-branch-and-set root idx new-node)))))) | |
245 | (match bs | |
246 | (($ <intmap> min shift root) | |
247 | (cond | |
4296c36e AW |
248 | ((< i 0) |
249 | ;; The power-of-two spanning trick doesn't work across 0. | |
250 | (error "Intmaps can only map non-negative integers." i)) | |
b3523093 AW |
251 | ((not val) (intmap-remove bs i)) |
252 | ((not root) | |
253 | ;; Add first element. | |
254 | (make-intmap i 0 val)) | |
255 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
256 | ;; Add element to map; level will not change. | |
257 | (let ((old-root root) | |
258 | (root (adjoin (- i min) shift root))) | |
259 | (if (eq? root old-root) | |
260 | bs | |
261 | (make-intmap min shift root)))) | |
262 | ((< i min) | |
263 | ;; Rebuild the tree by unioning two intmaps. | |
264 | (intmap-union (intmap-add empty-intmap i val error) bs error)) | |
265 | (else | |
266 | ;; Add a new level and try again. | |
95db5705 AW |
267 | (intmap-add (add-level min shift root) i val error)))) |
268 | (($ <transient-intmap>) | |
269 | (intmap-add (persistent-intmap bs) i val meet)))) | |
b3523093 AW |
270 | |
271 | (define (intmap-remove bs i) | |
272 | (define (remove i shift root) | |
273 | (cond | |
274 | ((zero? shift) #f) | |
275 | (else | |
276 | (let* ((shift (- shift *branch-bits*)) | |
277 | (idx (logand (ash i (- shift)) *branch-mask*))) | |
278 | (cond | |
279 | ((vector-ref root idx) | |
280 | => (lambda (node) | |
281 | (let ((new-node (remove i shift node))) | |
282 | (if (eq? node new-node) | |
283 | root | |
284 | (let ((root (clone-branch-and-set root idx new-node))) | |
285 | (and (or new-node (not (branch-empty? root))) | |
286 | root)))))) | |
287 | (else root)))))) | |
288 | (match bs | |
289 | (($ <intmap> min shift root) | |
290 | (cond | |
291 | ((not root) bs) | |
292 | ((and (<= min i) (< i (+ min (ash 1 shift)))) | |
293 | ;; Add element to map; level will not change. | |
294 | (let ((old-root root) | |
295 | (root (remove (- i min) shift root))) | |
296 | (if (eq? root old-root) | |
297 | bs | |
298 | (make-intmap/prune min shift root)))) | |
95db5705 AW |
299 | (else bs))) |
300 | (($ <transient-intmap>) | |
301 | (intmap-remove (persistent-intmap bs) i)))) | |
b3523093 AW |
302 | |
303 | (define (intmap-ref bs i) | |
95db5705 AW |
304 | (define (ref min shift root) |
305 | (if (zero? shift) | |
306 | (and (= i min) root) | |
307 | (and (<= min i) (< i (+ min (ash 1 shift))) | |
308 | (let ((i (- i min))) | |
309 | (let lp ((node root) (shift shift)) | |
310 | (and node | |
311 | (if (= shift *branch-bits*) | |
312 | (vector-ref node (logand i *branch-mask*)) | |
313 | (let* ((shift (- shift *branch-bits*)) | |
314 | (idx (logand (ash i (- shift)) | |
315 | *branch-mask*))) | |
316 | (lp (vector-ref node idx) shift))))))))) | |
b3523093 AW |
317 | (match bs |
318 | (($ <intmap> min shift root) | |
95db5705 AW |
319 | (ref min shift root)) |
320 | (($ <transient-intmap> min shift root edit) | |
321 | (assert-readable! edit) | |
322 | (ref min shift root)))) | |
b3523093 | 323 | |
2a24395a | 324 | (define* (intmap-next bs #:optional i) |
b3523093 AW |
325 | (define (visit-branch node shift i) |
326 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
327 | (and (< idx *branch-size*) | |
328 | (or (visit-node (vector-ref node idx) shift i) | |
329 | (let ((inc (ash 1 shift))) | |
330 | (lp (+ (round-down i shift) inc) (1+ idx))))))) | |
331 | (define (visit-node node shift i) | |
332 | (and node | |
333 | (if (zero? shift) | |
334 | i | |
335 | (visit-branch node (- shift *branch-bits*) i)))) | |
95db5705 AW |
336 | (define (next min shift root) |
337 | (let ((i (if (and i (< min i)) | |
338 | (- i min) | |
339 | 0))) | |
340 | (and (< i (ash 1 shift)) | |
341 | (let ((i (visit-node root shift i))) | |
342 | (and i (+ min i)))))) | |
b3523093 AW |
343 | (match bs |
344 | (($ <intmap> min shift root) | |
95db5705 AW |
345 | (next min shift root)) |
346 | (($ <transient-intmap> min shift root edit) | |
347 | (assert-readable! edit) | |
348 | (next min shift root)))) | |
b3523093 | 349 | |
2a24395a AW |
350 | (define* (intmap-prev bs #:optional i) |
351 | (define (visit-branch node shift i) | |
352 | (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*))) | |
353 | (and (<= 0 idx) | |
354 | (or (visit-node (vector-ref node idx) shift i) | |
355 | (lp (1- (round-down i shift)) (1- idx)))))) | |
356 | (define (visit-node node shift i) | |
357 | (and node | |
358 | (if (zero? shift) | |
359 | i | |
360 | (visit-branch node (- shift *branch-bits*) i)))) | |
95db5705 AW |
361 | (define (prev min shift root) |
362 | (let* ((i (if (and i (< i (+ min (ash 1 shift)))) | |
363 | (- i min) | |
364 | (1- (ash 1 shift))))) | |
365 | (and (<= 0 i) | |
366 | (let ((i (visit-node root shift i))) | |
367 | (and i (+ min i)))))) | |
2a24395a AW |
368 | (match bs |
369 | (($ <intmap> min shift root) | |
95db5705 AW |
370 | (prev min shift root)) |
371 | (($ <transient-intmap> min shift root edit) | |
372 | (assert-readable! edit) | |
373 | (prev min shift root)))) | |
2a24395a | 374 | |
b7668bd9 AW |
375 | (define (intmap-fold f map seed) |
376 | (define (visit-branch node shift min seed) | |
377 | (let ((shift (- shift *branch-bits*))) | |
378 | (if (zero? shift) | |
379 | (let lp ((i 0) (seed seed)) | |
380 | (if (< i *branch-size*) | |
381 | (let ((elt (vector-ref node i))) | |
382 | (lp (1+ i) | |
383 | (if elt | |
384 | (f (+ i min) elt seed) | |
385 | seed))) | |
386 | seed)) | |
387 | (let lp ((i 0) (seed seed)) | |
388 | (if (< i *branch-size*) | |
389 | (let ((elt (vector-ref node i))) | |
390 | (lp (1+ i) | |
391 | (if elt | |
392 | (visit-branch elt shift (+ min (ash i shift)) seed) | |
393 | seed))) | |
394 | seed))))) | |
395 | (match map | |
396 | (($ <intmap> min shift root) | |
397 | (cond | |
398 | ((not root) seed) | |
399 | ((zero? shift) (f min root seed)) | |
95db5705 AW |
400 | (else (visit-branch root shift min seed)))) |
401 | (($ <transient-intmap>) | |
402 | (intmap-fold f (persistent-intmap map) seed)))) | |
b7668bd9 | 403 | |
33ab2838 | 404 | (define* (intmap-union a b #:optional (meet meet-error)) |
b3523093 AW |
405 | ;; Union A and B from index I; the result will be fresh. |
406 | (define (union-branches/fresh shift a b i fresh) | |
407 | (let lp ((i 0)) | |
408 | (cond | |
409 | ((< i *branch-size*) | |
410 | (let* ((a-child (vector-ref a i)) | |
411 | (b-child (vector-ref b i))) | |
412 | (vector-set! fresh i (union shift a-child b-child)) | |
413 | (lp (1+ i)))) | |
414 | (else fresh)))) | |
415 | ;; Union A and B from index I; the result may be eq? to A. | |
416 | (define (union-branches/a shift a b i) | |
417 | (let lp ((i i)) | |
418 | (cond | |
419 | ((< i *branch-size*) | |
420 | (let* ((a-child (vector-ref a i)) | |
421 | (b-child (vector-ref b i))) | |
422 | (if (eq? a-child b-child) | |
423 | (lp (1+ i)) | |
424 | (let ((child (union shift a-child b-child))) | |
425 | (cond | |
426 | ((eq? a-child child) | |
427 | (lp (1+ i))) | |
428 | (else | |
429 | (let ((result (clone-branch-and-set a i child))) | |
430 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
431 | (else a)))) | |
432 | ;; Union A and B; the may could be eq? to either. | |
433 | (define (union-branches shift a b) | |
434 | (let lp ((i 0)) | |
435 | (cond | |
436 | ((< i *branch-size*) | |
437 | (let* ((a-child (vector-ref a i)) | |
438 | (b-child (vector-ref b i))) | |
439 | (if (eq? a-child b-child) | |
440 | (lp (1+ i)) | |
441 | (let ((child (union shift a-child b-child))) | |
442 | (cond | |
443 | ((eq? a-child child) | |
444 | (union-branches/a shift a b (1+ i))) | |
445 | ((eq? b-child child) | |
446 | (union-branches/a shift b a (1+ i))) | |
447 | (else | |
448 | (let ((result (clone-branch-and-set a i child))) | |
449 | (union-branches/fresh shift a b (1+ i) result)))))))) | |
450 | ;; Seems they are the same but not eq?. Odd. | |
451 | (else a)))) | |
452 | (define (union shift a-node b-node) | |
453 | (cond | |
454 | ((not a-node) b-node) | |
455 | ((not b-node) a-node) | |
456 | ((eq? a-node b-node) a-node) | |
457 | ((zero? shift) (meet a-node b-node)) | |
458 | (else (union-branches (- shift *branch-bits*) a-node b-node)))) | |
459 | (match (cons a b) | |
460 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
461 | (cond | |
462 | ((not (= b-shift a-shift)) | |
463 | ;; Hoist the map with the lowest shift to meet the one with the | |
464 | ;; higher shift. | |
465 | (if (< b-shift a-shift) | |
466 | (intmap-union a (add-level b-min b-shift b-root) meet) | |
467 | (intmap-union (add-level a-min a-shift a-root) b meet))) | |
468 | ((not (= b-min a-min)) | |
469 | ;; Nodes at the same shift but different minimums will cover | |
470 | ;; disjoint ranges (due to the round-down call on min). Hoist | |
471 | ;; both until they cover the same range. | |
472 | (intmap-union (add-level a-min a-shift a-root) | |
473 | (add-level b-min b-shift b-root) | |
474 | meet)) | |
475 | (else | |
476 | ;; At this point, A and B cover the same range. | |
477 | (let ((root (union a-shift a-root b-root))) | |
478 | (cond | |
479 | ((eq? root a-root) a) | |
480 | ((eq? root b-root) b) | |
481 | (else (make-intmap a-min a-shift root))))))))) | |
482 | ||
33ab2838 | 483 | (define* (intmap-intersect a b #:optional (meet meet-error)) |
b3523093 AW |
484 | ;; Intersect A and B from index I; the result will be fresh. |
485 | (define (intersect-branches/fresh shift a b i fresh) | |
486 | (let lp ((i 0)) | |
487 | (cond | |
488 | ((< i *branch-size*) | |
489 | (let* ((a-child (vector-ref a i)) | |
490 | (b-child (vector-ref b i))) | |
491 | (vector-set! fresh i (intersect shift a-child b-child)) | |
492 | (lp (1+ i)))) | |
493 | ((branch-empty? fresh) #f) | |
494 | (else fresh)))) | |
495 | ;; Intersect A and B from index I; the result may be eq? to A. | |
496 | (define (intersect-branches/a shift a b i) | |
497 | (let lp ((i i)) | |
498 | (cond | |
499 | ((< i *branch-size*) | |
500 | (let* ((a-child (vector-ref a i)) | |
501 | (b-child (vector-ref b i))) | |
502 | (if (eq? a-child b-child) | |
503 | (lp (1+ i)) | |
504 | (let ((child (intersect shift a-child b-child))) | |
505 | (cond | |
506 | ((eq? a-child child) | |
507 | (lp (1+ i))) | |
508 | (else | |
509 | (let ((result (clone-branch-and-set a i child))) | |
510 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
511 | (else a)))) | |
512 | ;; Intersect A and B; the may could be eq? to either. | |
513 | (define (intersect-branches shift a b) | |
514 | (let lp ((i 0)) | |
515 | (cond | |
516 | ((< i *branch-size*) | |
517 | (let* ((a-child (vector-ref a i)) | |
518 | (b-child (vector-ref b i))) | |
519 | (if (eq? a-child b-child) | |
520 | (lp (1+ i)) | |
521 | (let ((child (intersect shift a-child b-child))) | |
522 | (cond | |
523 | ((eq? a-child child) | |
524 | (intersect-branches/a shift a b (1+ i))) | |
525 | ((eq? b-child child) | |
526 | (intersect-branches/a shift b a (1+ i))) | |
527 | (else | |
528 | (let ((result (clone-branch-and-set a i child))) | |
529 | (intersect-branches/fresh shift a b (1+ i) result)))))))) | |
530 | ;; Seems they are the same but not eq?. Odd. | |
531 | (else a)))) | |
532 | (define (intersect shift a-node b-node) | |
533 | (cond | |
534 | ((or (not a-node) (not b-node)) #f) | |
535 | ((eq? a-node b-node) a-node) | |
536 | ((zero? shift) (meet a-node b-node)) | |
537 | (else (intersect-branches (- shift *branch-bits*) a-node b-node)))) | |
538 | ||
539 | (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?) | |
540 | (cond | |
541 | ((<= lo-shift hi-shift) | |
542 | ;; If LO has a lower shift and a lower min, it is disjoint. If | |
543 | ;; it has the same shift and a different min, it is also | |
544 | ;; disjoint. | |
545 | empty-intmap) | |
546 | (else | |
547 | (let* ((lo-shift (- lo-shift *branch-bits*)) | |
548 | (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) | |
e21dae43 AW |
549 | (cond |
550 | ((>= lo-idx *branch-size*) | |
551 | ;; HI has a lower shift, but it not within LO. | |
552 | empty-intmap) | |
553 | ((vector-ref lo-root lo-idx) | |
554 | => (lambda (lo-root) | |
555 | (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift)) | |
556 | lo-shift | |
557 | lo-root))) | |
558 | (if lo-is-a? | |
559 | (intmap-intersect lo hi meet) | |
560 | (intmap-intersect hi lo meet))))) | |
561 | (else empty-intmap)))))) | |
b3523093 AW |
562 | |
563 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) | |
e21dae43 AW |
564 | (cond |
565 | ((vector-ref hi-root 0) | |
566 | => (lambda (hi-root) | |
567 | (let ((hi (make-intmap min | |
568 | (- hi-shift *branch-bits*) | |
569 | hi-root))) | |
570 | (if lo-is-a? | |
571 | (intmap-intersect lo hi meet) | |
572 | (intmap-intersect hi lo meet))))) | |
573 | (else empty-intmap))) | |
b3523093 AW |
574 | |
575 | (match (cons a b) | |
576 | ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root)) | |
577 | (cond | |
578 | ((< a-min b-min) | |
579 | (different-mins a-min a-shift a-root b-min b-shift b #t)) | |
580 | ((< b-min a-min) | |
581 | (different-mins b-min b-shift b-root a-min a-shift a #f)) | |
582 | ((< a-shift b-shift) | |
583 | (different-shifts-same-min b-min b-shift b-root a #t)) | |
584 | ((< b-shift a-shift) | |
585 | (different-shifts-same-min a-min a-shift a-root b #f)) | |
586 | (else | |
587 | ;; At this point, A and B cover the same range. | |
588 | (let ((root (intersect a-shift a-root b-root))) | |
589 | (cond | |
590 | ((eq? root a-root) a) | |
591 | ((eq? root b-root) b) | |
592 | (else (make-intmap/prune a-min a-shift root))))))))) |