perf: Phase 3 -- LSM staging buffer + tempid hashtable + fulltext O(n^2) fix
ober
b935c9a005649aeb98767c2d9f05a3c6f053f1a1
--- a/benchmarks/mbrainz-bench.ss +++ b/benchmarks/mbrainz-bench.ss @@ -144,7 +144,8 @@ (transact! conn (mbrainz-schema-ops)) ;; ---- Phase 1: artists — collect eids for later reference ---- - (let ([artist-eids '()]) + (let ([artist-eids '()] + [t-p1-start (now-ms)]) (let loop ([i 0] [batch '()]) (cond [(= i num-artists) @@ -163,8 +164,10 @@ (loop (+ i 1) '())) (loop (+ i 1) b)))])) + (displayln " Phase 1 (artists): " (inexact->exact (round (- (now-ms) t-p1-start))) " ms") ;; ---- Phase 2: releases — flat pass, batch by batch ---- - (let ([total-releases 0]) + (let ([total-releases 0] + [t-p2-start (now-ms)]) (let loop ([eids artist-eids] [batch '()]) (cond [(null? eids) @@ -189,8 +192,10 @@ (loop (cdr eids) '())) (loop (cdr eids) b)))])) + (displayln " Phase 2 (releases): " (inexact->exact (round (- (now-ms) t-p2-start))) " ms") ;; ---- Phase 3: tracks — flat pass, batch by batch ---- - (let ([total-tracks 0]) + (let ([total-tracks 0] + [t-p3-start (now-ms)]) (let loop ([eids artist-eids] [batch '()]) (cond [(null? eids) @@ -213,6 +218,7 @@ (loop (cdr eids) b)))])) + (displayln " Phase 3 (tracks): " (inexact->exact (round (- (now-ms) t-p3-start))) " ms") (list 'artists (length artist-eids) 'releases total-releases 'tracks total-tracks)))))) --- a/lib/jerboa-db/fulltext.ss +++ b/lib/jerboa-db/fulltext.ss @@ -85,17 +85,29 @@ [vt (ft-idx-value-table ft)]) ;; Remove any previous index for this key (let ([old (hashtable-ref vt key #f)]) - (when old (remove-words! wt key (tokenize old)))) - ;; Store and index new value + (when old (remove-words! wt key (unique-tokens old)))) + ;; Store and index new value. We dedupe the tokens once up front so + ;; we can safely cons key onto each word-list without an O(n) member + ;; scan per word -- previously this was the dominant cost when many + ;; entities shared common words (e.g. 131K tracks all named "Track N" + ;; produced an O(n^2) blow-up under "track"). (hashtable-set! vt key value) (for-each (lambda (word) - (let ([existing (hashtable-ref wt word '())]) - (unless (member key existing) - (hashtable-set! wt word (cons key existing))))) - (tokenize value)) + (hashtable-set! wt word (cons key (hashtable-ref wt word '())))) + (unique-tokens value)) (ft-idx-entry-count-set! ft (+ (ft-idx-entry-count ft) 1)))) + (def (unique-tokens value) + (let ([seen (make-hashtable string-hash string=?)]) + (let loop ([toks (tokenize value)] [acc '()]) + (cond + [(null? toks) (reverse acc)] + [(hashtable-ref seen (car toks) #f) (loop (cdr toks) acc)] + [else + (hashtable-set! seen (car toks) #t) + (loop (cdr toks) (cons (car toks) acc))])))) + (def (remove-value! ft eid attr-id value) (let ([key (cons eid attr-id)] [wt (ft-idx-word-table ft)] --- a/lib/jerboa-db/index/memory.ss +++ b/lib/jerboa-db/index/memory.ss @@ -141,26 +141,99 @@ (rb-fold (lambda (k v acc) (+ acc 1)) 0 tree)) ;; ---- Memory index implementation ---- + ;; + ;; LSM-style two-tier layout: a base RB-tree of flushed datoms plus a + ;; staging buffer of pending writes. `add!` is O(1) (cons); reads merge + ;; base + buffer. The buffer auto-flushes once it crosses + ;; `+staging-threshold+`, amortising the RB-tree insert cost across + ;; many datoms instead of paying it per call. + ;; + ;; This collapses the per-datom restructuring cost: previously, loading + ;; 147K datoms into 3 indices issued ~440K rb-insert calls, each doing + ;; a recursive structural copy + balance. With the buffer, the heavy + ;; work happens once per flush window rather than once per datom. + + (def +staging-threshold+ 4096) (def (make-mem-index name comparator) - (let ([tree-cell (list (rb-empty))]) ;; mutable cell + (let ([tree-cell (list (rb-empty))] ;; sorted base + [buffer-cell (list '())] ;; LIFO list of pending datoms + [bufcnt-cell (list 0)]) ;; size of buffer-cell (define (get-tree) (car tree-cell)) (define (set-tree! t) (set-car! tree-cell t)) + (define (get-buf) (car buffer-cell)) + (define (set-buf! b) (set-car! buffer-cell b)) + (define (get-bufcnt) (car bufcnt-cell)) + (define (set-bufcnt! n) (set-car! bufcnt-cell n)) + + (define (flush!) + (let ([buf (get-buf)]) + (unless (null? buf) + ;; Sort buffer descending by comparator so that rb-insert sees + ;; them in some order (tree balancing handles any order). We + ;; just need to fold them in. + (set-tree! + (fold-left + (lambda (t d) (rb-insert t d #t comparator)) + (get-tree) + buf)) + (set-buf! '()) + (set-bufcnt! 0)))) (define (add! datom) - (set-tree! (rb-insert (get-tree) datom #t comparator))) + (set-buf! (cons datom (get-buf))) + (set-bufcnt! (+ (get-bufcnt) 1)) + (when (>= (get-bufcnt) +staging-threshold+) + (flush!))) (define (remove! datom) + ;; Remove must see the unified state. Flush first. + (flush!) (set-tree! (rb-delete (get-tree) datom comparator))) + (define (in-range? d lo hi) + (and (>= (comparator d lo) 0) + (<= (comparator d hi) 0))) + + (define (buffer-in-range lo hi) + ;; Filter buffer for datoms in [lo, hi]. + (let loop ([xs (get-buf)] [acc '()]) + (cond + [(null? xs) acc] + [(in-range? (car xs) lo hi) + (loop (cdr xs) (cons (car xs) acc))] + [else (loop (cdr xs) acc)]))) + + ;; Merge two sorted-by-comparator lists, dropping duplicates. + (define (merge-sorted a b) + (let loop ([a a] [b b] [acc '()]) + (cond + [(null? a) (append (reverse acc) b)] + [(null? b) (append (reverse acc) a)] + [else + (let ([c (comparator (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))] + ;; equal — drop one + [else (loop (cdr a) (cdr b) (cons (car a) acc))]))]))) + (define (range-query start end) - (reverse - (rb-range-fold (lambda (k v acc) (cons k acc)) - '() (get-tree) start end comparator))) + (let* ([base-list (reverse + (rb-range-fold + (lambda (k v acc) (cons k acc)) + '() (get-tree) start end comparator))] + [buf-list (buffer-in-range start end)]) + (cond + [(null? buf-list) base-list] + [(null? base-list) + (list-sort (lambda (a b) (< (comparator a b) 0)) buf-list)] + [else + (merge-sorted + base-list + (list-sort (lambda (a b) (< (comparator a b) 0)) buf-list))]))) (define (seek . components) - ;; Build probe datoms from components for a prefix scan. - ;; components is an alist of known fields. (let-values ([(e a v tx) (apply values components)]) (let ([lo (make-datom (or e 0) @@ -177,12 +250,16 @@ (range-query lo hi)))) (define (count-range start end) - (rb-range-fold (lambda (k v acc) (+ acc 1)) - 0 (get-tree) start end comparator)) + ;; range-query already dedupes; safe to count its result. + (length (range-query start end))) - (define (snapshot) (get-tree)) + (define (snapshot) + (flush!) + (get-tree)) - (define (all-datoms) (rb-keys (get-tree))) + (define (all-datoms) + (flush!) + (rb-keys (get-tree))) (make-dbi name add! remove! range-query seek count-range snapshot all-datoms))) --- a/lib/jerboa-db/tx.ss +++ b/lib/jerboa-db/tx.ss @@ -67,8 +67,14 @@ [tx-id (+ (db-value-basis-tx db) 1)] [next-eid (car next-eid-cell)] [initial-next-eid (car next-eid-cell)] ;; snapshot for fresh-entity detection + ;; Hashtable for O(1) resolve; alist mirror for the tx-report. + [tempid-table (make-eqv-hashtable)] [tempid-map '()] [produced-datoms '()]) + ;; Two-step record: keep both representations in sync. + (define (record-tempid! tid eid) + (hashtable-set! tempid-table tid eid) + (set! tempid-map (cons (cons tid eid) tempid-map))) ;; --- Schema lookup cache --- ;; Avoids repeated registry scans for the same attribute within one transaction. @@ -102,13 +108,13 @@ (format "Lookup ref found no entity: ~a = ~a" attr-ident val))) found-eid))] [(tempid? raw-eid) - (let ([found (assv raw-eid tempid-map)]) + (let ([found (hashtable-ref tempid-table raw-eid #f)]) (if found - (cdr found) + found ;; Check for upsert before allocating new eid (let ([eid next-eid]) (set! next-eid (+ next-eid 1)) - (set! tempid-map (cons (cons raw-eid eid) tempid-map)) + (record-tempid! raw-eid eid) eid)))] [(not raw-eid) ;; No db/id provided — allocate fresh @@ -237,7 +243,7 @@ [upsert-eid ;; Upsert: use existing entity, map tempid if needed (when (and raw-eid (tempid? raw-eid)) - (set! tempid-map (cons (cons raw-eid upsert-eid) tempid-map))) + (record-tempid! raw-eid upsert-eid)) upsert-eid] [else (resolve-eid raw-eid)])]) ;; Process each attribute