perf: Phase 1 — pure-aggregate pushdown for single-clause queries
ober
f77863f4c8de9ebdf5029fdecee279d6cc0fed2e
--- a/lib/jerboa-db/query/engine.ss +++ b/lib/jerboa-db/query/engine.ss @@ -777,6 +777,148 @@ (hashtable-set! ht r #t) (loop (cdr rs) (cons r out))))))))) + ;; ---- Pure-aggregate pushdown ---- + ;; Fast path for single-clause aggregation queries: walk the index once, + ;; updating accumulators directly from datom-e/datom-v without ever + ;; allocating a binding hashtable. Saves N hashtable allocs for an N-row + ;; scan. Biggest wins on Q5-style group-by-count queries. + + ;; Returns descriptor (e-spec v-spec a-ident slots) on eligibility, else #f. + ;; slots is a list — one entry per find-var: + ;; (grp e) — datom-e is the group key for this slot + ;; (grp v) — datom-v is the group key + ;; (agg <name> e|v) — accumulate datom-e or datom-v + ;; (lit <value>) — literal echoed to output + (def (pure-aggregate-eligible? find-vars in-vars where-clauses) + (and (equal? in-vars '($)) + (= 1 (length where-clauses)) + (let ([cl (car where-clauses)]) + (and (data-pattern? cl) + (= (length cl) 3) + (let ([e-spec (car cl)] [a-spec (cadr cl)] [v-spec (caddr cl)]) + (and (logic-var? e-spec) + (logic-var? v-spec) + (let map-slots ([fvs find-vars] [acc '()]) + (if (null? fvs) + (and (exists (lambda (s) (eq? (car s) 'agg)) + (reverse acc)) + (list e-spec v-spec a-spec (reverse acc))) + (let ([fv (car fvs)]) + (cond + [(and (logic-var? fv) (eq? fv e-spec)) + (map-slots (cdr fvs) + (cons (list 'grp 'e) acc))] + [(and (logic-var? fv) (eq? fv v-spec)) + (map-slots (cdr fvs) + (cons (list 'grp 'v) acc))] + [(and (pair? fv) + (streamable-aggregate? (car fv)) + (logic-var? (cadr fv)) + (or (eq? (cadr fv) e-spec) + (eq? (cadr fv) v-spec))) + (map-slots (cdr fvs) + (cons (list 'agg + (car fv) + (if (eq? (cadr fv) e-spec) + 'e 'v)) + acc))] + [(not (logic-var? fv)) + (map-slots (cdr fvs) + (cons (list 'lit fv) acc))] + [else #f])))))))))) + + (def (extract-pure-agg-row slots outer group-key) + (let loop ([ss slots] [ai 0] [gi 0] [acc '()]) + (if (null? ss) + (reverse acc) + (let ([s (car ss)]) + (case (car s) + [(agg) + (loop (cdr ss) (+ ai 1) gi + (cons (finalize-agg-acc (cadr s) (vector-ref outer ai)) + acc))] + [(grp) + (loop (cdr ss) ai (+ gi 1) + (cons (list-ref group-key gi) acc))] + [(lit) + (loop (cdr ss) ai gi (cons (cadr s) acc))]))))) + + (def (execute-pure-aggregate db descriptor) + (let* ([a-ident (caddr descriptor)] + [slots (cadddr descriptor)] + [schema (db-value-schema db)] + [attr (schema-lookup-by-ident schema a-ident)]) + (unless attr (error 'query "Unknown attribute" a-ident)) + (let* ([aid (db-attribute-id attr)] + [idx (db-resolve-index db 'aevt)] + [lo (make-datom 0 aid +min-val+ 0 #t)] + [hi (make-datom (greatest-fixnum) aid + +max-val+ (greatest-fixnum) #t)] + [raw (dbi-range idx lo hi)] + [filtered (filter (lambda (d) (db-filter-datom? db d)) raw)] + [datoms (if (db-value-history? db) + filtered + (resolve-current-datoms filtered))] + [grp-srcs (map cadr (filter (lambda (s) (eq? (car s) 'grp)) slots))] + [agg-slots (filter (lambda (s) (eq? (car s) 'agg)) slots)] + [n-aggs (length agg-slots)] + [n-grps (length grp-srcs)] + [accum-ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (d) + (let ([key (if (= n-grps 0) + '() + (map (lambda (src) + (case src + [(e) (datom-e d)] + [(v) (datom-v d)])) + grp-srcs))]) + (let ([outer (hashtable-ref accum-ht key #f)]) + (if outer + (let loop ([as agg-slots] [i 0]) + (unless (null? as) + (let* ([slot (car as)] + [val (case (caddr slot) + [(e) (datom-e d)] + [(v) (datom-v d)])]) + (update-agg-acc! (cadr slot) (vector-ref outer i) val)) + (loop (cdr as) (+ i 1)))) + (let ([new-outer (make-vector n-aggs)]) + (let loop ([as agg-slots] [i 0]) + (unless (null? as) + (let* ([slot (car as)] + [val (case (caddr slot) + [(e) (datom-e d)] + [(v) (datom-v d)])] + [acc (init-agg-acc (cadr slot))]) + (update-agg-acc! (cadr slot) acc val) + (vector-set! new-outer i acc)) + (loop (cdr as) (+ i 1)))) + (hashtable-set! accum-ht key new-outer)))))) + datoms) + (let-values ([(keys outers) (hashtable-entries accum-ht)]) + (cond + [(and (= n-grps 0) (= 0 (vector-length keys))) + ;; No grouping, no rows: emit zero-state row (matches sql semantics). + (list (extract-pure-agg-row + slots + (let ([z (make-vector n-aggs)]) + (let loop ([as agg-slots] [i 0]) + (unless (null? as) + (vector-set! z i (init-agg-acc (cadar as))) + (loop (cdr as) (+ i 1)))) + z) + '()))] + [else + (let loop ([i 0] [acc '()]) + (if (= i (vector-length keys)) + (reverse acc) + (loop (+ i 1) + (cons (extract-pure-agg-row slots + (vector-ref outers i) + (vector-ref keys i)) + acc))))]))))) + ;; ---- Hash-join execution ---- (def (merge-bindings b1 b2) @@ -861,6 +1003,14 @@ [in-vars (parsed-query-in-vars parsed)] [where-clauses (parsed-query-where-clauses parsed)] [rules-ht (parsed-query-rules parsed)] + [pure-agg-desc (pure-aggregate-eligible? find-vars in-vars where-clauses)]) + (if pure-agg-desc + (execute-pure-aggregate db pure-agg-desc) + (query-db-general schema find-vars in-vars where-clauses rules-ht + db inputs)))) + + (def (query-db-general schema find-vars in-vars where-clauses rules-ht db inputs) + (let* ([rules-ht rules-ht] ;; Build initial bindings from inputs ;; $ = db (implicit), % = rules, other = user inputs ;; Input var specs: