module/language/cps/intmap.scm

   1 ;;; Functional name maps
   2 ;;; Copyright (C) 2014 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 (intmap-add bs i val meet)
 106   (define (adjoin i shift root)
 107     (cond
 108      ((zero? shift)
 109       (cond
 110        ((eq? root val) root)
 111        ((not root) val)
 112        (else (meet root val))))
 113      (else
 114       (let* ((shift (- shift *branch-bits*))
 115              (idx (logand (ash i (- shift)) *branch-mask*))
 116              (node (and root (vector-ref root idx)))
 117              (new-node (adjoin i shift node)))
 118         (if (eq? node new-node)
 119             root
 120             (clone-branch-and-set root idx new-node))))))
 121   (match bs
 122     (($ <intmap> min shift root)
 123      (cond
 124       ((< i 0)
 125        ;; The power-of-two spanning trick doesn't work across 0.
 126        (error "Intmaps can only map non-negative integers." i))
 127       ((not val) (intmap-remove bs i))
 128       ((not root)
 129        ;; Add first element.
 130        (make-intmap i 0 val))
 131       ((and (<= min i) (< i (+ min (ash 1 shift))))
 132        ;; Add element to map; level will not change.
 133        (let ((old-root root)
 134              (root (adjoin (- i min) shift root)))
 135          (if (eq? root old-root)
 136              bs
 137              (make-intmap min shift root))))
 138       ((< i min)
 139        ;; Rebuild the tree by unioning two intmaps.
 140        (intmap-union (intmap-add empty-intmap i val error) bs error))
 141       (else
 142        ;; Add a new level and try again.
 143        (intmap-add (add-level min shift root) i val error))))))
 144
 145 (define (intmap-remove bs i)
 146   (define (remove i shift root)
 147     (cond
 148      ((zero? shift) #f)
 149      (else
 150       (let* ((shift (- shift *branch-bits*))
 151              (idx (logand (ash i (- shift)) *branch-mask*)))
 152         (cond
 153          ((vector-ref root idx)
 154           => (lambda (node)
 155                (let ((new-node (remove i shift node)))
 156                  (if (eq? node new-node)
 157                      root
 158                      (let ((root (clone-branch-and-set root idx new-node)))
 159                        (and (or new-node (not (branch-empty? root)))
 160                             root))))))
 161          (else root))))))
 162   (match bs
 163     (($ <intmap> min shift root)
 164      (cond
 165       ((not root) bs)
 166       ((and (<= min i) (< i (+ min (ash 1 shift))))
 167        ;; Add element to map; level will not change.
 168        (let ((old-root root)
 169              (root (remove (- i min) shift root)))
 170          (if (eq? root old-root)
 171              bs
 172              (make-intmap/prune min shift root))))
 173       (else bs)))))
 174
 175 (define (intmap-ref bs i)
 176   (match bs
 177     (($ <intmap> min shift root)
 178      (and (<= min i) (< i (+ min (ash 1 shift)))
 179           (let ((i (- i min)))
 180             (let lp ((node root) (shift shift))
 181               (and node
 182                    (if (= shift *branch-bits*)
 183                        (vector-ref node (logand i *branch-mask*))
 184                        (let* ((shift (- shift *branch-bits*))
 185                               (idx (logand (ash i (- shift))
 186                                            *branch-mask*)))
 187                          (lp (vector-ref node idx) shift))))))))))
 188
 189 (define (intmap-next bs i)
 190   (define (visit-branch node shift i)
 191     (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
 192       (and (< idx *branch-size*)
 193            (or (visit-node (vector-ref node idx) shift i)
 194                (let ((inc (ash 1 shift)))
 195                  (lp (+ (round-down i shift) inc) (1+ idx)))))))
 196   (define (visit-node node shift i)
 197     (and node
 198          (if (zero? shift)
 199              i
 200              (visit-branch node (- shift *branch-bits*) i))))
 201   (match bs
 202     (($ <intmap> min shift root)
 203      (let ((i (if (and i (< min i))
 204                   (- i min)
 205                   0)))
 206        (and (< i (ash 1 shift))
 207             (let ((i (visit-node root shift i)))
 208               (and i (+ min i))))))))
 209
 210 (define (intmap-union a b meet)
 211   ;; Union A and B from index I; the result will be fresh.
 212   (define (union-branches/fresh shift a b i fresh)
 213     (let lp ((i 0))
 214       (cond
 215        ((< i *branch-size*)
 216         (let* ((a-child (vector-ref a i))
 217                (b-child (vector-ref b i)))
 218           (vector-set! fresh i (union shift a-child b-child))
 219           (lp (1+ i))))
 220        (else fresh))))
 221   ;; Union A and B from index I; the result may be eq? to A.
 222   (define (union-branches/a shift a b i)
 223     (let lp ((i i))
 224       (cond
 225        ((< i *branch-size*)
 226         (let* ((a-child (vector-ref a i))
 227                (b-child (vector-ref b i)))
 228           (if (eq? a-child b-child)
 229               (lp (1+ i))
 230               (let ((child (union shift a-child b-child)))
 231                 (cond
 232                  ((eq? a-child child)
 233                   (lp (1+ i)))
 234                  (else
 235                   (let ((result (clone-branch-and-set a i child)))
 236                     (union-branches/fresh shift a b (1+ i) result))))))))
 237        (else a))))
 238   ;; Union A and B; the may could be eq? to either.
 239   (define (union-branches shift a b)
 240     (let lp ((i 0))
 241       (cond
 242        ((< i *branch-size*)
 243         (let* ((a-child (vector-ref a i))
 244                (b-child (vector-ref b i)))
 245           (if (eq? a-child b-child)
 246               (lp (1+ i))
 247               (let ((child (union shift a-child b-child)))
 248                 (cond
 249                  ((eq? a-child child)
 250                   (union-branches/a shift a b (1+ i)))
 251                  ((eq? b-child child)
 252                   (union-branches/a shift b a (1+ i)))
 253                  (else
 254                   (let ((result (clone-branch-and-set a i child)))
 255                     (union-branches/fresh shift a b (1+ i) result))))))))
 256        ;; Seems they are the same but not eq?.  Odd.
 257        (else a))))
 258   (define (union shift a-node b-node)
 259     (cond
 260      ((not a-node) b-node)
 261      ((not b-node) a-node)
 262      ((eq? a-node b-node) a-node)
 263      ((zero? shift) (meet a-node b-node))
 264      (else (union-branches (- shift *branch-bits*) a-node b-node))))
 265   (match (cons a b)
 266     ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
 267      (cond
 268       ((not (= b-shift a-shift))
 269        ;; Hoist the map with the lowest shift to meet the one with the
 270        ;; higher shift.
 271        (if (< b-shift a-shift)
 272            (intmap-union a (add-level b-min b-shift b-root) meet)
 273            (intmap-union (add-level a-min a-shift a-root) b meet)))
 274       ((not (= b-min a-min))
 275        ;; Nodes at the same shift but different minimums will cover
 276        ;; disjoint ranges (due to the round-down call on min).  Hoist
 277        ;; both until they cover the same range.
 278        (intmap-union (add-level a-min a-shift a-root)
 279                      (add-level b-min b-shift b-root)
 280                      meet))
 281       (else
 282        ;; At this point, A and B cover the same range.
 283        (let ((root (union a-shift a-root b-root)))
 284          (cond
 285           ((eq? root a-root) a)
 286           ((eq? root b-root) b)
 287           (else (make-intmap a-min a-shift root)))))))))
 288
 289 (define (intmap-intersect a b meet)
 290   ;; Intersect A and B from index I; the result will be fresh.
 291   (define (intersect-branches/fresh shift a b i fresh)
 292     (let lp ((i 0))
 293       (cond
 294        ((< i *branch-size*)
 295         (let* ((a-child (vector-ref a i))
 296                (b-child (vector-ref b i)))
 297           (vector-set! fresh i (intersect shift a-child b-child))
 298           (lp (1+ i))))
 299        ((branch-empty? fresh) #f)
 300        (else fresh))))
 301   ;; Intersect A and B from index I; the result may be eq? to A.
 302   (define (intersect-branches/a shift a b i)
 303     (let lp ((i i))
 304       (cond
 305        ((< i *branch-size*)
 306         (let* ((a-child (vector-ref a i))
 307                (b-child (vector-ref b i)))
 308           (if (eq? a-child b-child)
 309               (lp (1+ i))
 310               (let ((child (intersect shift a-child b-child)))
 311                 (cond
 312                  ((eq? a-child child)
 313                   (lp (1+ i)))
 314                  (else
 315                   (let ((result (clone-branch-and-set a i child)))
 316                     (intersect-branches/fresh shift a b (1+ i) result))))))))
 317        (else a))))
 318   ;; Intersect A and B; the may could be eq? to either.
 319   (define (intersect-branches shift a b)
 320     (let lp ((i 0))
 321       (cond
 322        ((< i *branch-size*)
 323         (let* ((a-child (vector-ref a i))
 324                (b-child (vector-ref b i)))
 325           (if (eq? a-child b-child)
 326               (lp (1+ i))
 327               (let ((child (intersect shift a-child b-child)))
 328                 (cond
 329                  ((eq? a-child child)
 330                   (intersect-branches/a shift a b (1+ i)))
 331                  ((eq? b-child child)
 332                   (intersect-branches/a shift b a (1+ i)))
 333                  (else
 334                   (let ((result (clone-branch-and-set a i child)))
 335                     (intersect-branches/fresh shift a b (1+ i) result))))))))
 336        ;; Seems they are the same but not eq?.  Odd.
 337        (else a))))
 338   (define (intersect shift a-node b-node)
 339     (cond
 340      ((or (not a-node) (not b-node)) #f)
 341      ((eq? a-node b-node) a-node)
 342      ((zero? shift) (meet a-node b-node))
 343      (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
 344
 345   (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
 346     (cond
 347      ((<= lo-shift hi-shift)
 348       ;; If LO has a lower shift and a lower min, it is disjoint.  If
 349       ;; it has the same shift and a different min, it is also
 350       ;; disjoint.
 351       empty-intmap)
 352      (else
 353       (let* ((lo-shift (- lo-shift *branch-bits*))
 354              (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
 355         (cond
 356          ((>= lo-idx *branch-size*)
 357           ;; HI has a lower shift, but it not within LO.
 358           empty-intmap)
 359          ((vector-ref lo-root lo-idx)
 360           => (lambda (lo-root)
 361                (let ((lo (make-intmap (+ lo-min (ash lo-idx lo-shift))
 362                                       lo-shift
 363                                       lo-root)))
 364                  (if lo-is-a?
 365                      (intmap-intersect lo hi meet)
 366                      (intmap-intersect hi lo meet)))))
 367          (else empty-intmap))))))
 368
 369   (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
 370     (cond
 371      ((vector-ref hi-root 0)
 372       => (lambda (hi-root)
 373            (let ((hi (make-intmap min
 374                                   (- hi-shift *branch-bits*)
 375                                   hi-root)))
 376              (if lo-is-a?
 377                  (intmap-intersect lo hi meet)
 378                  (intmap-intersect hi lo meet)))))
 379      (else empty-intmap)))
 380
 381   (match (cons a b)
 382     ((($ <intmap> a-min a-shift a-root) . ($ <intmap> b-min b-shift b-root))
 383      (cond
 384       ((< a-min b-min)
 385        (different-mins a-min a-shift a-root b-min b-shift b #t))
 386       ((< b-min a-min)
 387        (different-mins b-min b-shift b-root a-min a-shift a #f))
 388       ((< a-shift b-shift)
 389        (different-shifts-same-min b-min b-shift b-root a #t))
 390       ((< b-shift a-shift)
 391        (different-shifts-same-min a-min a-shift a-root b #f))
 392       (else
 393        ;; At this point, A and B cover the same range.
 394        (let ((root (intersect a-shift a-root b-root)))
 395          (cond
 396           ((eq? root a-root) a)
 397           ((eq? root b-root) b)
 398           (else (make-intmap/prune a-min a-shift root)))))))))