summaryrefslogtreecommitdiff
path: root/module/language/cps/intmap.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/cps/intmap.scm')
-rw-r--r--module/language/cps/intmap.scm767
1 files changed, 767 insertions, 0 deletions
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm
new file mode 100644
index 000000000..8995d6211
--- /dev/null
+++ b/module/language/cps/intmap.scm
@@ -0,0 +1,767 @@
+;;; Functional name maps
+;;; Copyright (C) 2014, 2015, 2017 Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; Some CPS passes need to perform a flow analysis in which every
+;;; program point has an associated map over some set of labels or
+;;; variables. The naive way to implement this is with an array of
+;;; arrays, but this has N^2 complexity, and it really can hurt us.
+;;;
+;;; Instead, this module provides a functional map that can share space
+;;; between program points, reducing the amortized space complexity of
+;;; the representations down to O(n log n). Adding entries to the
+;;; mapping and lookup are O(log n). Intersection and union between
+;;; intmaps that share state are fast, too.
+;;;
+;;; Code:
+
+(define-module (language cps intmap)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 match)
+ #:use-module ((ice-9 threads) #:select (current-thread))
+ #:export (empty-intmap
+ intmap?
+ transient-intmap?
+ persistent-intmap
+ transient-intmap
+ intmap-add
+ intmap-add!
+ intmap-replace
+ intmap-replace!
+ intmap-remove
+ intmap-ref
+ intmap-next
+ intmap-prev
+ intmap-fold
+ intmap-fold-right
+ intmap-union
+ intmap-intersect))
+
+;; Persistent sparse intmaps.
+
+(define-syntax-rule (define-inline name val)
+ (define-syntax name (identifier-syntax val)))
+
+;; FIXME: This should make an actual atomic reference.
+(define-inlinable (make-atomic-reference value)
+ (list value))
+(define-inlinable (get-atomic-reference reference)
+ (car reference))
+(define-inlinable (set-atomic-reference! reference value)
+ (set-car! reference value))
+
+(define-inline *branch-bits* 5)
+(define-inline *branch-size* (ash 1 *branch-bits*))
+(define-inline *branch-size-with-edit* (1+ *branch-size*))
+(define-inline *edit-index* *branch-size*)
+(define-inline *branch-mask* (1- *branch-size*))
+
+(define-record-type <intmap>
+ (make-intmap min shift root)
+ intmap?
+ (min intmap-min)
+ (shift intmap-shift)
+ (root intmap-root))
+
+(define-record-type <transient-intmap>
+ (make-transient-intmap min shift root edit)
+ transient-intmap?
+ (min transient-intmap-min set-transient-intmap-min!)
+ (shift transient-intmap-shift set-transient-intmap-shift!)
+ (root transient-intmap-root set-transient-intmap-root!)
+ (edit transient-intmap-edit set-transient-intmap-edit!))
+
+(define *absent* (list 'absent))
+(define-inlinable (absent? x)
+ (eq? x *absent*))
+(define-inlinable (present? x)
+ (not (absent? x)))
+
+(define-inlinable (new-branch edit)
+ (let ((vec (make-vector *branch-size-with-edit* *absent*)))
+ (vector-set! vec *edit-index* edit)
+ vec))
+(define-inlinable (clone-branch-with-edit branch edit)
+ (let ((new (vector-copy branch)))
+ (vector-set! new *edit-index* edit)
+ new))
+(define (clone-branch-and-set branch i elt)
+ (let ((new (clone-branch-with-edit branch #f)))
+ (vector-set! new i elt)
+ new))
+(define-inlinable (assert-readable! root-edit)
+ (unless (eq? (get-atomic-reference root-edit) (current-thread))
+ (error "Transient intmap owned by another thread" root-edit)))
+(define-inlinable (writable-branch branch root-edit)
+ (let ((edit (vector-ref branch *edit-index*)))
+ (if (eq? root-edit edit)
+ branch
+ (clone-branch-with-edit branch root-edit))))
+(define (branch-empty? branch)
+ (let lp ((i 0))
+ (or (= i *branch-size*)
+ (and (absent? (vector-ref branch i))
+ (lp (1+ i))))))
+
+(define-inlinable (round-down min shift)
+ (logand min (lognot (1- (ash 1 shift)))))
+
+(define empty-intmap (make-intmap 0 0 *absent*))
+
+(define (add-level min shift root)
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift))
+ *branch-mask*))
+ (root* (new-branch #f)))
+ (vector-set! root* idx root)
+ (make-intmap min* shift* root*)))
+
+(define (make-intmap/prune min shift root)
+ (if (zero? shift)
+ (make-intmap min shift root)
+ (let lp ((i 0) (elt #f))
+ (cond
+ ((< i *branch-size*)
+ (if (present? (vector-ref root i))
+ (if elt
+ (make-intmap min shift root)
+ (lp (1+ i) i))
+ (lp (1+ i) elt)))
+ (elt
+ (let ((shift (- shift *branch-bits*)))
+ (make-intmap/prune (+ min (ash elt shift))
+ shift
+ (vector-ref root elt))))
+ ;; Shouldn't be reached...
+ (else empty-intmap)))))
+
+(define (meet-error old new)
+ (error "Multiple differing values and no meet procedure defined" old new))
+
+(define* (transient-intmap #:optional (source empty-intmap))
+ (match source
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ source)
+ (($ <intmap> min shift root)
+ (let ((edit (make-atomic-reference (current-thread))))
+ (make-transient-intmap min shift root edit)))))
+
+(define* (persistent-intmap #:optional (source empty-intmap))
+ (match source
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ ;; Make a fresh reference, causing any further operations on this
+ ;; transient to clone its root afresh.
+ (set-transient-intmap-edit! source
+ (make-atomic-reference (current-thread)))
+ ;; Clear the reference to the current thread, causing our edited
+ ;; data structures to be persistent again.
+ (set-atomic-reference! edit #f)
+ (if min
+ (make-intmap min shift root)
+ empty-intmap))
+ (($ <intmap>)
+ source)))
+
+(define* (intmap-add! map i val #:optional (meet meet-error))
+ (define (ensure-branch! root idx)
+ (let ((edit (vector-ref root *edit-index*))
+ (v (vector-ref root idx)))
+ (if (absent? v)
+ (let ((v (new-branch edit)))
+ (vector-set! root idx v)
+ v)
+ (let ((v* (writable-branch v edit)))
+ (unless (eq? v v*)
+ (vector-set! root idx v*))
+ v*))))
+ (define (adjoin! i shift root)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (if (zero? shift)
+ (let ((node (vector-ref root idx)))
+ (unless (eq? node val)
+ (vector-set! root idx (if (present? node) (meet node val) val))))
+ (adjoin! i shift (ensure-branch! root idx)))))
+ (match map
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((absent? root)
+ (set-transient-intmap-min! map i)
+ (set-transient-intmap-shift! map 0)
+ (set-transient-intmap-root! map val))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (if (zero? shift)
+ (unless (eq? root val)
+ (set-transient-intmap-root! map (meet root val)))
+ (let ((root* (writable-branch root edit)))
+ (unless (eq? root root*)
+ (set-transient-intmap-root! map root*))
+ (adjoin! (- i min) shift root*))))
+ (else
+ (let lp ((min min)
+ (shift shift)
+ (root root))
+ (let* ((shift* (+ shift *branch-bits*))
+ (min* (round-down min shift*))
+ (idx (logand (ash (- min min*) (- shift))
+ *branch-mask*))
+ (root* (new-branch edit)))
+ (vector-set! root* idx root)
+ (cond
+ ((and (<= min* i) (< i (+ min* (ash 1 shift*))))
+ (set-transient-intmap-min! map min*)
+ (set-transient-intmap-shift! map shift*)
+ (set-transient-intmap-root! map root*)
+ (adjoin! (- i min*) shift* root*))
+ (else
+ (lp min* shift* root*)))))))
+ map)
+ (($ <intmap>)
+ (intmap-add! (transient-intmap map) i val meet))))
+
+(define* (intmap-add map i val #:optional (meet meet-error))
+ (define (adjoin i shift root)
+ (if (zero? shift)
+ (cond
+ ((eq? root val) root)
+ ((absent? root) val)
+ (else (meet root val)))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (if (absent? root)
+ (let ((root* (new-branch #f))
+ (node* (adjoin i shift root)))
+ (vector-set! root* idx node*)
+ root*)
+ (let* ((node (vector-ref root idx))
+ (node* (adjoin i shift node)))
+ (if (eq? node node*)
+ root
+ (clone-branch-and-set root idx node*)))))))
+ (match map
+ (($ <intmap> min shift root)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((absent? root)
+ ;; Add first element.
+ (make-intmap i 0 val))
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ map
+ (make-intmap min shift root))))
+ ((< i min)
+ ;; Rebuild the tree by unioning two intmaps.
+ (intmap-union (intmap-add empty-intmap i val error) map error))
+ (else
+ ;; Add a new level and try again.
+ (intmap-add (add-level min shift root) i val error))))
+ (($ <transient-intmap>)
+ (intmap-add (persistent-intmap map) i val meet))))
+
+(define* (intmap-replace! map i val #:optional (meet (lambda (old new) new)))
+ "Like intmap-add!, but requires that @var{i} was present in the map
+already, and always calls the meet procedure."
+ (define (not-found)
+ (error "not found" i))
+ (define (ensure-branch! root idx)
+ (let ((edit (vector-ref root *edit-index*))
+ (v (vector-ref root idx)))
+ (when (absent? v) (not-found))
+ (let ((v* (writable-branch v edit)))
+ (unless (eq? v v*)
+ (vector-set! root idx v*))
+ v*)))
+ (define (adjoin! i shift root)
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (if (zero? shift)
+ (let ((node (vector-ref root idx)))
+ (when (absent? node) (not-found))
+ (vector-set! root idx (meet node val)))
+ (adjoin! i shift (ensure-branch! root idx)))))
+ (match map
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((and (present? root) (<= min i) (< i (+ min (ash 1 shift))))
+ (if (zero? shift)
+ (set-transient-intmap-root! map (meet root val))
+ (let ((root* (writable-branch root edit)))
+ (unless (eq? root root*)
+ (set-transient-intmap-root! map root*))
+ (adjoin! (- i min) shift root*))))
+ (else
+ (not-found)))
+ map)
+ (($ <intmap>)
+ (intmap-add! (transient-intmap map) i val meet))))
+
+(define* (intmap-replace map i val #:optional (meet (lambda (old new) new)))
+ "Like intmap-add, but requires that @var{i} was present in the map
+already, and always calls the meet procedure."
+ (define (not-found)
+ (error "not found" i))
+ (define (adjoin i shift root)
+ (if (zero? shift)
+ (if (absent? root)
+ (not-found)
+ (meet root val))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
+ (if (absent? root)
+ (not-found)
+ (let* ((node (vector-ref root idx))
+ (node* (adjoin i shift node)))
+ (if (eq? node node*)
+ root
+ (clone-branch-and-set root idx node*)))))))
+ (match map
+ (($ <intmap> min shift root)
+ (cond
+ ((< i 0)
+ ;; The power-of-two spanning trick doesn't work across 0.
+ (error "Intmaps can only map non-negative integers." i))
+ ((and (present? root) (<= min i) (< i (+ min (ash 1 shift))))
+ (let ((old-root root)
+ (root (adjoin (- i min) shift root)))
+ (if (eq? root old-root)
+ map
+ (make-intmap min shift root))))
+ (else (not-found))))
+ (($ <transient-intmap>)
+ (intmap-replace (persistent-intmap map) i val meet))))
+
+(define (intmap-remove map i)
+ (define (remove i shift root)
+ (cond
+ ((zero? shift) *absent*)
+ (else
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (vector-ref root idx)))
+ (if (absent? node)
+ root
+ (let ((node* (remove i shift node)))
+ (if (eq? node node*)
+ root
+ (clone-branch-and-set root idx node*))))))))
+ (match map
+ (($ <intmap> min shift root)
+ (cond
+ ((absent? root) map)
+ ((and (<= min i) (< i (+ min (ash 1 shift))))
+ ;; Add element to map; level will not change.
+ (let ((root* (remove (- i min) shift root)))
+ (if (eq? root root*)
+ map
+ (if (absent? root*)
+ empty-intmap
+ (make-intmap/prune min shift root*)))))
+ (else map)))
+ (($ <transient-intmap>)
+ (intmap-remove (persistent-intmap map) i))))
+
+(define* (intmap-ref map i #:optional (not-found (lambda (i)
+ (error "not found" i))))
+ (define (absent) (not-found i))
+ (define (ref min shift root)
+ (if (zero? shift)
+ (if (and min (= i min) (present? root))
+ root
+ (absent))
+ (if (and (<= min i) (< i (+ min (ash 1 shift))))
+ (let ((i (- i min)))
+ (let lp ((node root) (shift shift))
+ (if (present? node)
+ (if (= shift *branch-bits*)
+ (let ((node (vector-ref node (logand i *branch-mask*))))
+ (if (present? node)
+ node
+ (absent)))
+ (let* ((shift (- shift *branch-bits*))
+ (idx (logand (ash i (- shift))
+ *branch-mask*)))
+ (lp (vector-ref node idx) shift)))
+ (absent))))
+ (absent))))
+ (match map
+ (($ <intmap> min shift root)
+ (ref min shift root))
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (ref min shift root))))
+
+(define* (intmap-next map #:optional i)
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (< idx *branch-size*)
+ (or (visit-node (vector-ref node idx) shift i)
+ (let ((inc (ash 1 shift)))
+ (lp (+ (round-down i shift) inc) (1+ idx)))))))
+ (define (visit-node node shift i)
+ (and (present? node)
+ (if (zero? shift)
+ i
+ (visit-branch node (- shift *branch-bits*) i))))
+ (define (next min shift root)
+ (let ((i (if (and i (< min i))
+ (- i min)
+ 0)))
+ (and (< i (ash 1 shift))
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))
+ (match map
+ (($ <intmap> min shift root)
+ (next min shift root))
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (next min shift root))))
+
+(define* (intmap-prev map #:optional i)
+ (define (visit-branch node shift i)
+ (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
+ (and (<= 0 idx)
+ (or (visit-node (vector-ref node idx) shift i)
+ (lp (1- (round-down i shift)) (1- idx))))))
+ (define (visit-node node shift i)
+ (and (present? node)
+ (if (zero? shift)
+ i
+ (visit-branch node (- shift *branch-bits*) i))))
+ (define (prev min shift root)
+ (let* ((i (if (and i (< i (+ min (ash 1 shift))))
+ (- i min)
+ (1- (ash 1 shift)))))
+ (and (<= 0 i)
+ (let ((i (visit-node root shift i)))
+ (and i (+ min i))))))
+ (match map
+ (($ <intmap> min shift root)
+ (prev min shift root))
+ (($ <transient-intmap> min shift root edit)
+ (assert-readable! edit)
+ (prev min shift root))))
+
+(define-syntax-rule (make-intmap-folder forward? seed ...)
+ (lambda (f map seed ...)
+ (define (visit-branch node shift min seed ...)
+ (let ((shift (- shift *branch-bits*)))
+ (if (zero? shift)
+ (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
+ (if (if forward? (< i *branch-size*) (<= 0 i))
+ (let ((elt (vector-ref node i)))
+ (call-with-values (lambda ()
+ (if (present? elt)
+ (f (+ i min) elt seed ...)
+ (values seed ...)))
+ (lambda (seed ...)
+ (lp (if forward? (1+ i) (1- i)) seed ...))))
+ (values seed ...)))
+ (let lp ((i (if forward? 0 (1- *branch-size*))) (seed seed) ...)
+ (if (if forward? (< i *branch-size*) (<= 0 i))
+ (let ((elt (vector-ref node i)))
+ (call-with-values
+ (lambda ()
+ (if (present? elt)
+ (visit-branch elt shift (+ min (ash i shift))
+ seed ...)
+ (values seed ...)))
+ (lambda (seed ...)
+ (lp (if forward? (1+ i) (1- i)) seed ...))))
+ (values seed ...))))))
+ (let fold ((map map))
+ (match map
+ (($ <intmap> min shift root)
+ (cond
+ ((absent? root) (values seed ...))
+ ((zero? shift) (f min root seed ...))
+ (else (visit-branch root shift min seed ...))))
+ (($ <transient-intmap>)
+ (fold (persistent-intmap map)))))))
+
+(define intmap-fold
+ (case-lambda
+ ((f map)
+ ((make-intmap-folder #t) f map))
+ ((f map seed)
+ ((make-intmap-folder #t seed) f map seed))
+ ((f map seed0 seed1)
+ ((make-intmap-folder #t seed0 seed1) f map seed0 seed1))
+ ((f map seed0 seed1 seed2)
+ ((make-intmap-folder #t seed0 seed1 seed2) f map seed0 seed1 seed2))))
+
+(define intmap-fold-right
+ (case-lambda
+ ((f map)
+ ((make-intmap-folder #f) f map))
+ ((f map seed)
+ ((make-intmap-folder #f seed) f map seed))
+ ((f map seed0 seed1)
+ ((make-intmap-folder #f seed0 seed1) f map seed0 seed1))
+ ((f map seed0 seed1 seed2)
+ ((make-intmap-folder #f seed0 seed1 seed2) f map seed0 seed1 seed2))))
+
+(define* (intmap-union a b #:optional (meet meet-error))
+ ;; Union A and B from index I; the result will be fresh.
+ (define (union-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (union shift a-child b-child))
+ (lp (1+ i))))
+ (else fresh))))
+ ;; Union A and B from index I; the result may be eq? to A.
+ (define (union-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Union A and B; the may could be eq? to either.
+ (define (union-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (union shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (union-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (union-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (union-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (union shift a-node b-node)
+ (cond
+ ((absent? a-node) b-node)
+ ((absent? b-node) a-node)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (union-branches (- shift *branch-bits*) a-node b-node))))
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((not (= b-shift a-shift))
+ ;; Hoist the map with the lowest shift to meet the one with the
+ ;; higher shift.
+ (if (< b-shift a-shift)
+ (intmap-union a (add-level b-min b-shift b-root) meet)
+ (intmap-union (add-level a-min a-shift a-root) b meet)))
+ ((not (= b-min a-min))
+ ;; Nodes at the same shift but different minimums will cover
+ ;; disjoint ranges (due to the round-down call on min). Hoist
+ ;; both until they cover the same range.
+ (intmap-union (add-level a-min a-shift a-root)
+ (add-level b-min b-shift b-root)
+ meet))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (union a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap a-min a-shift root)))))))))
+
+(define* (intmap-intersect a b #:optional (meet meet-error))
+ ;; Intersect A and B from index I; the result will be fresh.
+ (define (intersect-branches/fresh shift a b i fresh)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (vector-set! fresh i (intersect shift a-child b-child))
+ (lp (1+ i))))
+ ((branch-empty? fresh) *absent*)
+ (else fresh))))
+ ;; Intersect A and B from index I; the result may be eq? to A.
+ (define (intersect-branches/a shift a b i)
+ (let lp ((i i))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (lp (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ (else a))))
+ ;; Intersect A and B; the may could be eq? to either.
+ (define (intersect-branches shift a b)
+ (let lp ((i 0))
+ (cond
+ ((< i *branch-size*)
+ (let* ((a-child (vector-ref a i))
+ (b-child (vector-ref b i)))
+ (if (eq? a-child b-child)
+ (lp (1+ i))
+ (let ((child (intersect shift a-child b-child)))
+ (cond
+ ((eq? a-child child)
+ (intersect-branches/a shift a b (1+ i)))
+ ((eq? b-child child)
+ (intersect-branches/a shift b a (1+ i)))
+ (else
+ (let ((result (clone-branch-and-set a i child)))
+ (intersect-branches/fresh shift a b (1+ i) result))))))))
+ ;; Seems they are the same but not eq?. Odd.
+ (else a))))
+ (define (intersect shift a-node b-node)
+ (cond
+ ((or (absent? a-node) (absent? b-node)) *absent*)
+ ((eq? a-node b-node) a-node)
+ ((zero? shift) (meet a-node b-node))
+ (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
+
+ (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
+ (cond
+ ((<= lo-shift hi-shift)
+ ;; If LO has a lower shift and a lower min, it is disjoint. If
+ ;; it has the same shift and a different min, it is also
+ ;; disjoint.
+ empty-intmap)
+ (else
+ (let* ((lo-shift (- lo-shift *branch-bits*))
+ (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
+ (if (>= lo-idx *branch-size*)
+ ;; HI has a lower shift, but it not within LO.
+ empty-intmap
+ (let ((lo-root (vector-ref lo-root lo-idx)))
+ (if (absent? lo-root)
+ empty-intmap
+ (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
+ lo-shift
+ lo-root)))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet))))))))))
+
+ (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
+ (let ((hi-root (vector-ref hi-root 0)))
+ (if (absent? hi-root)
+ empty-intmap
+ (let ((hi (make-intmap min
+ (- hi-shift *branch-bits*)
+ hi-root)))
+ (if lo-is-a?
+ (intmap-intersect lo hi meet)
+ (intmap-intersect hi lo meet))))))
+
+ (match (cons a b)
+ ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
+ (cond
+ ((< a-min b-min)
+ (different-mins a-min a-shift a-root b-min b-shift b #t))
+ ((< b-min a-min)
+ (different-mins b-min b-shift b-root a-min a-shift a #f))
+ ((< a-shift b-shift)
+ (different-shifts-same-min b-min b-shift b-root a #t))
+ ((< b-shift a-shift)
+ (different-shifts-same-min a-min a-shift a-root b #f))
+ (else
+ ;; At this point, A and B cover the same range.
+ (let ((root (intersect a-shift a-root b-root)))
+ (cond
+ ((eq? root a-root) a)
+ ((eq? root b-root) b)
+ (else (make-intmap/prune a-min a-shift root)))))))))
+
+(define (intmap->alist intmap)
+ (reverse (intmap-fold acons intmap '())))
+
+(define (intmap-key-ranges intmap)
+ (call-with-values
+ (lambda ()
+ (intmap-fold (lambda (k v start end closed)
+ (cond
+ ((not start) (values k k closed))
+ ((= k (1+ end)) (values start k closed))
+ (else (values k k (acons start end closed)))))
+ intmap #f #f '()))
+ (lambda (start end closed)
+ (reverse (if start (acons start end closed) closed)))))
+
+(define (range-string ranges)
+ (string-join (map (match-lambda
+ ((start . start)
+ (format #f "~a" start))
+ ((start . end)
+ (format #f "~a-~a" start end)))
+ ranges)
+ ","))
+
+(define (print-helper port tag intmap)
+ (let ((ranges (intmap-key-ranges intmap)))
+ (match ranges
+ (()
+ (format port "#<~a>" tag))
+ (((0 . _) . _)
+ (format port "#<~a ~a>" tag (range-string ranges)))
+ (((min . end) . ranges)
+ (let ((ranges (map (match-lambda
+ ((start . end) (cons (- start min) (- end min))))
+ (acons min end ranges))))
+ (format port "#<~a ~a+~a>" tag min (range-string ranges)))))))
+
+(define (print-intmap intmap port)
+ (print-helper port "intmap" intmap))
+(define (print-transient-intmap intmap port)
+ (print-helper port "transient-intmap" intmap))
+
+(set-record-type-printer! <intmap> print-intmap)
+(set-record-type-printer! <transient-intmap> print-transient-intmap)