1 ;;; Functional name maps
2 ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
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.
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.
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/>.
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.
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.
33 (define-module (language cps intmap)
34 #:use-module (srfi srfi-9)
35 #:use-module (ice-9 match)
36 #:export (empty-intmap
47 ;; Persistent sparse intmaps.
49 (define-syntax-rule (define-inline name val)
50 (define-syntax name (identifier-syntax val)))
52 (define-inline *branch-bits* 5)
53 (define-inline *branch-size* (ash 1 *branch-bits*))
54 (define-inline *branch-mask* (1- *branch-size*))
56 (define-record-type <intmap>
57 (make-intmap min shift root)
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)
70 (define (branch-empty? branch)
72 (or (= i *branch-size*)
73 (and (not (vector-ref branch i))
76 (define (round-down min shift)
77 (logand min (lognot (1- (ash 1 shift)))))
79 (define empty-intmap (make-intmap 0 0 #f))
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))
86 (make-intmap min* shift* (clone-branch-and-set #f idx root))))
88 (define (make-intmap/prune min shift root)
90 (make-intmap min shift root)
91 (let lp ((i 0) (elt #f))
94 (if (vector-ref root i)
96 (make-intmap min shift root)
100 (let ((shift (- shift *branch-bits*)))
101 (make-intmap/prune (+ min (ash elt shift))
103 (vector-ref root elt))))
104 ;; Shouldn't be reached...
105 (else empty-intmap)))))
107 (define (meet-error old new)
108 (error "Multiple differing values and no meet procedure defined" old new))
110 (define* (intmap-add bs i val #:optional (meet meet-error))
111 (define (adjoin i shift root)
115 ((eq? root val) root)
117 (else (meet root val))))
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)
125 (clone-branch-and-set root idx new-node))))))
127 (($ <intmap> min shift root)
130 ;; The power-of-two spanning trick doesn't work across 0.
131 (error "Intmaps can only map non-negative integers." i))
132 ((not val) (intmap-remove bs i))
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)
142 (make-intmap min shift root))))
144 ;; Rebuild the tree by unioning two intmaps.
145 (intmap-union (intmap-add empty-intmap i val error) bs error))
147 ;; Add a new level and try again.
148 (intmap-add (add-level min shift root) i val error))))))
150 (define (intmap-remove bs i)
151 (define (remove i shift root)
155 (let* ((shift (- shift *branch-bits*))
156 (idx (logand (ash i (- shift)) *branch-mask*)))
158 ((vector-ref root idx)
160 (let ((new-node (remove i shift node)))
161 (if (eq? node new-node)
163 (let ((root (clone-branch-and-set root idx new-node)))
164 (and (or new-node (not (branch-empty? root)))
168 (($ <intmap> min shift root)
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)
177 (make-intmap/prune min shift root))))
180 (define (intmap-ref bs i)
182 (($ <intmap> min shift root)
185 (and (<= min i) (< i (+ min (ash 1 shift)))
187 (let lp ((node root) (shift shift))
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))
194 (lp (vector-ref node idx) shift)))))))))))
196 (define* (intmap-next bs #:optional i)
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)
207 (visit-branch node (- shift *branch-bits*) i))))
209 (($ <intmap> min shift root)
210 (let ((i (if (and i (< min i))
213 (and (< i (ash 1 shift))
214 (let ((i (visit-node root shift i)))
215 (and i (+ min i))))))))
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*)))
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)
227 (visit-branch node (- shift *branch-bits*) i))))
229 (($ <intmap> min shift root)
230 (let* ((i (if (and i (< i (+ min (ash 1 shift))))
232 (1- (ash 1 shift)))))
234 (let ((i (visit-node root shift i)))
235 (and i (+ min i))))))))
237 (define (intmap-fold f map seed)
238 (define (visit-branch node shift min seed)
239 (let ((shift (- shift *branch-bits*)))
241 (let lp ((i 0) (seed seed))
242 (if (< i *branch-size*)
243 (let ((elt (vector-ref node i)))
246 (f (+ i min) elt seed)
249 (let lp ((i 0) (seed seed))
250 (if (< i *branch-size*)
251 (let ((elt (vector-ref node i)))
254 (visit-branch elt shift (+ min (ash i shift)) seed)
258 (($ <intmap> min shift root)
261 ((zero? shift) (f min root seed))
262 (else (visit-branch root shift min seed))))))
264 (define* (intmap-union a b #:optional (meet meet-error))
265 ;; Union A and B from index I; the result will be fresh.
266 (define (union-branches/fresh shift a b i fresh)
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))
275 ;; Union A and B from index I; the result may be eq? to A.
276 (define (union-branches/a shift a b i)
280 (let* ((a-child (vector-ref a i))
281 (b-child (vector-ref b i)))
282 (if (eq? a-child b-child)
284 (let ((child (union shift a-child b-child)))
289 (let ((result (clone-branch-and-set a i child)))
290 (union-branches/fresh shift a b (1+ i) result))))))))
292 ;; Union A and B; the may could be eq? to either.
293 (define (union-branches shift a b)
297 (let* ((a-child (vector-ref a i))
298 (b-child (vector-ref b i)))
299 (if (eq? a-child b-child)
301 (let ((child (union shift a-child b-child)))
304 (union-branches/a shift a b (1+ i)))
306 (union-branches/a shift b a (1+ i)))
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.
312 (define (union shift a-node b-node)
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))))
320 ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
322 ((not (= b-shift a-shift))
323 ;; Hoist the map with the lowest shift to meet the one with the
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)
336 ;; At this point, A and B cover the same range.
337 (let ((root (union a-shift a-root b-root)))
339 ((eq? root a-root) a)
340 ((eq? root b-root) b)
341 (else (make-intmap a-min a-shift root)))))))))
343 (define* (intmap-intersect a b #:optional (meet meet-error))
344 ;; Intersect A and B from index I; the result will be fresh.
345 (define (intersect-branches/fresh shift a b i fresh)
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))
353 ((branch-empty? fresh) #f)
355 ;; Intersect A and B from index I; the result may be eq? to A.
356 (define (intersect-branches/a shift a b i)
360 (let* ((a-child (vector-ref a i))
361 (b-child (vector-ref b i)))
362 (if (eq? a-child b-child)
364 (let ((child (intersect shift a-child b-child)))
369 (let ((result (clone-branch-and-set a i child)))
370 (intersect-branches/fresh shift a b (1+ i) result))))))))
372 ;; Intersect A and B; the may could be eq? to either.
373 (define (intersect-branches shift a b)
377 (let* ((a-child (vector-ref a i))
378 (b-child (vector-ref b i)))
379 (if (eq? a-child b-child)
381 (let ((child (intersect shift a-child b-child)))
384 (intersect-branches/a shift a b (1+ i)))
386 (intersect-branches/a shift b a (1+ i)))
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.
392 (define (intersect shift a-node b-node)
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))))
399 (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
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
407 (let* ((lo-shift (- lo-shift *branch-bits*))
408 (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
410 ((>= lo-idx *branch-size*)
411 ;; HI has a lower shift, but it not within LO.
413 ((vector-ref lo-root lo-idx)
415 (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
419 (intmap-intersect lo hi meet)
420 (intmap-intersect hi lo meet)))))
421 (else empty-intmap))))))
423 (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
425 ((vector-ref hi-root 0)
427 (let ((hi (make-intmap min
428 (- hi-shift *branch-bits*)
431 (intmap-intersect lo hi meet)
432 (intmap-intersect hi lo meet)))))
433 (else empty-intmap)))
436 ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
439 (different-mins a-min a-shift a-root b-min b-shift b #t))
441 (different-mins b-min b-shift b-root a-min a-shift a #f))
443 (different-shifts-same-min b-min b-shift b-root a #t))
445 (different-shifts-same-min a-min a-shift a-root b #f))
447 ;; At this point, A and B cover the same range.
448 (let ((root (intersect a-shift a-root b-root)))
450 ((eq? root a-root) a)
451 ((eq? root b-root) b)
452 (else (make-intmap/prune a-min a-shift root)))))))))