1 ;;; Functional name maps
2 ;;; Copyright (C) 2014, 2015 Free Software Foundation, Inc.
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.
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.
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/>.
20 ;;; A persistent, functional data structure representing a set of
21 ;;; integers as a tree whose branches are vectors and whose leaves are
22 ;;; fixnums. Intsets are careful to preserve sub-structure, in the
23 ;;; sense of eq?, whereever possible.
27 (define-module (language cps intset)
28 #:use-module (rnrs bytevectors)
29 #:use-module (srfi srfi-9)
30 #:use-module (ice-9 match)
31 #:export (empty-intset
48 (define-syntax-rule (define-inline name val)
49 (define-syntax name (identifier-syntax val)))
52 (use-modules (system base target))
53 (define-syntax compile-time-cond
56 ((_ (test body ...) rest ...)
57 (if (primitive-eval (syntax->datum #'test))
59 #'(begin (compile-time-cond rest ...))))
63 (error "no compile-time-cond expression matched"))))))
66 ((eqv? (target-word-size) 4)
67 (define-inline *leaf-bits* 4))
68 ((eqv? (target-word-size) 8)
69 (define-inline *leaf-bits* 5)))
71 ;; FIXME: This should make an actual atomic reference.
72 (define-inlinable (make-atomic-reference value)
74 (define-inlinable (get-atomic-reference reference)
76 (define-inlinable (set-atomic-reference! reference value)
77 (set-car! reference value))
79 (define-inline *leaf-size* (ash 1 *leaf-bits*))
80 (define-inline *leaf-mask* (1- *leaf-size*))
81 (define-inline *branch-bits* 3)
82 (define-inline *branch-size* (ash 1 *branch-bits*))
83 (define-inline *branch-size-with-edit* (1+ *branch-size*))
84 (define-inline *edit-index* *branch-size*)
85 (define-inline *branch-mask* (1- *branch-size*))
87 (define-record-type <intset>
88 (make-intset min shift root)
94 (define-record-type <transient-intset>
95 (make-transient-intset min shift root edit)
97 (min transient-intset-min set-transient-intset-min!)
98 (shift transient-intset-shift set-transient-intset-shift!)
99 (root transient-intset-root set-transient-intset-root!)
100 (edit transient-intset-edit set-transient-intset-edit!))
102 (define (new-leaf) 0)
103 (define-inlinable (clone-leaf-and-set leaf i val)
106 (logior leaf (ash 1 i))
109 (logand leaf (lognot (ash 1 i)))
111 (define (leaf-empty? leaf)
114 (define-inlinable (new-branch edit)
115 (let ((vec (make-vector *branch-size-with-edit* #f)))
116 (when edit (vector-set! vec *edit-index* edit))
118 (define (clone-branch-and-set branch i elt)
119 (let ((new (new-branch #f)))
120 (when branch (vector-move-left! branch 0 *branch-size* new 0))
121 (vector-set! new i elt)
123 (define-inlinable (assert-readable! root-edit)
124 (unless (eq? (get-atomic-reference root-edit) (current-thread))
125 (error "Transient intset owned by another thread" root-edit)))
126 (define-inlinable (writable-branch branch root-edit)
127 (let ((edit (vector-ref branch *edit-index*)))
128 (if (eq? root-edit edit)
130 (clone-branch-and-set branch *edit-index* root-edit))))
131 (define (branch-empty? branch)
133 (or (= i *branch-size*)
134 (and (not (vector-ref branch i))
137 (define (round-down min shift)
138 (logand min (lognot (1- (ash 1 shift)))))
140 (define empty-intset (make-intset 0 *leaf-bits* #f))
142 (define (add-level min shift root)
143 (let* ((shift* (+ shift *branch-bits*))
144 (min* (round-down min shift*))
145 (idx (logand (ash (- min min*) (- shift)) *branch-mask*)))
146 (make-intset min* shift* (clone-branch-and-set #f idx root))))
148 (define (make-intset/prune min shift root)
152 ((= shift *leaf-bits*)
153 (make-intset min shift root))
155 (let lp ((i 0) (elt #f))
158 (if (vector-ref root i)
160 (make-intset min shift root)
164 (let ((shift (- shift *branch-bits*)))
165 (make-intset/prune (+ min (ash elt shift))
167 (vector-ref root elt))))
168 ;; Shouldn't be reached...
169 (else empty-intset))))))
171 (define* (transient-intset #:optional (source empty-intset))
173 (($ <transient-intset> min shift root edit)
174 (assert-readable! edit)
176 (($ <intset> min shift root)
177 (let ((edit (make-atomic-reference (current-thread))))
178 (make-transient-intset min shift root edit)))))
180 (define* (persistent-intset #:optional (source empty-intset))
182 (($ <transient-intset> min shift root edit)
183 (assert-readable! edit)
184 ;; Make a fresh reference, causing any further operations on this
185 ;; transient to clone its root afresh.
186 (set-transient-intset-edit! source
187 (make-atomic-reference (current-thread)))
188 ;; Clear the reference to the current thread, causing our edited
189 ;; data structures to be persistent again.
190 (set-atomic-reference! edit #f)
192 (make-intset min shift root)
197 (define (intset-add! bs i)
198 (define (adjoin-leaf i root)
199 (clone-leaf-and-set root (logand i *leaf-mask*) #t))
200 (define (ensure-branch! root idx)
201 (let ((edit (vector-ref root *edit-index*)))
202 (match (vector-ref root idx)
203 (#f (let ((v (new-branch edit)))
204 (vector-set! root idx v)
206 (v (writable-branch v edit)))))
207 (define (adjoin-branch! i shift root)
208 (let* ((shift (- shift *branch-bits*))
209 (idx (logand (ash i (- shift)) *branch-mask*)))
211 ((= shift *leaf-bits*)
212 (vector-set! root idx (adjoin-leaf i (vector-ref root idx))))
214 (adjoin-branch! i shift (ensure-branch! root idx))))))
216 (($ <transient-intset> min shift root edit)
217 (assert-readable! edit)
220 ;; The power-of-two spanning trick doesn't work across 0.
221 (error "Intsets can only hold non-negative integers." i))
223 ;; Add first element.
224 (let ((min (round-down i shift)))
225 (set-transient-intset-min! bs min)
226 (set-transient-intset-shift! bs *leaf-bits*)
227 (set-transient-intset-root! bs (adjoin-leaf (- i min) root))))
228 ((and (<= min i) (< i (+ min (ash 1 shift))))
229 ;; Add element to set; level will not change.
230 (if (= shift *leaf-bits*)
231 (set-transient-intset-root! bs (adjoin-leaf (- i min) root))
232 (adjoin-branch! (- i min) shift root)))
236 (root (if (eqv? shift *leaf-bits*)
238 (writable-branch root edit))))
239 (let* ((shift* (+ shift *branch-bits*))
240 (min* (round-down min shift*))
241 (idx (logand (ash (- min min*) (- shift)) *branch-mask*))
242 (root* (new-branch edit)))
243 (vector-set! root* idx root)
245 ((and (<= min* i) (< i (+ min* (ash 1 shift*))))
246 (set-transient-intset-min! bs min*)
247 (set-transient-intset-shift! bs shift*)
248 (set-transient-intset-root! bs root*)
249 (adjoin-branch! (- i min*) shift* root*))
251 (lp min* shift* root*)))))))
254 (intset-add! (transient-intset bs) i))))
256 (define (intset-add bs i)
257 (define (adjoin i shift root)
259 ((= shift *leaf-bits*)
260 (let ((idx (logand i *leaf-mask*)))
261 (if (and root (logbit? idx root))
263 (clone-leaf-and-set root idx #t))))
265 (let* ((shift (- shift *branch-bits*))
266 (idx (logand (ash i (- shift)) *branch-mask*))
267 (node (and root (vector-ref root idx)))
268 (new-node (adjoin i shift node)))
269 (if (eq? node new-node)
271 (clone-branch-and-set root idx new-node))))))
273 (($ <intset> min shift root)
276 ;; The power-of-two spanning trick doesn't work across 0.
277 (error "Intsets can only hold non-negative integers." i))
279 ;; Add first element.
280 (let ((min (round-down i shift)))
281 (make-intset min *leaf-bits*
282 (adjoin (- i min) *leaf-bits* root))))
283 ((and (<= min i) (< i (+ min (ash 1 shift))))
284 ;; Add element to set; level will not change.
285 (let ((old-root root)
286 (root (adjoin (- i min) shift root)))
287 (if (eq? root old-root)
289 (make-intset min shift root))))
291 ;; Rebuild the tree by unioning two intsets.
292 (intset-union (intset-add empty-intset i) bs))
294 ;; Add a new level and try again.
295 (intset-add (add-level min shift root) i))))))
297 (define (intset-remove bs i)
298 (define (remove i shift root)
300 ((= shift *leaf-bits*)
301 (let ((idx (logand i *leaf-mask*)))
302 (if (logbit? idx root)
303 (let ((root (clone-leaf-and-set root idx #f)))
304 (and (not (leaf-empty? root)) root))
307 (let* ((shift (- shift *branch-bits*))
308 (idx (logand (ash i (- shift)) *branch-mask*)))
310 ((vector-ref root idx)
312 (let ((new-node (remove i shift node)))
313 (if (eq? node new-node)
315 (let ((root (clone-branch-and-set root idx new-node)))
316 (and (or new-node (not (branch-empty? root)))
320 (($ <intset> min shift root)
323 ((and (<= min i) (< i (+ min (ash 1 shift))))
324 ;; Add element to set; level will not change.
325 (let ((old-root root)
326 (root (remove (- i min) shift root)))
327 (if (eq? root old-root)
329 (make-intset/prune min shift root))))
332 (define (intset-ref bs i)
333 (define (ref min shift root)
334 (and (<= min i) (< i (+ min (ash 1 shift)))
336 (let lp ((node root) (shift shift))
338 (if (= shift *leaf-bits*)
339 (logbit? (logand i *leaf-mask*) node)
340 (let* ((shift (- shift *branch-bits*))
341 (idx (logand (ash i (- shift)) *branch-mask*)))
342 (lp (vector-ref node idx) shift))))))))
344 (($ <intset> min shift root)
345 (ref min shift root))
346 (($ <transient-intset> min shift root edit)
347 (assert-readable! edit)
348 (ref min shift root))))
350 (define (intset-next bs i)
351 (define (visit-leaf node i)
352 (let lp ((idx (logand i *leaf-mask*)))
353 (if (logbit? idx node)
354 (logior (logand i (lognot *leaf-mask*)) idx)
355 (let ((idx (1+ idx)))
356 (and (< idx *leaf-size*)
358 (define (visit-branch node shift i)
359 (let lp ((i i) (idx (logand (ash i (- shift)) *branch-mask*)))
360 (and (< idx *branch-size*)
361 (or (let ((node (vector-ref node idx)))
362 (and node (visit-node node shift i)))
363 (let ((inc (ash 1 shift)))
364 (lp (+ (round-down i shift) inc) (1+ idx)))))))
365 (define (visit-node node shift i)
366 (if (= shift *leaf-bits*)
368 (visit-branch node (- shift *branch-bits*) i)))
369 (define (next min shift root)
370 (let ((i (if (and i (< min i))
373 (and root (< i (ash 1 shift))
374 (let ((i (visit-node root shift i)))
375 (and i (+ min i))))))
377 (($ <intset> min shift root)
378 (next min shift root))
379 (($ <transient-intset> min shift root edit)
380 (assert-readable! edit)
381 (next min shift root))))
383 (define (intset-fold f set seed)
384 (define (visit-branch node shift min seed)
386 ((= shift *leaf-bits*)
387 (let lp ((i 0) (seed seed))
388 (if (< i *leaf-size*)
395 (let ((shift (- shift *branch-bits*)))
396 (let lp ((i 0) (seed seed))
397 (if (< i *branch-size*)
398 (let ((elt (vector-ref node i)))
401 (visit-branch elt shift (+ min (ash i shift)) seed)
405 (($ <intset> min shift root)
408 (else (visit-branch root shift min seed))))
409 (($ <transient-intset>)
410 (intset-fold f (persistent-intset set) seed))))
412 (define (intset-fold2 f set s0 s1)
413 (define (visit-branch node shift min s0 s1)
415 ((= shift *leaf-bits*)
416 (let lp ((i 0) (s0 s0) (s1 s1))
417 (if (< i *leaf-size*)
419 (call-with-values (lambda () (f (+ i min) s0 s1))
425 (let ((shift (- shift *branch-bits*)))
426 (let lp ((i 0) (s0 s0) (s1 s1))
427 (if (< i *branch-size*)
428 (let ((elt (vector-ref node i)))
432 (visit-branch elt shift (+ min (ash i shift)) s0 s1))
438 (($ <intset> min shift root)
440 ((not root) (values s0 s1))
441 (else (visit-branch root shift min s0 s1))))
442 (($ <transient-intset>)
443 (intset-fold2 f (persistent-intset set) s0 s1))))
445 (define (intset-size shift root)
448 ((= *leaf-bits* shift) *leaf-size*)
450 (let lp ((i (1- *branch-size*)))
451 (let ((node (vector-ref root i)))
453 (let ((shift (- shift *branch-bits*)))
454 (+ (intset-size shift node)
455 (* i (ash 1 shift))))
458 (define (intset-union a b)
460 (define (union-leaves a b)
461 (logior (or a 0) (or b 0)))
462 ;; Union A and B from index I; the result will be fresh.
463 (define (union-branches/fresh shift a b i fresh)
467 (let* ((a-child (vector-ref a i))
468 (b-child (vector-ref b i)))
469 (vector-set! fresh i (union shift a-child b-child))
472 ;; Union A and B from index I; the result may be eq? to A.
473 (define (union-branches/a shift a b i)
477 (let* ((a-child (vector-ref a i))
478 (b-child (vector-ref b i)))
479 (if (eq? a-child b-child)
481 (let ((child (union shift a-child b-child)))
486 (let ((result (clone-branch-and-set a i child)))
487 (union-branches/fresh shift a b (1+ i) result))))))))
489 ;; Union A and B; the may could be eq? to either.
490 (define (union-branches shift a b)
494 (let* ((a-child (vector-ref a i))
495 (b-child (vector-ref b i)))
496 (if (eq? a-child b-child)
498 (let ((child (union shift a-child b-child)))
501 (union-branches/a shift a b (1+ i)))
503 (union-branches/a shift b a (1+ i)))
505 (let ((result (clone-branch-and-set a i child)))
506 (union-branches/fresh shift a b (1+ i) result))))))))
507 ;; Seems they are the same but not eq?. Odd.
509 (define (union shift a-node b-node)
511 ((not a-node) b-node)
512 ((not b-node) a-node)
513 ((eq? a-node b-node) a-node)
514 ((= shift *leaf-bits*) (union-leaves a-node b-node))
515 (else (union-branches (- shift *branch-bits*) a-node b-node))))
517 ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
519 ((not (= b-shift a-shift))
520 ;; Hoist the set with the lowest shift to meet the one with the
522 (if (< b-shift a-shift)
523 (intset-union a (add-level b-min b-shift b-root))
524 (intset-union (add-level a-min a-shift a-root) b)))
525 ((not (= b-min a-min))
526 ;; Nodes at the same shift but different minimums will cover
527 ;; disjoint ranges (due to the round-down call on min). Hoist
528 ;; both until they cover the same range.
529 (intset-union (add-level a-min a-shift a-root)
530 (add-level b-min b-shift b-root)))
532 ;; At this point, A and B cover the same range.
533 (let ((root (union a-shift a-root b-root)))
535 ((eq? root a-root) a)
536 ((eq? root b-root) b)
537 (else (make-intset a-min a-shift root)))))))))
539 (define (intset-intersect a b)
540 (define tmp (new-leaf))
542 (define (intersect-leaves a b)
544 ;; Intersect A and B from index I; the result will be fresh.
545 (define (intersect-branches/fresh shift a b i fresh)
549 (let* ((a-child (vector-ref a i))
550 (b-child (vector-ref b i)))
551 (vector-set! fresh i (intersect shift a-child b-child))
553 ((branch-empty? fresh) #f)
555 ;; Intersect A and B from index I; the result may be eq? to A.
556 (define (intersect-branches/a shift a b i)
560 (let* ((a-child (vector-ref a i))
561 (b-child (vector-ref b i)))
562 (if (eq? a-child b-child)
564 (let ((child (intersect shift a-child b-child)))
569 (let ((result (clone-branch-and-set a i child)))
570 (intersect-branches/fresh shift a b (1+ i) result))))))))
572 ;; Intersect A and B; the may could be eq? to either.
573 (define (intersect-branches shift a b)
577 (let* ((a-child (vector-ref a i))
578 (b-child (vector-ref b i)))
579 (if (eq? a-child b-child)
581 (let ((child (intersect shift a-child b-child)))
584 (intersect-branches/a shift a b (1+ i)))
586 (intersect-branches/a shift b a (1+ i)))
588 (let ((result (clone-branch-and-set a i child)))
589 (intersect-branches/fresh shift a b (1+ i) result))))))))
590 ;; Seems they are the same but not eq?. Odd.
592 (define (intersect shift a-node b-node)
594 ((or (not a-node) (not b-node)) #f)
595 ((eq? a-node b-node) a-node)
596 ((= shift *leaf-bits*) (intersect-leaves a-node b-node))
597 (else (intersect-branches (- shift *branch-bits*) a-node b-node))))
599 (define (different-mins lo-min lo-shift lo-root hi-min hi-shift hi lo-is-a?)
601 ((<= lo-shift hi-shift)
602 ;; If LO has a lower shift and a lower min, it is disjoint. If
603 ;; it has the same shift and a different min, it is also
607 (let* ((lo-shift (- lo-shift *branch-bits*))
608 (lo-idx (ash (- hi-min lo-min) (- lo-shift))))
610 ((>= lo-idx *branch-size*)
611 ;; HI has a lower shift, but it not within LO.
613 ((vector-ref lo-root lo-idx)
615 (let ((lo (make-intset (+ lo-min (ash lo-idx lo-shift))
619 (intset-intersect lo hi)
620 (intset-intersect hi lo)))))
621 (else empty-intset))))))
623 (define (different-shifts-same-min min hi-shift hi-root lo lo-is-a?)
625 ((vector-ref hi-root 0)
627 (let ((hi (make-intset min
628 (- hi-shift *branch-bits*)
631 (intset-intersect lo hi)
632 (intset-intersect hi lo)))))
633 (else empty-intset)))
636 ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
639 (different-mins a-min a-shift a-root b-min b-shift b #t))
641 (different-mins b-min b-shift b-root a-min a-shift a #f))
643 (different-shifts-same-min b-min b-shift b-root a #t))
645 (different-shifts-same-min a-min a-shift a-root b #f))
647 ;; At this point, A and B cover the same range.
648 (let ((root (intersect a-shift a-root b-root)))
650 ((eq? root a-root) a)
651 ((eq? root b-root) b)
652 (else (make-intset/prune a-min a-shift root)))))))))
654 (define (intset-subtract a b)
655 (define tmp (new-leaf))
657 (define (subtract-leaves a b)
658 (logand a (lognot b)))
659 ;; Subtract B from A starting at index I; the result will be fresh.
660 (define (subtract-branches/fresh shift a b i fresh)
664 (let* ((a-child (vector-ref a i))
665 (b-child (vector-ref b i)))
666 (vector-set! fresh i (subtract-nodes shift a-child b-child))
668 ((branch-empty? fresh) #f)
670 ;; Subtract B from A. The result may be eq? to A.
671 (define (subtract-branches shift a b)
675 (let* ((a-child (vector-ref a i))
676 (b-child (vector-ref b i)))
677 (let ((child (subtract-nodes shift a-child b-child)))
682 (let ((result (clone-branch-and-set a i child)))
683 (subtract-branches/fresh shift a b (1+ i) result)))))))
685 (define (subtract-nodes shift a-node b-node)
687 ((or (not a-node) (not b-node)) a-node)
688 ((eq? a-node b-node) #f)
689 ((= shift *leaf-bits*) (subtract-leaves a-node b-node))
690 (else (subtract-branches (- shift *branch-bits*) a-node b-node))))
693 ((($ <intset> a-min a-shift a-root) . ($ <intset> b-min b-shift b-root))
694 (define (return root)
696 ((eq? root a-root) a)
697 (else (make-intset/prune a-min a-shift root))))
699 ((<= a-shift b-shift)
700 (let lp ((b-min b-min) (b-shift b-shift) (b-root b-root))
701 (if (= a-shift b-shift)
703 (return (subtract-nodes a-shift a-root b-root))
705 (let* ((b-shift (- b-shift *branch-bits*))
706 (b-idx (ash (- a-min b-min) (- b-shift)))
707 (b-min (+ b-min (ash b-idx b-shift)))
710 (< b-idx *branch-size*)
711 (vector-ref b-root b-idx))))
712 (lp b-min b-shift b-root)))))
715 (let lp ((a-min a-min) (a-shift a-shift) (a-root a-root))
716 (if (= a-shift b-shift)
718 (subtract-nodes a-shift a-root b-root)
720 (let* ((a-shift (- a-shift *branch-bits*))
721 (a-idx (ash (- b-min a-min) (- a-shift)))
722 (a-min (+ a-min (ash a-idx a-shift)))
725 (< a-idx *branch-size*)
726 (vector-ref a-root a-idx)))
727 (new (lp a-min a-shift old)))
730 (clone-branch-and-set a-root a-idx new)))))))))))
732 (define (bitvector->intset bv)
733 (define (finish-tail out min tail)
736 (intset-union out (make-intset min *leaf-bits* tail))))
737 (let lp ((out empty-intset) (min 0) (pos 0) (tail 0))
738 (let ((pos (bit-position #t bv pos)))
741 (finish-tail out min tail))
742 ((< pos (+ min *leaf-size*))
743 (lp out min (1+ pos) (logior tail (ash 1 (- pos min)))))
745 (let ((min* (round-down pos *leaf-bits*)))
746 (lp (finish-tail out min tail)
747 min* pos (ash 1 (- pos min*)))))))))