guile/module/language/cps/intmap.scm

;;; Functional name maps
;;; Copyright (C) 2014-2017,2019 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
          ((absent? root) empty-intmap)
          ((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)