| 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 (srfi srfi-18) |
| 36 | #:use-module (ice-9 match) |
| 37 | #:export (empty-intmap |
| 38 | intmap? |
| 39 | transient-intmap? |
| 40 | persistent-intmap |
| 41 | transient-intmap |
| 42 | intmap-add |
| 43 | intmap-add! |
| 44 | intmap-remove |
| 45 | intmap-ref |
| 46 | intmap-next |
| 47 | intmap-prev |
| 48 | intmap-fold |
| 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 | |
| 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 | |
| 65 | (define-inline *branch-bits* 5) |
| 66 | (define-inline *branch-size* (ash 1 *branch-bits*)) |
| 67 | (define-inline *branch-size-with-edit* (1+ *branch-size*)) |
| 68 | (define-inline *edit-index* *branch-size*) |
| 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 | |
| 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)) |
| 90 | (define (clone-branch-and-set branch i elt) |
| 91 | (let ((new (new-branch #f))) |
| 92 | (when branch (vector-move-left! branch 0 *branch-size* new 0)) |
| 93 | (vector-set! new i elt) |
| 94 | new)) |
| 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)))) |
| 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 | |
| 109 | (define-inlinable (round-down min shift) |
| 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 | |
| 140 | (define (meet-error old new) |
| 141 | (error "Multiple differing values and no meet procedure defined" old new)) |
| 142 | |
| 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 | |
| 229 | (define* (intmap-add bs i val #:optional (meet meet-error)) |
| 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 |
| 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)) |
| 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. |
| 267 | (intmap-add (add-level min shift root) i val error)))) |
| 268 | (($ <transient-intmap>) |
| 269 | (intmap-add (persistent-intmap bs) i val meet)))) |
| 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)))) |
| 299 | (else bs))) |
| 300 | (($ <transient-intmap>) |
| 301 | (intmap-remove (persistent-intmap bs) i)))) |
| 302 | |
| 303 | (define (intmap-ref bs i) |
| 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))))))))) |
| 317 | (match bs |
| 318 | (($ <intmap> min shift root) |
| 319 | (ref min shift root)) |
| 320 | (($ <transient-intmap> min shift root edit) |
| 321 | (assert-readable! edit) |
| 322 | (ref min shift root)))) |
| 323 | |
| 324 | (define* (intmap-next bs #:optional i) |
| 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)))) |
| 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)))))) |
| 343 | (match bs |
| 344 | (($ <intmap> min shift root) |
| 345 | (next min shift root)) |
| 346 | (($ <transient-intmap> min shift root edit) |
| 347 | (assert-readable! edit) |
| 348 | (next min shift root)))) |
| 349 | |
| 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)))) |
| 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)))))) |
| 368 | (match bs |
| 369 | (($ <intmap> min shift root) |
| 370 | (prev min shift root)) |
| 371 | (($ <transient-intmap> min shift root edit) |
| 372 | (assert-readable! edit) |
| 373 | (prev min shift root)))) |
| 374 | |
| 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)) |
| 400 | (else (visit-branch root shift min seed)))) |
| 401 | (($ <transient-intmap>) |
| 402 | (intmap-fold f (persistent-intmap map) seed)))) |
| 403 | |
| 404 | (define* (intmap-union a b #:optional (meet meet-error)) |
| 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 | |
| 483 | (define* (intmap-intersect a b #:optional (meet meet-error)) |
| 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)))) |
| 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)))))) |
| 562 | |
| 563 | (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?) |
| 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))) |
| 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))))))))) |