segtree: disk-backed (filesystem) segment store
ober
d1bc62457a4e0cee757e81a468e42d092259dc7a
new file mode 100644 --- /dev/null +++ b/benchmarks/segtree-persist-read.ss @@ -0,0 +1,9 @@ +(import (chezscheme) (jerboa-db datom) (jerboa-db index segtree)) +(define dir "/tmp/jdb-persist-demo") +(define ss (make-fs-segstore dir)) +(define rb (call-with-port (open-file-input-port (string-append dir "/root.bin")) (lambda (p) (get-bytevector-all p)))) +(define t (segtree-load rb compare-datoms-eavt)) +(define hit (segtree-range->list t ss (make-datom 500 0 +min-val+ 0 #t) + (make-datom 500 (greatest-fixnum) +max-val+ (greatest-fixnum) #t))) +(printf "REOPENED ~a datoms from disk (fresh process); e=500 -> v=~s~n" + (segtree-total t) (and (pair? hit) (datom-v (car hit)))) new file mode 100644 --- /dev/null +++ b/benchmarks/segtree-persist-write.ss @@ -0,0 +1,9 @@ +(import (chezscheme) (jerboa-db datom) (jerboa-db index segtree)) +(define dir "/tmp/jdb-persist-demo") +(when (file-exists? dir) (for-each (lambda (f) (delete-file (string-append dir "/" f))) (directory-list dir))) +(define ss (make-fs-segstore dir)) +(define ds (let loop ([i 0] [a '()]) (if (= i 1000) a (loop (+ i 1) (cons (make-datom i 1 (* i 10) 1 #t) a))))) +(define t (segtree-build ss ds compare-datoms-eavt 64)) +(call-with-port (open-file-output-port (string-append dir "/root.bin")) + (lambda (p) (put-bytevector p (segtree-save t)))) +(printf "WROTE ~a datoms -> ~a leaf files on disk~n" (segtree-total t) (segstore-size ss)) --- a/lib/jerboa-db/index/segtree.ss +++ b/lib/jerboa-db/index/segtree.ss @@ -24,10 +24,10 @@ (library (jerboa-db index segtree) (export - make-mem-segstore segstore? segstore-size segstore-gc! + make-mem-segstore make-fs-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-add segtree-live-ids segtree-save segtree-load +segtree-default-seg-size+) (import (except (chezscheme) @@ -49,32 +49,80 @@ ;; ---- 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)) + ;; A segstore is a set of operation closures, so the backing (memory or disk) + ;; is pluggable. put -> content-hash id; get id -> bytes|#f; gc live-ids -> + ;; #removed; size -> count. + (define-record-type segstore (fields put-fn get-fn gc-fn size-fn)) + (def (segstore-put! ss bytes) ((segstore-put-fn ss) bytes)) + (def (segstore-get ss id) ((segstore-get-fn ss) id)) + (def (segstore-gc! ss live-ids) ((segstore-gc-fn ss) live-ids)) + (def (segstore-size ss) ((segstore-size-fn ss))) + + ;; In-memory store (id -> bytes hashtable). + (def (make-mem-segstore) + (let ([table (make-hashtable equal-hash equal?)]) + (make-segstore + (lambda (bytes) + (let ([id (content-hash-bytes bytes)]) + (unless (hashtable-contains? table id) (hashtable-set! table id bytes)) + id)) + (lambda (id) (hashtable-ref table id #f)) + (lambda (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 table)]) + (vector-for-each + (lambda (id) (unless (hashtable-ref keep id #f) + (hashtable-delete! table id) (set! removed (+ removed 1)))) + ks)) + removed)) + (lambda () (hashtable-size table))))) + + ;; Disk store: each segment is a content-addressed file <dir>/<hexid>.seg. + ;; Content addressing makes writes idempotent and dedups identical segments. + (def (bytes->hex bv) + (let ([n (bytevector-length bv)] [digits "0123456789abcdef"]) + (let ([out (make-string (* 2 n))]) + (do ([i 0 (+ i 1)]) ((= i n) out) + (let ([b (bytevector-u8-ref bv i)]) + (string-set! out (* 2 i) (string-ref digits (quotient b 16))) + (string-set! out (+ (* 2 i) 1) (string-ref digits (remainder b 16)))))))) + (def (has-suffix? suf s) + (let ([ls (string-length s)] [lf (string-length suf)]) + (and (>= ls lf) (string=? suf (substring s (- ls lf) ls))))) + + (def (make-fs-segstore dir) + (unless (file-exists? dir) (mkdir dir)) + (let ([id->path (lambda (id) (string-append dir "/" (bytes->hex id) ".seg"))]) + (make-segstore + (lambda (bytes) + (let* ([id (content-hash-bytes bytes)] [p (id->path id)]) + (unless (file-exists? p) + (call-with-port (open-file-output-port p) + (lambda (po) (put-bytevector po bytes)))) + id)) + (lambda (id) + (let ([p (id->path id)]) + (and (file-exists? p) + (call-with-port (open-file-input-port p) + (lambda (pi) (get-bytevector-all pi)))))) + (lambda (live-ids) + (let ([keep (make-hashtable equal-hash equal?)] [removed 0]) + (for-each (lambda (id) (hashtable-set! keep (bytes->hex id) #t)) live-ids) + (for-each + (lambda (fname) + (when (has-suffix? ".seg" fname) + (let ([hex (substring fname 0 (- (string-length fname) 4))]) + (unless (hashtable-ref keep hex #f) + (delete-file (string-append dir "/" fname)) + (set! removed (+ removed 1)))))) + (directory-list dir)) + removed)) + (lambda () + (let loop ([fs (directory-list dir)] [n 0]) + (cond [(null? fs) n] + [(has-suffix? ".seg" (car fs)) (loop (cdr fs) (+ n 1))] + [else (loop (cdr fs) n)])))))) ;; ---- Directory + tree ---- ;; entry: #(min-datom max-datom seg-id count) @@ -232,4 +280,33 @@ acc (loop (+ i 1) (cons (entry-id (vector-ref dir i)) acc)))))) + ;; ---- Root persistence ---- + ;; The leaf bytes live in the segment store; this serialises just the + ;; directory (total + per-leaf min/max/id/count) so a tree can be reopened + ;; against the same store. Datoms are decomposed to plain lists so the blob is + ;; portable across processes (no record-rtd dependency); the comparator is + ;; supplied on load (the caller knows which index it is). + (def (segtree-save tree) + (let-values ([(port extract) (open-bytevector-output-port)]) + (fasl-write + (vector (segtree-total tree) + (vector-map (lambda (e) + (vector (datom->list (entry-min e)) + (datom->list (entry-max e)) + (entry-id e) (entry-cnt e))) + (segtree-dir tree))) + port) + (extract))) + + (def (segtree-load bytes cmp) + (let* ([saved (fasl-read (open-bytevector-input-port bytes))] + [total (vector-ref saved 0)] + [dir (vector-map + (lambda (se) + (vector (apply make-datom (vector-ref se 0)) + (apply make-datom (vector-ref se 1)) + (vector-ref se 2) (vector-ref se 3))) + (vector-ref saved 1))]) + (make-segtree dir cmp total))) + ) ;; end library --- a/tests/test-core.ss +++ b/tests/test-core.ss @@ -945,6 +945,28 @@ (transact! conn (list `(db/retract ,eid p/age 999))) (assert-equal (q '((find ?a) (in $ ?e) (where (?e p/age ?a))) (db conn) eid) '())))) +(test "disk-backed segment store: leaves persist + tree reopens from disk" + (let* ([dir "/tmp/jdb-segtree-test"] + [ss (make-fs-segstore dir)] + [cmp compare-datoms-eavt] + [ds (for/collect ([i (in-range 40)]) (make-datom i 1 i 1 #t))] + [t (segtree-build ss ds cmp 8)]) + (assert-true (> (segstore-size ss) 0)) ;; leaves are real files on disk + ;; reopen: reload the saved root + a FRESH store handle over the same dir + (let* ([t2 (segtree-load (segtree-save t) cmp)] + [ss2 (make-fs-segstore dir)]) + (assert-equal (segtree-total t2) 40) + ;; reading the tree pulls every leaf back off disk through ss2 + (assert-equal (map datom-e (segtree->list t2 ss2)) (for/collect ([i (in-range 40)]) i)) + (assert-equal (segtree-count t2 ss2 + (make-datom 10 0 +min-val+ 0 #t) + (make-datom 19 (greatest-fixnum) +max-val+ (greatest-fixnum) #t)) 10) + ;; on-disk GC: keep all live -> nothing swept; empty live set -> files removed + (segstore-gc! ss2 (segtree-live-ids t2)) + (assert-true (> (segstore-size ss2) 0)) + (segstore-gc! ss2 '()) + (assert-equal (segstore-size ss2) 0)))) + ;; ============================================================ ;; Report ;; ============================================================