@@ 2,23 2,47 @@
;; Copyright 2019 Andy Wingo
;; Licensed under the Blue Oak Model license 1.0.0 (see the file LICENSE)
;;
-;; A functional vector.
+;; A functional vector implementation for guile scheme.
;; It uses 32-way trees to represent the fector, which means that the tree will never
;; become very deep, making lookups what you call "effectively O(1)". This is like
;; the persistent vectors of clojure. A fector-set or fector-push operation returns
;; a new fector, with the paths to whatever value set copied, meaning the original
;; fector is never edited. For batch operations, it provides transient fectors, that
;; speed up operations by doing the updates in place.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;
+;; Comparison to vlists
+;;;;;;;;;;;;;;;;;;;;;;;
+;; fectors and vlists have similar performance characteristics. The main difference is that
+;; fectors supports effectively O(1) updates of values in the fector, whereas vlists are limited
+;; to prepends. The length of fectors is also o(1), compared to o(logN) for vlists.
+;; In real life, this fector implementation is faster than vlists for everything but random access.
+;;
+;; Had the guile implementation of vlists supported transients the story would have been different
+;; since vlist-cons could be made very cheap (i.e: not allocating a new vlist on each cons.)
+;; This should be a trivial addition to the guile VList implementation.
+;;
+;; Fectors are also thread safe, since no internal data is mutated on push or set. Transients
+;; are guarranteed to only be usable from one thread. This may be a problem when using guile-fibers
+;; since a fiber may be re-scheduled on a different thread. If anyone has a low-cost fix
+;; for this i'd love to hear about it.
+;; TODO: why is fector-ref so much slower than vlist-ref?
+;; have a look at immer pvectors to see if there is anything they are doing except being
+;; c++.
+;; TODO: actually inline make-atomic-reference and don't rely on macros.
+;; TODO: Rewrite (cond ... (else (cond ...)).
+;; TODO: Should we allow for regular fectors in transient procedures with implicit conversion?
+;; It is comfortable, but just mixing it is bad style.
(define-module (fector)
#:use-module (srfi srfi-9)
+ #:use-module (ice-9 atomic)
#:use-module (ice-9 match)
#:export (fector?
transient-fector?
transient-fector
persistent-fector
empty-fector
- fector
make-fector
fector-length
fector-ref
@@ 31,7 55,9 @@
fector-fold
fector-fold-right
+ fector
build-fector
+ fector-iota
fector-map
fector-map!
fector-filter
@@ 44,23 70,30 @@
vector->fector
))
+
+(define-inlinable (make-atomic-reference value)
+ (make-atomic-box value))
+(define-inlinable (get-atomic-reference reference)
+ (atomic-box-ref reference))
+(define-inlinable (set-atomic-reference! reference value)
+ (atomic-box-set! reference value))
+
+
(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 <tail>
+ (make-tail length children)
+ tail?
+ (length tail-length)
+ (children tail-children))
+
(define-record-type <fector>
(make-fector length shift root tail)
fector?
@@ 88,13 121,16 @@
(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 (vector-copy branch)))
(vector-set! new i elt)
new))
+
(define-inlinable (assert-readable! root-edit)
(unless (eq? (get-atomic-reference root-edit) (current-thread))
(error "Transient fector 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)
@@ 150,7 186,7 @@
;; data structures to be persistent again.
(set-atomic-reference! edit #f)
(let* ((tail-length (compute-tail-length length))
- (tail* (make-vector tail-length #f)))
+ (tail* (make-vector tail-length #f)))
(vector-move-left! tail 0 tail-length tail* 0)
(make-fector length shift root tail)))
(($ <fector>)
@@ 194,10 230,10 @@
(define (fector-set fector i val)
(define (update-tree shift root)
(let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift)) *branch-mask*))
- (node (if (zero? shift)
- val
- (update-tree shift (vector-ref root idx)))))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (node (if (zero? shift)
+ val
+ (update-tree shift (vector-ref root idx)))))
(clone-branch-and-set root idx node)))
(match fector
(($ <fector> length shift root tail)
@@ 205,12 241,12 @@
(error "index out of range" i))
(let ((tail-offset (compute-tail-offset length)))
(cond
- ((<= tail-offset i)
- (let ((new-tail (vector-copy tail)))
- (vector-set! new-tail (- i tail-offset) val)
- (make-fector length shift root new-tail)))
- (else
- (make-fector length shift (update-tree shift root) tail)))))
+ ((<= tail-offset i)
+ (let ((new-tail (vector-copy tail)))
+ (vector-set! new-tail (- i tail-offset) val)
+ (make-fector length shift root new-tail)))
+ (else
+ (make-fector length shift (update-tree shift root) tail)))))
(($ <transient-fector>)
(fector-set (persistent-fector fector) i val))))
@@ 226,48 262,48 @@
(define (fector-push! fector val)
(define (add-tail! i shift root tail)
(let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift)) *branch-mask*)))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
(if (= shift *branch-bits*)
- (vector-set! root idx tail)
- (let* ((branch (vector-ref root idx))
- (edit (vector-ref root *edit-index*))
- (branch* (if branch
- (writable-branch branch edit)
- (new-branch edit))))
- (unless (eq? branch branch*)
- (vector-set! root idx branch*))
- (add-tail! i shift branch* tail)))))
+ (vector-set! root idx tail)
+ (let* ((branch (vector-ref root idx))
+ (edit (vector-ref root *edit-index*))
+ (branch* (if branch
+ (writable-branch branch edit)
+ (new-branch edit))))
+ (unless (eq? branch branch*)
+ (vector-set! root idx branch*))
+ (add-tail! i shift branch* tail)))))
(match fector
(($ <transient-fector> length shift root tail edit)
(assert-readable! edit)
- (let* ((tail-length (compute-tail-length length)))
+ (let ((tail-length (compute-tail-length length)))
(cond
- ((< tail-length *branch-size*)
- ;; Normal case: just add to the tail.
- (vector-set! tail tail-length val))
- (else
- ;; Tail array is full; push into tree.
- (cond
- ((= length *branch-size*)
- ;; The tail becomes the first root.
- (set-transient-fector-root! fector tail))
- ((= length (+ (ash 1 shift) *branch-size*))
- ;; Tree is full; add a level.
- (let ((root* (new-branch edit))
- (shift* (+ shift *branch-bits*)))
- (vector-set! root* 0 root)
- (set-transient-fector-root! fector root*)
- (set-transient-fector-shift! fector shift*)
- (add-tail! (- length *branch-size*) shift* root* tail)))
- (else
- (let ((root* (writable-branch root edit)))
- (unless (eq? root root*)
- (set-transient-fector-root! fector root*))
- (add-tail! (- length *branch-size*) shift root* tail))))
- ;; Make a fresh tail and add the pushed val.
- (let ((tail (new-branch edit)))
- (set-transient-fector-tail! fector tail)
- (vector-set! tail 0 val)))))
+ ((< tail-length *branch-size*)
+ ;; Normal case: just add to the tail.
+ (vector-set! tail tail-length val))
+ (else
+ ;; Tail array is full; push into tree.
+ (cond
+ ((= length *branch-size*)
+ ;; The tail becomes the first root.
+ (set-transient-fector-root! fector tail))
+ ((= length (+ (ash 1 shift) *branch-size*))
+ ;; Tree is full; add a level.
+ (let ((root* (new-branch edit))
+ (shift* (+ shift *branch-bits*)))
+ (vector-set! root* 0 root)
+ (set-transient-fector-root! fector root*)
+ (set-transient-fector-shift! fector shift*)
+ (add-tail! (- length *branch-size*) shift* root* tail)))
+ (else
+ (let ((root* (writable-branch root edit)))
+ (unless (eq? root root*)
+ (set-transient-fector-root! fector root*))
+ (add-tail! (- length *branch-size*) shift root* tail))))
+ ;; Make a fresh tail and add the pushed val.
+ (let ((tail (new-branch edit)))
+ (set-transient-fector-tail! fector tail)
+ (vector-set! tail 0 val)))))
(set-transient-fector-length! fector (1+ length))
fector)
(($ <fector>)
@@ 283,46 319,46 @@
(define (fector-push fector val)
(define (add-tail i shift root tail)
(let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift)) *branch-mask*))
- (branch (if (= shift *branch-bits*)
- tail
- (add-tail i shift
- (or (vector-ref root idx) (new-branch #f))
- tail))))
+ (idx (logand (ash i (- shift)) *branch-mask*))
+ (branch (if (= shift *branch-bits*)
+ tail
+ (add-tail i shift
+ (or (vector-ref root idx) (new-branch #f))
+ tail))))
(clone-branch-and-set root idx branch)))
(match fector
(($ <fector> length shift root tail)
- (let* ((tail-length (compute-tail-length length)))
+ (let ((tail-length (compute-tail-length length)))
(cond
- ((< tail-length *branch-size*)
- ;; Normal case: just add to the tail.
- (let ((new-tail (make-vector (1+ tail-length) #f)))
- (vector-move-left! tail 0 tail-length new-tail 0)
- (vector-set! new-tail tail-length val)
- (make-fector (1+ length) shift root new-tail)))
- (else
- ;; Tail array is full; push into tree. We have to copy the
- ;; tail, though, in order to add the trailing "edit" field.
- (let ((tail (let ((tail* (new-branch #f)))
- (vector-move-left! tail 0 *branch-size* tail* 0)
- tail*))
- (new-tail (new-branch #f)))
- ;; Go ahead and add the pushed value to the new tail.
- (vector-set! new-tail 0 val)
- (cond
- ((= length *branch-size*)
- ;; The tail becomes the first root.
- (make-fector (1+ length) shift tail new-tail))
- ((= length (+ (ash 1 shift) *branch-size*))
- ;; Tree is full; add a level.
- (let ((root* (new-branch #f))
- (shift* (+ shift *branch-bits*)))
- (vector-set! root* 0 root)
- (let ((root* (add-tail (ash 1 shift) shift* root* tail)))
- (make-fector (1+ length) shift* root* new-tail))))
- (else
- (let ((root (add-tail (- length *branch-size*) shift root tail)))
- (make-fector (1+ length) shift root new-tail)))))))))
+ ((< tail-length *branch-size*)
+ ;; Normal case: just add to the tail.
+ (let ((new-tail (make-vector (1+ tail-length) #f)))
+ (vector-move-left! tail 0 tail-length new-tail 0)
+ (vector-set! new-tail tail-length val)
+ (make-fector (1+ length) shift root new-tail)))
+ (else
+ ;; Tail array is full; push into tree. We have to copy the
+ ;; tail, though, in order to add the trailing "edit" field.
+ (let ((tail (let ((tail* (new-branch #f)))
+ (vector-move-left! tail 0 *branch-size* tail* 0)
+ tail*))
+ (new-tail (new-branch #f)))
+ ;; Go ahead and add the pushed value to the new tail.
+ (vector-set! new-tail 0 val)
+ (cond
+ ((= length *branch-size*)
+ ;; The tail becomes the first root.
+ (make-fector (1+ length) shift tail new-tail))
+ ((= length (+ (ash 1 shift) *branch-size*))
+ ;; Tree is full; add a level.
+ (let ((root* (new-branch #f))
+ (shift* (+ shift *branch-bits*)))
+ (vector-set! root* 0 root)
+ (let ((root* (add-tail (ash 1 shift) shift* root* tail)))
+ (make-fector (1+ length) shift* root* new-tail))))
+ (else
+ (let ((root (add-tail (- length *branch-size*) shift root tail)))
+ (make-fector (1+ length) shift root new-tail)))))))))
(($ <transient-fector>)
(fector-push (persistent-fector fector) val))))
@@ 332,51 368,51 @@
(define (fector-pop! fector)
(define (pop-tail! i shift root)
(let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift)) *branch-mask*)))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
(if (= shift *branch-bits*)
- (let ((tail (vector-ref root idx)))
- (vector-set! root idx #f)
- tail)
- (let* ((branch (vector-ref root idx))
- (edit (vector-ref root *edit-index*))
- (branch* (writable-branch branch edit)))
- (unless (eq? branch branch*)
- (vector-set! root idx branch*))
- (pop-tail! i shift branch*)))))
+ (let ((tail (vector-ref root idx)))
+ (vector-set! root idx #f)
+ tail)
+ (let* ((branch (vector-ref root idx))
+ (edit (vector-ref root *edit-index*))
+ (branch* (writable-branch branch edit)))
+ (unless (eq? branch branch*)
+ (vector-set! root idx branch*))
+ (pop-tail! i shift branch*)))))
(match fector
(($ <transient-fector> length shift root tail edit)
(assert-readable! edit)
(let* ((tail-length (compute-tail-length length)))
(cond
- ((< 1 tail-length)
- ;; Normal case: just clear the last entry in the tail.
- (when (zero? length)
- (error "can't pop from empty fector"))
- (vector-set! tail (1- tail-length) #f))
- (else
- ;; Tail array will be empty; pop a tail from the tree.
- (cond
- ((= length (1+ *branch-size*))
- ;; The root becomes the tail.
- (set-transient-fector-tail! fector (writable-branch root edit))
- (set-transient-fector-root! fector *empty-branch*))
- ((= length (+ (ash 1 shift) *branch-size* 1))
- ;; Shrink the tree.
- (let ((tail (let lp ((branch (vector-ref root 1))
- (shift (- shift *branch-bits*)))
- (if (= shift *branch-bits*)
- (writable-branch branch edit)
- (lp (vector-ref branch 0)
- (- shift *branch-bits*))))))
- (set-transient-fector-tail! fector tail)
- (set-transient-fector-root! fector (vector-ref root 0))
- (set-transient-fector-shift! fector (- shift *branch-bits*))))
- (else
- (let ((root* (writable-branch root edit)))
- (unless (eq? root root*)
- (set-transient-fector-root! fector root*))
- (let ((tail (pop-tail! (- length 1 *branch-size*) shift root*)))
- (set-transient-fector-tail! fector tail))))))))
+ ((< 1 tail-length)
+ ;; Normal case: just clear the last entry in the tail.
+ (when (zero? length)
+ (error "can't pop from empty fector"))
+ (vector-set! tail (1- tail-length) #f))
+ (else
+ ;; Tail array will be empty; pop a tail from the tree.
+ (cond
+ ((= length (1+ *branch-size*))
+ ;; The root becomes the tail.
+ (set-transient-fector-tail! fector (writable-branch root edit))
+ (set-transient-fector-root! fector *empty-branch*))
+ ((= length (+ (ash 1 shift) *branch-size* 1))
+ ;; Shrink the tree.
+ (let ((tail (let lp ((branch (vector-ref root 1))
+ (shift (- shift *branch-bits*)))
+ (if (= shift *branch-bits*)
+ (writable-branch branch edit)
+ (lp (vector-ref branch 0)
+ (- shift *branch-bits*))))))
+ (set-transient-fector-tail! fector tail)
+ (set-transient-fector-root! fector (vector-ref root 0))
+ (set-transient-fector-shift! fector (- shift *branch-bits*))))
+ (else
+ (let ((root* (writable-branch root edit)))
+ (unless (eq? root root*)
+ (set-transient-fector-root! fector root*))
+ (let ((tail (pop-tail! (- length 1 *branch-size*) shift root*)))
+ (set-transient-fector-tail! fector tail))))))))
(set-transient-fector-length! fector (1- length))
fector)
(($ <fector>)
@@ 386,46 422,46 @@
(define (fector-pop fector)
(define (pop-tail i shift root)
(let* ((shift (- shift *branch-bits*))
- (idx (logand (ash i (- shift)) *branch-mask*)))
+ (idx (logand (ash i (- shift)) *branch-mask*)))
(call-with-values (lambda ()
- (if (= shift *branch-bits*)
- (values #f (vector-ref root idx))
- (pop-tail i shift (vector-ref root idx))))
- (lambda (branch tail)
- (values (clone-branch-and-set root idx branch)
- tail)))))
+ (if (= shift *branch-bits*)
+ (values #f (vector-ref root idx))
+ (pop-tail i shift (vector-ref root idx))))
+ (lambda (branch tail)
+ (values (clone-branch-and-set root idx branch)
+ tail)))))
(match fector
(($ <fector> length shift root tail)
(let* ((tail-length (compute-tail-length length)))
(cond
- ((< 1 tail-length)
- ;; Normal case: just trim the tail.
- (when (zero? length)
- (error "can't pop from empty fector"))
- (let ((new-tail (make-vector (1- tail-length) #f)))
- (vector-move-left! tail 0 (1- tail-length) new-tail 0)
- (make-fector (1- length) shift root new-tail)))
- (else
- ;; Tail array will be empty; pop a tail from the tree.
- (cond
- ((= length (1+ *branch-size*))
- ;; The root becomes the tail.
- (make-fector *branch-size* *branch-bits* *empty-branch* root))
- ((= length (+ (ash 1 shift) *branch-size* 1))
- ;; Shrink the tree.
- (let ((tail (let lp ((branch (vector-ref root 1))
- (shift (- shift *branch-bits*)))
- (if (= shift *branch-bits*)
- branch
- (lp (vector-ref branch 0)
- (- shift *branch-bits*))))))
- (make-fector (1- length) (- shift *branch-bits*)
- (vector-ref root 0) tail)))
- (else
- (call-with-values (lambda ()
- (pop-tail (- length 1 *branch-size*) shift root))
- (lambda (root tail)
- (make-fector (1- length) shift root tail)))))))))
+ ((< 1 tail-length)
+ ;; Normal case: just trim the tail.
+ (when (zero? length)
+ (error "can't pop from empty fector"))
+ (let ((new-tail (make-vector (1- tail-length) #f)))
+ (vector-move-left! tail 0 (1- tail-length) new-tail 0)
+ (make-fector (1- length) shift root new-tail)))
+ (else
+ ;; Tail array will be empty; pop a tail from the tree.
+ (cond
+ ((= length (1+ *branch-size*))
+ ;; The root becomes the tail.
+ (make-fector *branch-size* *branch-bits* *empty-branch* root))
+ ((= length (+ (ash 1 shift) *branch-size* 1))
+ ;; Shrink the tree.
+ (let ((tail (let lp ((branch (vector-ref root 1))
+ (shift (- shift *branch-bits*)))
+ (if (= shift *branch-bits*)
+ branch
+ (lp (vector-ref branch 0)
+ (- shift *branch-bits*))))))
+ (make-fector (1- length) (- shift *branch-bits*)
+ (vector-ref root 0) tail)))
+ (else
+ (call-with-values (lambda ()
+ (pop-tail (- length 1 *branch-size*) shift root))
+ (lambda (root tail)
+ (make-fector (1- length) shift root tail)))))))))
(($ <transient-fector>)
(fector-pop (persistent-fector fector)))))
@@ 435,15 471,14 @@
(unless (< i length)
(error "index out of range" i))
(let ((tail-offset (compute-tail-offset length)))
- (cond
- ((<= tail-offset i) (vector-ref tail (- i tail-offset)))
- (else
- (let lp ((shift shift) (root root))
- (let* ((shift (- shift *branch-bits*)))
- (if (zero? shift)
- (vector-ref root (logand i *branch-mask*))
- (let ((idx (logand (ash i (- shift)) *branch-mask*)))
- (lp shift (vector-ref root idx))))))))))
+ (if (<= tail-offset i)
+ (vector-ref tail (- i tail-offset))
+ (let lp ((shift shift) (root root))
+ (let ((shift (- shift *branch-bits*)))
+ (if (zero? shift)
+ (vector-ref root (logand i *branch-mask*))
+ (let ((idx (logand (ash i (- shift)) *branch-mask*)))
+ (lp shift (vector-ref root idx)))))))))
(match fector
(($ <fector> length shift root tail)
(ref length shift root tail))
@@ 457,8 492,8 @@
(define (fector-fold f fector seed)
(define (visit-branch branch start end shift seed)
(let* ((shift (- shift *branch-bits*))
- (end-idx (ash (- end start 1) (- shift)))
- (inc (ash 1 shift)))
+ (end-idx (ash (- end start 1) (- shift)))
+ (inc (ash 1 shift)))
(let lp ((i 0) (start start) (seed seed))
(let ((node (vector-ref branch i)))
(if (< i end-idx)
@@ 475,7 510,7 @@
(if (< n *branch-size*)
(lp (1+ n) (f (+ start n) (vector-ref leaf n) seed))
seed)))
-
+
(match fector
(($ <fector> length shift root tail)
(let* ((tail-offset (compute-tail-offset length))
@@ 552,13 587,23 @@
(let loop ((t (transient-fector)) (i 0))
(if (= n i)
(persistent-fector t)
- (loop (fector-push t (proc i)) (1+ i)))))
+ (loop (fector-push! t (proc i)) (1+ i)))))
+
+;; Builds a fector of all integers between @var{start} to @var{end} increased by @var{step}
+(define fector-iota
+ (case-lambda
+ ((end) (fector-iota 0 end 1))
+ ((start end) (fector-iota start end 1))
+ ((start end step)
+ (let loop ((t (transient-fector)) (n start))
+ (if (>= n end)
+ (persistent-fector t)
+ (loop (fector-push! t n) (+ n step)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mapping and filtering
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
;; Applies @var{proc} to every value of @var{fector} and returns a new persistent vector.
(define (fector-map proc fector)
(fector-fold (lambda (index value result) (fector-push! result (proc value)))
@@ 589,7 634,7 @@
result)))
(persistent-fector (fector-fold f fector (transient-fector))))
-;; Returns a new persistent fector with the values of @var{f2} to @var{f}
+;; Returns a new persistent fector with the values of @var{f2} added to the end of @var{f}
(define (fector-append f f2)
(persistent-fector (fector-fold (lambda (index value result) (fector-push! result value)) f2 (transient-fector f))))
@@ 633,3 678,10 @@
(if (< n count)
(lp (1+ n) (fector-push! fec n))
(persistent-fector fec))))
+
+;;; Sums all elements in fector, just for benchmarks
+(define (benchmark-fector-ref fec)
+ (let loop ((index (1- (fector-length fec))) (sum 0))
+ (if (= -1 index)
+ sum
+ (loop (1- index) (+ sum (fector-ref fec index))))))