# HG changeset patch # User Linus Björnstam # Date 1556797375 -7200 # Thu May 02 13:42:55 2019 +0200 # Node ID d0269ce64b88cf8f47f3a96818a4370047395500 # Parent 25189bfa3dc9e6cc5288b5732e9a6d012ddcc8e1 Fixed some stupid bugs, added fector-iota and fixed the indetation. diff --git a/fector.scm b/fector.scm --- a/fector.scm +++ b/fector.scm @@ -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 + (make-tail length children) + tail? + (length tail-length) + (children tail-children)) + (define-record-type (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))) (($ ) @@ -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 (($ 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))))) (($ ) (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 (($ 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) (($ ) @@ -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 (($ 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))))))))) (($ ) (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 (($ 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) (($ ) @@ -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 (($ 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))))))))) (($ ) (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 (($ 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 (($ 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))))))