| 1 | ;;; Functional name maps |
| 2 | ;;; Copyright (C) 2014, 2015 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 (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)) |
| 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 |
| 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)) |
| 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) |
| 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))))))))))) |
| 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 | |
| 215 | (define* (intmap-union a b #:optional (meet meet-error)) |
| 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 | |
| 294 | (define* (intmap-intersect a b #:optional (meet meet-error)) |
| 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)))) |
| 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)))))) |
| 373 | |
| 374 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) |
| 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))) |
| 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))))))))) |