feat: Phase 5 — close remaining Datomic API gaps
ober
4b9106cb984152ac67b25139e91d2a1a2744ab7a
--- a/lib/jerboa-db/backup.ss +++ b/lib/jerboa-db/backup.ss @@ -195,13 +195,15 @@ +first-user-attr-id+ datom-list)]) ;; Build the initial db-value - (let* ([initial-db (make-db-value basis-tx indices schema #f #f #f)] + (let* ([initial-db (make-db-value basis-tx indices schema #f #f #f #f)] [conn (make-connection initial-db (list (+ max-eid 1)) '() (new-db-cache 10000) ":memory:" + #f ;; db-handles + #f ;; fulltext-index #f)]) conn)))))) --- a/lib/jerboa-db/core.ss +++ b/lib/jerboa-db/core.ss @@ -48,11 +48,19 @@ make-value-store value-store-put! value-store-get value-store-has? value-store-close value-store-stats + ;; Transaction log navigation + log log? log-tx-range log-tx-list + + ;; Index range and seek + index-range seek-datoms + ;; Internal constructors (used by backup/restore) make-connection new-db-cache connection-current-db-set! connection-next-eid connection-next-eid-set! connection-fulltext-index + connection-tx-log + connection-db-stats ;; Analytics (DuckDB-backed OLAP) analytics-export! analytics-query analytics-close! @@ -68,6 +76,7 @@ iota 1+ 1- partition make-date make-time + log atom? meta) (jerboa prelude) (jerboa-db datom) @@ -83,7 +92,9 @@ (jerboa-db fulltext) (jerboa-db gc) (jerboa-db spec) - (jerboa-db value-store)) + (jerboa-db value-store) + (jerboa-db log) + (jerboa-db stats)) ;; ---- Connection ---- ;; A connection holds the mutable state: current db-value, entity counter, @@ -96,7 +107,8 @@ db-cache ;; LRU cache path ;; storage path (":memory:" for in-memory) db-handles ;; LevelDB handles for cleanup (#f for in-memory) - fulltext-index)) ;; in-memory fulltext inverted index + fulltext-index ;; in-memory fulltext inverted index + db-stats)) ;; db-stats record: per-attribute datom counts ;; ---- connect ---- ;; path = ":memory:" → in-memory RB-tree indices @@ -125,7 +137,8 @@ (ensure-leveldb!) (leveldb-make-index-set path)))]) (let* ([schema (new-schema-registry)] - [initial-db (make-db-value 0 indices schema #f #f #f)] + [stats (make-db-stats)] + [initial-db (make-db-value 0 indices schema #f #f #f stats)] [conn (make-connection initial-db (list +first-user-attr-id+) @@ -133,7 +146,8 @@ (new-db-cache 10000) path handles - (make-fulltext-index))]) + (make-fulltext-index) + stats)]) conn))) ;; ---- close ---- @@ -160,16 +174,29 @@ ;; Update schema if schema attributes were transacted (materialize-schema-datoms! (db-value-schema (tx-report-db-after report)) (tx-report-tx-data report)) - ;; Update connection state - (connection-current-db-set! conn (tx-report-db-after report)) - (connection-tx-log-set! conn (cons report (connection-tx-log conn))) - ;; Clear entity cache (conservative — could be smarter) - (cache-clear! (connection-db-cache conn)) - ;; Update fulltext index with new datoms - (fulltext-index-datoms! (connection-fulltext-index conn) - (db-value-schema (tx-report-db-after report)) - (tx-report-tx-data report)) - report)) + ;; Update per-attribute statistics incrementally + (let* ([stats (connection-db-stats conn)] + [db-after-raw (tx-report-db-after report)] + ;; Attach live stats to the new db-value so queries can use them + [db-after (make-db-value + (db-value-basis-tx db-after-raw) + (db-value-indices db-after-raw) + (db-value-schema db-after-raw) + (db-value-as-of-tx db-after-raw) + (db-value-since-tx db-after-raw) + (db-value-history? db-after-raw) + stats)]) + (db-stats-update! stats (tx-report-tx-data report)) + ;; Update connection state + (connection-current-db-set! conn db-after) + (connection-tx-log-set! conn (cons report (connection-tx-log conn))) + ;; Clear entity cache (conservative — could be smarter) + (cache-clear! (connection-db-cache conn)) + ;; Update fulltext index with new datoms + (fulltext-index-datoms! (connection-fulltext-index conn) + (db-value-schema db-after) + (tx-report-tx-data report)) + report))) ;; ---- Schema materialization ---- ;; When datoms define schema attributes, materialize them into the registry. @@ -256,6 +283,14 @@ tx-data)]) (loop (cdr log) (append matching result))))))) + ;; ---- Transaction log navigation (log API) ---- + + (def (log conn) + "Return a navigable log-handle wrapping conn's transaction history." + (make-log-handle (connection-tx-log conn))) + + ;; log?, log-tx-list, log-tx-range are re-exported directly from (jerboa-db log) + ;; ---- Utilities ---- (def (db-stats conn) @@ -375,6 +410,34 @@ (datom-added? d))) raw)))))) + ;; ---- index-range ---- + ;; (index-range db attr-ident start end) + ;; Returns AVET datoms for attr whose value is in [start, end] (both inclusive). + ;; Either start or end may be #f for open-ended ranges. + + (def (index-range db attr-ident start end) + (let* ([schema (db-value-schema db)] + [attr (schema-lookup-by-ident schema attr-ident)] + [aid (if attr (db-attribute-id attr) + (error 'index-range "Unknown attribute" attr-ident))] + [idx (db-resolve-index db 'avet)] + [lo (make-datom 0 aid (if start start +min-val+) 0 #t)] + [hi (make-datom (greatest-fixnum) aid + (if end end +max-val+) (greatest-fixnum) #t)] + [raw (dbi-range idx lo hi)]) + (filter (lambda (d) + (and (db-filter-datom? db d) + (datom-added? d))) + raw))) + + ;; ---- seek-datoms ---- + ;; (seek-datoms db index-name components...) + ;; Like datoms but semantically a positioned scan — delegates to datoms. + ;; Returns all datoms matching the given component prefix. + + (def (seek-datoms db index-name . components) + (apply datoms db index-name components)) + ;; ---- Fulltext search ---- ;; Search for text in fulltext-indexed attributes on this connection. --- a/lib/jerboa-db/history.ss +++ b/lib/jerboa-db/history.ss @@ -12,6 +12,7 @@ make-db-value db-value? db-value-basis-tx db-value-indices db-value-schema db-value-as-of-tx db-value-since-tx db-value-history? + db-value-stats ;; Time-travel constructors as-of since history @@ -42,7 +43,8 @@ schema ;; schema-registry at this point in time as-of-tx ;; #f for current, or tx-id for time-travel since-tx ;; #f for current, or tx-id for since filter - history?)) ;; #t to include retracted datoms + history? ;; #t to include retracted datoms + stats)) ;; db-stats record (per-attribute datom counts), or #f ;; ---- Time-travel constructors ---- @@ -54,7 +56,8 @@ (db-value-schema db) tx-id (db-value-since-tx db) - (db-value-history? db))) + (db-value-history? db) + (db-value-stats db))) ;; Return db showing only datoms added after tx-id (def (since db tx-id) @@ -64,7 +67,8 @@ (db-value-schema db) (db-value-as-of-tx db) tx-id - (db-value-history? db))) + (db-value-history? db) + (db-value-stats db))) ;; Return db showing all datoms including retracted ones (def (history db) @@ -74,7 +78,8 @@ (db-value-schema db) (db-value-as-of-tx db) (db-value-since-tx db) - #t)) + #t + (db-value-stats db))) ;; ---- Datom filtering ---- new file mode 100644 --- /dev/null +++ b/lib/jerboa-db/log.ss @@ -0,0 +1,46 @@ +#!chezscheme +;;; (jerboa-db log) — Transaction log navigation API +;;; +;;; Provides log-handle, a navigable wrapper over a connection's tx-log list, +;;; matching Datomic's (d/log conn) API. +;;; +;;; Note: (log conn) is defined in (jerboa-db core) which wraps this library. +;;; This library operates on a tx-report list; core.ss extracts it from the conn. + +(library (jerboa-db log) + (export make-log-handle log-handle? log-handle-tx-log + log? log-tx-range log-tx-list) + + (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 tx) + (jerboa-db history)) + + (defstruct log-handle (tx-log)) + + (def (log? x) (log-handle? x)) + + ;; Return all tx-reports as a list (most recent first) + (def (log-tx-list lh) + (log-handle-tx-log lh)) + + ;; (log-tx-range lh start end) — returns tx-reports whose tx-id is in [start, end] + ;; start/end: tx integer IDs, or #f for open-ended + (def (log-tx-range lh start end) + (filter + (lambda (report) + (let ([tx-id (db-value-basis-tx (tx-report-db-after report))]) + (and (or (not start) (>= tx-id start)) + (or (not end) (<= tx-id end))))) + (log-tx-list lh))) + +) ;; end library --- a/lib/jerboa-db/migrate.ss +++ b/lib/jerboa-db/migrate.ss @@ -6,9 +6,10 @@ (library (jerboa-db migrate) (export - migrate! migration? + migrate! migration? make-migration make-rename-attr make-add-index make-remove-index make-merge-attr make-split-attr + make-retype-attr make-delete-attr migration-plan migration-dry-run ;; Online reindexing @@ -23,6 +24,7 @@ iota 1+ 1- partition make-date make-time + log atom? meta) (jerboa prelude) (jerboa-db datom) @@ -52,6 +54,12 @@ (define-record-type split-op (fields from-attr into-a into-b split-fn)) + (define-record-type retype-op + (fields attr-ident new-type coerce-fn)) + + (define-record-type delete-attr-op + (fields attr-ident)) + ;; ---- Convenience constructors ---- (def (make-rename-attr from to) (make-rename-op from to)) @@ -59,6 +67,10 @@ (def (make-remove-index attr) (make-remove-index-op attr)) (def (make-merge-attr from into fn) (make-merge-op from into fn)) (def (make-split-attr from a b fn) (make-split-op from a b fn)) + (def (make-retype-attr attr new-type coerce-fn) + (make-retype-op attr new-type coerce-fn)) + (def (make-delete-attr attr) + (make-delete-attr-op attr)) ;; ---- Execute migration ---- @@ -84,6 +96,13 @@ (migrate-split! conn schema (split-op-from-attr op) (split-op-into-a op) (split-op-into-b op) (split-op-split-fn op))] + [(retype-op? op) + (migrate-retype! conn schema + (retype-op-attr-ident op) + (retype-op-new-type op) + (retype-op-coerce-fn op))] + [(delete-attr-op? op) + (migrate-delete-attr! conn schema (delete-attr-op-attr-ident op))] [else (error 'migrate! "Unknown migration op" op)])) ops))) @@ -165,6 +184,92 @@ (,into-b . ,vb)))) results))))) + ;; ---- Schema entity lookup helper ---- + + (def (find-schema-entity-eid conn ident) + ;; Find the entity ID for a schema attribute by its db/ident value. + ;; Returns the EID or #f if not found. + (let ([results (q `((find ?e) + (in $ ?ident) + (where (?e db/ident ?ident))) + (db conn) ident)]) + (and (pair? results) (caar results)))) + + ;; ---- migrate-retype! ---- + + (def (migrate-retype! conn schema attr-ident new-type coerce-fn) + ;; Step 1: Validate the attribute exists + (let ([attr (schema-lookup-by-ident schema attr-ident)]) + (unless attr + (error 'migrate-retype! "Attribute not found" attr-ident)) + ;; Step 2: Query all current (entity, value) pairs for this attribute + (let ([results (q `((find ?e ?v) + (where (?e ,attr-ident ?v))) + (db conn))]) + ;; Step 3: Validate that coerce-fn works for all values (safety check before + ;; any data is changed — fail fast before touching anything) + (for-each + (lambda (row) + (let ([v (cadr row)]) + (guard (exn [#t (error 'migrate-retype! + (format "coerce-fn failed for value ~a: ~a" + v (with-output-to-string + (lambda () (display-condition exn)))) + attr-ident)]) + (coerce-fn v)))) + results) + ;; Step 4: Retract all existing values (using the old type, which is fine + ;; since db/retract does not validate value types) + (when (pair? results) + (transact! conn + (map (lambda (row) + `(db/retract ,(car row) ,attr-ident ,(cadr row))) + results))) + ;; Step 5: Update the schema attribute's value-type BEFORE asserting new values. + ;; We must include db/ident in this transaction so that materialize-schema-datoms! + ;; fires and updates the in-memory schema registry (it only triggers on db/ident datoms). + (transact! conn + (list `((db/ident . ,attr-ident) + (db/valueType . ,new-type) + (db/cardinality . ,(db-attribute-cardinality attr))))) + ;; Step 6: Assert new coerced values (schema is now the new type) + (when (pair? results) + (transact! conn + (map (lambda (row) + `((db/id . ,(car row)) + (,attr-ident . ,(coerce-fn (cadr row))))) + results))) + ;; Step 7: Rebuild AVET for the attribute if it is indexed + (let* ([new-schema (db-value-schema (db conn))] + [new-attr (schema-lookup-by-ident new-schema attr-ident)]) + (when (and new-attr + (or (db-attribute-index? new-attr) + (db-attribute-unique new-attr))) + (reindex-attribute! conn attr-ident))) + (length results)))) + + ;; ---- migrate-delete-attr! ---- + + (def (migrate-delete-attr! conn schema attr-ident) + ;; Step 1: Validate the attribute exists + (let ([attr (schema-lookup-by-ident schema attr-ident)]) + (unless attr + (error 'migrate-delete-attr! "Attribute not found" attr-ident)) + ;; Step 2: Query all entities that have this attribute + (let ([results (q `((find ?e ?v) (where (?e ,attr-ident ?v))) + (db conn))]) + ;; Step 3: Retract all data datoms for this attribute + (when (pair? results) + (transact! conn + (map (lambda (row) + `(db/retract ,(car row) ,attr-ident ,(cadr row))) + results))) + ;; Step 4: Retract the schema entity for this attribute + (let ([schema-eid (find-schema-entity-eid conn attr-ident)]) + (when schema-eid + (transact! conn (list `(db/retractEntity ,schema-eid))))) + (length results)))) + ;; ---- Planning and dry-run ---- (def (migration-plan migration-obj) @@ -182,15 +287,50 @@ [(split-op? op) (format "SPLIT ~a into ~a, ~a" (split-op-from-attr op) (split-op-into-a op) (split-op-into-b op))] + [(retype-op? op) + (format "RETYPE ~a -> ~a" (retype-op-attr-ident op) (retype-op-new-type op))] + [(delete-attr-op? op) + (format "DELETE ATTRIBUTE ~a (all datoms will be retracted)" + (delete-attr-op-attr-ident op))] [else "UNKNOWN"])) (migration-operations migration-obj))) (def (migration-dry-run conn migration-obj) - ;; Report what would change without executing - (let ([plan (migration-plan migration-obj)]) - (display "Migration plan:\n") - (for-each (lambda (step) (display (format " ~a\n" step))) plan) - plan)) + ;; Report what would change without executing. + ;; Returns a list of descriptors; each descriptor includes an 'affects N datoms' + ;; count for operations that touch data. + (map + (lambda (op) + (cond + [(rename-op? op) + (let ([count (length (q `((find ?e ?v) + (where (?e ,(rename-op-from-attr op) ?v))) + (db conn)))]) + (list 'rename (rename-op-from-attr op) '-> (rename-op-to-attr op) + 'affects count 'datoms))] + [(retype-op? op) + (let ([count (length (q `((find ?e ?v) + (where (?e ,(retype-op-attr-ident op) ?v))) + (db conn)))]) + (list 'retype (retype-op-attr-ident op) '-> (retype-op-new-type op) + 'affects count 'datoms))] + [(delete-attr-op? op) + (let ([count (length (q `((find ?e ?v) + (where (?e ,(delete-attr-op-attr-ident op) ?v))) + (db conn)))]) + (list 'delete (delete-attr-op-attr-ident op) + 'affects count 'datoms))] + [(add-index-op? op) + (list 'add-index (add-index-op-attr-ident op))] + [(remove-index-op? op) + (list 'remove-index (remove-index-op-attr-ident op))] + [(merge-op? op) + (list 'merge (merge-op-from-attr op) 'into (merge-op-into-attr op))] + [(split-op? op) + (list 'split (split-op-from-attr op) 'into + (split-op-into-a op) (split-op-into-b op))] + [else (list 'unknown op)])) + (migration-operations migration-obj))) ;; ---- Online reindexing ---- --- a/lib/jerboa-db/query/aggregates.ss +++ b/lib/jerboa-db/query/aggregates.ss @@ -39,6 +39,16 @@ ;; ---- Built-in aggregates ---- + ;; Welford one-pass variance helper (pure function, no state) + (def (welford-variance vals bessel?) + (let* ([nums (filter number? vals)] + [n (length nums)]) + (if (< n 2) 0.0 + (let* ([mean (/ (apply + nums) n)] + [ss (apply + (map (lambda (x) (let ([d (- x mean)]) (* d d))) nums))] + [denom (if bessel? (- n 1) n)]) + (inexact (/ ss denom)))))) + ;; count: number of values (register-aggregate! 'count length) @@ -110,4 +120,20 @@ (register-aggregate! 'rand (lambda (vs) vs)) ;; alias for sample + ;; population variance (Datomic-compatible default) + (register-aggregate! 'variance + (lambda (vs) (welford-variance vs #f))) + + ;; sample variance (Bessel-corrected, n-1 denominator) + (register-aggregate! 'variance-sample + (lambda (vs) (welford-variance vs #t))) + + ;; population stddev + (register-aggregate! 'stddev + (lambda (vs) (sqrt (welford-variance vs #f)))) + + ;; sample stddev + (register-aggregate! 'stddev-sample + (lambda (vs) (sqrt (welford-variance vs #t)))) + ) ;; end library --- a/lib/jerboa-db/query/engine.ss +++ b/lib/jerboa-db/query/engine.ss @@ -280,6 +280,14 @@ ;; (not sub-clause ...) — negation (and (pair? clause) (eq? (car clause) 'not))) + (def (not-join-clause? clause) + ;; (not-join [?e ?x ...] sub-clause ...) + (and (pair? clause) + (eq? (car clause) 'not-join) + (pair? (cdr clause)) + (list? (cadr clause)) ;; join-vars list + (pair? (cddr clause)))) ;; at least one sub-clause + (def (or-clause? clause) ;; (or alt1 alt2 ...) — disjunction (and (pair? clause) (eq? (car clause) 'or))) @@ -483,6 +491,8 @@ (cond [(not-clause? clause) (evaluate-not-clause db clause bindings schema rules-ht)] + [(not-join-clause? clause) + (evaluate-not-join-clause db clause bindings schema rules-ht)] [(or-clause? clause) (evaluate-or-clause db clause bindings schema rules-ht)] [(data-pattern? clause) @@ -519,6 +529,29 @@ (list bindings) ;; not matched -> keep this binding '()))) ;; matched -> exclude + ;; ---- Not-join clause evaluation ---- + ;; (not-join [?e ?x ...] sub-clause ...) — like not, but only the listed + ;; join vars cross into the sub-query; other vars inside are local. + + (def (evaluate-not-join-clause db clause bindings schema rules-ht) + (let* ([join-vars (cadr clause)] + [sub-clauses (cddr clause)] + ;; Build restricted bindings containing ONLY the join vars + [restricted (let ([new-ht (make-hashtable symbol-hash eq?)]) + (for-each + (lambda (v) + (let ([val (binding-ref bindings v)]) + (when val (hashtable-set! new-ht v val)))) + join-vars) + new-ht)] + ;; Evaluate sub-clauses from the restricted binding set only + [results (evaluate-where-clauses db sub-clauses + (list restricted) schema rules-ht)]) + ;; If sub-query produced results → exclude this outer binding + (if (null? results) + (list bindings) ;; not matched → keep + '()))) + ;; ---- Or clause evaluation ---- ;; (or alt1 alt2 ...) — union of bindings from each alternative. @@ -554,7 +587,7 @@ ;; for count/sum/avg/min/max (only 3 group objects for Q8's 655K rows). (def (streamable-aggregate? name) - (memq name '(count sum avg min max))) + (memq name '(count sum avg min max variance variance-sample stddev stddev-sample))) (def (init-agg-acc name) (case name @@ -562,7 +595,9 @@ [(sum) (vector 0)] [(avg) (vector 0 0)] ;; #(sum count) [(min) (vector #f)] - [(max) (vector #f)])) + [(max) (vector #f)] + [(variance variance-sample stddev stddev-sample) + (vector 0 0.0 0.0)])) (def (update-agg-acc! name acc val) (case name @@ -586,7 +621,18 @@ (when (or (not cur) (and (number? val) (number? cur) (> val cur)) (and (string? val) (string? cur) (string>? val cur))) - (vector-set! acc 0 val)))])) + (vector-set! acc 0 val)))] + [(variance variance-sample stddev stddev-sample) + (when (number? val) + (let* ([n (+ (vector-ref acc 0) 1)] + [x (inexact val)] + [delta (- x (vector-ref acc 1))] + [mean (+ (vector-ref acc 1) (/ delta n))] + [delta2 (- x mean)] + [M2 (+ (vector-ref acc 2) (* delta delta2))]) + (vector-set! acc 0 n) + (vector-set! acc 1 mean) + (vector-set! acc 2 M2)))])) (def (finalize-agg-acc name acc) (case name @@ -594,6 +640,18 @@ (let ([cnt (vector-ref acc 1)]) (if (= cnt 0) 0 (inexact (/ (vector-ref acc 0) cnt))))] + [(variance) + (let ([n (vector-ref acc 0)] [M2 (vector-ref acc 2)]) + (if (< n 1) 0.0 (/ M2 n)))] + [(variance-sample) + (let ([n (vector-ref acc 0)] [M2 (vector-ref acc 2)]) + (if (< n 2) 0.0 (/ M2 (- n 1))))] + [(stddev) + (let ([n (vector-ref acc 0)] [M2 (vector-ref acc 2)]) + (if (< n 1) 0.0 (sqrt (/ M2 n))))] + [(stddev-sample) + (let ([n (vector-ref acc 0)] [M2 (vector-ref acc 2)]) + (if (< n 2) 0.0 (sqrt (/ M2 (- n 1)))))] [else (vector-ref acc 0)])) (def (streaming-aggregate find-vars grouping-vars agg-specs bindings-list) @@ -719,6 +777,82 @@ (hashtable-set! ht r #t) (loop (cdr rs) (cons r out))))))))) + ;; ---- Hash-join execution ---- + + (def (merge-bindings b1 b2) + ;; Merge two binding hashtables; combined keys from both. + ;; Values in b2 override b1 on conflict (shouldn't conflict on non-join vars). + (let ([new-ht (hashtable-copy b1 #t)]) + (let-values ([(keys vals) (hashtable-entries b2)]) + (vector-for-each (lambda (k v) (hashtable-set! new-ht k v)) keys vals)) + new-ht)) + + (def (evaluate-hash-join db ca cb join-vars bindings-list schema) + ;; Step 1: evaluate ca from current bindings → side-A + (let* ([side-a (let loop ([lst bindings-list] [acc '()]) + (if (null? lst) + (reverse acc) + (loop (cdr lst) + (append (reverse + (evaluate-single-clause db ca (car lst) schema #f)) + acc))))] + ;; Step 2: build probe table HT[join-key] → list of side-A bindings + [ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (b) + (let ([key (map (lambda (v) (binding-ref b v)) join-vars)]) + (hashtable-update! ht key + (lambda (existing) (cons b existing)) + '()))) + side-a) + ;; Step 3: evaluate cb from current bindings → side-B + (let ([side-b (let loop ([lst bindings-list] [acc '()]) + (if (null? lst) + (reverse acc) + (loop (cdr lst) + (append (reverse + (evaluate-single-clause db cb (car lst) schema #f)) + acc))))]) + ;; Step 4: probe — for each side-B binding, find matching side-A bindings + (let loop ([lst side-b] [acc '()]) + (if (null? lst) + (reverse acc) + (let* ([b-binding (car lst)] + [key (map (lambda (v) (binding-ref b-binding v)) join-vars)] + [matches (hashtable-ref ht key '())]) + (loop (cdr lst) + (append (reverse + (map (lambda (a-binding) + (merge-bindings a-binding b-binding)) + matches)) + acc)))))))) + + (def (evaluate-plan db hj-plan bindings-list schema rules-ht) + (if (null? hj-plan) + bindings-list + (let* ([step (car hj-plan)] + [rest (cdr hj-plan)] + [step-type (car step)] + [new-bindings + (cond + [(eq? step-type 'sequential) + (let ([clause (cadr step)]) + (let loop ([lst bindings-list] [acc '()]) + (if (null? lst) + (reverse acc) + (loop (cdr lst) + (append (reverse + (evaluate-single-clause + db clause (car lst) schema rules-ht)) + acc)))))] + [(eq? step-type 'hash-join) + (evaluate-hash-join db (cadr step) (caddr step) (cadddr step) + bindings-list schema)] + [else (error 'evaluate-plan "Unknown step type" step-type)])]) + (if (null? new-bindings) + '() + (evaluate-plan db rest new-bindings schema rules-ht))))) + ;; ---- Top-level query function ---- (def (query-db parsed db . inputs) @@ -802,14 +936,23 @@ ;; input-bindings is now a list of binding-sets [bound-at-start (if (null? input-bindings) '() (vector->list (hashtable-keys (car input-bindings))))] - [ordered-clauses (reorder-clauses where-clauses bound-at-start schema)] + [db-stats (db-value-stats db)] + [ordered-clauses (reorder-clauses where-clauses bound-at-start schema db-stats)] ;; Compute live variable sets for projection pushdown [live-vars-steps (compute-live-vars-at-each-step ordered-clauses find-vars)] - ;; Execute + ;; Compute hash-join plan for top-level clause execution + [hj-plan (hash-join-plan ordered-clauses bound-at-start schema)] + ;; Execute: use evaluate-plan for top-level (hash-join aware), + ;; evaluate-where-clauses is kept for recursive sub-query calls. + ;; If hash-join plan has any hash-join steps, use evaluate-plan. + ;; Otherwise fall through to the projection-aware evaluate-where-clauses. + [has-hash-joins? (exists (lambda (s) (eq? (car s) 'hash-join)) hj-plan)] [result-bindings - (evaluate-where-clauses db ordered-clauses - input-bindings schema rules-from-input - live-vars-steps)]) + (if has-hash-joins? + (evaluate-plan db hj-plan input-bindings schema rules-from-input) + (evaluate-where-clauses db ordered-clauses + input-bindings schema rules-from-input + live-vars-steps))]) (extract-find-results find-vars result-bindings))) ;; Helper: find position of element in list @@ -845,7 +988,8 @@ (loop (cdr ivs) (cdr inps) (append vars bound)))] [else (loop (cdr ivs) (cdr inps) (cons (car ivs) bound))]))] - [ordered-clauses (reorder-clauses where-clauses bound-at-start schema)]) + [db-stats (db-value-stats db-val)] + [ordered-clauses (reorder-clauses where-clauses bound-at-start schema db-stats)]) ;; Build plan: for each clause, describe it and the chosen index (let build-plan ([clauses ordered-clauses] [bound bound-at-start] [plan '()]) (if (null? clauses) --- a/lib/jerboa-db/query/planner.ss +++ b/lib/jerboa-db/query/planner.ss @@ -9,7 +9,8 @@ reorder-clauses choose-index clause-bound-vars clause-used-vars score-clause - compute-live-vars-at-each-step) + compute-live-vars-at-each-step + hash-join-plan) (import (except (chezscheme) make-hash-table hash-table? @@ -22,7 +23,8 @@ make-date make-time atom? meta) (jerboa prelude) - (jerboa-db schema)) + (jerboa-db schema) + (jerboa-db stats)) ;; ---- Variable detection ---- @@ -32,6 +34,15 @@ (and (> (string-length s) 0) (char=? (string-ref s 0) #\?))))) + ;; A data pattern: (something attr-symbol something ...) + ;; First element is a var or literal, second is a non-logic-var symbol (attribute) + (def (data-pattern? clause) + (and (pair? clause) + (not (pair? (car clause))) + (>= (length clause) 3) + (symbol? (cadr clause)) + (not (logic-var? (cadr clause))))) + ;; Variables that a data-pattern clause binds (introduces) (def (clause-bound-vars clause already-bound) (filter (lambda (v) (and (logic-var? v) (not (memq v already-bound)))) @@ -39,6 +50,9 @@ ;; Not clause: (not sub-clause ...) — binds nothing (filter only) [(and (pair? clause) (eq? (car clause) 'not)) '()] + ;; Not-join clause: (not-join [vars...] sub-clause ...) — binds nothing + [(and (pair? clause) (eq? (car clause) 'not-join)) + '()] ;; Or clause: (or alt ...) — binds the union of what alternatives bind [(and (pair? clause) (eq? (car clause) 'or)) (if (null? (cdr clause)) '() @@ -68,6 +82,11 @@ ;; Not/or: collect vars from sub-clauses [(and (pair? clause) (memq (car clause) '(not or))) (apply append (map clause-used-vars (cdr clause)))] + ;; Not-join: uses explicit join vars plus vars in sub-clauses + [(and (pair? clause) (eq? (car clause) 'not-join)) + (let ([join-vars (cadr clause)] + [sub-vars (apply append (map clause-used-vars (cddr clause)))]) + (append join-vars sub-vars))] [(and (pair? clause) (not (pair? (car clause)))) (filter logic-var? clause)] [(and (pair? clause) (pair? (car clause))) @@ -76,65 +95,83 @@ ;; ---- Selectivity scoring ---- ;; Higher score = more selective = should come first. + ;; Optional db-stats argument enables attribute-count-based scoring. - (def (score-clause clause bound-vars schema) - (cond - ;; Not clause: should come after its sub-clause vars are bound. - ;; Score low so it's placed late (it's a filter). - [(and (pair? clause) (eq? (car clause) 'not)) - (let ([used (clause-used-vars clause)]) - (if (for-all (lambda (v) (memq v bound-vars)) used) 3 -100))] - ;; Or clause: score like the best alternative - [(and (pair? clause) (eq? (car clause) 'or)) - (let ([alt-scores (map (lambda (alt) (score-clause alt bound-vars schema)) - (cdr clause))]) - (if (null? alt-scores) 0 (apply max alt-scores)))] - ;; Data pattern: (?e attr ?v ...) - [(and (pair? clause) (not (pair? (car clause))) - (>= (length clause) 3)) - (let* ([e-pos (car clause)] - [a-pos (cadr clause)] - [v-pos (caddr clause)] - [e-bound? (or (not (logic-var? e-pos)) (memq e-pos bound-vars))] - [a-bound? (not (logic-var? a-pos))] ;; attrs are always concrete - [v-bound? (or (not (logic-var? v-pos)) (memq v-pos bound-vars))]) - (let ([attr (and a-bound? (schema-lookup-by-ident schema a-pos))]) - (+ - (if e-bound? 100 0) ;; entity bound: very selective - (if (and attr (db-attribute-unique attr)) 90 0) ;; unique attr: point lookup - ;; V-bound + scalar attr: AVET range scan (fast). - ;; V-bound + ref attr: VAET reverse lookup (also fast). - (if v-bound? (if (and attr (avet-eligible? attr)) 60 50) 0) - (if a-bound? 20 0))))] ;; attribute bound (always true for valid queries) - ;; Predicate/function clauses: if ALL vars are bound, score maximally so - ;; the clause fires as an early filter immediately after its last dep. - ;; Otherwise score proportionally to bound vars. - [(and (pair? clause) (pair? (car clause))) - (let ([used (clause-used-vars clause)]) - (if (for-all (lambda (v) (memq v bound-vars)) used) - 1000 - (* 5 (length (filter (lambda (v) (memq v bound-vars)) used)))))] - [else 0])) + (def (score-clause clause bound-vars schema . rest) + (let ([db-stats (and (pair? rest) (car rest))]) + (cond + ;; Not clause: should come after its sub-clause vars are bound. + ;; Score low so it's placed late (it's a filter). + [(and (pair? clause) (eq? (car clause) 'not)) + (let ([used (clause-used-vars clause)]) + (if (for-all (lambda (v) (memq v bound-vars)) used) 3 -100))] + ;; Not-join clause: score 3 when all join vars are bound, -100 otherwise. + [(and (pair? clause) (eq? (car clause) 'not-join)) + (let ([join-vars (cadr clause)]) + (if (for-all (lambda (v) (memq v bound-vars)) join-vars) 3 -100))] + ;; Or clause: score like the best alternative + [(and (pair? clause) (eq? (car clause) 'or)) + (let ([alt-scores (map (lambda (alt) (score-clause alt bound-vars schema db-stats)) + (cdr clause))]) + (if (null? alt-scores) 0 (apply max alt-scores)))] + ;; Data pattern: (?e attr ?v ...) + [(and (pair? clause) (not (pair? (car clause))) + (>= (length clause) 3)) + (let* ([e-pos (car clause)] + [a-pos (cadr clause)] + [v-pos (caddr clause)] + [e-bound? (or (not (logic-var? e-pos)) (memq e-pos bound-vars))] + [a-bound? (not (logic-var? a-pos))] ;; attrs are always concrete + [v-bound? (or (not (logic-var? v-pos)) (memq v-pos bound-vars))]) + (let* ([attr (and a-bound? (schema-lookup-by-ident schema a-pos))] + [aid (and attr (db-attribute-id attr))] + ;; Stats-based bonus: smaller attribute -> higher score. + ;; Only applies when entity is unbound (otherwise EAVT point-lookup + ;; dominates regardless of attribute cardinality). + ;; Divide by 10: contributes 0-90, below entity-bound (100) and + ;; unique-attr (90) but above plain attribute-bound (20). + [stat-bonus (if (and db-stats aid (not e-bound?)) + (quotient (db-stats-selectivity-score db-stats aid) 10) + 0)]) + (+ + (if e-bound? 100 0) ;; entity bound: very selective + (if (and attr (db-attribute-unique attr)) 90 0) ;; unique attr: point lookup + ;; V-bound + scalar attr: AVET range scan (fast). + ;; V-bound + ref attr: VAET reverse lookup (also fast). + (if v-bound? (if (and attr (avet-eligible? attr)) 60 50) 0) + (if a-bound? 20 0) + stat-bonus)))] ;; 0-90 based on attribute selectivity + ;; Predicate/function clauses: if ALL vars are bound, score maximally so + ;; the clause fires as an early filter immediately after its last dep. + ;; Otherwise score proportionally to bound vars. + [(and (pair? clause) (pair? (car clause))) + (let ([used (clause-used-vars clause)]) + (if (for-all (lambda (v) (memq v bound-vars)) used) + 1000 + (* 5 (length (filter (lambda (v) (memq v bound-vars)) used)))))] + [else 0]))) ;; ---- Clause reordering ---- ;; Greedy algorithm: pick the highest-scoring clause, add its bindings, ;; repeat until all clauses are placed. + ;; Optional db-stats argument enables attribute-count-based ordering. - (def (reorder-clauses clauses initial-bound-vars schema) - (let loop ([remaining clauses] - [bound-vars initial-bound-vars] - [result '()]) - (if (null? remaining) - (reverse result) - (let* ([scored (map (lambda (c) - (cons (score-clause c bound-vars schema) c)) - remaining)] - [sorted (sort scored (lambda (a b) (> (car a) (car b))))] - [best (cdar sorted)] - [new-bound (clause-bound-vars best bound-vars)]) - (loop (remq best remaining) - (append new-bound bound-vars) - (cons best result)))))) + (def (reorder-clauses clauses initial-bound-vars schema . rest) + (let ([db-stats (and (pair? rest) (car rest))]) + (let loop ([remaining clauses] + [bound-vars initial-bound-vars] + [result '()]) + (if (null? remaining) + (reverse result) + (let* ([scored (map (lambda (c) + (cons (score-clause c bound-vars schema db-stats) c)) + remaining)] + [sorted (sort scored (lambda (a b) (> (car a) (car b))))] + [best (cdar sorted)] + [new-bound (clause-bound-vars best bound-vars)]) + (loop (remq best remaining) + (append new-bound bound-vars) + (cons best result))))))) ;; ---- Live variable analysis (projection pushdown support) ---- @@ -191,4 +228,60 @@ ;; Default: scan by attribute -> AEVT [else 'aevt]))) + ;; ---- Hash-join plan ---- + ;; Analyze a list of reordered clauses and group consecutive data-pattern pairs + ;; that form a binary join (share an unbound variable, both are data patterns, + ;; and the shared var isn't already bound from outside). + ;; Returns a list of plan steps, each one of: + ;; (hash-join clause-A clause-B join-vars) — execute as hash-join + ;; (sequential clause) — execute normally + + (def (hash-join-plan clauses initial-bound-vars schema) + (let loop ([clauses clauses] [bound initial-bound-vars] [result '()]) + (cond + [(null? clauses) + (reverse result)] + [(null? (cdr clauses)) + ;; Last clause — always sequential + (reverse (cons (list 'sequential (car clauses)) result))] + [else + (let* ([ca (car clauses)] + [cb (cadr clauses)] + [vars-a (filter logic-var? (clause-used-vars ca))] + [vars-b (filter logic-var? (clause-used-vars cb))] + ;; Shared vars that are NOT already bound from outside + [shared (filter (lambda (v) + (and (memq v vars-a) + (memq v vars-b) + (not (memq v bound)))) + vars-a)] + ;; Only hash-join if: both are bare data patterns, share ≥1 unbound var, + ;; and both patterns have no entity pre-bound (otherwise EAVT point-lookup + ;; is always faster than a hash-join). + ;; Correctness requirement: neither clause may reference a bound var that + ;; the other doesn't also reference — otherwise the two sides would see + ;; different external constraints and produce incorrect cross-product rows. + [bound-in-a (filter (lambda (v) (memq v bound)) vars-a)] + [bound-in-b (filter (lambda (v) (memq v bound)) vars-b)] + ;; Each bound-var used by A must also appear in B, and vice versa. + [symmetric-bound? + (and (for-all (lambda (v) (memq v vars-b)) bound-in-a) + (for-all (lambda (v) (memq v vars-a)) bound-in-b))] + [joinable? (and (pair? shared) + (data-pattern? ca)