index/segtree: durable immutable segment-tree index (substrate)
ober
e2088e80dee5a2ffe48cff151f94e05f4ea2865c
new file mode 100644 --- /dev/null +++ b/lib/jerboa-db/index/segtree.ss @@ -0,0 +1,235 @@ +#!chezscheme +;;; (jerboa-db index segtree) — Durable immutable segment-tree index +;;; +;;; After Datomic's durable index (RootNode -> DirNode -> segment): a sorted +;;; datom set stored as immutable, CONTENT-ADDRESSED columnar segments in a +;;; segment store, with an in-memory directory of (min, max, seg-id, count) per +;;; leaf. Three properties this buys, all demonstrated here: +;;; +;;; * Structural sharing / O(1) snapshots — a "tree" value is just its +;;; directory of segment ids; updating rewrites only the affected leaves +;;; (new content-hash ids) and shares the rest, so an old tree value remains +;;; a valid immutable snapshot pointing at the old leaves. +;;; * Range count without decoding — leaves fully inside the range are counted +;;; from directory metadata; only boundary leaves are loaded (Datomic's +;;; DirNode counts/offsets idea). +;;; * Lazy range scans — segments load on demand, so a range + early-exit +;;; (e.g. :limit) touches only the leaves it needs. +;;; +;;; Leaves are columnar (jerboa-db segment). Segment ids are the FNV content +;;; hash of the serialized bytes, so identical leaves dedup automatically. +;;; +;;; This is the durable substrate; wiring it under the dbi protocol as the live +;;; durable backend (merged with the in-memory index) is the follow-on. + +(library (jerboa-db index segtree) + (export + make-mem-segstore segstore? segstore-size segstore-gc! + segtree-build segtree? segtree-total segtree-count + segtree-range segtree-range->list segtree->list + segtree-add segtree-live-ids + +segtree-default-seg-size+) + + (import (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time + atom? meta) + (jerboa prelude) + (jerboa-db datom) + (jerboa-db segment) + (jerboa-db encoding)) + + (def +segtree-default-seg-size+ 1024) + + ;; ---- Content-addressed segment store: id (bytevector) -> bytevector ---- + + (define-record-type segstore (fields table)) + + (def (make-mem-segstore) (make-segstore (make-hashtable equal-hash equal?))) + (def (segstore-size ss) (hashtable-size (segstore-table ss))) + + (def (segstore-put! ss bytes) + (let ([id (content-hash-bytes bytes)]) ;; content hash -> dedup + (unless (hashtable-contains? (segstore-table ss) id) + (hashtable-set! (segstore-table ss) id bytes)) + id)) + + (def (segstore-get ss id) (hashtable-ref (segstore-table ss) id #f)) + + ;; Keep only the given live ids; remove (sweep) the rest. Returns #removed. + (def (segstore-gc! ss live-ids) + (let ([keep (make-hashtable equal-hash equal?)] + [removed 0]) + (for-each (lambda (id) (hashtable-set! keep id #t)) live-ids) + (let-values ([(ks vs) (hashtable-entries (segstore-table ss))]) + (vector-for-each + (lambda (id) + (unless (hashtable-ref keep id #f) + (hashtable-delete! (segstore-table ss) id) + (set! removed (+ removed 1)))) + ks)) + removed)) + + ;; ---- Directory + tree ---- + ;; entry: #(min-datom max-datom seg-id count) + + (def (entry-min e) (vector-ref e 0)) + (def (entry-max e) (vector-ref e 1)) + (def (entry-id e) (vector-ref e 2)) + (def (entry-cnt e) (vector-ref e 3)) + + (define-record-type segtree (fields dir cmp total)) ;; dir: vector of entries + + (def (sort-datoms lst cmp) (list-sort (lambda (a b) (< (cmp a b) 0)) lst)) + + (def (chunk-list lst k) + (if (null? lst) + '() + (let loop ([l lst] [i 0] [cur '()] [acc '()]) + (cond + [(null? l) (reverse (cons (reverse cur) acc))] + [(= i k) (loop l 0 '() (cons (reverse cur) acc))] + [else (loop (cdr l) (+ i 1) (cons (car l) cur) acc)])))) + + (def (make-leaf-entry segstore chunk) + (let* ([seg (make-segment chunk)] + [id (segstore-put! segstore (segment->bytevector seg))]) + (vector (segment-min-datom seg) (segment-max-datom seg) id (segment-count seg)))) + + (def (entries->tree entries cmp) + (make-segtree (list->vector entries) cmp + (fold-left + 0 (map entry-cnt entries)))) + + ;; Build a tree from datoms (sorted internally) at the given leaf size. + (def (segtree-build segstore datoms cmp seg-size) + (entries->tree + (map (lambda (chunk) (make-leaf-entry segstore chunk)) + (chunk-list (sort-datoms datoms cmp) (max 1 seg-size))) + cmp)) + + ;; Largest dir index whose min-key <= key (0 if key precedes everything). + (def (dir-floor-index dir key cmp) + (let ([n (vector-length dir)]) + (let loop ([a 0] [b n]) + (if (= a b) + (max 0 (- a 1)) + (let ([mid (quotient (+ a b) 2)]) + (if (> (cmp (entry-min (vector-ref dir mid)) key) 0) + (loop a mid) + (loop (+ mid 1) b))))))) + + ;; ---- Range scan (lazy: '() | (cons datom (delay rest))) ---- + + (def (load-seg segstore id) (bytevector->segment (segstore-get segstore id))) + + (def (segtree-range tree segstore lo hi) + (let* ([dir (segtree-dir tree)] [cmp (segtree-cmp tree)] [n (vector-length dir)]) + (let seg-loop ([i (dir-floor-index dir lo cmp)]) + (if (or (>= i n) (> (cmp (entry-min (vector-ref dir i)) hi) 0)) + '() + (let* ([seg (load-seg segstore (entry-id (vector-ref dir i)))] + [m (segment-count seg)]) + (let dat-loop ([j 0]) + (if (>= j m) + (seg-loop (+ i 1)) + (let ([d (segment-ref seg j)]) + (cond + [(< (cmp d lo) 0) (dat-loop (+ j 1))] ;; below range + [(> (cmp d hi) 0) '()] ;; past range -> done + [else (cons d (delay (dat-loop (+ j 1)))) ]))))))))) + + (def (segtree-range->list tree segstore lo hi) + (let loop ([s (segtree-range tree segstore lo hi)] [acc '()]) + (if (null? s) (reverse acc) (loop (force (cdr s)) (cons (car s) acc))))) + + (def (universal-lo) (make-datom 0 0 +min-val+ 0 #t)) + (def (universal-hi) (make-datom (greatest-fixnum) (greatest-fixnum) +max-val+ (greatest-fixnum) #t)) + (def (segtree->list tree segstore) + (segtree-range->list tree segstore (universal-lo) (universal-hi))) + + ;; ---- Range count (interior leaves from metadata, boundaries loaded) ---- + + (def (segtree-count tree segstore lo hi) + (let* ([dir (segtree-dir tree)] [cmp (segtree-cmp tree)] [n (vector-length dir)]) + (let loop ([i (dir-floor-index dir lo cmp)] [acc 0]) + (if (or (>= i n) (> (cmp (entry-min (vector-ref dir i)) hi) 0)) + acc + (let ([e (vector-ref dir i)]) + (if (and (>= (cmp (entry-min e) lo) 0) (<= (cmp (entry-max e) hi) 0)) + (loop (+ i 1) (+ acc (entry-cnt e))) ;; fully inside: no load + (let* ([seg (load-seg segstore (entry-id e))] [m (segment-count seg)]) + (let dloop ([j 0] [c 0]) + (if (>= j m) + (loop (+ i 1) (+ acc c)) + (let ([d (segment-ref seg j)]) + (dloop (+ j 1) + (if (and (>= (cmp d lo) 0) (<= (cmp d hi) 0)) (+ c 1) c)))))))))))) + + ;; ---- Update with structural sharing (the indexing job, in miniature) ---- + + (def (segment->datoms seg) + (let ([m (segment-count seg)]) + (let loop ([j (- m 1)] [acc '()]) + (if (< j 0) acc (loop (- j 1) (cons (segment-ref seg j) acc)))))) + + (def (merge-dedup a b cmp) ;; both ascending; drop equal duplicates + (let loop ([a a] [b b] [acc '()]) + (cond + [(null? a) (append (reverse acc) b)] + [(null? b) (append (reverse acc) a)] + [else (let ([c (cmp (car a) (car b))]) + (cond [(< c 0) (loop (cdr a) b (cons (car a) acc))] + [(> c 0) (loop a (cdr b) (cons (car b) acc))] + [else (loop (cdr a) (cdr b) (cons (car a) acc))]))]))) + + ;; Add datoms, returning a NEW tree that shares every unaffected leaf id with + ;; `tree` (so `tree` stays a valid snapshot). Only leaves receiving new datoms + ;; are rewritten (new content-hash ids). + (def (segtree-add tree segstore new-datoms cmp seg-size) + (let ([dir (segtree-dir tree)]) + (cond + [(null? new-datoms) tree] + [(= (vector-length dir) 0) + (segtree-build segstore new-datoms cmp seg-size)] + [else + (let* ([sorted (sort-datoms new-datoms cmp)] + [n (vector-length dir)] + [groups (make-vector n '())] + [new-entries '()]) + ;; route each new datom to the leaf whose min-key floors it + (for-each + (lambda (d) + (let ([idx (dir-floor-index dir d cmp)]) + (vector-set! groups idx (cons d (vector-ref groups idx))))) + sorted) + ;; rebuild: keep untouched leaves (shared id), rewrite touched ones + (let loop ([i 0]) + (when (< i n) + (let ([grp (vector-ref groups i)]) + (if (null? grp) + (set! new-entries (cons (vector-ref dir i) new-entries)) + (let* ([old (segment->datoms (load-seg segstore (entry-id (vector-ref dir i))))] + [merged (merge-dedup old (sort-datoms grp cmp) cmp)]) + (for-each + (lambda (chunk) + (set! new-entries (cons (make-leaf-entry segstore chunk) new-entries))) + (chunk-list merged (max 1 seg-size)))))) + (loop (+ i 1)))) + (entries->tree (reverse new-entries) cmp))]))) + + ;; ---- GC support: the leaf ids reachable from a tree ---- + + (def (segtree-live-ids tree) + (let ([dir (segtree-dir tree)]) + (let loop ([i 0] [acc '()]) + (if (>= i (vector-length dir)) + acc + (loop (+ i 1) (cons (entry-id (vector-ref dir i)) acc)))))) + +) ;; end library --- a/tests/test-core.ss +++ b/tests/test-core.ss @@ -9,7 +9,8 @@ (jerboa-db index protocol) (jerboa-db index memory) (jerboa-db segment) - (jerboa-db query group)) + (jerboa-db query group) + (jerboa-db index segtree)) ;; ---- Test harness ---- @@ -884,6 +885,38 @@ (assert-equal (length lim) 4) (assert-true (for-all (lambda (e) (memv e all-a)) lim)))))) +(test "durable segment tree: build/range/count + snapshot sharing + gc" + (let* ([ss (make-mem-segstore)] + [cmp compare-datoms-eavt] + [ds (for/collect ([i (in-range 50)]) (make-datom i 1 i 1 #t))] + [t0 (segtree-build ss ds cmp 8)]) ;; ~7 columnar leaves of 8 + (assert-equal (segtree-total t0) 50) + (assert-equal (map datom-e (segtree->list t0 ss)) (for/collect ([i (in-range 50)]) i)) + ;; range + count over [10..19] + (let ([lo (make-datom 10 0 +min-val+ 0 #t)] + [hi (make-datom 19 (greatest-fixnum) +max-val+ (greatest-fixnum) #t)]) + (assert-equal (map datom-e (segtree-range->list t0 ss lo hi)) + (for/collect ([i (in-range 10 20)]) i)) + (assert-equal (segtree-count t0 ss lo hi) 10)) + ;; structural sharing: adding datoms yields a new tree; the old one is intact + (let ([t1 (segtree-add t0 ss (list (make-datom 100 1 100 2 #t) + (make-datom 101 1 101 2 #t)) cmp 8)]) + (assert-equal (segtree-total t1) 52) + (assert-equal (segtree-total t0) 50) ;; snapshot intact + (assert-equal (map datom-e (segtree->list t0 ss)) (for/collect ([i (in-range 50)]) i)) + (assert-true (memv 100 (map datom-e (segtree->list t1 ss)))) + (let ([shared (filter (lambda (id) (member id (segtree-live-ids t1))) + (segtree-live-ids t0))]) + (assert-true (> (length shared) 0))) ;; leaves shared + ;; GC: both roots live -> nothing freed; drop t0 -> old-only leaves swept + (let ([before (segstore-size ss)]) + (segstore-gc! ss (append (segtree-live-ids t0) (segtree-live-ids t1))) + (assert-equal (segstore-size ss) before) + (segstore-gc! ss (segtree-live-ids t1)) + (assert-true (<= (segstore-size ss) (length (segtree-live-ids t1)))) + (assert-equal (segtree-total t1) 52) + (assert-true (memv 101 (map datom-e (segtree->list t1 ss)))))))) + ;; ============================================================ ;; Report ;; ============================================================