perf: bound the value store with an LRU (entry + byte limits)
ober
1410b03b44fc3355ad422a79799ba47047569f70
--- a/lib/jerboa-db/value-store.ss +++ b/lib/jerboa-db/value-store.ss @@ -30,16 +30,108 @@ ;; ---- Record ---- + ;; The store is a bounded LRU: each entry is a node in a doubly-linked + ;; recency list (head = most recent) keyed in the hashtable by its 8-byte + ;; content hash. Puts and hits move/insert at the head and evict from the + ;; tail once the entry-count or byte limit is exceeded, so memory stays + ;; bounded by the limits instead of growing with distinct large values. + + (defstruct vs-node + (key ;; 8-byte content hash (hashtable key, kept for eviction) + entry ;; (full-hash . value) + prev next ;; LRU list links + size)) ;; accounted bytes for this entry + (defstruct vs-rec - (table ;; equal-hash hashtable: 8-byte content hash -> (full-hash . value) + (table ;; equal-hash hashtable: 8-byte content hash -> vs-node hit-count miss-count - dedup-count)) + dedup-count + head tail ;; LRU list endpoints (head = most recent) + count bytes ;; current entry count / accounted bytes + entry-limit ;; max entries (<= 0 disables the count bound) + byte-limit ;; max accounted bytes (<= 0 disables the byte bound) + evictions)) + + (def *value-store-entry-limit* 65536) + (def *value-store-byte-limit* (* 256 1024 1024)) (def (value-store? x) (vs-rec? x)) - (def (make-value-store) - (make-vs-rec (make-hashtable equal-hash equal?) 0 0 0)) + (def (make-value-store . opts) + (let ([entry-limit (if (and (pair? opts) (car opts)) + (car opts) *value-store-entry-limit*)] + [byte-limit (if (and (pair? opts) (pair? (cdr opts)) (cadr opts)) + (cadr opts) *value-store-byte-limit*)]) + (make-vs-rec (make-hashtable equal-hash equal?) 0 0 0 + #f #f 0 0 entry-limit byte-limit 0))) + + ;; ---- LRU bookkeeping ---- + + (def (vs-entry-size entry) + ;; Account the 32-byte full digest plus an estimate of the value's bytes. + (+ (bytevector-length (car entry)) + (let ([v (cdr entry)]) + (cond [(string? v) (* 2 (string-length v))] + [(bytevector? v) (bytevector-length v)] + [else 16])))) + + (def (vs-unlink! vs node) + (let ([prev (vs-node-prev node)] [next (vs-node-next node)]) + (if prev (vs-node-next-set! prev next) (vs-rec-head-set! vs next)) + (if next (vs-node-prev-set! next prev) (vs-rec-tail-set! vs prev)) + (vs-node-prev-set! node #f) + (vs-node-next-set! node #f))) + + (def (vs-link-head! vs node) + (let ([old-head (vs-rec-head vs)]) + (vs-node-prev-set! node #f) + (vs-node-next-set! node old-head) + (when old-head (vs-node-prev-set! old-head node)) + (vs-rec-head-set! vs node) + (unless (vs-rec-tail vs) (vs-rec-tail-set! vs node)))) + + (def (vs-move-head! vs node) + (unless (eq? node (vs-rec-head vs)) + (vs-unlink! vs node) + (vs-link-head! vs node))) + + (def (vs-remove! vs node count-eviction?) + (vs-unlink! vs node) + (hashtable-delete! (vs-rec-table vs) (vs-node-key node)) + (vs-rec-count-set! vs (- (vs-rec-count vs) 1)) + (vs-rec-bytes-set! vs (max 0 (- (vs-rec-bytes vs) (vs-node-size node)))) + (when count-eviction? + (vs-rec-evictions-set! vs (+ (vs-rec-evictions vs) 1)))) + + (def (vs-evict-tail! vs) + (let ([tail (vs-rec-tail vs)]) + (when tail (vs-remove! vs tail #t)))) + + (def (vs-evict-to-limits! vs) + (let loop () + (when (and (positive? (vs-rec-count vs)) + (or (and (> (vs-rec-entry-limit vs) 0) + (> (vs-rec-count vs) (vs-rec-entry-limit vs))) + (and (> (vs-rec-byte-limit vs) 0) + (> (vs-rec-bytes vs) (vs-rec-byte-limit vs))))) + (vs-evict-tail! vs) + (loop)))) + + ;; Insert a fresh entry under KEY, then evict least-recent entries until the + ;; store is back within its limits. An entry that alone exceeds the byte limit + ;; is dropped (and counted as an eviction) rather than stored. + (def (vs-insert! vs key entry) + (let ([sz (vs-entry-size entry)]) + (if (and (> (vs-rec-byte-limit vs) 0) (> sz (vs-rec-byte-limit vs))) + (vs-rec-evictions-set! vs (+ (vs-rec-evictions vs) 1)) + (begin + (let ([node (make-vs-node key entry #f #f sz)]) + (hashtable-set! (vs-rec-table vs) key node) + (vs-link-head! vs node) + (vs-rec-count-set! vs (+ (vs-rec-count vs) 1)) + (vs-rec-bytes-set! vs (+ (vs-rec-bytes vs) sz)) + (vs-evict-to-limits! vs)))))) ;; ---- Operations ---- @@ -60,40 +152,48 @@ (let ([existing (hashtable-ref (vs-rec-table vs) hash-bv #f)]) (cond [(not existing) - (hashtable-set! (vs-rec-table vs) hash-bv (cons full-bv value)) - hash-bv] - [(not (and (pair? existing) - (bytevector? (car existing)) - (= (bytevector-length (car existing)) 32))) - (error 'value-store-put! - "stored value-store entry is corrupt" - (bytevector-length hash-bv))] - [(timing-safe-equal? (car existing) full-bv) - (vs-rec-dedup-count-set! vs (+ (vs-rec-dedup-count vs) 1)) + (vs-insert! vs hash-bv (cons full-bv value)) hash-bv] [else - (error 'value-store-put! - "content-hash collision detected (8-byte slot)" - hash-bv)])))) + (let ([entry (vs-node-entry existing)]) + (cond + [(not (and (pair? entry) + (bytevector? (car entry)) + (= (bytevector-length (car entry)) 32))) + (error 'value-store-put! + "stored value-store entry is corrupt" + (bytevector-length hash-bv))] + [(timing-safe-equal? (car entry) full-bv) + (vs-rec-dedup-count-set! vs (+ (vs-rec-dedup-count vs) 1)) + (vs-move-head! vs existing) + hash-bv] + [else + (error 'value-store-put! + "content-hash collision detected (8-byte slot)" + hash-bv)]))])))) (def (value-store-get vs hash-bv) - (let ([entry (hashtable-ref (vs-rec-table vs) hash-bv #f)]) + (let ([node (hashtable-ref (vs-rec-table vs) hash-bv #f)]) (cond - [(not entry) + [(not node) (vs-rec-miss-count-set! vs (+ (vs-rec-miss-count vs) 1)) #f] - [(not (and (pair? entry) - (bytevector? (car entry)) - (= (bytevector-length (car entry)) 32))) - (error 'value-store-get "stored value-store entry is corrupt" hash-bv)] - [(timing-safe-equal? (car entry) - (content-hash-full-bytes (cdr entry))) - (vs-rec-hit-count-set! vs (+ (vs-rec-hit-count vs) 1)) - (cdr entry)] [else - (error 'value-store-get - "stored value fails full-digest verification (collision or corruption)" - hash-bv)]))) + (let ([entry (vs-node-entry node)]) + (cond + [(not (and (pair? entry) + (bytevector? (car entry)) + (= (bytevector-length (car entry)) 32))) + (error 'value-store-get "stored value-store entry is corrupt" hash-bv)] + [(timing-safe-equal? (car entry) + (content-hash-full-bytes (cdr entry))) + (vs-rec-hit-count-set! vs (+ (vs-rec-hit-count vs) 1)) + (vs-move-head! vs node) + (cdr entry)] + [else + (error 'value-store-get + "stored value fails full-digest verification (collision or corruption)" + hash-bv)]))]))) (def (value-store-has? vs hash-bv) (hashtable-contains? (vs-rec-table vs) hash-bv)) @@ -106,13 +206,24 @@ (list (cons 'entries (hashtable-size (vs-rec-table vs))) (cons 'hits (vs-rec-hit-count vs)) (cons 'misses (vs-rec-miss-count vs)) - (cons 'dedup-saves (vs-rec-dedup-count vs)))) + (cons 'dedup-saves (vs-rec-dedup-count vs)) + (cons 'evictions (vs-rec-evictions vs)) + (cons 'bytes (vs-rec-bytes vs)))) (def (value-store-test-inject-entry! vs hash-bv full-bv value) ;; Test-only: install a (8-byte-hash -> (full-hash . value)) entry with a ;; caller-chosen full digest so a self-test can simulate a content-hash ;; collision that the put/get paths would otherwise never observe against ;; real SHA-256. - (hashtable-set! (vs-rec-table vs) hash-bv (cons full-bv value))) + (let ([entry (cons full-bv value)] + [existing (hashtable-ref (vs-rec-table vs) hash-bv #f)]) + (if existing + (let ([sz (vs-entry-size entry)]) + (vs-rec-bytes-set! vs + (+ (- (vs-rec-bytes vs) (vs-node-size existing)) sz)) + (vs-node-entry-set! existing entry) + (vs-node-size-set! existing sz) + (vs-move-head! vs existing)) + (vs-insert! vs hash-bv entry)))) ) ;; end library