diff options
author | Andy Wingo <wingo@pobox.com> | 2015-04-01 10:01:16 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-04-08 17:17:59 +0200 |
commit | 95db5705288c8f72cd81e52a2d94cd876dc6ea04 (patch) | |
tree | 366e74decda701fcf9f6abeb243a76c9c7955089 /module/language/cps/intmap.scm | |
parent | cf512e32687b41690ab436f13322d7a9e00094b7 (diff) | |
download | guile-95db5705288c8f72cd81e52a2d94cd876dc6ea04.tar.gz |
Add "transient" intmap interface
* module/language/cps/intmap.scm (make-atomic-reference):
(get-atomic-reference, set-atomic-reference!): New helpers.
(*branch-size-with-edit*, *edit-index*): Branches now have a trailing
field, an atomic reference to their owner.
(<transient-intmap>): New record type. A mutable intmap.
(new-branch): Set the "edit" field on the branch.
(clone-branch-and-set): No editor for this field.
(assert-readable!, writable-branch): New helpers.
(transient-intmap, persistent-intmap): New exported functions.
(intmap-add!): New function.
(intmap-next, intmap-prev, intmap-ref): Work on transient intmaps.
(intmap-fold): Persist the intmap before folding over it.
Diffstat (limited to 'module/language/cps/intmap.scm')
-rw-r--r-- | module/language/cps/intmap.scm | 202 |
1 files changed, 171 insertions, 31 deletions
diff --git a/module/language/cps/intmap.scm b/module/language/cps/intmap.scm index 948d0baba..7ab8f67da 100644 --- a/module/language/cps/intmap.scm +++ b/module/language/cps/intmap.scm @@ -32,10 +32,15 @@ (define-module (language cps intmap) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-18) #:use-module (ice-9 match) #:export (empty-intmap intmap? + transient-intmap? + persistent-intmap + transient-intmap intmap-add + intmap-add! intmap-remove intmap-ref intmap-next @@ -49,8 +54,18 @@ (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> @@ -60,20 +75,38 @@ (shift intmap-shift) (root intmap-root)) -(define (new-branch) - (make-vector *branch-size* #f)) +(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-inlinable (new-branch edit) + (let ((vec (make-vector *branch-size-with-edit* #f))) + (when edit (vector-set! vec *edit-index* edit)) + vec)) (define (clone-branch-and-set branch i elt) - (let ((new (new-branch))) + (let ((new (new-branch #f))) (when branch (vector-move-left! branch 0 *branch-size* new 0)) (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-and-set branch *edit-index* root-edit)))) (define (branch-empty? branch) (let lp ((i 0)) (or (= i *branch-size*) (and (not (vector-ref branch i)) (lp (1+ i)))))) -(define (round-down min shift) +(define-inlinable (round-down min shift) (logand min (lognot (1- (ash 1 shift))))) (define empty-intmap (make-intmap 0 0 #f)) @@ -107,6 +140,92 @@ (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*))) + (match (vector-ref root idx) + (#f (let ((v (new-branch edit))) + (vector-set! root idx v) + v)) + (v (writable-branch v edit))))) + (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)))))) + (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)) + ((not 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 bs i val #:optional (meet meet-error)) (define (adjoin i shift root) (cond @@ -145,7 +264,9 @@ (intmap-union (intmap-add empty-intmap i val error) bs error)) (else ;; Add a new level and try again. - (intmap-add (add-level min shift root) i val error)))))) + (intmap-add (add-level min shift root) i val error)))) + (($ <transient-intmap>) + (intmap-add (persistent-intmap bs) i val meet)))) (define (intmap-remove bs i) (define (remove i shift root) @@ -175,23 +296,30 @@ (if (eq? root old-root) bs (make-intmap/prune min shift root)))) - (else bs))))) + (else bs))) + (($ <transient-intmap>) + (intmap-remove (persistent-intmap bs) i)))) (define (intmap-ref bs 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 (($ <intmap> 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))))))))))) + (ref min shift root)) + (($ <transient-intmap> min shift root edit) + (assert-readable! edit) + (ref min shift root)))) (define* (intmap-next bs #:optional i) (define (visit-branch node shift i) @@ -205,14 +333,19 @@ (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 bs (($ <intmap> 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)))))))) + (next min shift root)) + (($ <transient-intmap> min shift root edit) + (assert-readable! edit) + (next min shift root)))) (define* (intmap-prev bs #:optional i) (define (visit-branch node shift i) @@ -225,14 +358,19 @@ (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 bs (($ <intmap> 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)))))))) + (prev min shift root)) + (($ <transient-intmap> min shift root edit) + (assert-readable! edit) + (prev min shift root)))) (define (intmap-fold f map seed) (define (visit-branch node shift min seed) @@ -259,7 +397,9 @@ (cond ((not root) seed) ((zero? shift) (f min root seed)) - (else (visit-branch root shift min seed)))))) + (else (visit-branch root shift min seed)))) + (($ <transient-intmap>) + (intmap-fold f (persistent-intmap map) seed)))) (define* (intmap-union a b #:optional (meet meet-error)) ;; Union A and B from index I; the result will be fresh. |