diff options
author | Andy Wingo <wingo@pobox.com> | 2015-05-14 13:46:09 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-05-20 19:18:45 +0200 |
commit | 2b06e90ca40e556471fa00241861b3d90eef932b (patch) | |
tree | 2877213aa0edb36b0c135e06570d706d3dbd211c /module/language/cps/intmap.scm | |
parent | cb7aa0b3b13b3f9c8dfba3a044d9e97e9dcd8c68 (diff) | |
download | guile-2b06e90ca40e556471fa00241861b3d90eef932b.tar.gz |
Intmaps do not treat #f specially as a value
* module/language/cps/intmap.scm: Intmaps can now contain any value;
#f does not indicate the absence of a value. Instead we use a unique
private sentinel to mark absent values or branches.
(*absent*, absent?, present?): New helpers.
(new-branch): Initialize empty elements to *absent*.
(clone-branch-with-edit): New helper.
(clone-branch-and-set): Use clone-branch-with-edit.
(writable-branch): Use clone-branch-with-edit
(empty-intmap): Initialize value to *absent*.
(add-level): clone-branch-and-set doesn't take #f as a branch any
more; use new-branch.
(branch-empty?, make-intmap/prune, intmap-add!):
(intmap-add, intmap-remove, intmap-next, intmap-prev):
(intmap-fold, intmap-union, intmap-intersect): Use absent? to detect
absent branches / values.
(intmap-ref): Likewise. Instead of returning #f if the value is not
found, call the optional not-found procedure. By default this will
signal an error.
* module/language/cps/types.scm:
* module/language/cps2/renumber.scm:
* module/language/cps2/simplify.scm: Adapt to intmap-ref signalling an
error by default if the value is not found.
* module/language/tree-il/compile-cps2.scm: Adapt to intmap-add
signalling an error if #f was in the intmap as a value.
Diffstat (limited to 'module/language/cps/intmap.scm')
-rw-r--r-- | module/language/cps/intmap.scm | 252 |
1 files changed, 133 insertions, 119 deletions
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index 9081f3362..8263f42c7 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -84,13 +84,22 @@ (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* #f))) - (when edit (vector-set! vec *edit-index* 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 (new-branch #f))) - (when branch (vector-move-left! branch 0 *branch-size* new 0)) + (let ((new (clone-branch-with-edit branch #f))) (vector-set! new i elt) new)) (define-inlinable (assert-readable! root-edit) @@ -100,24 +109,26 @@ (let ((edit (vector-ref branch *edit-index*))) (if (eq? root-edit edit) branch - (clone-branch-and-set branch *edit-index* root-edit)))) + (clone-branch-with-edit branch root-edit)))) (define (branch-empty? branch) (let lp ((i 0)) (or (= i *branch-size*) - (and (not (vector-ref branch i)) + (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 #f)) +(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*))) - (make-intmap min* shift* (clone-branch-and-set #f idx root)))) + *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) @@ -125,7 +136,7 @@ (let lp ((i 0) (elt #f)) (cond ((< i *branch-size*) - (if (vector-ref root i) + (if (present? (vector-ref root i)) (if elt (make-intmap min shift root) (lp (1+ i) i)) @@ -169,25 +180,24 @@ (define* (intmap-add! map i val #:optional (meet meet-error)) (define (ensure-branch! root idx) - (let ((edit (vector-ref root *edit-index*))) - (match (vector-ref root idx) - (#f (let ((v (new-branch edit))) - (vector-set! root idx v) - v)) - (v (let ((v* (writable-branch v edit))) - (unless (eq? v v*) - (vector-set! root idx v*)) - v*))))) + (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*))) - (cond - ((zero? shift) - (let ((node (vector-ref root idx))) - (unless (eq? node val) - (vector-set! root idx (if node (meet node val) val))))) - (else - (adjoin! i shift (ensure-branch! root idx)))))) + (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) @@ -195,7 +205,7 @@ ((< i 0) ;; The power-of-two spanning trick doesn't work across 0. (error "Intmaps can only map non-negative integers." i)) - ((not root) + ((absent? root) (set-transient-intmap-min! map i) (set-transient-intmap-shift! map 0) (set-transient-intmap-root! map val)) @@ -230,30 +240,32 @@ (($ <intmap>) (intmap-add! (transient-intmap map) i val meet)))) -(define* (intmap-add bs i val #:optional (meet meet-error)) +(define* (intmap-add map i val #:optional (meet meet-error)) (define (adjoin i shift root) - (cond - ((zero? shift) - (cond - ((eq? root val) root) - ((not root) val) - (else (meet root val)))) - (else - (let* ((shift (- shift *branch-bits*)) - (idx (logand (ash i (- shift)) *branch-mask*)) - (node (and root (vector-ref root idx))) - (new-node (adjoin i shift node))) - (if (eq? node new-node) - root - (clone-branch-and-set root idx new-node)))))) - (match bs + (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)) - ((not val) (intmap-remove bs i)) - ((not root) + ((absent? root) ;; Add first element. (make-intmap i 0 val)) ((and (<= min i) (< i (+ min (ash 1 shift)))) @@ -261,71 +273,75 @@ (let ((old-root root) (root (adjoin (- i min) shift root))) (if (eq? root old-root) - bs + map (make-intmap min shift root)))) ((< i min) ;; Rebuild the tree by unioning two intmaps. - (intmap-union (intmap-add empty-intmap i val error) bs error)) + (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 bs) i val meet)))) + (intmap-add (persistent-intmap map) i val meet)))) -(define (intmap-remove bs i) +(define (intmap-remove map i) (define (remove i shift root) (cond - ((zero? shift) #f) + ((zero? shift) *absent*) (else (let* ((shift (- shift *branch-bits*)) - (idx (logand (ash i (- shift)) *branch-mask*))) - (cond - ((vector-ref root idx) - => (lambda (node) - (let ((new-node (remove i shift node))) - (if (eq? node new-node) - root - (let ((root (clone-branch-and-set root idx new-node))) - (and (or new-node (not (branch-empty? root))) - root)))))) - (else root)))))) - (match bs + (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 - ((not root) bs) + ((absent? root) map) ((and (<= min i) (< i (+ min (ash 1 shift)))) ;; Add element to map; level will not change. - (let ((old-root root) - (root (remove (- i min) shift root))) - (if (eq? root old-root) - bs - (make-intmap/prune min shift root)))) - (else bs))) + (let ((root* (remove (- i min) shift root))) + (if (eq? root root*) + map + (make-intmap/prune min shift root*)))) + (else map))) (($ <transient-intmap>) - (intmap-remove (persistent-intmap bs) i)))) + (intmap-remove (persistent-intmap map) i)))) -(define (intmap-ref bs i) +(define* (intmap-ref map i #:optional (not-found (lambda (i) + (error "not found" i)))) (define (ref min shift root) (if (zero? shift) - (and (= i min) root) - (and (<= min i) (< i (+ min (ash 1 shift))) - (let ((i (- i min))) - (let lp ((node root) (shift shift)) - (and node - (if (= shift *branch-bits*) - (vector-ref node (logand i *branch-mask*)) - (let* ((shift (- shift *branch-bits*)) - (idx (logand (ash i (- shift)) - *branch-mask*))) - (lp (vector-ref node idx) shift))))))))) - (match bs + (if (and min (= i min) (present? root)) + root + (not-found i)) + (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 + (not-found i))) + (let* ((shift (- shift *branch-bits*)) + (idx (logand (ash i (- shift)) + *branch-mask*))) + (lp (vector-ref node idx) shift))) + (not-found i)))) + (not-found i)))) + (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 bs #:optional i) +(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*) @@ -333,7 +349,7 @@ (let ((inc (ash 1 shift))) (lp (+ (round-down i shift) inc) (1+ idx))))))) (define (visit-node node shift i) - (and node + (and (present? node) (if (zero? shift) i (visit-branch node (- shift *branch-bits*) i)))) @@ -344,21 +360,21 @@ (and (< i (ash 1 shift)) (let ((i (visit-node root shift i))) (and i (+ min i)))))) - (match bs + (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 bs #:optional i) +(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 node + (and (present? node) (if (zero? shift) i (visit-branch node (- shift *branch-bits*) i)))) @@ -369,7 +385,7 @@ (and (<= 0 i) (let ((i (visit-node root shift i))) (and i (+ min i)))))) - (match bs + (match map (($ <intmap> min shift root) (prev min shift root)) (($ <transient-intmap> min shift root edit) @@ -384,7 +400,7 @@ (if (< i *branch-size*) (let ((elt (vector-ref node i))) (lp (1+ i) - (if elt + (if (present? elt) (f (+ i min) elt seed) seed))) seed)) @@ -392,14 +408,14 @@ (if (< i *branch-size*) (let ((elt (vector-ref node i))) (lp (1+ i) - (if elt + (if (present? elt) (visit-branch elt shift (+ min (ash i shift)) seed) seed))) seed))))) (match map (($ <intmap> min shift root) (cond - ((not root) seed) + ((absent? root) seed) ((zero? shift) (f min root seed)) (else (visit-branch root shift min seed)))) (($ <transient-intmap>) @@ -455,8 +471,8 @@ (else a)))) (define (union shift a-node b-node) (cond - ((not a-node) b-node) - ((not b-node) a-node) + ((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)))) @@ -494,7 +510,7 @@ (b-child (vector-ref b i))) (vector-set! fresh i (intersect shift a-child b-child)) (lp (1+ i)))) - ((branch-empty? fresh) #f) + ((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) @@ -535,7 +551,7 @@ (else a)))) (define (intersect shift a-node b-node) (cond - ((or (not a-node) (not b-node)) #f) + ((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)))) @@ -550,31 +566,29 @@ (else (let* ((lo-shift (- lo-shift *branch-bits*)) (lo-idx (ash (- hi-min lo-min) (- lo-shift)))) - (cond - ((>= lo-idx *branch-size*) - ;; HI has a lower shift, but it not within LO. - empty-intmap) - ((vector-ref lo-root lo-idx) - => (lambda (lo-root) - (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))))) - (else empty-intmap)))))) + (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?) - (cond - ((vector-ref hi-root 0) - => (lambda (hi-root) - (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))))) - (else empty-intmap))) + (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)) |