diff --git a/bench/dune b/bench/dune index 0d37dee..e769179 100644 --- a/bench/dune +++ b/bench/dune @@ -75,6 +75,24 @@ (modes exe) (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) +(executable + (name tave_storage_ratio) + (modules tave_storage_ratio) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) + +(executable + (name logseq_query_bench) + (modules logseq_query_bench) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite datascript_lmdb unix sqlite3)) + +(executable + (name logseq_query_bench_shared) + (modules logseq_query_bench_shared) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite unix sqlite3)) + (executable (name outliner_insert_ocaml) (modules outliner_insert_ocaml) @@ -112,3 +130,4 @@ ../script/benchmark_gate_vs_cljs_check_test.sh) (action (run bash %{dep:../script/benchmark_gate_vs_cljs_check_test.sh}))) + diff --git a/bench/external/.gitignore b/bench/external/.gitignore new file mode 100644 index 0000000..bd04223 --- /dev/null +++ b/bench/external/.gitignore @@ -0,0 +1 @@ +.cpcache/ diff --git a/bench/external/deps.edn b/bench/external/deps.edn new file mode 100644 index 0000000..d295fec --- /dev/null +++ b/bench/external/deps.edn @@ -0,0 +1,8 @@ +{:paths ["."] + :deps {org.clojure/clojure {:mvn/version "1.12.5"} + io.replikativ/datahike-jdbc {:mvn/version "0.3.50"} + org.xerial/sqlite-jdbc {:mvn/version "3.53.2.1"} + datalevin/datalevin {:local/root "../../_deps/datalevin"}} + :aliases + {:run {:main-opts ["-m" "logseq-query-bench-clj"]} + :shared {:main-opts ["-m" "shared-query-bench-clj"]}}} diff --git a/bench/external/logseq_query_bench_clj.clj b/bench/external/logseq_query_bench_clj.clj new file mode 100644 index 0000000..daa9e3b --- /dev/null +++ b/bench/external/logseq_query_bench_clj.clj @@ -0,0 +1,416 @@ +(ns logseq-query-bench-clj + "Logseq shared-query bench for Datahike (PSS + SQLite JDBC) and Datalevin. + Emits the same TSV + result-edn lines as the OCaml/CLJS shared harness." + (:require [clojure.string :as str] + [datahike.api :as dh] + [datahike-jdbc.core] + [datalevin.core :as dl])) + +(defn now-ms [] (double (/ (System/nanoTime) 1e6))) + +(defn format-ms [v] + (cond + (> v 1) (format "%.2f" (double v)) + (> v 0.01) (format "%.3f" (double v)) + :else (format "%.4f" (double v)))) + +(def blackhole (atom 0)) +(defn bump! [n] (swap! blackhole #(bit-and (+ % n) 0x3fffffff))) + +(defn keep-take [n pred xs] + (into [] (comp (filter pred) (take n)) xs)) + +(defn median [xs] + (let [s (vec (sort xs))] + (nth s (quot (count s) 2)))) + +(defn dotime [duration-ms step f] + (let [start (now-ms) + deadline (+ start duration-ms)] + (loop [iters 0] + (dotimes [_ step] (f)) + (let [iters (+ iters step)] + (if (< (now-ms) deadline) + (recur iters) + (/ (- (now-ms) start) iters)))))) + +(defn bench [cfg f] + (dotime (:warmup-ms cfg) (:step cfg) f) + (median + (mapv (fn [_] (dotime (:sample-ms cfg) (:step cfg) f)) + (range (:repeats cfg))))) + +(def schema-dh + (mapv + (fn [i m] (assoc m :db/id (+ 100000 (inc i)))) + (range) + [{:db/ident :block/uuid :db/valueType :db.type/string :db/unique :db.unique/identity :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/title :db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/name :db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/updated-at :db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/created-at :db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/journal-day :db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/parent :db/valueType :db.type/ref :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/page :db/valueType :db.type/ref :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :block/tags :db/valueType :db.type/ref :db/cardinality :db.cardinality/many :db/index true} + {:db/ident :block/refs :db/valueType :db.type/ref :db/cardinality :db.cardinality/many :db/index true} + {:db/ident :block/content :db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true}])) + +(def schema-dl + {:block/uuid {:db/valueType :db.type/string :db/unique :db.unique/identity :db/cardinality :db.cardinality/one :db/index true} + :block/title {:db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + :block/name {:db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + :block/updated-at {:db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + :block/created-at {:db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + :block/journal-day {:db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + :block/parent {:db/valueType :db.type/ref :db/cardinality :db.cardinality/one :db/index true} + :block/page {:db/valueType :db.type/ref :db/cardinality :db.cardinality/one :db/index true} + :block/tags {:db/valueType :db.type/ref :db/cardinality :db.cardinality/many :db/index true} + :block/refs {:db/valueType :db.type/ref :db/cardinality :db.cardinality/many :db/index true} + :block/content {:db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true}}) + +(defn- dl-index [index] + (case index + :eavt :eav + :aevt :aev + :avet :ave + index)) + +(defn uuid-of [i] + (str "00000000-0000-4000-8000-" (format "%012d" (long i)))) + +(defn journal-day-of [i] + (+ 20250101 (mod i 400))) + +(defn build-tx [size pages] + (let [pages (max 1 (min pages size)) + base-ms 1700000000000 + day-ms 86400000 + tag-count (min 32 pages) + tx (transient [])] + (doseq [e (range 1 (inc pages))] + (let [updated (+ base-ms (* 10 day-ms) (* e 1000)) + ent (cond-> {:db/id e + :block/uuid (uuid-of e) + :block/title (str "Page " e) + :block/name (str "page-" e) + :block/updated-at updated + :block/created-at (- updated day-ms) + :block/content (str "page body " e)} + (zero? (mod e 5)) (assoc :block/journal-day (journal-day-of e)) + (zero? (mod e 7)) (assoc :block/tags (inc (mod e tag-count))))] + (conj! tx ent))) + (doseq [index (range (- size pages))] + (let [e (+ pages index 1) + page (inc (mod index pages)) + parent (if (or (zero? index) (zero? (mod index 3))) page (dec e)) + updated (+ base-ms (* e 30)) + ent (cond-> {:db/id e + :block/uuid (uuid-of e) + :block/title (str "Block " e) + :block/updated-at updated + :block/created-at (- updated 60000) + :block/parent parent + :block/page page + :block/content (str "block body " e)} + (zero? (mod e 11)) + (assoc :block/tags (inc (mod e tag-count)) :block/refs page))] + (conj! tx ent))) + {:tx (persistent! tx) :pages pages :base-ms base-ms})) + +(defn parse-args [argv] + (loop [xs argv + cfg {:size 5000 :pages 500 :warmup-ms 200.0 :sample-ms 200.0 + :repeats 3 :step 5 :jit-warmup 20 :runtime "datahike" + :sqlite-path nil :query nil}] + (if (empty? xs) + cfg + (let [[a b & more] xs] + (case a + "--size" (recur more (assoc cfg :size (Long/parseLong b))) + "--pages" (recur more (assoc cfg :pages (Long/parseLong b))) + "--warmup-ms" (recur more (assoc cfg :warmup-ms (Double/parseDouble b))) + "--sample-ms" (recur more (assoc cfg :sample-ms (Double/parseDouble b))) + "--repeats" (recur more (assoc cfg :repeats (Long/parseLong b))) + "--jit-warmup" (recur more (assoc cfg :jit-warmup (Long/parseLong b))) + "--runtime" (recur more (assoc cfg :runtime b)) + "--sqlite" (recur more (assoc cfg :sqlite-path b)) + "--query" (recur more (assoc cfg :query b)) + (throw (ex-info (str "unknown arg " a) {:arg a}))))))) + +(defn disk-bytes [path] + (let [f (java.io.File. path)] + (cond + (not (.exists f)) 0 + (.isFile f) (.length f) + (.isDirectory f) + (->> (file-seq f) + (filter #(.isFile %)) + (map #(.length %)) + (reduce + 0)) + :else 0))) + +(defn remove-path [path] + (let [f (java.io.File. path)] + (when (.exists f) + (doseq [x (reverse (file-seq f))] + (.delete x)))) + (doseq [sfx ["-wal" "-shm" "-lock"]] + (let [s (java.io.File. (str path sfx))] + (when (.exists s) (.delete s))))) + +(defn datoms [store index & components] + (case (:engine store) + :datahike (apply dh/datoms (:db store) index components) + :datalevin (apply dl/datoms (:db store) (dl-index index) components) + (throw (ex-info "datoms: missing :engine on store" {:keys (keys store)})))) + +(defn entity [store eid] + (case (:engine store) + :datahike (dh/entity (:db store) eid) + :datalevin (dl/entity (:db store) eid) + (throw (ex-info "entity: missing :engine on store" {:keys (keys store)})))) + +(defn q [store query & inputs] + (case (:engine store) + :datahike (apply dh/q query (:db store) inputs) + :datalevin (apply dl/q query (:db store) inputs) + (throw (ex-info "q: missing :engine on store" {:keys (keys store)})))) + +(defn avet-attr-rseq [store attr] + ;; Logseq: (rseq (d/datoms db :avet attr)) — exact attr, then reverse. + ;; Do not use bare rseek-datoms: it continues into earlier AVET attrs. + (rseq (vec (datoms store :avet attr)))) + +(defn is-page? [store datom] + (and (empty? (datoms store :eavt (:e datom) :block/page)) + (let [titles (datoms store :eavt (:e datom) :block/title)] + (and (seq titles) + (string? (:v (first titles))) + (pos? (count (str/trim (str (:v (first titles)))))))))) + +(defn recent-page-datoms [store] + (keep-take 15 #(is-page? store %) (avet-attr-rseq store :block/updated-at))) + +(defn latest-journal-datoms [store pages] + (let [today (journal-day-of pages)] + (keep-take 10 + (fn [datom] + (and (number? (:v datom)) (<= (:v datom) today))) + (avet-attr-rseq store :block/journal-day)))) + +(defn hydrate-forward! [ent] + (when ent + (doseq [attr [:block/uuid :block/title :block/name :block/updated-at :block/journal-day]] + (when (some? (get ent attr)) + (bump! 1))))) + +(defn hydrate-edn-pairs [ent] + (->> [:block/uuid :block/title :block/name :block/updated-at :block/journal-day] + (keep (fn [attr] + (when-some [v (get ent attr)] + [attr v]))) + (sort-by (comp str first)) + vec)) + +(defn sorted-eids [ds] + (vec (sort (map :e ds)))) + +(defn edn-q-rows [rows] + (->> rows (map (fn [row] (mapv identity row))) (sort-by pr-str) vec)) + +(defn result-edn [store name] + (let [{:keys [pages base-ms sample-uuid sample-page sample-tag]} store] + (case name + "recent-pages" (mapv :e (recent-page-datoms store)) + "latest-journals" (mapv :e (latest-journal-datoms store pages)) + "uuid-lookup" + (let [e (entity store [:block/uuid sample-uuid])] + (if e [(:db/id e) (hydrate-edn-pairs e)] nil)) + "title-lookup" + (sorted-eids (datoms store :avet :block/title (str "Page " (quot pages 2)))) + "children-by-parent" + (sorted-eids (datoms store :avet :block/parent sample-page)) + "blocks-by-page" + (sorted-eids (datoms store :avet :block/page sample-page)) + "tags-scan" + (sorted-eids (datoms store :avet :block/tags sample-tag)) + "eavt-entity" + (->> (datoms store :eavt sample-page) + (mapv (fn [d] [(:a d) (:v d)])) + (sort-by (comp str first)) + vec) + "entity-hydrate" + (let [e (entity store sample-page)] + (if e [(:db/id e) (hydrate-edn-pairs e)] nil)) + "q-updated-at-between" + (let [lo (+ base-ms 3600000) hi (+ base-ms 86400000)] + (edn-q-rows + (q store '[:find ?e ?t :in $ ?lo ?hi + :where [?e :block/updated-at ?t] [(>= ?t ?lo)] [(<= ?t ?hi)]] + lo hi))) + "q-journal-pages" + (edn-q-rows (q store '[:find ?e ?d :where [?e :block/journal-day ?d] [?e :block/title ?t]])) + "q-page-by-name" + (edn-q-rows + (q store '[:find ?e :in $ ?n :where [?e :block/name ?n]] + (str "page-" (quot pages 3)))) + (throw (ex-info (str "unknown query " name) {:name name}))))) + +(defn make-queries [store] + (let [{:keys [pages base-ms sample-uuid sample-page sample-tag]} store] + [{:name "recent-pages" + :run (fn [] + (doseq [datom (recent-page-datoms store)] + (hydrate-forward! (entity store (:e datom)))))} + {:name "latest-journals" + :run (fn [] + (doseq [datom (latest-journal-datoms store pages)] + (hydrate-forward! (entity store (:e datom)))))} + {:name "uuid-lookup" + :run (fn [] (hydrate-forward! (entity store [:block/uuid sample-uuid])))} + {:name "title-lookup" + :run (fn [] (bump! (count (datoms store :avet :block/title (str "Page " (quot pages 2))))))} + {:name "children-by-parent" + :run (fn [] (bump! (count (datoms store :avet :block/parent sample-page))))} + {:name "blocks-by-page" + :run (fn [] (bump! (count (datoms store :avet :block/page sample-page))))} + {:name "tags-scan" + :run (fn [] (bump! (count (datoms store :avet :block/tags sample-tag))))} + {:name "eavt-entity" + :run (fn [] (bump! (count (datoms store :eavt sample-page))))} + {:name "entity-hydrate" + :run (fn [] (hydrate-forward! (entity store sample-page)))} + {:name "q-updated-at-between" + :run (fn [] + (let [lo (+ base-ms 3600000) hi (+ base-ms 86400000)] + (bump! (count (q store '[:find ?e ?t :in $ ?lo ?hi + :where [?e :block/updated-at ?t] + [(>= ?t ?lo)] [(<= ?t ?hi)]] + lo hi)))))} + {:name "q-journal-pages" + :run (fn [] + (bump! (count (q store '[:find ?e ?d + :where [?e :block/journal-day ?d] + [?e :block/title ?t]]))))} + {:name "q-page-by-name" + :run (fn [] + (bump! (count (q store '[:find ?e :in $ ?n :where [?e :block/name ?n]] + (str "page-" (quot pages 3))))))}])) + +(defn open-datalevin [dir] + ;; Durable LMDB on disk (not :mem). Memory page cache is fine. + (remove-path dir) + (.mkdirs (java.io.File. dir)) + (let [conn (dl/get-conn dir schema-dl)] + {:engine :datalevin :conn conn + :backend "lmdb-durable" + :close! (fn [] + (try (dl/close conn) (catch Exception _)) + (remove-path dir))})) + +(defn open-datahike [sqlite-path] + ;; Durable SQLite via JDBC konserve (PSS indexes; in-process cache OK). + (remove-path sqlite-path) + (let [cfg {:store {:backend :jdbc :dbtype "sqlite" :dbname sqlite-path} + :schema-flexibility :write + :keep-history? false + :index :datahike.index/persistent-set + :initial-tx schema-dh}] + (try (dh/delete-database cfg) (catch Exception _)) + (remove-path sqlite-path) + (dh/create-database cfg) + (let [conn (dh/connect cfg)] + {:engine :datahike :conn conn :cfg cfg + :backend "jdbc-sqlite-pss-durable" + :close! (fn [] + (try (dh/release conn) (catch Exception _)) + (try (dh/delete-database cfg) (catch Exception _)) + (remove-path sqlite-path))}))) + +(defn build-prepared [cfg] + (let [runtime (:runtime cfg) + sqlite-path (or (:sqlite-path cfg) + (str "/tmp/logseq-query-bench-" runtime "-" (:size cfg) ".sqlite3")) + built (build-tx (:size cfg) (:pages cfg)) + started (now-ms) + opened (case runtime + "datahike" (open-datahike sqlite-path) + "datalevin" (open-datalevin (str sqlite-path ".dl")) + (throw (ex-info "runtime must be datahike|datalevin" cfg))) + conn (:conn opened) + _ (case runtime + "datahike" (dh/transact conn (:tx built)) + "datalevin" (dl/transact! conn (:tx built))) + build-ms (- (now-ms) started) + restore-started (now-ms) + opened (case runtime + "datahike" + (do + (dh/release conn) + (let [conn2 (dh/connect (:cfg opened))] + (assoc opened :conn conn2 :db @conn2 + :close! (fn [] + (try (dh/release conn2) (catch Exception _)) + (try (dh/delete-database (:cfg opened)) (catch Exception _)))))) + "datalevin" + (assoc opened :db (dl/db conn))) + restore-ms (- (now-ms) restore-started) + pages (:pages built) + disk-path (case runtime + "datahike" sqlite-path + "datalevin" (str sqlite-path ".dl") + sqlite-path)] + (merge opened + {:pages pages + :base-ms (:base-ms built) + :sample-uuid (uuid-of (max 1 (quot pages 2))) + :sample-page 1 + :sample-tag 1 + :build-ms build-ms + :restore-ms restore-ms + :sqlite-path sqlite-path + :disk-bytes (disk-bytes disk-path)}))) + +(defn -main [& argv] + ;; Keep stdout as clean TSV for the compare scripts. + (System/setProperty "taoensso.timbre.min-level.edn" ":warn") + (try + ((requiring-resolve 'taoensso.timbre/set-min-level!) :warn) + (catch Exception _)) + (let [cfg (parse-args argv) + label (or (System/getenv "BENCH_RUNTIME_LABEL") + (case (:runtime cfg) + "datahike" "datahike-pss-sqlite" + "datalevin" "datalevin-lmdb" + (:runtime cfg))) + prepared (build-prepared cfg) + queries (cond->> (make-queries prepared) + (:query cfg) (filterv #(= (:name %) (:query cfg))))] + (try + (println (str "runtime\t" label)) + (println "suite\tlogseq-queries-shared") + (println (str "backend\t" (:backend prepared))) + (println (str "size\t" (:size cfg))) + (println (str "pages\t" (:pages cfg))) + (println (str "warmup-ms\t" (long (:warmup-ms cfg)))) + (println (str "sample-ms\t" (long (:sample-ms cfg)))) + (println (str "repeats\t" (:repeats cfg))) + (println (str "jit-warmup\t" (:jit-warmup cfg))) + (println (str "sqlite-path\t" (:sqlite-path prepared))) + (println (str "build-ms\t" (format-ms (:build-ms prepared)))) + (println (str "restore-ms\t" (format-ms (:restore-ms prepared)))) + (println (str "disk-bytes\t" (:disk-bytes prepared))) + (println (str "query-cases\t" (count queries))) + (doseq [q queries] + (println (str "result-edn\t" (:name q) "\t" (pr-str (result-edn prepared (:name q)))))) + (when (pos? (:jit-warmup cfg)) + (doseq [q queries] + (dotimes [_ (:jit-warmup cfg)] + ((:run q))))) + (doseq [q queries] + (println (str (:name q) "\t" (format-ms (bench cfg (:run q)))))) + (binding [*out* *err*] + (println (str "blackhole=" @blackhole))) + (finally + ((:close! prepared)))))) diff --git a/bench/external/shared_query_bench_clj.clj b/bench/external/shared_query_bench_clj.clj new file mode 100644 index 0000000..809c80a --- /dev/null +++ b/bench/external/shared_query_bench_clj.clj @@ -0,0 +1,324 @@ +(ns shared-query-bench-clj + "Shared people-query suite (q1/q2/q3/…) for Datahike (PSS + SQLite JDBC) + and Datalevin (durable LMDB). Matches OCaml bench/shared_query_bench.ml + data generation (seed=1 LCG) and emits result-edn + timing TSV. + + Datalevin timings are reported twice: + - -nocache : datalevin.query/*cache?* false (engine cost) + - : default result+plan cache on (steady-state / Datalevin default)" + (:require [clojure.string :as str] + [datahike.api :as dh] + [datahike-jdbc.core] + [datalevin.core :as dl] + [datalevin.query :as dq])) + +(defn now-ms [] (double (/ (System/nanoTime) 1e6))) + +(defn format-ms [v] + (cond + (> v 1) (format "%.2f" (double v)) + (> v 0.01) (format "%.3f" (double v)) + :else (format "%.4f" (double v)))) + +(def blackhole (atom 0)) +(defn bump! [n] (swap! blackhole #(bit-and (+ % n) 0x3fffffff))) + +(defn median [xs] + (let [s (vec (sort xs))] + (nth s (quot (count s) 2)))) + +(defn dotime [duration-ms step f] + (let [start (now-ms) + deadline (+ start duration-ms)] + (loop [iters 0] + (dotimes [_ step] (f)) + (let [iters (+ iters step)] + (if (< (now-ms) deadline) + (recur iters) + (/ (- (now-ms) start) iters)))))) + +(defn bench [cfg f] + (dotime (:warmup-ms cfg) (:step cfg) f) + (median + (mapv (fn [_] (dotime (:sample-ms cfg) (:step cfg) f)) + (range (:repeats cfg))))) + +;; --- LCG matching OCaml Int32 (seed=1) --- +(defn next-int! + "Mutates rng long-array[0]; matches OCaml shared_query_bench next_int." + [^longs rng ^long bound] + (let [s (bit-and (unchecked-add (unchecked-multiply (aget rng 0) 1664525) 1013904223) + 0xffffffff) + _ (aset rng 0 s) + u (bit-and (unsigned-bit-shift-right (unchecked-int s) 1) 0x3fffffff)] + (rem u bound))) + +(def names ["Ivan" "Petr" "Sergei" "Oleg" "Yuri" "Dmitry" "Fedor" "Denis"]) +(def last-names ["Ivanov" "Petrov" "Sidorov" "Kovalev" "Kuznetsov" "Voronoi"]) +(def sexes [:male :female]) + +(defn rand-nth! [rng xs] + (nth xs (next-int! rng (count xs)))) + +(defn rand-sex! [rng] + ;; Decorrelate sex from name (same as OCaml: next_int 997 mod 2). + (nth sexes (mod (next-int! rng 997) (count sexes)))) + +(def schema-dh + (mapv + (fn [i m] (assoc m :db/id (+ 100000 (inc i)))) + (range) + [{:db/ident :name :db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :last-name :db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :sex :db/valueType :db.type/keyword :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :age :db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :salary :db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + {:db/ident :follows :db/valueType :db.type/ref :db/cardinality :db.cardinality/many}])) + +(def schema-dl + {:name {:db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + :last-name {:db/valueType :db.type/string :db/cardinality :db.cardinality/one :db/index true} + :sex {:db/valueType :db.type/keyword :db/cardinality :db.cardinality/one :db/index true} + :age {:db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + :salary {:db/valueType :db.type/long :db/cardinality :db.cardinality/one :db/index true} + :follows {:db/valueType :db.type/ref :db/cardinality :db.cardinality/many}}) + +(defn build-tx [size] + (let [rng (long-array [1]) + people + (mapv + (fn [i] + {:db/id i + :name (rand-nth! rng names) + :last-name (rand-nth! rng last-names) + :sex (rand-sex! rng) + :age (next-int! rng 100) + :salary (next-int! rng 100000)}) + (range 1 (inc size))) + follows + (into [] + (keep + (fn [eid] + (when (zero? (next-int! rng 2)) + [:db/add eid :follows (inc (next-int! rng size))]))) + (range 1 (inc size)))] + (into people follows))) + +(def follow-rules '[[[follow ?e1 ?e2] [?e1 :follows ?e2]]]) + +(defn parse-args [argv] + (loop [xs argv + cfg {:size 20000 :warmup-ms 200.0 :sample-ms 200.0 + :repeats 2 :step 10 :jit-warmup 100 :runtime "datahike" + :sqlite-path nil :query nil}] + (if (empty? xs) + cfg + (let [[a b & more] xs] + (case a + "--size" (recur more (assoc cfg :size (Long/parseLong b))) + "--warmup-ms" (recur more (assoc cfg :warmup-ms (Double/parseDouble b))) + "--sample-ms" (recur more (assoc cfg :sample-ms (Double/parseDouble b))) + "--repeats" (recur more (assoc cfg :repeats (Long/parseLong b))) + "--jit-warmup" (recur more (assoc cfg :jit-warmup (Long/parseLong b))) + "--runtime" (recur more (assoc cfg :runtime b)) + "--sqlite" (recur more (assoc cfg :sqlite-path b)) + "--query" (recur more (assoc cfg :query b)) + (throw (ex-info (str "unknown arg " a) {:arg a}))))))) + +(defn disk-bytes [path] + (let [f (java.io.File. path)] + (cond + (not (.exists f)) 0 + (.isFile f) (.length f) + (.isDirectory f) + (->> (file-seq f) + (filter #(.isFile %)) + (map #(.length %)) + (reduce + 0)) + :else 0))) + +(defn remove-path [path] + (let [f (java.io.File. path)] + (when (.exists f) + (doseq [x (reverse (file-seq f))] + (.delete x)))) + (doseq [sfx ["-wal" "-shm" "-lock"]] + (let [s (java.io.File. (str path sfx))] + (when (.exists s) (.delete s))))) + +(defn q [store query & inputs] + (case (:engine store) + :datahike (apply dh/q query (:db store) inputs) + :datalevin (apply dl/q query (:db store) inputs) + (throw (ex-info "q: missing :engine" {:keys (keys store)})))) + +(defn edn-q-rows [rows] + ;; Match OCaml: sort row EDN strings, then wrap as a vector. + (->> rows + (map (fn [row] (vec row))) + (sort-by pr-str) + vec)) + +(defn result-edn [store name] + (case name + "q1" (edn-q-rows (q store '[:find ?e :where [?e :name "Ivan"]])) + "q2" (edn-q-rows (q store '[:find ?e ?a :where [?e :name "Ivan"] [?e :age ?a]])) + "q2-switch" (edn-q-rows (q store '[:find ?e ?a :where [?e :age ?a] [?e :name "Ivan"]])) + "q3" (edn-q-rows (q store '[:find ?e ?a :where [?e :name "Ivan"] [?e :age ?a] [?e :sex :male]])) + "q4" (edn-q-rows (q store '[:find ?e ?l ?a :where [?e :name "Ivan"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]])) + "q5" (edn-q-rows (q store '[:find ?e1 ?l ?a :where [?e :name "Ivan"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]])) + "qpred1" (edn-q-rows (q store '[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]])) + "qpred2" (edn-q-rows (q store '[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]] 50000)) + "q-or" (edn-q-rows (q store '[:find ?e :where (or [?e :name "Ivan"] [?e :name "Petr"])])) + "q-not" (edn-q-rows (q store '[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])])) + "q-or-join" (edn-q-rows (q store '[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name "Ivan"] [?e :name "Petr"])])) + "q-not-join" (edn-q-rows (q store '[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])])) + "q-pred-range" (edn-q-rows (q store '[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]])) + "q-5-merge" (edn-q-rows (q store '[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]])) + "q-rule" (edn-q-rows (q store '[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)] follow-rules)) + (throw (ex-info (str "unknown query " name) {:name name})))) + +(defn make-queries [store] + [{:name "q1" :run (fn [] (bump! (count (q store '[:find ?e :where [?e :name "Ivan"]]))))} + {:name "q2" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :name "Ivan"] [?e :age ?a]]))))} + {:name "q2-switch" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :age ?a] [?e :name "Ivan"]]))))} + {:name "q3" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :name "Ivan"] [?e :age ?a] [?e :sex :male]]))))} + {:name "q4" :run (fn [] (bump! (count (q store '[:find ?e ?l ?a :where [?e :name "Ivan"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]))))} + {:name "q5" :run (fn [] (bump! (count (q store '[:find ?e1 ?l ?a :where [?e :name "Ivan"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]))))} + {:name "qpred1" :run (fn [] (bump! (count (q store '[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]))))} + {:name "qpred2" :run (fn [] (bump! (count (q store '[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]] 50000))))} + {:name "q-or" :run (fn [] (bump! (count (q store '[:find ?e :where (or [?e :name "Ivan"] [?e :name "Petr"])]))))} + {:name "q-not" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]))))} + {:name "q-or-join" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name "Ivan"] [?e :name "Petr"])]))))} + {:name "q-not-join" :run (fn [] (bump! (count (q store '[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]))))} + {:name "q-pred-range" :run (fn [] (bump! (count (q store '[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]))))} + {:name "q-5-merge" :run (fn [] (bump! (count (q store '[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]))))} + {:name "q-rule" :run (fn [] (bump! (count (q store '[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)] follow-rules))))}]) + +(defn open-datalevin [dir] + (remove-path dir) + (.mkdirs (java.io.File. dir)) + (let [conn (dl/get-conn dir schema-dl)] + {:engine :datalevin :conn conn + :backend "lmdb-durable" + :close! (fn [] + (try (dl/close conn) (catch Exception _)) + (remove-path dir))})) + +(defn open-datahike [sqlite-path] + (remove-path sqlite-path) + (let [cfg {:store {:backend :jdbc :dbtype "sqlite" :dbname sqlite-path} + :schema-flexibility :write + :keep-history? false + :index :datahike.index/persistent-set + :initial-tx schema-dh}] + (try (dh/delete-database cfg) (catch Exception _)) + (remove-path sqlite-path) + (dh/create-database cfg) + (let [conn (dh/connect cfg)] + {:engine :datahike :conn conn :cfg cfg + :backend "jdbc-sqlite-pss-durable" + :close! (fn [] + (try (dh/release conn) (catch Exception _)) + (try (dh/delete-database cfg) (catch Exception _)) + (remove-path sqlite-path))}))) + +(defn build-prepared [cfg] + (let [runtime (:runtime cfg) + sqlite-path (or (:sqlite-path cfg) + (str "/tmp/shared-query-bench-" runtime "-" (:size cfg) ".sqlite3")) + tx (build-tx (:size cfg)) + started (now-ms) + opened (case runtime + "datahike" (open-datahike sqlite-path) + "datalevin" (open-datalevin (str sqlite-path ".dl")) + (throw (ex-info "runtime must be datahike|datalevin" cfg))) + conn (:conn opened) + _ (case runtime + "datahike" (dh/transact conn tx) + "datalevin" (dl/transact! conn tx)) + build-ms (- (now-ms) started) + restore-started (now-ms) + opened (case runtime + "datahike" + (do + (dh/release conn) + (let [conn2 (dh/connect (:cfg opened))] + (assoc opened :conn conn2 :db @conn2 + :close! (fn [] + (try (dh/release conn2) (catch Exception _)) + (try (dh/delete-database (:cfg opened)) (catch Exception _)) + (remove-path sqlite-path))))) + "datalevin" + (assoc opened :db (dl/db conn))) + restore-ms (- (now-ms) restore-started) + disk-path (case runtime + "datahike" sqlite-path + "datalevin" (str sqlite-path ".dl") + sqlite-path)] + (merge opened + {:build-ms build-ms + :restore-ms restore-ms + :sqlite-path sqlite-path + :disk-bytes (disk-bytes disk-path)}))) + +(defn -main [& argv] + (System/setProperty "taoensso.timbre.min-level.edn" ":warn") + (try + ((requiring-resolve 'taoensso.timbre/set-min-level!) :warn) + (catch Exception _)) + (let [cfg (parse-args argv) + label (or (System/getenv "BENCH_RUNTIME_LABEL") + (case (:runtime cfg) + "datahike" "datahike-pss-sqlite" + "datalevin" "datalevin-lmdb" + (:runtime cfg))) + prepared (build-prepared cfg) + queries (cond->> (make-queries prepared) + (:query cfg) (filterv #(= (:name %) (:query cfg))))] + (try + (println (str "runtime\t" label)) + (println "suite\tshared-people-queries") + (println (str "backend\t" (:backend prepared))) + (println (str "size\t" (:size cfg))) + (println (str "warmup-ms\t" (long (:warmup-ms cfg)))) + (println (str "sample-ms\t" (long (:sample-ms cfg)))) + (println (str "repeats\t" (:repeats cfg))) + (println (str "jit-warmup\t" (:jit-warmup cfg))) + (println (str "sqlite-path\t" (:sqlite-path prepared))) + (println (str "build-ms\t" (format-ms (:build-ms prepared)))) + (println (str "restore-ms\t" (format-ms (:restore-ms prepared)))) + (println (str "disk-bytes\t" (:disk-bytes prepared))) + (println (str "query-cases\t" (count queries))) + (doseq [q queries] + (println (str "result-edn\t" (:name q) "\t" (pr-str (result-edn prepared (:name q)))))) + ;; Cold / no result-cache path (fair engine comparison). + (println "cache-mode\tnocache") + (let [run-nocache + (fn [q] + (case (:runtime cfg) + "datalevin" (binding [dq/*cache?* false] ((:run q))) + ((:run q))))] + (when (pos? (:jit-warmup cfg)) + (doseq [q queries] + (dotimes [_ (min 5 (:jit-warmup cfg))] + (run-nocache q)))) + (doseq [q queries] + (let [t0 (now-ms) + _ (run-nocache q) + first-ms (- (now-ms) t0) + steady (bench cfg (fn [] (run-nocache q)))] + (println (str (:name q) "-first\t" (format-ms first-ms))) + (println (str (:name q) "-nocache\t" (format-ms steady)))))) + ;; Warm path with Datalevin result/plan cache (default *cache?* true). + (println "cache-mode\twarm") + (when (pos? (:jit-warmup cfg)) + (doseq [q queries] + (dotimes [_ (:jit-warmup cfg)] + ((:run q))))) + (doseq [q queries] + (println (str (:name q) "\t" (format-ms (bench cfg (:run q)))))) + (binding [*out* *err*] + (println (str "blackhole=" @blackhole))) + (finally + ((:close! prepared)))))) diff --git a/bench/logseq_query_bench.ml b/bench/logseq_query_bench.ml new file mode 100644 index 0000000..6b7896d --- /dev/null +++ b/bench/logseq_query_bench.ml @@ -0,0 +1,787 @@ +(* Logseq-shaped query microbench. + Patterns mirror deps/db/.../initial_data.cljs hot paths and common + d/entity + AVET lookups — not the people/follows shared suite. *) + +open Datascript + +type storage_backend = + | Memory_lmdb_nosync + | Lmdb_file + | Sqlite_file + +type config = + { size : int + ; pages : int + ; warmup_ms : float + ; sample_ms : float + ; repeats : int + ; step : int + ; jit_warmup : int + ; query : string option + ; storages : storage_backend list + ; data_dir : string + } + +let default_config = + { size = 20_000 + ; pages = 2_000 + ; warmup_ms = 200. + ; sample_ms = 200. + ; repeats = 3 + ; step = 5 + ; jit_warmup = 50 + ; query = None + ; storages = [ Memory_lmdb_nosync; Lmdb_file; Sqlite_file ] + ; data_dir = Filename.get_temp_dir_name () + } + +let storage_label = function + | Memory_lmdb_nosync -> "memory-lmdb-nosync" + | Lmdb_file -> "lmdb" + | Sqlite_file -> "sqlite" + +let parse_storage_list value = + value + |> String.split_on_char ',' + |> List.map String.trim + |> List.filter (fun s -> s <> "") + |> List.map (function + | "memory-lmdb-nosync" | "memory" -> Memory_lmdb_nosync + | "lmdb" -> Lmdb_file + | "sqlite" -> Sqlite_file + | other -> + invalid_arg + ("unknown storage " + ^ other + ^ " (expected: memory-lmdb-nosync|lmdb|sqlite, comma-separated)")) + +let int_from_env name default = + match Sys.getenv_opt name with + | Some value -> int_of_string value + | None -> default + +let float_from_env name default = + match Sys.getenv_opt name with + | Some value -> float_of_string value + | None -> default + +let config_from_env base = + { base with + warmup_ms = float_from_env "BENCH_WARMUP_MS" base.warmup_ms + ; sample_ms = float_from_env "BENCH_SAMPLE_MS" base.sample_ms + ; repeats = int_from_env "BENCH_REPEATS" base.repeats + ; jit_warmup = int_from_env "BENCH_JIT_WARMUP" base.jit_warmup + ; size = int_from_env "BENCH_SIZE" base.size + ; pages = int_from_env "BENCH_PAGES" base.pages + } + +let parse_args () = + let config = ref (config_from_env default_config) in + let debug_profile = ref false in + let set_size value = config := { !config with size = int_of_string value } in + let set_pages value = config := { !config with pages = int_of_string value } in + let set_warmup value = config := { !config with warmup_ms = float_of_string value } in + let set_sample_ms value = config := { !config with sample_ms = float_of_string value } in + let set_repeats value = config := { !config with repeats = int_of_string value } in + let set_jit_warmup value = config := { !config with jit_warmup = int_of_string value } in + let set_query value = config := { !config with query = Some value } in + let set_storage value = + config := + { !config with + storages = + (match value with + | "all" -> [ Memory_lmdb_nosync; Lmdb_file; Sqlite_file ] + | "compare" -> [ Lmdb_file; Sqlite_file ] + | other -> parse_storage_list other) + } + in + let set_data_dir value = config := { !config with data_dir = value } in + let rec loop = function + | [] -> !config, !debug_profile + | "--size" :: value :: rest -> + set_size value; + loop rest + | "--pages" :: value :: rest -> + set_pages value; + loop rest + | "--warmup-ms" :: value :: rest -> + set_warmup value; + loop rest + | "--sample-ms" :: value :: rest -> + set_sample_ms value; + loop rest + | "--repeats" :: value :: rest -> + set_repeats value; + loop rest + | "--jit-warmup" :: value :: rest -> + set_jit_warmup value; + loop rest + | "--query" :: value :: rest -> + set_query value; + loop rest + | "--storage" :: value :: rest -> + set_storage value; + loop rest + | "--data-dir" :: value :: rest -> + set_data_dir value; + loop rest + | "--debug-profile" :: rest -> + debug_profile := true; + loop rest + | arg :: _ -> invalid_arg ("unknown benchmark argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let now_ms () = Unix.gettimeofday () *. 1000. + +let median values = + let sorted = List.sort Float.compare values in + List.nth sorted (List.length sorted / 2) + +let format_ms value = + if value > 1. then Printf.sprintf "%.2f" value + else if value > 0.01 then Printf.sprintf "%.3f" value + else Printf.sprintf "%.4f" value + +let blackhole = ref 0 + +let bump n = blackhole := (!blackhole + n) land 0x3fffffff + +let consume_seq seq = bump (Seq.fold_left (fun n _ -> n + 1) 0 seq) + +let consume_rows rows = + match rows with + | [] -> () + | first :: rest -> + bump (List.length first + if rest == [] then 0 else 1) + +let keep_take n pred seq = + let rec loop i seq acc = + if i <= 0 then List.rev acc + else + match seq () with + | Seq.Nil -> List.rev acc + | Seq.Cons (x, xs) -> + if pred x then loop (i - 1) xs (x :: acc) else loop i xs acc + in + loop n seq [] + +let dotime duration_ms step f = + let start = now_ms () in + let deadline = start +. duration_ms in + let rec loop iterations = + for _ = 1 to step do + f () + done; + let iterations = iterations + step in + if now_ms () < deadline then loop iterations else (now_ms () -. start) /. float iterations + in + loop step + +let bench config f = + ignore (dotime config.warmup_ms config.step f); + let samples = List.init config.repeats (fun _ -> dotime config.sample_ms config.step f) in + median samples + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let unique_identity = { indexed with unique = Some Identity } +let ref_one = { indexed with value_type = Some RefType } +let ref_many = { ref_one with cardinality = Many } + +(* Minimal Logseq-like attrs used by initial_data / common lookups. *) +let schema = + [ "block/uuid", unique_identity + ; "block/title", indexed + ; "block/name", indexed + ; "block/updated-at", indexed + ; "block/created-at", indexed + ; "block/journal-day", indexed + ; "block/parent", ref_one + ; "block/page", ref_one + ; "block/tags", ref_many + ; "block/refs", ref_many + ; "block/content", indexed + ] + +let uuid_of i = Printf.sprintf "00000000-0000-4000-8000-%012d" i + +(* Day integers like Logseq journal-day (YYYYMMDD-ish packed ints). *) +let journal_day_of i = 202_501_01 + (i mod 400) + +let build_logseq_graph ~size ~pages = + let pages = max 1 (min pages size) in + let base_ms = 1_700_000_000_000 in + let day_ms = 86_400_000 in + let tag_count = min 32 pages in + (* Pages sit at the high end of updated-at so rseek finds them quickly — + matching “recently edited pages” rather than burying them under blocks. *) + let page_updated e = base_ms + (10 * day_ms) + (e * 1_000) in + let block_updated e = base_ms + (e * 30) in + let page_entity e = + let updated = page_updated e in + let is_journal = e mod 5 = 0 in + let attrs = + [ "block/uuid", One_value (String (uuid_of e)) + ; "block/title", One_value (String (Printf.sprintf "Page %d" e)) + ; "block/name", One_value (String (Printf.sprintf "page-%d" e)) + ; "block/updated-at", One_value (Int updated) + ; "block/created-at", One_value (Int (updated - day_ms)) + ; "block/content", One_value (String (Printf.sprintf "page body %d" e)) + ] + @ (if is_journal then [ "block/journal-day", One_value (Int (journal_day_of e)) ] else []) + @ + if e mod 7 = 0 then + [ "block/tags", Many_values [ Ref ((e mod tag_count) + 1) ] ] + else + [] + in + Entity { db_id = Some (Entity_id e); attrs } + in + let block_entity index = + let e = pages + index + 1 in + let page = 1 + (index mod pages) in + let parent = if index = 0 || index mod 3 = 0 then page else e - 1 in + let updated = block_updated e in + let attrs = + [ "block/uuid", One_value (String (uuid_of e)) + ; "block/title", One_value (String (Printf.sprintf "Block %d" e)) + ; "block/updated-at", One_value (Int updated) + ; "block/created-at", One_value (Int (updated - 60_000)) + ; "block/parent", One_value (Ref parent) + ; "block/page", One_value (Ref page) + ; "block/content", One_value (String (Printf.sprintf "block body %d" e)) + ] + @ + if e mod 11 = 0 then + [ "block/tags", Many_values [ Ref ((e mod tag_count) + 1) ] + ; "block/refs", Many_values [ Ref page ] + ] + else + [] + in + Entity { db_id = Some (Entity_id e); attrs } + in + let ops = + Array.init size (fun index -> + if index < pages then page_entity (index + 1) else block_entity (index - pages)) + in + ops, pages, base_ms + +type prepared = + { label : string + ; db : db + ; pages : int + ; size : int + ; base_ms : int + ; mid_tx : tx + ; sample_uuid : string + ; sample_page : entity_id + ; sample_tag : entity_id + ; build_ms : float + ; restore_ms : float + ; path : string option + ; cleanup : unit -> unit + } + +let remove_path path = + if Sys.file_exists path then Sys.remove path; + List.iter + (fun suffix -> + let sibling = path ^ suffix in + if Sys.file_exists sibling then Sys.remove sibling) + [ "-wal"; "-shm"; "-lock" ] + +let file_size path = + if Sys.file_exists path then (Unix.stat path).st_size else 0 + +let disk_footprint path = + List.fold_left + (fun total suffix -> total + file_size (if suffix = "" then path else path ^ suffix)) + 0 + [ ""; "-wal"; "-shm"; "-lock" ] + +let build_db ~storage ~persist ~size ~pages = + set_tave_retention_days 30; + let ops, pages, base_ms = build_logseq_graph ~size ~pages in + let started = now_ms () in + (* Spread entities across txs so since/TAVE has a meaningful window. *) + let batch = 250 in + let rec loop db i = + if i >= Array.length ops then db + else + let hi = min (Array.length ops) (i + batch) in + let chunk = Array.to_list (Array.sub ops i (hi - i)) in + let instant = base_ms + (i * 1_000) in + let r = transact ~tx_meta:[ "db/txInstant", Instant instant ] db chunk in + loop r.db_after hi + in + let db = loop (empty_db ~schema ~storage ()) 0 in + let db = refresh_db_indexes db in + let build_ms = now_ms () -. started in + let mid_tx = db.max_tx / 2 in + let sample_page = 1 in + let sample_tag = 1 in + let sample_uuid = uuid_of (max 1 (pages / 2)) in + if not persist then + db, pages, base_ms, mid_tx, sample_uuid, sample_page, sample_tag, build_ms, 0. + else + let store_started = now_ms () in + store db; + collect_garbage storage; + let restored = + match restore storage with + | Some db -> db + | None -> failwith "storage-backed logseq bench should restore" + in + let restore_ms = now_ms () -. store_started in + restored, pages, base_ms, mid_tx, sample_uuid, sample_page, sample_tag, build_ms, restore_ms + +let prepare_backend ~data_dir backend ~size ~pages = + match backend with + | Memory_lmdb_nosync -> + let storage = benchmark_memory_storage () in + let db, pages, base_ms, mid_tx, sample_uuid, sample_page, sample_tag, build_ms, restore_ms = + build_db ~storage ~persist:false ~size ~pages + in + { label = storage_label backend + ; db + ; pages + ; size + ; base_ms + ; mid_tx + ; sample_uuid + ; sample_page + ; sample_tag + ; build_ms + ; restore_ms + ; path = None + ; cleanup = Fun.id + } + | Lmdb_file -> + let path = + Filename.concat data_dir (Printf.sprintf "logseq-query-bench-lmdb-%d.mdb" size) + in + remove_path path; + let session = Datascript_lmdb.open_session path in + let storage = storage_of_handle (Datascript_lmdb.storage session) in + let db, pages, base_ms, mid_tx, sample_uuid, sample_page, sample_tag, build_ms, restore_ms = + build_db ~storage ~persist:true ~size ~pages + in + { label = storage_label backend + ; db + ; pages + ; size + ; base_ms + ; mid_tx + ; sample_uuid + ; sample_page + ; sample_tag + ; build_ms + ; restore_ms + ; path = Some path + ; cleanup = + (fun () -> + Datascript_lmdb.close session; + remove_path path) + } + | Sqlite_file -> + let path = + Filename.concat data_dir + (Printf.sprintf "logseq-query-bench-sqlite-%d.sqlite3" size) + in + remove_path path; + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db, pages, base_ms, mid_tx, sample_uuid, sample_page, sample_tag, build_ms, restore_ms = + build_db ~storage ~persist:true ~size ~pages + in + { label = storage_label backend + ; db + ; pages + ; size + ; base_ms + ; mid_tx + ; sample_uuid + ; sample_page + ; sample_tag + ; build_ms + ; restore_ms + ; path = Some path + ; cleanup = + (fun () -> + Datascript_sqlite.close session; + remove_path path) + } + +type query_case = + { name : string + ; run : prepared -> unit + } + +(* Selective forward attrs — Logseq page?/title checks are lazy, not pull [*]. *) +let hydrate_forward e = + List.iter + (fun attr -> match entity_attr e attr with Some _ -> bump 1 | None -> ()) + [ "block/uuid"; "block/title"; "block/name"; "block/updated-at"; "block/journal-day" ] + +(* Logseq: (rseq (d/datoms db :avet attr)) — exact attr, then reverse. + Not rseek-datoms (which continues into earlier attrs per DataScript). *) +let avet_attr_rseq db attr = + datoms db Avet ~a:attr () |> List.of_seq |> List.rev |> List.to_seq + +(* Mirror get-recent-updated-pages: reverse AVET updated-at, keep pages, take 15. *) +let recent_pages prepared = + let db = prepared.db in + let is_page d = + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/page" ()) with + | Some _ -> false + | None -> ( + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/title" ()) with + | Some (t, _) -> (match t.v with String s -> String.trim s <> "" | _ -> false) + | None -> false) + in + let pages = keep_take 15 is_page (avet_attr_rseq db "block/updated-at") in + List.iter + (fun d -> + match entity db (Entity_id d.e) with + | Some e -> hydrate_forward e + | None -> ()) + pages + +(* Mirror get-latest-journals: reverse journal-day AVET, take 10 journals. *) +let latest_journals prepared = + let today = journal_day_of prepared.pages in + let kept = + keep_take 10 + (fun d -> match d.v with Int day -> day <= today | _ -> false) + (avet_attr_rseq prepared.db "block/journal-day") + in + List.iter + (fun d -> + match entity prepared.db (Entity_id d.e) with + | Some e -> hydrate_forward e + | None -> ()) + kept + +let uuid_lookup prepared = + match entity prepared.db (Lookup_ref ("block/uuid", String prepared.sample_uuid)) with + | Some e -> hydrate_forward e + | None -> bump 0 + +let title_lookup prepared = + let title = Printf.sprintf "Page %d" (prepared.pages / 2) in + consume_seq (datoms prepared.db Avet ~a:"block/title" ~v:(String title) ()) + +let children_by_parent prepared = + consume_seq + (datoms prepared.db Avet ~a:"block/parent" ~v:(Ref prepared.sample_page) ()) + +let blocks_by_page prepared = + consume_seq (datoms prepared.db Avet ~a:"block/page" ~v:(Ref prepared.sample_page) ()) + +let tags_scan prepared = + consume_seq (datoms prepared.db Avet ~a:"block/tags" ~v:(Ref prepared.sample_tag) ()) + +let eavt_entity prepared = + consume_seq (datoms prepared.db Eavt ~e:prepared.sample_page ()) + +let entity_hydrate prepared = + match entity prepared.db (Entity_id prepared.sample_page) with + | Some e -> hydrate_forward e + | None -> bump 0 + +(* Full materialize including reverse refs (all_datoms scan) — expensive; kept for contrast. *) +let entity_attrs_full prepared = + match entity prepared.db (Entity_id prepared.sample_page) with + | Some e -> bump (List.length (entity_attrs e)) + | None -> bump 0 + +(* DSL-like between on updated-at (Logseq (between …) expands similarly). *) +let q_updated_at_between prepared = + let lo = prepared.base_ms + 3_600_000 in + let hi = prepared.base_ms + 86_400_000 in + let query = + "[:find ?e ?t :in $ ?lo ?hi :where [?e :block/updated-at ?t] [(>= ?t ?lo)] [(<= ?t ?hi)]]" + in + consume_rows + (q_string + ~inputs: + [ Arg_scalar (Result_value (Int lo)); Arg_scalar (Result_value (Int hi)) ] + prepared.db query) + +let q_journal_pages prepared = + consume_rows + (q_string prepared.db + "[:find ?e ?d :where [?e :block/journal-day ?d] [?e :block/title ?t]]") + +let q_page_by_name prepared = + let name = Printf.sprintf "page-%d" (prepared.pages / 3) in + consume_rows + (q_string + ~inputs:[ Arg_scalar (Result_value (String name)) ] + prepared.db + "[:find ?e :in $ ?n :where [?e :block/name ?n]]") + +(* Engine path Logseq does not use today: since + attr AEVT (TAVE when clean). *) +let since_attr_aevt prepared = + consume_seq (datoms (since prepared.mid_tx prepared.db) Aevt ~a:"block/updated-at" ()) + +let full_attr_aevt prepared = + consume_seq (datoms prepared.db Aevt ~a:"block/updated-at" ()) + +let since_attr_avet prepared = + consume_seq (datoms (since prepared.mid_tx prepared.db) Avet ~a:"block/updated-at" ()) + +let queries = + [ { name = "recent-pages"; run = recent_pages } + ; { name = "latest-journals"; run = latest_journals } + ; { name = "uuid-lookup"; run = uuid_lookup } + ; { name = "title-lookup"; run = title_lookup } + ; { name = "children-by-parent"; run = children_by_parent } + ; { name = "blocks-by-page"; run = blocks_by_page } + ; { name = "tags-scan"; run = tags_scan } + ; { name = "eavt-entity"; run = eavt_entity } + ; { name = "entity-hydrate"; run = entity_hydrate } + ; { name = "entity-attrs-full"; run = entity_attrs_full } + ; { name = "q-updated-at-between"; run = q_updated_at_between } + ; { name = "q-journal-pages"; run = q_journal_pages } + ; { name = "q-page-by-name"; run = q_page_by_name } + ; { name = "since-attr-aevt"; run = since_attr_aevt } + ; { name = "full-attr-aevt"; run = full_attr_aevt } + ; { name = "since-attr-avet"; run = since_attr_avet } + ] + +let query_names = List.map (fun q -> q.name) queries + +let select_queries = function + | None -> queries + | Some name -> ( + match List.find_opt (fun q -> q.name = name) queries with + | Some q -> [ q ] + | None -> + invalid_arg + (Printf.sprintf "unknown query %S (available: %s)" name (String.concat ", " query_names))) + +let warmup_queries jit_warmup selected prepared = + if jit_warmup <= 0 then () + else + List.iter + (fun query -> + for _ = 1 to jit_warmup do + query.run prepared + done) + selected + +let run_backend config selected prepared = + Printf.printf "storage\t%s\n%!" prepared.label; + (match prepared.path with + | Some path -> + Printf.printf "path\t%s\n%!" path; + Printf.printf "disk-bytes\t%d\n%!" (disk_footprint path) + | None -> Printf.printf "path\tmemory\n%!"); + Printf.printf "pages\t%d\n%!" prepared.pages; + Printf.printf "entities\t%d\n%!" prepared.size; + Printf.printf "mid-tx\t%d\n%!" prepared.mid_tx; + Printf.printf "build-ms\t%s\n%!" (format_ms prepared.build_ms); + if prepared.restore_ms > 0. then + Printf.printf "store-restore-ms\t%s\n%!" (format_ms prepared.restore_ms); + Printf.eprintf + "[%s] JIT pre-warmup (%d/query)...\n%!" + prepared.label + config.jit_warmup; + warmup_queries config.jit_warmup selected prepared; + Printf.eprintf "[%s] Running %d logseq query cases...\n%!" prepared.label (List.length selected); + List.iter + (fun query -> + let ms = bench config (fun () -> query.run prepared) in + Printf.printf "%s\t%s\n%!" query.name (format_ms ms)) + selected + +let ensure_dir path = + let rec loop dir = + if dir = "" || dir = Filename.current_dir_name || Sys.file_exists dir then () + else ( + loop (Filename.dirname dir); + try Unix.mkdir dir 0o755 with + | Unix.Unix_error (Unix.EEXIST, _, _) -> ()) + in + loop path + +let debug_ms label t0 = + let elapsed = now_ms () -. t0 in + Printf.printf "debug\t%s\t%.3f\n%!" label elapsed; + elapsed + +(* Phase-level instrumentation for recent-pages / entity — evidence only, no behavior change. *) +let debug_profile_recent prepared = + let db = prepared.db in + Printf.printf "debug\tstorage\t%s\n%!" prepared.label; + Printf.printf "debug\tentities\t%d\n%!" prepared.size; + Printf.printf "debug\tpages\t%d\n%!" prepared.pages; + (* 1) Force full AVET updated-at via datoms (ascending). *) + let t0 = now_ms () in + let avet_count = Seq.fold_left (fun n _ -> n + 1) 0 (datoms db Avet ~a:"block/updated-at" ()) in + ignore (debug_ms "datoms-avet-updated-at-full-count" t0); + Printf.printf "debug\tavet-updated-at-count\t%d\n%!" avet_count; + (* 2) Force full rseek of same attr. *) + let t0 = now_ms () in + let rseek_count = + Seq.fold_left (fun n _ -> n + 1) 0 (rseek_datoms db Avet ~a:"block/updated-at" ()) + in + ignore (debug_ms "rseek-avet-updated-at-full-count" t0); + Printf.printf "debug\trseek-updated-at-count\t%d\n%!" rseek_count; + (* 3) Take first 15 from rseek with no filter. *) + let t0 = now_ms () in + let first15 = + let rec loop i seq acc = + if i <= 0 then List.rev acc + else + match seq () with + | Seq.Nil -> List.rev acc + | Seq.Cons (x, xs) -> loop (i - 1) xs (x :: acc) + in + loop 15 (rseek_datoms db Avet ~a:"block/updated-at" ()) [] + in + ignore (debug_ms "rseek-take-15-nofilter" t0); + Printf.printf "debug\trseek-first15-e\t%s\n%!" + (String.concat "," (List.map (fun d -> string_of_int d.e) first15)); + Printf.printf "debug\trseek-first15-a\t%s\n%!" + (String.concat "," (List.map (fun d -> d.a) first15)); + (* Logseq path: exact attr datoms then reverse *) + let t0 = now_ms () in + let exact_rev = + datoms db Avet ~a:"block/updated-at" () + |> List.of_seq + |> List.rev + in + ignore (debug_ms "datoms-avet-attr-then-list-rev" t0); + Printf.printf "debug\texact-rev-count\t%d\n%!" (List.length exact_rev); + let exact15 = List.filteri (fun i _ -> i < 15) exact_rev in + Printf.printf "debug\texact-rev-first15-e\t%s\n%!" + (String.concat "," (List.map (fun d -> string_of_int d.e) exact15)); + let t0 = now_ms () in + let _ = + keep_take 15 + (fun d -> + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/page" ()) with + | Some _ -> false + | None -> true) + (List.to_seq exact_rev) + in + ignore (debug_ms "logseq-style-keep-take-15-on-exact-rev" t0); + (* 4) keep_take 15 with is_page on Logseq-style exact-attr reverse. *) + let visited = ref 0 in + let page_hits = ref 0 in + let filter_ms = ref 0. in + let is_page d = + let t = now_ms () in + incr visited; + let ok = + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/page" ()) with + | Some _ -> false + | None -> ( + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/title" ()) with + | Some (t, _) -> (match t.v with String s -> String.trim s <> "" | _ -> false) + | None -> false) + in + if ok then incr page_hits; + filter_ms := !filter_ms +. (now_ms () -. t); + ok + in + let t0 = now_ms () in + let pages = keep_take 15 is_page (avet_attr_rseq db "block/updated-at") in + let keep_ms = debug_ms "keep-take-15-is-page-logseq-style" t0 in + Printf.printf "debug\tkeep-visited\t%d\n%!" !visited; + Printf.printf "debug\tkeep-page-hits\t%d\n%!" !page_hits; + Printf.printf "debug\tkeep-filter-ms-sum\t%.3f\n%!" !filter_ms; + Printf.printf "debug\tkeep-scan-overhead-ms\t%.3f\n%!" (keep_ms -. !filter_ms); + Printf.printf "debug\tkeep-page-e\t%s\n%!" + (String.concat "," (List.map (fun d -> string_of_int d.e) pages)); + (* 5) Hydrate costs: entity only, entity_attr x5, entity_attrs full. *) + let sample_e = + match pages with + | d :: _ -> d.e + | [] -> prepared.sample_page + in + let t0 = now_ms () in + let ent = entity db (Entity_id sample_e) in + ignore (debug_ms "entity-only" t0); + (match ent with + | None -> Printf.printf "debug\tentity-missing\t%d\n%!" sample_e + | Some e -> + let t0 = now_ms () in + List.iter + (fun attr -> + let t = now_ms () in + let v = entity_attr e attr in + Printf.printf "debug\tentity-attr\t%s\t%.3f\tpresent=%b\n%!" attr (now_ms () -. t) + (Option.is_some v)) + [ "block/uuid"; "block/title"; "block/name"; "block/updated-at"; "block/journal-day" ]; + ignore (debug_ms "hydrate-forward-5attrs" t0); + let t0 = now_ms () in + let n = List.length (entity_attrs e) in + ignore (debug_ms "entity-attrs-full" t0); + Printf.printf "debug\tentity-attrs-count\t%d\n%!" n); + (* 6) Repeat full recent_pages once timed. *) + let t0 = now_ms () in + recent_pages prepared; + ignore (debug_ms "recent-pages-once" t0); + (* 7) Contrast: datoms Eavt for one entity. *) + let t0 = now_ms () in + let n = Seq.fold_left (fun n _ -> n + 1) 0 (datoms db Eavt ~e:sample_e ()) in + ignore (debug_ms "datoms-eavt-one-entity" t0); + Printf.printf "debug\teavt-one-entity-count\t%d\n%!" n; + (* 8) Full EAVT count (entity_attrs reverse path scans this). *) + let t0 = now_ms () in + let n = Seq.fold_left (fun n _ -> n + 1) 0 (datoms db Eavt ()) in + ignore (debug_ms "datoms-eavt-full" t0); + Printf.printf "debug\teavt-full-count\t%d\n%!" n + +let main () = + let config, do_debug = parse_args () in + let selected = select_queries config.query in + ensure_dir config.data_dir; + Printf.printf "runtime\tocaml\n%!"; + Printf.printf "suite\tlogseq-queries\n%!"; + Printf.printf "size\t%d\n%!" config.size; + Printf.printf "pages\t%d\n%!" config.pages; + Printf.printf "warmup-ms\t%.0f\n%!" config.warmup_ms; + Printf.printf "sample-ms\t%.0f\n%!" config.sample_ms; + Printf.printf "repeats\t%d\n%!" config.repeats; + Printf.printf "jit-warmup\t%d\n%!" config.jit_warmup; + Printf.printf "data-dir\t%s\n%!" config.data_dir; + Printf.printf "query-cases\t%d\n%!" (List.length selected); + Printf.printf "debug-profile\t%b\n%!" do_debug; + (match config.query with + | Some name -> Printf.printf "query\t%s\n%!" name + | None -> ()); + List.iter + (fun backend -> + Printf.eprintf + "Building logseq-shaped db (entities=%d pages=%d storage=%s)...\n%!" + config.size config.pages (storage_label backend); + let prepared = + prepare_backend ~data_dir:config.data_dir backend ~size:config.size ~pages:config.pages + in + Fun.protect ~finally:prepared.cleanup (fun () -> + if do_debug then debug_profile_recent prepared + else run_backend config selected prepared)) + config.storages; + Printf.eprintf "blackhole=%d\n%!" !blackhole + +let () = + if Array.mem "--list-queries" Sys.argv then ( + List.iter (fun q -> Printf.printf "%s\n%!" q.name) queries; + exit 0); + main () diff --git a/bench/logseq_query_bench_shared.ml b/bench/logseq_query_bench_shared.ml new file mode 100644 index 0000000..0524c1e --- /dev/null +++ b/bench/logseq_query_bench_shared.ml @@ -0,0 +1,569 @@ +(* Logseq-shaped shared query suite for cross-runtime comparison. + Durable backend: SQLite (store + restore) — same shape as the nbb CLJS harness. *) + +open Datascript + +type config = + { size : int + ; pages : int + ; warmup_ms : float + ; sample_ms : float + ; repeats : int + ; step : int + ; jit_warmup : int + ; query : string option + ; sqlite_path : string option + } + +let default_config = + { size = 20_000 + ; pages = 2_000 + ; warmup_ms = 200. + ; sample_ms = 200. + ; repeats = 3 + ; step = 5 + ; jit_warmup = 50 + ; query = None + ; sqlite_path = None + } + +let int_from_env name default = + match Sys.getenv_opt name with + | Some value -> int_of_string value + | None -> default + +let float_from_env name default = + match Sys.getenv_opt name with + | Some value -> float_of_string value + | None -> default + +let parse_args () = + let config = + ref + { default_config with + warmup_ms = float_from_env "BENCH_WARMUP_MS" default_config.warmup_ms + ; sample_ms = float_from_env "BENCH_SAMPLE_MS" default_config.sample_ms + ; repeats = int_from_env "BENCH_REPEATS" default_config.repeats + ; jit_warmup = int_from_env "BENCH_JIT_WARMUP" default_config.jit_warmup + ; size = int_from_env "BENCH_SIZE" default_config.size + ; pages = int_from_env "BENCH_PAGES" default_config.pages + } + in + let rec loop = function + | [] -> !config + | "--size" :: v :: rest -> + config := { !config with size = int_of_string v }; + loop rest + | "--pages" :: v :: rest -> + config := { !config with pages = int_of_string v }; + loop rest + | "--warmup-ms" :: v :: rest -> + config := { !config with warmup_ms = float_of_string v }; + loop rest + | "--sample-ms" :: v :: rest -> + config := { !config with sample_ms = float_of_string v }; + loop rest + | "--repeats" :: v :: rest -> + config := { !config with repeats = int_of_string v }; + loop rest + | "--jit-warmup" :: v :: rest -> + config := { !config with jit_warmup = int_of_string v }; + loop rest + | "--query" :: v :: rest -> + config := { !config with query = Some v }; + loop rest + | "--sqlite" :: v :: rest -> + config := { !config with sqlite_path = Some v }; + loop rest + | arg :: _ -> invalid_arg ("unknown argument: " ^ arg) + in + Sys.argv |> Array.to_list |> List.tl |> loop + +let now_ms () = Unix.gettimeofday () *. 1000. + +let median values = + let sorted = List.sort Float.compare values in + List.nth sorted (List.length sorted / 2) + +let format_ms value = + if value > 1. then Printf.sprintf "%.2f" value + else if value > 0.01 then Printf.sprintf "%.3f" value + else Printf.sprintf "%.4f" value + +let blackhole = ref 0 +let bump n = blackhole := (!blackhole + n) land 0x3fffffff +let consume_seq seq = bump (Seq.fold_left (fun n _ -> n + 1) 0 seq) + +let consume_rows rows = + match rows with + | [] -> () + | first :: rest -> bump (List.length first + if rest == [] then 0 else 1) + +let keep_take n pred seq = + let rec loop i seq acc = + if i <= 0 then List.rev acc + else + match seq () with + | Seq.Nil -> List.rev acc + | Seq.Cons (x, xs) -> if pred x then loop (i - 1) xs (x :: acc) else loop i xs acc + in + loop n seq [] + +let dotime duration_ms step f = + let start = now_ms () in + let deadline = start +. duration_ms in + let rec loop iterations = + for _ = 1 to step do + f () + done; + let iterations = iterations + step in + if now_ms () < deadline then loop iterations else (now_ms () -. start) /. float iterations + in + loop step + +let bench config f = + ignore (dotime config.warmup_ms config.step f); + let samples = List.init config.repeats (fun _ -> dotime config.sample_ms config.step f) in + median samples + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let unique_identity = { indexed with unique = Some Identity } +let ref_one = { indexed with value_type = Some RefType } +let ref_many = { ref_one with cardinality = Many } + +let schema = + [ "block/uuid", unique_identity + ; "block/title", indexed + ; "block/name", indexed + ; "block/updated-at", indexed + ; "block/created-at", indexed + ; "block/journal-day", indexed + ; "block/parent", ref_one + ; "block/page", ref_one + ; "block/tags", ref_many + ; "block/refs", ref_many + ; "block/content", indexed + ] + +let uuid_of i = Printf.sprintf "00000000-0000-4000-8000-%012d" i +let journal_day_of i = 202_501_01 + (i mod 400) + +let build_graph ~size ~pages = + let pages = max 1 (min pages size) in + let base_ms = 1_700_000_000_000 in + let day_ms = 86_400_000 in + let tag_count = min 32 pages in + let page_updated e = base_ms + (10 * day_ms) + (e * 1_000) in + let block_updated e = base_ms + (e * 30) in + let page_entity e = + let updated = page_updated e in + let is_journal = e mod 5 = 0 in + let attrs = + [ "block/uuid", One_value (String (uuid_of e)) + ; "block/title", One_value (String (Printf.sprintf "Page %d" e)) + ; "block/name", One_value (String (Printf.sprintf "page-%d" e)) + ; "block/updated-at", One_value (Int updated) + ; "block/created-at", One_value (Int (updated - day_ms)) + ; "block/content", One_value (String (Printf.sprintf "page body %d" e)) + ] + @ (if is_journal then [ "block/journal-day", One_value (Int (journal_day_of e)) ] else []) + @ + if e mod 7 = 0 then [ "block/tags", Many_values [ Ref ((e mod tag_count) + 1) ] ] else [] + in + Entity { db_id = Some (Entity_id e); attrs } + in + let block_entity index = + let e = pages + index + 1 in + let page = 1 + (index mod pages) in + let parent = if index = 0 || index mod 3 = 0 then page else e - 1 in + let updated = block_updated e in + let attrs = + [ "block/uuid", One_value (String (uuid_of e)) + ; "block/title", One_value (String (Printf.sprintf "Block %d" e)) + ; "block/updated-at", One_value (Int updated) + ; "block/created-at", One_value (Int (updated - 60_000)) + ; "block/parent", One_value (Ref parent) + ; "block/page", One_value (Ref page) + ; "block/content", One_value (String (Printf.sprintf "block body %d" e)) + ] + @ + if e mod 11 = 0 then + [ "block/tags", Many_values [ Ref ((e mod tag_count) + 1) ] + ; "block/refs", Many_values [ Ref page ] + ] + else + [] + in + Entity { db_id = Some (Entity_id e); attrs } + in + let ops = + Array.init size (fun index -> + if index < pages then page_entity (index + 1) else block_entity (index - pages)) + in + Array.to_list ops, pages, base_ms + +let remove_path path = + if Sys.file_exists path then Sys.remove path; + List.iter + (fun suffix -> + let sibling = path ^ suffix in + if Sys.file_exists sibling then Sys.remove sibling) + [ "-wal"; "-shm"; "-lock" ] + +let file_size path = + if Sys.file_exists path then (Unix.stat path).st_size else 0 + +type prepared = + { db : db + ; pages : int + ; base_ms : int + ; sample_uuid : string + ; sample_page : entity_id + ; sample_tag : entity_id + ; build_ms : float + ; restore_ms : float + ; sqlite_path : string + ; cleanup : unit -> unit + } + +let build ~size ~pages ~sqlite_path = + let ops, pages, base_ms = build_graph ~size ~pages in + let path = + match sqlite_path with + | Some p -> p + | None -> Filename.temp_file "logseq-query-bench-shared-" ".sqlite3" + in + remove_path path; + let started = now_ms () in + let session = Datascript_sqlite.open_session path in + (* Current branch: sqlite plugin returns Datascript_types.storage (Storage_handle). + origin/main returns Datascript.storage directly — compare script strips + storage_of_handle / refresh_db_indexes when copying into the main worktree. *) + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db = db_with ops (empty_db ~schema ~storage ()) in + let db = refresh_db_indexes db in + store db; + collect_garbage storage; + let build_ms = now_ms () -. started in + let restore_started = now_ms () in + let restored = + match restore storage with + | Some db -> db + | None -> failwith "sqlite restore failed" + in + let restore_ms = now_ms () -. restore_started in + { db = restored + ; pages + ; base_ms + ; sample_uuid = uuid_of (max 1 (pages / 2)) + ; sample_page = 1 + ; sample_tag = 1 + ; build_ms + ; restore_ms + ; sqlite_path = path + ; cleanup = + (fun () -> + Datascript_sqlite.close session; + remove_path path) + } + +let hydrate_forward e = + List.iter + (fun attr -> match entity_attr e attr with Some _ -> bump 1 | None -> ()) + [ "block/uuid"; "block/title"; "block/name"; "block/updated-at"; "block/journal-day" ] + +let avet_attr_rseq db attr = + (* Match CLJS `(rseq (datoms :avet attr))` — reverse scan of one attr only. *) + rseek_datoms db Avet ~a:attr () + +let is_page db d = + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/page" ()) with + | Some _ -> false + | None -> ( + match Seq.uncons (datoms db Eavt ~e:d.e ~a:"block/title" ()) with + | Some (t, _) -> (match t.v with String s -> String.trim s <> "" | _ -> false) + | None -> false) + +let recent_page_datoms p = + keep_take 15 (is_page p.db) (avet_attr_rseq p.db "block/updated-at") + +let journal_day_value = function + | Int day -> Some day + | Float f when float_of_int (int_of_float f) = f -> Some (int_of_float f) + | _ -> None + +let latest_journal_datoms p = + let today = journal_day_of p.pages in + keep_take 10 + (fun d -> match journal_day_value d.v with Some day -> day <= today | None -> false) + (avet_attr_rseq p.db "block/journal-day") + +(* Canonical EDN strings for cross-runtime result equality (match Clojure pr-str). *) +let edn_of_value = function + | Nil -> "nil" + | Bool true -> "true" + | Bool false -> "false" + | Int i -> string_of_int i + | Float f when float_of_int (int_of_float f) = f -> string_of_int (int_of_float f) + | Float f -> + (* Match JS/Clojure number print for this workload (ints + small floats). *) + let s = Printf.sprintf "%.15g" f in + if String.contains s '.' || String.contains s 'e' || String.contains s 'E' then s + else s ^ ".0" + | String s -> "\"" ^ String.escaped s ^ "\"" + | Keyword k -> ":" ^ k + | Symbol s -> s + | Uuid u -> "#uuid \"" ^ u ^ "\"" + | Instant i -> string_of_int i + | Ref e -> string_of_int e + | other -> + (* Fallback: keep type visible without inventing EDN readers. *) + match other with + | Regex r -> "#\"" ^ String.escaped r ^ "\"" + | _ -> "nil" + +let edn_vector items = "[" ^ String.concat " " items ^ "]" + +let edn_of_tx_value = function + | One_value v -> edn_of_value v + | Many_values vs -> + vs + |> List.map edn_of_value + |> List.sort String.compare + |> edn_vector + | One_entity _ | Many_entities _ -> "nil" + +let edn_of_result_cell = function + | Result_value v -> edn_of_value v + | Result_entity e -> string_of_int e + | Result_attr a -> ":" ^ a + | Result_db _ -> "$" + | Result_pull _ -> "nil" + +let edn_of_q_rows rows = + rows + |> List.map (fun row -> edn_vector (List.map edn_of_result_cell row)) + |> List.sort String.compare + |> edn_vector + +let hydrate_edn_map e = + [ "block/uuid"; "block/title"; "block/name"; "block/updated-at"; "block/journal-day" ] + |> List.filter_map (fun attr -> + match entity_attr e attr with + | None -> None + | Some tv -> Some (edn_vector [ ":" ^ attr; edn_of_tx_value tv ])) + |> List.sort String.compare + |> edn_vector + +(* Pre-parse once — matches CLJS/Datahike quoted queries (no per-op string parse). *) +let q_updated_at_between_query = + parse_query_string + "[:find ?e ?t :in $ ?lo ?hi :where [?e :block/updated-at ?t] [(>= ?t ?lo)] [(<= ?t ?hi)]]" + +let q_journal_pages_query = + parse_query_string "[:find ?e ?d :where [?e :block/journal-day ?d] [?e :block/title ?t]]" + +let q_page_by_name_query = + parse_query_string "[:find ?e :in $ ?n :where [?e :block/name ?n]]" + +let result_edn p name = + match name with + | "recent-pages" -> + recent_page_datoms p |> List.map (fun d -> string_of_int d.e) |> edn_vector + | "latest-journals" -> + latest_journal_datoms p |> List.map (fun d -> string_of_int d.e) |> edn_vector + | "uuid-lookup" -> ( + match entity p.db (Lookup_ref ("block/uuid", String p.sample_uuid)) with + | None -> "nil" + | Some e -> edn_vector [ string_of_int e.id; hydrate_edn_map e ]) + | "title-lookup" -> + let title = Printf.sprintf "Page %d" (p.pages / 2) in + datoms p.db Avet ~a:"block/title" ~v:(String title) () + |> List.of_seq + |> List.map (fun d -> d.e) + |> List.sort compare + |> List.map string_of_int + |> edn_vector + | "children-by-parent" -> + datoms p.db Avet ~a:"block/parent" ~v:(Ref p.sample_page) () + |> List.of_seq + |> List.map (fun d -> d.e) + |> List.sort compare + |> List.map string_of_int + |> edn_vector + | "blocks-by-page" -> + datoms p.db Avet ~a:"block/page" ~v:(Ref p.sample_page) () + |> List.of_seq + |> List.map (fun d -> d.e) + |> List.sort compare + |> List.map string_of_int + |> edn_vector + | "tags-scan" -> + datoms p.db Avet ~a:"block/tags" ~v:(Ref p.sample_tag) () + |> List.of_seq + |> List.map (fun d -> d.e) + |> List.sort compare + |> List.map string_of_int + |> edn_vector + | "eavt-entity" -> + datoms p.db Eavt ~e:p.sample_page () + |> List.of_seq + |> List.map (fun d -> edn_vector [ ":" ^ d.a; edn_of_value d.v ]) + |> List.sort String.compare + |> edn_vector + | "entity-hydrate" -> ( + match entity p.db (Entity_id p.sample_page) with + | None -> "nil" + | Some e -> edn_vector [ string_of_int e.id; hydrate_edn_map e ]) + | "q-updated-at-between" -> + let lo = p.base_ms + 3_600_000 in + let hi = p.base_ms + 86_400_000 in + edn_of_q_rows + (q + ~inputs: + [ Arg_scalar (Result_value (Int lo)); Arg_scalar (Result_value (Int hi)) ] + p.db q_updated_at_between_query) + | "q-journal-pages" -> + edn_of_q_rows (q p.db q_journal_pages_query) + | "q-page-by-name" -> + let name = Printf.sprintf "page-%d" (p.pages / 3) in + edn_of_q_rows + (q ~inputs:[ Arg_scalar (Result_value (String name)) ] p.db q_page_by_name_query) + | other -> invalid_arg ("unknown result-edn query: " ^ other) + +let recent_pages p = + List.iter + (fun d -> match entity p.db (Entity_id d.e) with Some e -> hydrate_forward e | None -> ()) + (recent_page_datoms p) + +let latest_journals p = + List.iter + (fun d -> match entity p.db (Entity_id d.e) with Some e -> hydrate_forward e | None -> ()) + (latest_journal_datoms p) + +let uuid_lookup p = + match entity p.db (Lookup_ref ("block/uuid", String p.sample_uuid)) with + | Some e -> hydrate_forward e + | None -> bump 0 + +let title_lookup p = + let title = Printf.sprintf "Page %d" (p.pages / 2) in + consume_seq (datoms p.db Avet ~a:"block/title" ~v:(String title) ()) + +let children_by_parent p = + consume_seq (datoms p.db Avet ~a:"block/parent" ~v:(Ref p.sample_page) ()) + +let blocks_by_page p = + consume_seq (datoms p.db Avet ~a:"block/page" ~v:(Ref p.sample_page) ()) + +let tags_scan p = + consume_seq (datoms p.db Avet ~a:"block/tags" ~v:(Ref p.sample_tag) ()) + +let eavt_entity p = consume_seq (datoms p.db Eavt ~e:p.sample_page ()) + +let entity_hydrate p = + match entity p.db (Entity_id p.sample_page) with + | Some e -> hydrate_forward e + | None -> bump 0 + +let q_updated_at_between p = + let lo = p.base_ms + 3_600_000 in + let hi = p.base_ms + 86_400_000 in + consume_rows + (q + ~inputs: + [ Arg_scalar (Result_value (Int lo)); Arg_scalar (Result_value (Int hi)) ] + p.db q_updated_at_between_query) + +let q_journal_pages p = + consume_rows (q p.db q_journal_pages_query) + +let q_page_by_name p = + let name = Printf.sprintf "page-%d" (p.pages / 3) in + consume_rows + (q ~inputs:[ Arg_scalar (Result_value (String name)) ] p.db q_page_by_name_query) + +type query_case = { name : string; run : prepared -> unit } + +let queries = + [ { name = "recent-pages"; run = recent_pages } + ; { name = "latest-journals"; run = latest_journals } + ; { name = "uuid-lookup"; run = uuid_lookup } + ; { name = "title-lookup"; run = title_lookup } + ; { name = "children-by-parent"; run = children_by_parent } + ; { name = "blocks-by-page"; run = blocks_by_page } + ; { name = "tags-scan"; run = tags_scan } + ; { name = "eavt-entity"; run = eavt_entity } + ; { name = "entity-hydrate"; run = entity_hydrate } + ; { name = "q-updated-at-between"; run = q_updated_at_between } + ; { name = "q-journal-pages"; run = q_journal_pages } + ; { name = "q-page-by-name"; run = q_page_by_name } + ] + +let select_queries = function + | None -> queries + | Some name -> ( + match List.find_opt (fun q -> q.name = name) queries with + | Some q -> [ q ] + | None -> + invalid_arg + (Printf.sprintf "unknown query %S (available: %s)" name + (String.concat ", " (List.map (fun q -> q.name) queries)))) + +let () = + if Array.mem "--list-queries" Sys.argv then ( + List.iter (fun q -> Printf.printf "%s\n%!" q.name) queries; + exit 0); + let config = parse_args () in + let selected = select_queries config.query in + let label = + match Sys.getenv_opt "BENCH_RUNTIME_LABEL" with + | Some l -> l + | None -> "ocaml" + in + Printf.printf "runtime\t%s\n%!" label; + Printf.printf "suite\tlogseq-queries-shared\n%!"; + Printf.printf "backend\tsqlite\n%!"; + Printf.printf "size\t%d\n%!" config.size; + Printf.printf "pages\t%d\n%!" config.pages; + Printf.printf "warmup-ms\t%.0f\n%!" config.warmup_ms; + Printf.printf "sample-ms\t%.0f\n%!" config.sample_ms; + Printf.printf "repeats\t%d\n%!" config.repeats; + Printf.printf "jit-warmup\t%d\n%!" config.jit_warmup; + Printf.printf "query-cases\t%d\n%!" (List.length selected); + Printf.eprintf + "Building sqlite logseq graph (entities=%d pages=%d)...\n%!" config.size config.pages; + let prepared = build ~size:config.size ~pages:config.pages ~sqlite_path:config.sqlite_path in + Fun.protect ~finally:prepared.cleanup (fun () -> + Printf.printf "sqlite-path\t%s\n%!" prepared.sqlite_path; + Printf.printf "disk-bytes\t%d\n%!" (file_size prepared.sqlite_path); + Printf.printf "build-ms\t%s\n%!" (format_ms prepared.build_ms); + Printf.printf "restore-ms\t%s\n%!" (format_ms prepared.restore_ms); + List.iter + (fun q -> + Printf.printf "result-edn\t%s\t%s\n%!" q.name (result_edn prepared q.name)) + selected; + if config.jit_warmup > 0 then + List.iter + (fun q -> + for _ = 1 to config.jit_warmup do + q.run prepared + done) + selected; + List.iter + (fun q -> + let ms = bench config (fun () -> q.run prepared) in + Printf.printf "%s\t%s\n%!" q.name (format_ms ms)) + selected; + Printf.eprintf "blackhole=%d\n%!" !blackhole) diff --git a/bench/logseq_query_bench_upstream.cljs b/bench/logseq_query_bench_upstream.cljs new file mode 100644 index 0000000..9cb15d4 --- /dev/null +++ b/bench/logseq_query_bench_upstream.cljs @@ -0,0 +1,448 @@ +#!/usr/bin/env nbb-logseq +;; Logseq-shaped query bench via @logseq/nbb-logseq#feat-db-v34. +;; Persistence matches Logseq DB graphs (see logseq.db.common.sqlite-cli): +;; IStorage → SQLite kvs + transit, create-conn {:storage} + transact!. +;; No release-js / datascript.js interop. OCaml side stays non-PSS. +(ns logseq-query-bench-upstream + (:require + ["node:sqlite" :refer [DatabaseSync]] + ["fs" :as fs] + ["process" :as process] + [datascript.core :as d] + [datascript.storage :refer [IStorage]] + [datascript.transit :as dt])) + +(def default-config + {:size 20000 + :pages 2000 + :warmup-ms 200 + :sample-ms 200 + :repeats 3 + :step 5 + :jit-warmup 50 + :query nil + :sqlite-path nil}) + +(defn parse-args [argv] + (loop [cfg default-config + args (vec argv)] + (if (empty? args) + cfg + (let [[a b & more] args] + (case a + "--size" (recur (assoc cfg :size (js/parseInt b 10)) more) + "--pages" (recur (assoc cfg :pages (js/parseInt b 10)) more) + "--warmup-ms" (recur (assoc cfg :warmup-ms (js/parseFloat b)) more) + "--sample-ms" (recur (assoc cfg :sample-ms (js/parseFloat b)) more) + "--repeats" (recur (assoc cfg :repeats (js/parseInt b 10)) more) + "--jit-warmup" (recur (assoc cfg :jit-warmup (js/parseInt b 10)) more) + "--query" (recur (assoc cfg :query b) more) + "--sqlite" (recur (assoc cfg :sqlite-path b) more) + "--list-queries" (recur (assoc cfg :list-queries true) more) + (throw (js/Error. (str "unknown argument: " a)))))))) + +(defn now-ms [] + (let [t (.hrtime process)] + (+ (* (aget t 0) 1000) (/ (aget t 1) 1e6)))) + +(defn median [xs] + (let [s (vec (sort xs))] + (nth s (quot (count s) 2)))) + +(defn format-ms [v] + (cond + (> v 1) (.toFixed v 2) + (> v 0.01) (.toFixed v 3) + :else (.toFixed v 4))) + +(def blackhole (atom 0)) +(defn bump! [n] + (swap! blackhole #(bit-and (+ % n) 0x3fffffff))) + +(defn keep-take [n pred xs] + (into [] (comp (filter pred) (take n)) xs)) + +(defn dotime [duration-ms step f] + (let [start (now-ms) + deadline (+ start duration-ms)] + (loop [iters 0] + (dotimes [_ step] (f)) + (let [iters (+ iters step)] + (if (< (now-ms) deadline) + (recur iters) + (/ (- (now-ms) start) iters)))))) + +(defn bench [cfg f] + (dotime (:warmup-ms cfg) (:step cfg) f) + (median + (mapv (fn [_] (dotime (:sample-ms cfg) (:step cfg) f)) + (range (:repeats cfg))))) + +(def schema + {:block/uuid {:db/unique :db.unique/identity :db/index true} + :block/title {:db/index true} + :block/name {:db/index true} + :block/updated-at {:db/index true} + :block/created-at {:db/index true} + :block/journal-day {:db/index true} + :block/parent {:db/valueType :db.type/ref :db/index true} + :block/page {:db/valueType :db.type/ref :db/index true} + :block/tags {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many + :db/index true} + :block/refs {:db/valueType :db.type/ref + :db/cardinality :db.cardinality/many + :db/index true} + :block/content {:db/index true}}) + +(defn uuid-of [i] + (str "00000000-0000-4000-8000-" (.padStart (str i) 12 "0"))) + +(defn journal-day-of [i] + (+ 20250101 (mod i 400))) + +(defn build-tx [size pages] + (let [pages (max 1 (min pages size)) + base-ms 1700000000000 + day-ms 86400000 + tag-count (min 32 pages) + tx (transient [])] + (doseq [e (range 1 (inc pages))] + (let [updated (+ base-ms (* 10 day-ms) (* e 1000)) + ent (cond-> {:db/id e + :block/uuid (uuid-of e) + :block/title (str "Page " e) + :block/name (str "page-" e) + :block/updated-at updated + :block/created-at (- updated day-ms) + :block/content (str "page body " e)} + (zero? (mod e 5)) + (assoc :block/journal-day (journal-day-of e)) + (zero? (mod e 7)) + (assoc :block/tags (inc (mod e tag-count))))] + (conj! tx ent))) + (doseq [index (range (- size pages))] + (let [e (+ pages index 1) + page (inc (mod index pages)) + parent (if (or (zero? index) (zero? (mod index 3))) page (dec e)) + updated (+ base-ms (* e 30)) + ent (cond-> {:db/id e + :block/uuid (uuid-of e) + :block/title (str "Block " e) + :block/updated-at updated + :block/created-at (- updated 60000) + :block/parent parent + :block/page page + :block/content (str "block body " e)} + (zero? (mod e 11)) + (assoc :block/tags (inc (mod e tag-count)) + :block/refs page))] + (conj! tx ent))) + {:tx (persistent! tx) + :pages pages + :base-ms base-ms})) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Storage — aligned with logseq.db.common.sqlite-cli / db-worker +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn create-kvs-table! + "Same DDL as logseq.db.common.sqlite/create-kvs-table!" + [^js sql-db] + (.exec sql-db + "create table if not exists kvs (addr INTEGER primary key, content TEXT, addresses JSON)")) + +(defn- upsert-addr-content! + "Same semantics as sqlite-cli/upsert-addr-content!. + node:sqlite has no better-sqlite3 `.transaction`; apply rows sequentially." + [^js sql-db rows] + (assert sql-db ::upsert-addr-content!) + (let [insert (.prepare sql-db + "INSERT INTO kvs (addr, content, addresses) values (?, ?, ?) on conflict(addr) do update set content = excluded.content, addresses = excluded.addresses")] + (doseq [item rows] + (.run insert (.-addr item) (.-content item) (.-addresses item))))) + +(defn- restore-data-from-addr + "Same semantics as sqlite-cli/restore-data-from-addr." + [^js sql-db addr] + (when-let [row (.get (.prepare sql-db "select content, addresses from kvs where addr = ?") addr)] + (let [content (.-content row) + addresses (when (.-addresses row) + (js/JSON.parse (.-addresses row))) + data (dt/read-transit-str content)] + (if (and addresses (map? data)) + (assoc data :addresses addresses) + data)))) + +(defn new-sqlite-storage + "Creates a datascript IStorage for sqlite. + Mirrors logseq.db.common.sqlite-cli/new-sqlite-storage (transit content + addresses JSON)." + [^js sql-db] + (reify IStorage + (-store [_ addr+data-seq _delete-addrs] + (let [data (map + (fn [[addr payload]] + (let [payload' (if (map? payload) (dissoc payload :addresses) payload) + addresses (when (map? payload) + (when-let [as (:addresses payload)] + (js/JSON.stringify (clj->js as))))] + #js {:addr addr + :content (dt/write-transit-str payload') + :addresses addresses})) + addr+data-seq)] + (upsert-addr-content! sql-db data))) + (-restore [_ addr] + (restore-data-from-addr sql-db addr)))) + +(defn get-storage-conn + "Same as logseq.db.common.sqlite/get-storage-conn." + [storage schema] + (or (d/restore-conn storage) + (d/create-conn schema {:storage storage}))) + +(defn sqlite-open [sqlite-path] + (when (and sqlite-path (fs/existsSync sqlite-path)) + (fs/unlinkSync sqlite-path)) + (let [db (DatabaseSync. (or sqlite-path ":memory:"))] + (create-kvs-table! db) + db)) + +(defn build-prepared [{:keys [size pages sqlite-path]}] + (let [built (build-tx size pages) + started (now-ms) + sql-db (sqlite-open sqlite-path) + storage (new-sqlite-storage sql-db) + conn (get-storage-conn storage schema) + ;; Logseq path: transact! on a storage-backed conn (auto-stores PSS nodes). + _ (d/transact! conn (:tx built)) + restore-started (now-ms) + ;; Re-open like a fresh process: restore-conn from the same kvs. + conn' (or (d/restore-conn storage) + (throw (js/Error. "sqlite PSS restore-conn failed"))) + restore-ms (- (now-ms) restore-started) + build-ms (- (now-ms) started) + db @conn' + p (:pages built) + disk-bytes (if (and sqlite-path (fs/existsSync sqlite-path)) + (.-size (fs/statSync sqlite-path)) + 0)] + {:db db + :conn conn' + :sql-db sql-db + :pages p + :base-ms (:base-ms built) + :sample-uuid (uuid-of (max 1 (quot p 2))) + :sample-page 1 + :sample-tag 1 + :build-ms build-ms + :restore-ms restore-ms + :disk-bytes disk-bytes + :sqlite-path (or sqlite-path ":memory:")})) + +(defn hydrate-forward! [entity] + (when entity + (doseq [attr [:block/uuid :block/title :block/name :block/updated-at :block/journal-day]] + (when (some? (get entity attr)) + (bump! 1))))) + +(defn avet-attr-rseq [db attr] + ;; Logseq: (rseq (d/datoms db :avet attr)). Prefer rseek-datoms (same order, lazy). + (d/rseek-datoms db :avet attr)) + +(defn is-page? [db datom] + (and (empty? (d/datoms db :eavt (:e datom) :block/page)) + (let [titles (d/datoms db :eavt (:e datom) :block/title)] + (and (seq titles) + (string? (:v (first titles))) + (pos? (count (.trim ^js/String (:v (first titles))))))))) + +(defn recent-page-datoms [db] + (keep-take 15 #(is-page? db %) (avet-attr-rseq db :block/updated-at))) + +(defn latest-journal-datoms [db pages] + (let [today (journal-day-of pages)] + (keep-take 10 + (fn [datom] + (and (number? (:v datom)) (<= (:v datom) today))) + (avet-attr-rseq db :block/journal-day)))) + +(defn hydrate-edn-pairs [entity] + (->> [:block/uuid :block/title :block/name :block/updated-at :block/journal-day] + (keep (fn [attr] + (when-some [v (get entity attr)] + [attr v]))) + (sort-by (comp str first)) + vec)) + +(defn sorted-eids [datoms] + (vec (sort (map :e datoms)))) + +(defn edn-q-rows [rows] + ;; Stable EDN: sorted vector of row vectors (find returns a set in CLJS). + (->> rows + (map (fn [row] (mapv identity row))) + (sort-by pr-str) + vec)) + +(defn result-edn [{:keys [db pages base-ms sample-uuid sample-page sample-tag]} name] + (case name + "recent-pages" + (mapv :e (recent-page-datoms db)) + "latest-journals" + (mapv :e (latest-journal-datoms db pages)) + "uuid-lookup" + (let [e (d/entity db [:block/uuid sample-uuid])] + (if e + [(:db/id e) (hydrate-edn-pairs e)] + nil)) + "title-lookup" + (sorted-eids (d/datoms db :avet :block/title (str "Page " (quot pages 2)))) + "children-by-parent" + (sorted-eids (d/datoms db :avet :block/parent sample-page)) + "blocks-by-page" + (sorted-eids (d/datoms db :avet :block/page sample-page)) + "tags-scan" + (sorted-eids (d/datoms db :avet :block/tags sample-tag)) + "eavt-entity" + (->> (d/datoms db :eavt sample-page) + (mapv (fn [d] [(:a d) (:v d)])) + (sort-by (comp str first)) + vec) + "entity-hydrate" + (let [e (d/entity db sample-page)] + (if e + [(:db/id e) (hydrate-edn-pairs e)] + nil)) + "q-updated-at-between" + (let [lo (+ base-ms 3600000) + hi (+ base-ms 86400000)] + (edn-q-rows + (d/q '[:find ?e ?t + :in $ ?lo ?hi + :where + [?e :block/updated-at ?t] + [(>= ?t ?lo)] + [(<= ?t ?hi)]] + db lo hi))) + "q-journal-pages" + (edn-q-rows + (d/q '[:find ?e ?d + :where + [?e :block/journal-day ?d] + [?e :block/title ?t]] + db)) + "q-page-by-name" + (edn-q-rows + (d/q '[:find ?e + :in $ ?n + :where [?e :block/name ?n]] + db + (str "page-" (quot pages 3)))) + (throw (js/Error. (str "unknown result-edn query " name))))) + +(defn make-queries [{:keys [db pages base-ms sample-uuid sample-page sample-tag]}] + [{:name "recent-pages" + :run (fn [] + (doseq [datom (recent-page-datoms db)] + (hydrate-forward! (d/entity db (:e datom)))))} + {:name "latest-journals" + :run (fn [] + (doseq [datom (latest-journal-datoms db pages)] + (hydrate-forward! (d/entity db (:e datom)))))} + {:name "uuid-lookup" + :run (fn [] (hydrate-forward! (d/entity db [:block/uuid sample-uuid])))} + {:name "title-lookup" + :run (fn [] + (bump! (count (d/datoms db :avet :block/title (str "Page " (quot pages 2))))))} + {:name "children-by-parent" + :run (fn [] + (bump! (count (d/datoms db :avet :block/parent sample-page))))} + {:name "blocks-by-page" + :run (fn [] + (bump! (count (d/datoms db :avet :block/page sample-page))))} + {:name "tags-scan" + :run (fn [] + (bump! (count (d/datoms db :avet :block/tags sample-tag))))} + {:name "eavt-entity" + :run (fn [] + (bump! (count (d/datoms db :eavt sample-page))))} + {:name "entity-hydrate" + :run (fn [] (hydrate-forward! (d/entity db sample-page)))} + {:name "q-updated-at-between" + :run (fn [] + (let [lo (+ base-ms 3600000) + hi (+ base-ms 86400000) + rows (d/q '[:find ?e ?t + :in $ ?lo ?hi + :where + [?e :block/updated-at ?t] + [(>= ?t ?lo)] + [(<= ?t ?hi)]] + db lo hi)] + (bump! (count rows))))} + {:name "q-journal-pages" + :run (fn [] + (bump! (count + (d/q '[:find ?e ?d + :where + [?e :block/journal-day ?d] + [?e :block/title ?t]] + db))))} + {:name "q-page-by-name" + :run (fn [] + (bump! (count + (d/q '[:find ?e + :in $ ?n + :where [?e :block/name ?n]] + db + (str "page-" (quot pages 3))))))}]) + +(def query-names + ["recent-pages" "latest-journals" "uuid-lookup" "title-lookup" + "children-by-parent" "blocks-by-page" "tags-scan" "eavt-entity" + "entity-hydrate" "q-updated-at-between" "q-journal-pages" "q-page-by-name"]) + +(defn -main [& argv] + (let [cfg (parse-args argv)] + (when (:list-queries cfg) + (doseq [q query-names] (println q)) + (.exit process 0)) + (let [label (or (.-BENCH_RUNTIME_LABEL (.-env process)) "cljs-nbb-logseq-pss") + sqlite-path (or (:sqlite-path cfg) + (str "/tmp/logseq-query-bench-cljs-" (:size cfg) ".sqlite3"))] + (println (str "runtime\t" label)) + (println "suite\tlogseq-queries-shared") + (println "backend\tsqlite-kvs-pss") + (println (str "size\t" (:size cfg))) + (println (str "pages\t" (:pages cfg))) + (println (str "warmup-ms\t" (:warmup-ms cfg))) + (println (str "sample-ms\t" (:sample-ms cfg))) + (println (str "repeats\t" (:repeats cfg))) + (println (str "jit-warmup\t" (:jit-warmup cfg))) + (println (str "sqlite-path\t" sqlite-path)) + (.write (.-stderr process) + (str "Building via nbb-logseq PSS+kvs+transact! (entities=" (:size cfg) + " pages=" (:pages cfg) ")...\n")) + (let [prepared (build-prepared (assoc cfg :sqlite-path sqlite-path)) + queries (cond->> (make-queries prepared) + (:query cfg) + (filterv #(= (:name %) (:query cfg))))] + (when (empty? queries) + (throw (js/Error. (str "unknown query " (:query cfg))))) + (println (str "build-ms\t" (format-ms (:build-ms prepared)))) + (println (str "restore-ms\t" (format-ms (:restore-ms prepared)))) + (println (str "disk-bytes\t" (:disk-bytes prepared))) + (println (str "query-cases\t" (count queries))) + (doseq [q queries] + (println (str "result-edn\t" (:name q) "\t" (pr-str (result-edn prepared (:name q)))))) + (when (pos? (:jit-warmup cfg)) + (doseq [q queries] + (dotimes [_ (:jit-warmup cfg)] + ((:run q))))) + (doseq [q queries] + (println (str (:name q) "\t" (format-ms (bench cfg (:run q)))))) + (.write (.-stderr process) (str "blackhole=" @blackhole "\n")) + (when-let [sql (:sql-db prepared)] + (try (.close sql) (catch :default _))))))) + +(apply -main *command-line-args*) diff --git a/bench/persistent_sqlite.ml b/bench/persistent_sqlite.ml index f4c5e87..d4ed6dc 100644 --- a/bench/persistent_sqlite.ml +++ b/bench/persistent_sqlite.ml @@ -188,7 +188,7 @@ let run_size size = Datascript_sqlite.close session; remove_if_exists conn_db_path) (fun () -> - let storage = Datascript_sqlite.storage session in + let storage = storage_of_handle (Datascript_sqlite.storage session) in let conn_build, conn = time "conn-build" (fun () -> let conn = create_conn ~schema ~storage () in diff --git a/bench/results/bench-logseq-shared-3way-5k.md b/bench/results/bench-logseq-shared-3way-5k.md new file mode 100644 index 0000000..1740f06 --- /dev/null +++ b/bench/results/bench-logseq-shared-3way-5k.md @@ -0,0 +1,32 @@ +# Logseq shared query bench (3-way) + +- Size: 5000 entities / 500 pages +- CLJS: `@logseq/nbb-logseq#feat-db-v34` — PSS indexes + SQLite `kvs` IStorage +- OCaml main: PSS + SQLite blob kvs (working set in memory after restore) +- OCaml current: non-PSS durable SQLite Share indexes (live B-tree tables) +- Workload: Logseq `initial_data` hot paths + +| query | cljs-nbb-logseq-pss | ocaml-main-pss | ocaml-current-non-pss | +| --- | ---: | ---: | ---: | +| `build-ms` | 4398.35 | 309.07 | 9560.89 | +| `restore-ms` | 1.40 | 0.060 | 0.038 | +| `disk-bytes` | 5267456 | 7356416 | 9834496 | +| `recent-pages` | 0.424 | 0.416 | 0.269 | +| `latest-journals` | 0.269 | 0.210 | 0.035 | +| `uuid-lookup` | 0.032 | 0.018 | 0.016 | +| `title-lookup` | 0.0087 | 0.0024 | 0.0017 | +| `children-by-parent` | 0.0079 | 0.0021 | 0.0024 | +| `blocks-by-page` | 0.0073 | 0.0024 | 0.0046 | +| `tags-scan` | 0.0079 | 0.0026 | 0.0067 | +| `eavt-entity` | 0.0029 | 0.0018 | 0.0047 | +| `entity-hydrate` | 0.022 | 0.011 | 0.013 | +| `q-updated-at-between` | 4.01 | 0.135 | 0.184 | +| `q-journal-pages` | 0.772 | 3.83 | 0.458 | +| `q-page-by-name` | 0.048 | 0.0054 | 0.0029 | + +Times are median ms/op. + +Artifacts: +- `bench-logseq-shared-cljs-nbb.txt` (cljs-nbb-logseq-pss) +- `bench-logseq-shared-ocaml-main.txt` (ocaml-main-pss) +- `bench-logseq-shared-ocaml-current.txt` (ocaml-current-non-pss) diff --git a/bench/results/bench-logseq-shared-cljs-nbb.txt b/bench/results/bench-logseq-shared-cljs-nbb.txt new file mode 100644 index 0000000..6e12eed --- /dev/null +++ b/bench/results/bench-logseq-shared-cljs-nbb.txt @@ -0,0 +1,26 @@ +runtime cljs-nbb-logseq-pss +suite logseq-queries-shared +backend sqlite-kvs-pss +size 5000 +pages 500 +warmup-ms 200 +sample-ms 200 +repeats 3 +jit-warmup 20 +sqlite-path /opt/cursor/artifacts/logseq-bench-cljs-5000.sqlite3 +build-ms 4398.35 +restore-ms 1.40 +disk-bytes 5267456 +query-cases 12 +recent-pages 0.424 +latest-journals 0.269 +uuid-lookup 0.032 +title-lookup 0.0087 +children-by-parent 0.0079 +blocks-by-page 0.0073 +tags-scan 0.0079 +eavt-entity 0.0029 +entity-hydrate 0.022 +q-updated-at-between 4.01 +q-journal-pages 0.772 +q-page-by-name 0.048 diff --git a/bench/results/bench-logseq-shared-ocaml-current.txt b/bench/results/bench-logseq-shared-ocaml-current.txt new file mode 100644 index 0000000..2e7075b --- /dev/null +++ b/bench/results/bench-logseq-shared-ocaml-current.txt @@ -0,0 +1,26 @@ +runtime ocaml-current-non-pss +suite logseq-queries-shared +backend sqlite +size 5000 +pages 500 +warmup-ms 200 +sample-ms 200 +repeats 3 +jit-warmup 20 +query-cases 12 +sqlite-path /opt/cursor/artifacts/logseq-bench-ocaml-current-5000.sqlite3 +disk-bytes 9834496 +build-ms 9560.89 +restore-ms 0.038 +recent-pages 0.269 +latest-journals 0.035 +uuid-lookup 0.016 +title-lookup 0.0017 +children-by-parent 0.0024 +blocks-by-page 0.0046 +tags-scan 0.0067 +eavt-entity 0.0047 +entity-hydrate 0.013 +q-updated-at-between 0.184 +q-journal-pages 0.458 +q-page-by-name 0.0029 diff --git a/bench/results/bench-logseq-shared-ocaml-main.txt b/bench/results/bench-logseq-shared-ocaml-main.txt new file mode 100644 index 0000000..e4cedfa --- /dev/null +++ b/bench/results/bench-logseq-shared-ocaml-main.txt @@ -0,0 +1,26 @@ +runtime ocaml-main-pss +suite logseq-queries-shared +backend sqlite +size 5000 +pages 500 +warmup-ms 200 +sample-ms 200 +repeats 3 +jit-warmup 20 +query-cases 12 +sqlite-path /opt/cursor/artifacts/logseq-bench-ocaml-main-5000.sqlite3 +disk-bytes 7356416 +build-ms 309.07 +restore-ms 0.060 +recent-pages 0.416 +latest-journals 0.210 +uuid-lookup 0.018 +title-lookup 0.0024 +children-by-parent 0.0021 +blocks-by-page 0.0024 +tags-scan 0.0026 +eavt-entity 0.0018 +entity-hydrate 0.011 +q-updated-at-between 0.135 +q-journal-pages 3.83 +q-page-by-name 0.0054 diff --git a/bench/shared_query_bench.ml b/bench/shared_query_bench.ml index 25d0cbd..b2e0b80 100644 --- a/bench/shared_query_bench.ml +++ b/bench/shared_query_bench.ml @@ -217,16 +217,20 @@ let rand_nth rng values = values.(next_int rng (Array.length values)) let rand_sex rng = sexes.(next_int rng 997 mod Array.length sexes) let random_man rng i = + let name = rand_nth rng names in + let last_name = rand_nth rng last_names in + let sex = rand_sex rng in + let age = next_int rng 100 in + let salary = next_int rng 100_000 in Entity { - db_id = Some (Temp_id (string_of_int i) - ) + db_id = Some (Entity_id i) ; attrs = - [ "name", One_value (String (rand_nth rng names)) - ; "last-name", One_value (String (rand_nth rng last_names)) - ; "sex", One_value (Keyword (rand_sex rng)) - ; "age", One_value (Int (next_int rng 100)) - ; "salary", One_value (Int (next_int rng 100_000)) + [ "name", One_value (String name) + ; "last-name", One_value (String last_name) + ; "sex", One_value (Keyword sex) + ; "age", One_value (Int age) + ; "salary", One_value (Int salary) ] } @@ -239,52 +243,100 @@ let follow_rules = [ QueryFormSymbol "?e1"; QueryFormKeyword "follows"; QueryFormSymbol "?e2" ] ] ]) +(* Canonical EDN strings for cross-runtime result equality (match Clojure pr-str). *) +let edn_of_value = function + | Nil -> "nil" + | Bool true -> "true" + | Bool false -> "false" + | Int i -> string_of_int i + | Float f when float_of_int (int_of_float f) = f -> string_of_int (int_of_float f) + | Float f -> + let s = Printf.sprintf "%.15g" f in + if String.contains s '.' || String.contains s 'e' || String.contains s 'E' then s + else s ^ ".0" + | String s -> "\"" ^ String.escaped s ^ "\"" + | Keyword k -> ":" ^ k + | Symbol s -> s + | Uuid u -> "#uuid \"" ^ u ^ "\"" + | Instant i -> string_of_int i + | Ref e -> string_of_int e + | Regex r -> "#\"" ^ String.escaped r ^ "\"" + | _ -> "nil" + +let edn_vector items = "[" ^ String.concat " " items ^ "]" + +let edn_of_result_cell = function + | Result_value v -> edn_of_value v + | Result_entity e -> string_of_int e + | Result_attr a -> ":" ^ a + | Result_db _ -> "$" + | Result_pull _ -> "nil" + +let edn_of_q_rows rows = + rows + |> List.map (fun row -> edn_vector (List.map edn_of_result_cell row)) + |> List.sort String.compare + |> edn_vector + type query_case = { name : string ; run : db -> unit + ; result_edn : db -> string } -let q name query = - { name; run = (fun db -> consume_rows (q_string db query)) } +let mk_q name query_string = + let parsed = parse_query_string query_string in + { + name + ; run = (fun db -> consume_rows (Datascript.q db parsed)) + ; result_edn = (fun db -> edn_of_q_rows (Datascript.q db parsed)) + } -let q_inputs name query inputs = +let mk_q_inputs name query_string inputs = + let parsed = parse_query_string query_string in { name - ; run = - (fun db -> consume_rows (q_string ~inputs db query)) + ; run = (fun db -> consume_rows (Datascript.q ~inputs db parsed)) + ; result_edn = (fun db -> edn_of_q_rows (Datascript.q ~inputs db parsed)) } -let q_rules name query = - { name; run = (fun db -> consume_rows (q_string ~inputs:[ Arg_rules follow_rules ] db query)) } +let mk_q_rules name query_string = + let parsed = parse_query_string query_string in + let inputs = [ Arg_rules follow_rules ] in + { + name + ; run = (fun db -> consume_rows (Datascript.q ~inputs db parsed)) + ; result_edn = (fun db -> edn_of_q_rows (Datascript.q ~inputs db parsed)) + } let queries = [ - q "q1" "[:find ?e :where [?e :name \"Ivan\"]]" - ; q "q2" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]" - ; q "q2-switch" "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]" - ; q "q3" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]" - ; q + mk_q "q1" "[:find ?e :where [?e :name \"Ivan\"]]" + ; mk_q "q2" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a]]" + ; mk_q "q2-switch" "[:find ?e ?a :where [?e :age ?a] [?e :name \"Ivan\"]]" + ; mk_q "q3" "[:find ?e ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e :sex :male]]" + ; mk_q "q4" "[:find ?e ?l ?a :where [?e :name \"Ivan\"] [?e :last-name ?l] [?e :age ?a] [?e :sex :male]]" - ; q + ; mk_q "q5" "[:find ?e1 ?l ?a :where [?e :name \"Ivan\"] [?e :age ?a] [?e1 :age ?a] [?e1 :last-name ?l]]" - ; q "qpred1" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]" - ; q_inputs "qpred2" "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" + ; mk_q "qpred1" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]" + ; mk_q_inputs "qpred2" "[:find ?e ?s :in $ ?min_s :where [?e :salary ?s] [(> ?s ?min_s)]]" [ Arg_scalar (Result_value (Int 50_000)) ] - ; q "q-or" "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]" - ; q "q-not" "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]" - ; q + ; mk_q "q-or" "[:find ?e :where (or [?e :name \"Ivan\"] [?e :name \"Petr\"])]" + ; mk_q "q-not" "[:find ?e ?a :where [?e :age ?a] (not [?e :sex :male])]" + ; mk_q "q-or-join" "[:find ?e ?a :where [?e :age ?a] (or-join [?e] [?e :name \"Ivan\"] [?e :name \"Petr\"])]" - ; q "q-not-join" "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]" - ; q + ; mk_q "q-not-join" "[:find ?e ?a :where [?e :age ?a] (not-join [?e] [?e :sex :male])]" + ; mk_q "q-pred-range" "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]" - ; q + ; mk_q "q-5-merge" "[:find ?e ?n ?l ?a ?s :where [?e :name ?n] [?e :last-name ?l] [?e :age ?a] [?e :salary ?s] [?e :sex :male]]" - ; q_rules "q-rule" "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" + ; mk_q_rules "q-rule" "[:find ?e1 ?e2 :in $ % :where (follow ?e1 ?e2)]" ] let query_names = @@ -431,17 +483,43 @@ let run_backend config selected prepared = Printf.printf "build-ms\t%s\n%!" (format_ms prepared.build_ms); if prepared.restore_ms > 0. then Printf.printf "store-restore-ms\t%s\n%!" (format_ms prepared.restore_ms); - Printf.eprintf - "[%s] JIT pre-warmup (%d/query)...\n%!" - prepared.label - config.jit_warmup; - warmup_queries config.jit_warmup selected prepared.db; - Printf.eprintf "[%s] Running %d query benchmarks...\n%!" prepared.label (List.length selected); List.iter (fun query -> - let ms = bench config (fun () -> query.run prepared.db) in - Printf.printf "%s\t%s\n%!" query.name (format_ms ms)) - selected + Printf.printf "result-edn\t%s\t%s\n%!" query.name (query.result_edn prepared.db)) + selected; + (* Cold engine path: Datalevin-comparable without result cache. *) + Printf.printf "cache-mode\tnocache\n%!"; + clear_query_result_cache (); + with_query_result_cache false (fun () -> + let warm_n = min 5 config.jit_warmup in + if warm_n > 0 then ( + Printf.eprintf "[%s] nocache JIT (%d/query)...\n%!" prepared.label warm_n; + warmup_queries warm_n selected prepared.db); + Printf.eprintf "[%s] Running %d nocache query benchmarks...\n%!" prepared.label (List.length selected); + List.iter + (fun query -> + let t0 = now_ms () in + query.run prepared.db; + let first_ms = now_ms () -. t0 in + let ms = bench config (fun () -> query.run prepared.db) in + Printf.printf "%s-first\t%s\n%!" query.name (format_ms first_ms); + Printf.printf "%s-nocache\t%s\n%!" query.name (format_ms ms)) + selected); + (* Warm path with result cache (Datalevin default). *) + Printf.printf "cache-mode\twarm\n%!"; + clear_query_result_cache (); + with_query_result_cache true (fun () -> + Printf.eprintf + "[%s] JIT pre-warmup with result cache (%d/query)...\n%!" + prepared.label + config.jit_warmup; + warmup_queries config.jit_warmup selected prepared.db; + Printf.eprintf "[%s] Running %d warm query benchmarks...\n%!" prepared.label (List.length selected); + List.iter + (fun query -> + let ms = bench config (fun () -> query.run prepared.db) in + Printf.printf "%s\t%s\n%!" query.name (format_ms ms)) + selected) let ensure_dir path = let rec loop dir = diff --git a/bench/tave_storage_ratio.ml b/bench/tave_storage_ratio.ml new file mode 100644 index 0000000..b9a5dde --- /dev/null +++ b/bench/tave_storage_ratio.ml @@ -0,0 +1,129 @@ +open Datascript + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let schema = + [ "name", indexed; "age", indexed; "salary", indexed; "sex", indexed ] + +let names = [| "Ivan"; "Petr"; "Sergey"; "Oleg"; "Yuri"; "Dmitry"; "Fedor"; "Denis" |] + +let now_ms () = int_of_float (Unix.gettimeofday () *. 1000.) + +let build size ~sqlite ~prune = + if prune then set_tave_retention_days 30 else set_tave_retention_days 0; + let path = + Filename.temp_file "tave-ratio" (if sqlite then ".sqlite3" else ".mdb") + in + Sys.remove path; + let session_close, storage = + if sqlite then + let s = Datascript_sqlite.open_session path in + (fun () -> Datascript_sqlite.close s), storage_of_handle (Datascript_sqlite.storage s) + else + let s = Datascript_lmdb.open_session path in + (fun () -> Datascript_lmdb.close s), storage_of_handle (Datascript_lmdb.storage s) + in + let db = empty_db ~schema ~storage () in + let base_ms = now_ms () - 3_600_000 in + let batch = 500 in + let rec loop db i = + if i >= size then db + else + let hi = min size (i + batch) in + let tx = + List.init (hi - i) (fun j -> + let e = i + j + 1 in + let name = names.(e mod Array.length names) in + [ Add (Entity_id e, "name", String name) + ; Add (Entity_id e, "age", Int (e mod 100)) + ; Add (Entity_id e, "salary", Int (e * 10)) + ; Add (Entity_id e, "sex", String (if e mod 2 = 0 then "m" else "f")) + ]) + |> List.concat + in + let r = + transact ~tx_meta:[ "db/txInstant", Instant (base_ms + i) ] db tx + in + loop r.db_after hi + in + let db = loop db 0 in + store ~storage db; + path, session_close, db + +let sqlite_table_bytes path table = + let db = Sqlite3.db_open ~mode:`READONLY path in + let sql = Printf.sprintf "SELECT SUM(LENGTH(key)+LENGTH(value)) FROM %s;" table in + let stmt = Sqlite3.prepare db sql in + let n = + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> ( + match Sqlite3.column stmt 0 with + | Sqlite3.Data.INT i -> Int64.to_int i + | Sqlite3.Data.FLOAT f -> int_of_float f + | _ -> 0) + | _ -> 0 + in + ignore (Sqlite3.finalize stmt); + ignore (Sqlite3.db_close db); + n + +let sqlite_table_count path table = + let db = Sqlite3.db_open ~mode:`READONLY path in + let sql = Printf.sprintf "SELECT COUNT(*) FROM %s;" table in + let stmt = Sqlite3.prepare db sql in + let n = + match Sqlite3.step stmt with + | Sqlite3.Rc.ROW -> ( + match Sqlite3.column stmt 0 with + | Sqlite3.Data.INT i -> Int64.to_int i + | _ -> 0) + | _ -> 0 + in + ignore (Sqlite3.finalize stmt); + ignore (Sqlite3.db_close db); + n + +let file_size path = + try (Unix.stat path).Unix.st_size with _ -> 0 + +let report_sqlite label path = + let tables = [ "ds_eavt"; "ds_aevt"; "ds_avet"; "ds_tave"; "ds_meta" ] in + List.iter + (fun t -> + Printf.printf "%s-table\t%s\tbytes=%d\trows=%d\n%!" label t (sqlite_table_bytes path t) + (sqlite_table_count path t)) + tables; + let eavt = sqlite_table_bytes path "ds_eavt" in + let aevt = sqlite_table_bytes path "ds_aevt" in + let avet = sqlite_table_bytes path "ds_avet" in + let tave = sqlite_table_bytes path "ds_tave" in + let three = eavt + aevt + avet in + let four = three + tave in + Printf.printf "%s-three-indexes\t%d\n%!" label three; + Printf.printf "%s-with-tave\t%d\n%!" label four; + Printf.printf "%s-tave-ratio-vs-three\t%.3f\n%!" label (float tave /. float (max 1 three)); + Printf.printf "%s-total-growth\t%.3f\n%!" label (float four /. float (max 1 three)); + Printf.printf "%s-file\t%d\n%!" label (file_size path) + +let () = + let size = try int_of_string Sys.argv.(1) with _ -> 10000 in + Printf.printf "size\t%d\n%!" size; + let path, close, _ = build size ~sqlite:true ~prune:false in + report_sqlite "sqlite-noprune" path; + close (); + let path, close, _ = build size ~sqlite:true ~prune:true in + report_sqlite "sqlite-retain30d" path; + close (); + let path, close, _ = build size ~sqlite:false ~prune:false in + Printf.printf "lmdb-noprune-file\t%d\n%!" (file_size path); + close () diff --git a/docs/design-tx-window-index.md b/docs/design-tx-window-index.md new file mode 100644 index 0000000..6e0cbae --- /dev/null +++ b/docs/design-tx-window-index.md @@ -0,0 +1,450 @@ +# Tx-Window Index: Narrow Scans with `t` + +Branch: `logseq/tx-window-index-fe5d` +Builds on: Share_index_db (LMDB / SQLite) + tx-visibility (`as_of` / `since` / `history`) + +## Problem + +Every datom carries `tx` (`t`), and larger `tx` means a later transaction. Today +`since` / `as_of` only **filter** after a cursor already walks EAVT / AEVT / AVET. + +Those indexes sort as: + +| Index | Key order | +| --- | --- | +| EAVT | `e → a → v → tx → added` | +| AEVT | `a → e → v → tx → added` | +| AVET | `a → v → e → tx → added` | + +`tx` is last. There is **no** seek that means “only datoms with `tx > T`”. +On a large graph, “last N days” still pays full-attr / full-entity scan cost. + +Wall-clock time is not `tx` itself: `:db/txInstant` lives on the **transaction +entity** (`e = tx`). N days → a tx lower bound needs that mapping first. + +## Goal + +Use `t` to **physically bound** how much index we touch, so a time window’s cost +tracks **window size**, not full graph size — for the access paths that opt in. + +Non-goals for v1: + +- Make every arbitrary Datalog shape automatically fast on a huge live window. +- Replace EAVT/AEVT/AVET. +- Change observable DataScript results for unscoped queries. + +## Semantics (pick explicitly) + +Two useful meanings of “recent”; the design supports both from one structure. + +| Mode | Meaning | Typical product use | +| --- | --- | --- | +| **A. Tx-datom window** | Datoms whose `tx` is in `(tx_lo, tx_hi]` | History / activity / “what changed” | +| **B. Touched-entity window** | Distinct `e` that appear in any datom with `tx` in range, then read **current** facts for those entities from EAVT | “Pages/blocks edited in last N days” | + +Mode A is the raw temporal slice. Mode B is usually what Logseq-style UIs want. +`since` today is closer to A applied as a filter on every scan, not B. + +## Design + +### 1. Resolve wall time → tx range + +Keep using `:db/txInstant` on tx entities (already written on `transact` when +`tx_meta` supplies it). + +```text +instant_lo → smallest tx with txInstant >= instant_lo (or next tx after) +instant_hi → max_tx (or as_of bound) +``` + +Implementation options (v1 can be simple): + +1. **AVET on `:db/txInstant`** (already indexed if marked `:db/index`) — range + scan values in `[lo, hi]` → list of tx entity ids. Fine while tx count is + modest vs datom count. +2. Later: compact **tx-time side table** `instant → tx` if AVET over all txs + becomes hot. + +Cache `(instant_lo → tx_lo)` per db basis (`max_tx`) in the session. + +### 2. Fourth index: TEAV (tx-ordered posting) + +Add a Share_index DBI / SQLite table alongside EAVT/AEVT/AVET: + +```text +TEAV key: tx | e | a | v | added +TEAV value: same payload as other indexes (or empty if value is fully in key) +``` + +Codec: same order-preserving components as today; only component order changes. +LMDB and SQLite Share_index both grow one map/table (`ds_teav`). + +Write path (same txn as the three indexes): + +- On each assert/retract in `tx_data`, also `put` TEAV. +- Purge / remove must delete TEAV keys too. +- `sync_append_since_tx` copies TEAV deltas like the others. + +Read API: + +```ocaml +val fold_teav_range : + db -> from_tx:tx -> ?to_tx:tx -> (datom -> unit) -> unit +``` + +Ascending `tx` order → cheap “everything after `tx_lo`”. + +Optional covering variants later (not v1): + +- `T-A-E-V` if “recent datoms of attr A” dominates. +- Posting list `tx → [e]` only (smaller) if Mode B is the only consumer. + +### 3. Window handle on `db` + +Extend the temporal view (compatible with existing fields): + +```ocaml +(* conceptual *) +type tx_window = { tx_lo : tx; tx_hi : tx; mode : Tx_datoms | Touched_entities } + +val since_window : ?mode:_ -> tx_lo:tx -> db -> db +val since_instant : ?mode:_ -> Instant.t -> db -> db +``` + +- `since_instant` = resolve instant → `tx_lo`, then `since_window`. +- Existing `since tx` stays; window APIs are additive and document Mode A vs B. + +### 4. How queries use the window + +Planner / `datoms` do **not** rewrite every clause. They change the **seed set**: + +```text +if db has tx_window: + candidates = TEAV.range(tx_lo, tx_hi) (* Mode A: datoms *) + or unique e from that range (* Mode B: entities *) + evaluate where-clauses constrained to candidates +else: + current Share_index path +``` + +Concrete wiring (v1): + +1. **`datoms` / index scans with empty `e`** under Mode A: iterate TEAV range, + then apply `a`/`v` predicates in memory (or seek within TEAV if we add T-A…). +2. **Mode B**: build `e` bitset/hashset from TEAV range once per query (or cache + on the windowed `db` value); pattern resolution requires `e ∈ candidates` + (entity-group / EAVT-by-e stays selective). +3. **Already-bound `e`**: keep EAVT; only check `tx` if Mode A. No TEAV needed. +4. **Full unbound scans** (`[?e :attr ?v]` with no selective const) under a + window: **prefer TEAV → filter attr** when `|window| << |attr|`; else keep + AEVT and filter tx (today). Cost model: compare window datom count vs attr + cardinality estimate. + +This is how “use `t` to narrow” becomes real: **unbounded attribute scans become +window scans when a window is set.** + +### 5. What stays slow (honest bound) + +| Situation | Still expensive? | +| --- | --- | +| Window spans most of the graph | Yes — window ≈ full DB | +| Query result itself is huge inside the window | Yes — output-bound | +| No window set | Same as today | +| Mode B + need all attrs of touched entities | Pays EAVT-per-e (good if few touched ids) | +| Rules / or that escape the candidate set | Must keep candidates threaded; leaks = full scan | + +Guarantee we **can** claim: + +> With a tx window set, scans that would have been full-index are rewritten to +> TEAV `[tx_lo, tx_hi]` (or entity-restricted EAVT). Cost scales with +> **datoms/entities touched in that tx range**, not total graph size. + +Guarantee we **cannot** claim: + +> Any Datalog string is always fast for any N and any graph. + +## Storage cost + +- Extra index ≈ one more copy of every historied datom key (same order as + append-only growth). Roughly **+25–35%** index bytes vs three indexes only + (codec-dependent). +- SQLite: one more `WITHOUT ROWID` BLOB table; same write txn. +- Compaction: `purge_history_before` / window eviction must drop TEAV too. + +## Phased delivery + +| Phase | Deliverable | Gate | +| --- | --- | --- | +| 0 | This design; agree Mode A vs B default for Logseq | Review | +| 1 | TEAV codec + write on LMDB & SQLite Share_index; roundtrip tests | `dune runtest` | +| 2 | `fold_teav_range`; `since_instant` → `tx_lo`; Mode A `datoms` path under window | Temporal + sqlite tests | +| 3 | Mode B candidate entity set; wire into entity-group / unbound attr scans | Bench: 200k graph, 1-day window ≪ full AEVT | +| 4 | Query planner cost hint: choose TEAV vs AEVT when window set | Shared query suite, no result regressions | +| 5 | Optional `T-A-E-V` or tx→e posting if Mode B profiles hot | Microbench | + +## Bench protocol (must prove narrowing) + +Fixed large DB (e.g. 200k–500k entities), measure: + +1. Unscoped `datoms` / AEVT attr scan (baseline). +2. Same op under `since_instant` **without** TEAV (filter-only) — today’s cost. +3. Same op **with** TEAV window rewrite. + +Success: (3) ≈ O(window), (2) ≈ O(graph); (3) ≪ (2) when window ≪ graph. +Also track write amp and disk (+TEAV). + +## Alternatives considered + +| Option | Why not as v1 | +| --- | --- | +| Only improve `since` filter | No seek; does not shrink IO | +| Time-partitioned EAVT files | Strong isolation, heavy ops/rebalance; later | +| Hot DB copy of last N days | Great product UX; duplication + sync lag; can sit **on top** of TEAV | +| Rely on `:block/updated-at` AVET alone | App-level, misses tx semantics / history; complements, does not replace TEAV | + +## Compatibility + +- Observable unscoped behavior unchanged. +- Existing `since` / `as_of` / `history` remain; window APIs are additive. +- Melange/jsoo: TEAV native-first; JS backends follow or stay filter-only until ported. +- Upstream DataScript has no TEAV; document as dbval/Logseq extension (same class as history). + +## Retention: current window only (default 1 month) + +TAVE is **not** a full historical fourth copy of the DB. It only retains datoms +whose `tx` falls inside a configurable rolling window: + +| Knob | Default | Meaning | +| --- | --- | --- | +| `tave_retention_days` | **30** | Wall-clock window via `:db/txInstant` → `tx_lo` | + +**Keep in TAVE:** asserts/retracts with `tx > tx_lo(retention)`. +**Drop from TAVE:** keys with `tx <= tx_lo` (`prune_tave_before` / `prune_tave_to_retention`). +**Never use TAVE as source of truth for “what is true now”** — that remains +EAVT/AEVT/AVET (full history / current facts as today). + +Public API (optional; callers need not use it): + +```ocaml +Datascript.set_tave_retention_days 30 (* default; adjustable *) +Datascript.tave_retention_days () +Datascript.prune_tave_to_retention db +``` + +Prune runs after `transact` (best-effort). Queries older than retention fall back +to AEVT/AVET + tx filter (correct, slower). + +### Implemented (this branch) + +- `| Tave` index; key order `tx | a | v | e | added` (BLOB KV on LMDB `ds/tave` + SQLite `ds_tave`) +- Written on every append alongside EAVT/AEVT/(AVET when indexed) +- `fold_tave_range` / `prune_tave_before`; retention default 30 days +- **API unchanged:** `since` + attr scan (`datoms … Aevt ~a`) auto-uses TAVE when applicable +- LMDB `meta_set` invalidates read txn (fixes stale restore meta) + +## API stability: callers must not change + +**Constraint (Logseq / app):** keep using `d/q`, `d/datoms`, `d/entity` as today. +No required `since_instant`, Mode B handle, or query rewrite at the call site. + +Faster paths are chosen **inside** the engine from the query / db view: + +```text +parse where + → recognize selective shapes (AVET value, AVET time range, bound e, …) + → pick index + physical op + → optional: if db already has since_tx / as_of, prefer TAVE only when + that beats AEVT/AVET for the clause set +``` + +### Auto-selection rules (aligned with Logseq survey) + +| Query / datoms shape (unchanged API) | Prefer | Why | +| --- | --- | --- | +| `[?e :block/uuid u]` / lookup-ref | AVET unique → EAVT | already selective | +| `[?e :block/updated-at ?t] [(>= ?t lo)] …` | **AVET range** on updated-at | Logseq’s real “recent” | +| `[?p :block/journal-day ?d] [(>= ?d lo)]` | **AVET range** on journal-day | journals / between | +| `(between …)` / DSL timestamp between | same AVET ranges (via rules expansion) | query_dsl today | +| Bound `?e` then attrs | EAVT | entity hydrate | +| `[?e :attr]` full presence, huge attr | AEVT (status quo) | no free lunch | +| Db view with `since` / history + unbound attr scan | **TAVE** `tx\|a\|…` when estimated cheaper than AEVT+filter | engine-only; apps need not opt in | +| `d/datoms db :avet :block/updated-at` (+ rseq) | keep AVET | `get-recent-updated-pages` | + +Planner cost hint (same as above): for each clause, estimate `|AVET(attr,range)|` vs +`|AEVT(attr)|` vs `|TAVE(tx_lo,attr)|` when a tx lower bound is in scope; pick min. +Wrong choice only affects speed, not results. + +### What this means for TAVE + +- **Not** a new public “window API” for Logseq UI queries. +- **Yes** a storage/access path the executor may use when: + 1. the db value already carries `since_tx` / history semantics, **or** + 2. future internal sync/history ops need tx-ordered scans, + and AVET cannot express the bound (no denormalized time attr in the clause). + +For shipping Logseq shapes, auto-fast means **recognize AVET time ranges and +bound-entity plans** — that is the win without app changes. TAVE is backup for +tx-scoped views, not a replacement for `:block/updated-at`. + +### Non-goals under this constraint + +- Requiring apps to call `since_instant` / pass Mode B. +- Changing EDN query syntax for “recent”. +- Silently changing `since` result semantics to Mode B (touched-entity current facts). + +Optional later: *internal* connection defaults (e.g. always maintain TAVE) remain +invisible to `d/q` callers. + +## Index selection (EAVT / AVET stay primary) + +TEAV does **not** retire the other indexes. Selection is per clause / seed: + +| Clause shape (under window) | Preferred index | Role of TEAV | +| --- | --- | --- | +| Bound `e` (`[e :a ?v]`, pull, entity) | **EAVT** | None (Mode A: optional tx check) | +| Bound `a` + bound `v` (unique / lookup) | **AVET** | None, unless needing “only if written in window” | +| Bound `a`, unbound `e`/`v`, **no window** | **AEVT** | — | +| Bound `a`, unbound `e`, **window**, `\|TEAV\| ≪ \|A\|` | **TEAV** then filter `a` | Seed / narrow | +| Bound `a`, unbound `e`, **window**, attr tiny | **AEVT** + tx filter | Skip TEAV | +| Mode B after candidate `e` set built | **EAVT** per `e` | Only to build the `e` set once | +| `txInstant` → `tx_lo` | **AVET** on `:db/txInstant` | Bootstrap only | + +Invariant: **current-fact identity** always comes from EAVT/AEVT/AVET + existing +tx-visibility/`datoms_filter`. TEAV never answers “what is true now?” alone in +Mode B; it only answers “who/what was touched in this tx range?”. + +```text + ┌── selective e/v ──► EAVT / AVET (unchanged) + query + window ────┤ + └── unselective scan ──► TEAV[tx_lo..] ──► filter / rejoin EAVT +``` + +## Layering on `since` / `as_of` / `history` + +| Mechanism | What it does today | Relation to TEAV window | +| --- | --- | --- | +| `as_of` | Upper bound `tx <= T` on every datom | Still applied; TEAV range uses `to_tx = min(window_hi, as_of)` | +| `since` | Drop `tx <= since_tx` after scan | Window’s `tx_lo` should **subsume** filter when TEAV path is used; filter remains as safety on EAVT paths | +| `history` | Skip cancel of add/retract | Mode A natural fit; Mode B should use **non-history** EAVT for “current entity state” | +| `filter` pred | Extra datom predicate | Unchanged; runs after index choice | + +Recommended stacking: + +```text +db0 = conn.db +db1 = as_of? tx_hi db0 (* optional snapshot *) +db2 = since_instant ~mode:B t0 db1 +q query db2 (* planner sees window on db2 *) +``` + +Do **not** silently reinterpret plain `since` as Mode B — that would change +results (Mode B returns current attrs of touched entities, including attrs last +written *before* the window). Mode A ≈ today’s `since` semantics with a faster +physical path; Mode B is a **different product API**. + +## Candidate discipline (Mode B) + +Once `E_touched = unique e in TEAV[tx_lo, tx_hi]` (excluding pure tx entities if +desired): + +1. Every pattern that produces new `?e` must intersect `E_touched`, **or** be a + join from an already-bound var that itself descends from that set. +2. Rules / `or` / `or-join`: expand inside the same candidate constraint; if a + branch cannot honor it, either reject planning for window (fallback warning) + or evaluate branch then intersect — never full-DB seed. +3. Reverse refs (`[_ :block/refs e]`): still AEVT/AVET, but result `e` filtered to + candidates when the query is window-scoped “touched pages” style. +4. Cache `E_touched` on the windowed `db` value (O(window) build once per basis). + +Leakage = accidental full AEVT scan = design bug, not “planner best effort”. + +## Product-shaped API (sketch only) + +```text +;; Mode B — default for “recent work” +(d/q query (d/since-instant #inst "..." db)) + +;; Mode A — activity / history slice (same facts as filtered since, faster path) +(d/q query (d/since-instant db #inst "..." {:mode :tx-datoms})) + +;; Explicit tx bound when caller already mapped time → tx +(d/since-tx-window db tx-lo {:mode :touched-entities}) +``` + +Logseq layer can keep `:block/updated-at` for UX sorting; TEAV window is the +**engine** bound. App attr indexes remain complementary, not a substitute for +transaction-scoped narrowing. + +## Cost model (planner hint) + +Rough compare for “scan attr `A` under window”: + +```text +cost_aevt ≈ |datoms(A)| // + cheap tx filter if since set +cost_teav ≈ |datoms in window| // + filter a = A +pick min +``` + +Estimates: maintain `max_tx`, optional running `datoms_in_recent_tx` sketch, or +sample TEAV first page. Wrong choice only hurts constant factors when sizes are +close; correctness unchanged. + +## Open decisions (need agreement before code) + +1. **Default mode** for `since_instant`: B (product) vs A (semantic continuity with `since`). +2. **TEAV fullness**: full datom keys vs `tx → e` posting only (B-optimized, A needs extra joins). +3. **Tx entities in Mode B**: include `e = tx` rows or strip them from `E_touched`. +4. **Mandatory txInstant**: require stamp on every tx for wall-clock windows, or allow tx-only API. +5. **SQLite + LMDB together in v1** vs native LMDB first. +6. Whether plain `since` gains TEAV acceleration (Mode A path) in the same phase as Mode B API. + +## Logseq production query survey (2026-08-29) + +Shallow clone of `logseq/logseq` (`3e85583`). Scope: `deps/db`, `deps/outliner`, +`src/main` production code (not tests). + +### Access mix (approx) + +| Mechanism | ~count | Index fit | +| --- | ---: | --- | +| `d/entity` | 600+ | EAVT (bound entity) | +| Lookup-ref `[:block/uuid …]` | ~250 | unique → EAVT | +| `d/datoms :avet` | ~100+ | AVET | +| `d/datoms :eavt` | ~50–60 | EAVT | +| `d/q` | ~50 | mixed | +| `d/datoms :aevt` | handful | AEVT (rare) | + +Hot attrs (schema-indexed): `:block/uuid`, `:block/tags`, `:block/name` / +`:block/title`, `:block/parent`, `:block/page`, `:block/refs`, `:block/alias`, +`:block/journal-day`, `:block/created-at`, `:block/updated-at`. + +### How “recent” is done today (not via `tx`) + +| Intent | Mechanism | File | +| --- | --- | --- | +| Recent pages | `d/datoms :avet :block/updated-at` + `rseq` + take 15 | `deps/db/.../initial_data.cljs` `get-recent-updated-pages` | +| Latest journals | `d/datoms :avet :block/journal-day` + `rseq` | same file `get-latest-journals` | +| Journal by day | AVET exact `:block/journal-day` | `deps/db/src/logseq/db.cljs` | +| DSL `(between …)` | journal-day rule **or** `created-at`/`updated-at` range | `query_dsl.cljs`, `rules.cljc` `:between` | +| Doing last 14d / Todo next 7d | `(task …)` + journal-day window | `frontend/state.cljs` default journal queries | +| View sort | default `:block/updated-at` desc via AVET | `common/view.cljs` | + +**Not found** in production Datalog: `:db/txInstant`, DataScript `since`, or +“datoms since tx T” shapes. Sync `:since` is protocol-level, not an index scan. + +### Implications for TAVE + +| Workload | Needs TAVE? | +| --- | --- | +| Recent pages / journals / `(between updated-at)` | **No** — denormalized time on **AVET** already | +| UUID / name / tags / parent / page / refs | **No** — unique / AVET / EAVT | +| Bound hydrate (`d/entity`) | **No** — EAVT | +| “All assertions of attr A in tx window” / audit without `updated-at` | **Yes** — only if product moves to tx-log time | +| Sync/history deltas by transaction | **Yes** (future) | + +**Conclusion for Logseq as it ships today:** keep investing in **AVET** (time attrs, +tags, journal-day) and **EAVT** entity paths. TAVE is justified for engine-level +tx-window scans and history, not for replacing `:block/updated-at` recent-page UX. + +If implementing TAVE anyway, prioritize engine/sync use cases; do not expect +Logseq’s current “recent N days” queries to switch to it without an app rewrite. diff --git a/impl/datascript.ml b/impl/datascript.ml index 1a710dc..57344b4 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -86,6 +86,9 @@ let as_of_instant = Db_impl.as_of_instant let since = Db_impl.since let history = Db_impl.history let is_history = Db_impl.is_history +let set_tave_retention_days = Db_impl.set_tave_retention_days +let tave_retention_days = Db_impl.get_tave_retention_days +let prune_tave_to_retention = Db_impl.prune_tave_to_retention let resolve_tx_at_instant = Db_impl.resolve_tx_at_instant let purge_history_before = Db_impl.purge_history_before let as_of_tx = Db_impl.as_of_tx @@ -878,6 +881,8 @@ let transact_report ?(tx_meta = []) db tx_ops = Db_impl.refresh_indexes_with_tx_data db_after [ stamped ], tx_data @ [ stamped ] | Some _ -> invalid_arg ":db/txInstant must be an Instant value" in + (* Amortized TAVE retention prune (rolling window; default 30 days). *) + (try Db_impl.prune_tave_to_retention db_after with _ -> ()); { db_before; db_after; tx_data; tempids; tx_meta; purged_datoms } let transact ?(tx_meta = []) db tx_ops = @@ -959,6 +964,7 @@ let resolve_ref_value = Entity_refs_impl.resolve_ref_value let entity_context = { Entity.datoms_by_entity = (fun db entity_id -> datoms db Eavt ~e:entity_id ()) + ; datoms_by_entity_attr = (fun db entity_id attr -> datoms db Eavt ~e:entity_id ~a:attr ()) ; datoms_by_avet_ref = (fun db attr entity_id -> datoms db Avet ~a:attr ~v:(Ref entity_id) ()) ; all_datoms = (fun db -> datoms db Eavt ()) ; compare_value @@ -1517,10 +1523,12 @@ module Query_exec_impl = Query_exec.Make (struct let entity_ids_array_by_attr_value = entity_ids_array_by_attr_value let query_attr_uses_avet = query_attr_uses_avet let query_value_uses_avet = query_value_uses_avet + let is_ref_attr = is_ref_attr let aevt_attr_array = Db.aevt_attr_array let aevt_duplicate_datoms db attr = Option.value (Hashtbl.find_opt db.duplicate_aevt_by_attr attr) ~default:[] let find_entity_in_aevt_array = Db.find_entity_in_aevt_array + let fold_index_range = fold_index_range end) let execute_plan db sources rules bindings plan = @@ -1712,6 +1720,10 @@ type query_exec_path = Query_api.query_exec_path = let last_query_exec_path = Query_api.last_query_exec_path let with_force_relation_fallback = Query_api.with_force_relation_fallback +let clear_query_result_cache = Query_api.clear_query_result_cache +let with_query_result_cache = Query_api.with_query_result_cache +let query_result_cache_enabled = Query_api.query_result_cache_enabled +let last_query_cache_hit = Query_api.last_query_cache_hit module Query_impl = Query diff --git a/impl/datascript.mli b/impl/datascript.mli index 90f4439..ec1d49d 100644 --- a/impl/datascript.mli +++ b/impl/datascript.mli @@ -156,6 +156,9 @@ module Db : sig val is_history : db -> bool val resolve_tx_at_instant : value -> db -> tx val purge_history_before : tx -> db -> db * datom list + val set_tave_retention_days : int -> unit + val get_tave_retention_days : unit -> int + val prune_tave_to_retention : db -> unit val hash : db -> int val hash_cache_size : unit -> int val diff : db -> db -> datom list * datom list * datom list @@ -166,6 +169,7 @@ end module Entity : sig type context = { datoms_by_entity : db -> entity_id -> datom Seq.t + ; datoms_by_entity_attr : db -> entity_id -> attr -> datom Seq.t ; datoms_by_avet_ref : db -> attr -> entity_id -> datom Seq.t ; all_datoms : db -> datom Seq.t ; compare_value : value -> value -> int @@ -408,6 +412,9 @@ val history : db -> db val is_history : db -> bool val resolve_tx_at_instant : value -> db -> tx val purge_history_before : tx -> db -> db * datom list +val set_tave_retention_days : int -> unit +val tave_retention_days : unit -> int +val prune_tave_to_retention : db -> unit module Tx_visibility : module type of Tx_visibility module Query_plan : sig type index_choice = @@ -604,6 +611,14 @@ val last_query_exec_path : unit -> query_exec_path (** Run [f] with fused [Query_exec] disabled so [q] uses the relational fallback. *) val with_force_relation_fallback : (unit -> 'a) -> 'a +(** Datalevin-style query result cache (general; keyed by db epoch + physical query). + Enabled by default; set [DATASCRIPT_QUERY_RESULT_CACHE=0] to disable. + Set [DATASCRIPT_QUERY_DEBUG=1] for plan/exec/cache stderr traces. *) +val clear_query_result_cache : unit -> unit +val with_query_result_cache : bool -> (unit -> 'a) -> 'a +val query_result_cache_enabled : unit -> bool +val last_query_cache_hit : unit -> bool + module Query : sig type query_callables = { callable_predicates : (string * (query_result list -> bool)) list diff --git a/impl/db.ml b/impl/db.ml index 091bca5..bc9661c 100644 --- a/impl/db.ml +++ b/impl/db.ml @@ -163,7 +163,19 @@ let apply_db_view_seq db seq = Tx_visibility.filter_seq db.schema (view_bounds d (** Apply temporal cancel to a descending (rseek) sequence by restoring ascending order. *) let apply_db_view_reverse_seq db seq = - seq |> List.of_seq |> List.rev |> apply_db_view db |> List.rev |> List.to_seq + if Option.is_some db.as_of_tx || Option.is_some db.since_tx || db.history then + (* Cancel pairs need ascending order; only materialize for temporal views. *) + seq |> List.of_seq |> List.rev |> apply_db_view db |> List.rev |> List.to_seq + else + (* Live index streams current facts; keep descending order and stay lazy. *) + apply_db_view_seq db seq + +let array_rev_seq arr = + let len = Array.length arr in + let rec loop i () = + if i < 0 then Seq.Nil else Seq.Cons (Array.unsafe_get arr i, loop (i - 1)) + in + loop (len - 1) let indexes_on_storage db = Option.is_some db.storage_ref @@ -176,7 +188,7 @@ let pending_for_index db index = match index with | Avet -> List.filter (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) db.pending_datoms - | Eavt | Aevt -> db.pending_datoms + | Eavt | Aevt | Tave -> db.pending_datoms in List.sort (Util.compare_datom index) datoms @@ -248,7 +260,8 @@ let set_indexes_from_datoms db datoms = lmdb; let eavt_index = Index.empty Eavt lmdb and aevt_index = Index.empty Aevt lmdb - and avet_index = Index.empty Avet lmdb in + and avet_index = Index.empty Avet lmdb + and tave_index = Index.empty Tave lmdb in let duplicate_aevt_datoms = List.sort (Util.compare_datom Aevt) duplicate_datoms in let duplicate_avet_datoms = duplicate_datoms @@ -263,6 +276,7 @@ let set_indexes_from_datoms db datoms = eavt_index ; aevt_index ; avet_index + ; tave_index ; aevt_by_attr = group_sorted_datoms_by_attr aevt_sorted ; avet_by_attr = group_sorted_datoms_by_attr avet_sorted ; avet_entities_by_attr_value = index_avet_entities_by_attr_value avet_sorted @@ -302,6 +316,7 @@ let refresh_indexes_with_added_datoms db added_datoms = (fun d -> Schema.schema_attr_is_avet_accessible db.schema d.a) added_datoms db.avet_index + ; tave_index = add_datoms_to_index (fun _ -> true) added_datoms db.tave_index ; duplicate_datoms = db.duplicate_datoms ; duplicate_aevt_datoms = db.duplicate_aevt_datoms ; duplicate_avet_datoms = db.duplicate_avet_datoms @@ -349,6 +364,7 @@ let refresh_indexes_with_removed_datoms db removed_datoms = let eavt_index = remove_from db.eavt_index in let aevt_index = remove_from db.aevt_index in let avet_index = remove_from db.avet_index in + let tave_index = remove_from db.tave_index in let duplicate_datoms = without_stored_datoms removed_datoms db.duplicate_datoms in let duplicate_aevt_datoms = without_stored_datoms removed_datoms db.duplicate_aevt_datoms in let duplicate_avet_datoms = without_stored_datoms removed_datoms db.duplicate_avet_datoms in @@ -357,6 +373,7 @@ let refresh_indexes_with_removed_datoms db removed_datoms = eavt_index ; aevt_index ; avet_index + ; tave_index ; duplicate_datoms ; duplicate_aevt_datoms ; duplicate_avet_datoms @@ -369,6 +386,15 @@ let snapshot_db db = db let temporal_view db = Option.is_some db.as_of_tx || Option.is_some db.since_tx || db.history +(** Rolling TAVE retention window in days. [0] disables pruning (index still written). *) +let tave_retention_days = ref 30 + +let set_tave_retention_days days = tave_retention_days := max 0 days + +let get_tave_retention_days () = !tave_retention_days + +let millis_per_day = 86_400_000 + let basis_tx db = db.max_tx let as_of_t db = db.as_of_tx @@ -410,6 +436,7 @@ let empty_db context ?(schema = []) ?storage () = ; eavt_index = empty_index Eavt index_db ; aevt_index = empty_index Aevt index_db ; avet_index = empty_index Avet index_db + ; tave_index = empty_index Tave index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 @@ -447,6 +474,7 @@ let init_db context ?(schema = []) ?storage datoms = ; eavt_index = empty_index Eavt index_db ; aevt_index = empty_index Aevt index_db ; avet_index = empty_index Avet index_db + ; tave_index = empty_index Tave index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 @@ -520,6 +548,7 @@ let stored_index db = function | Eavt -> db.eavt_index | Aevt -> db.aevt_index | Avet -> db.avet_index + | Tave -> db.tave_index let merge_sorted_datoms index left right = let cmp = Util.compare_datom index in @@ -550,7 +579,7 @@ let merge_sorted_datom_seqs compare_datom left right = let duplicate_index_datoms db index = match index with - | Eavt -> db.duplicate_datoms + | Eavt | Tave -> db.duplicate_datoms | Aevt -> db.duplicate_aevt_datoms | Avet -> db.duplicate_avet_datoms @@ -558,7 +587,7 @@ let duplicate_attr_datoms db index attr = match index with | Aevt -> Option.value (Hashtbl.find_opt db.duplicate_aevt_by_attr attr) ~default:[] | Avet -> Option.value (Hashtbl.find_opt db.duplicate_avet_by_attr attr) ~default:[] - | Eavt -> duplicate_index_datoms db index + | Eavt | Tave -> duplicate_index_datoms db index let cache_avet_entities_for_attr db attr datoms = let by_value = Hashtbl.create 16 in @@ -588,15 +617,24 @@ let primary_attr_datoms db index attr = let temporal = temporal_view db in match index with | Aevt -> - (match (if temporal then None else Hashtbl.find_opt db.aevt_by_attr attr) with - | Some datoms -> Array.to_list datoms - | None -> - let datoms = - merge_sorted_datoms Aevt (attr_prefix_datoms Aevt db.aevt_index) pending_attr - |> apply_db_view db - in - if not temporal then Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); - datoms) + (match db.since_tx with + | Some from_tx when temporal && not (merged_index db) && not (pending_overlay db) -> + (* Prefer TAVE for since-bounded attr scans (API unchanged). *) + Index.fold_tave_range + (fun acc datom -> datom :: acc) + [] db.tave_index ~from_tx ~to_tx:db.max_tx ~attr () + |> List.rev + |> apply_db_view db + | _ -> + (match (if temporal then None else Hashtbl.find_opt db.aevt_by_attr attr) with + | Some datoms -> Array.to_list datoms + | None -> + let datoms = + merge_sorted_datoms Aevt (attr_prefix_datoms Aevt db.aevt_index) pending_attr + |> apply_db_view db + in + if not temporal then Hashtbl.replace db.aevt_by_attr attr (Array.of_list datoms); + datoms)) | Avet -> (match (if temporal then None else Hashtbl.find_opt db.avet_by_attr attr) with | Some datoms -> Array.to_list datoms @@ -609,8 +647,9 @@ let primary_attr_datoms db index attr = Hashtbl.replace db.avet_by_attr attr (Array.of_list datoms); cache_avet_entities_for_attr db attr datoms); datoms) - | Eavt -> - merge_sorted_datoms Eavt (Index.to_list db.eavt_index) pending_attr |> apply_db_view db + | Eavt | Tave -> + merge_sorted_datoms index (Index.to_list (stored_index db index)) pending_attr + |> apply_db_view db let aevt_attr_array db attr = ignore (primary_attr_datoms db Aevt attr); @@ -694,6 +733,23 @@ let resolve_tx_at_instant instant db = let as_of_instant instant db = as_of (resolve_tx_at_instant instant db) db +let try_resolve_tx_at_instant instant db = + try Some (resolve_tx_at_instant instant db) with Invalid_argument _ -> None + +(** Lowest tx still inside the TAVE retention window, if resolvable via txInstant. *) +let retention_tx_lo db = + match !tave_retention_days with + | 0 -> None + | days -> + let now_ms = int_of_float (Platform.now_seconds () *. 1000.) in + let cutoff = Instant (now_ms - (days * millis_per_day)) in + try_resolve_tx_at_instant cutoff db + +let prune_tave_to_retention db = + match retention_tx_lo db with + | None -> () + | Some tx_lo -> Index.prune_tave_before db.tave_index ~before_tx:tx_lo + (** Physically drop history facts with [tx < before] while keeping the current projection and all datoms at or after [before]. *) let purge_history_before before db = @@ -795,6 +851,12 @@ let compare_bound_fields context fields left right = function (compare_bound_v context fields left right) (compare_bound_e fields left right) (compare_bound_tx fields left right) + | Tave -> + first_nonzero4 + (compare_bound_tx fields left right) + (compare_bound_a fields left right) + (compare_bound_v context fields left right) + (compare_bound_e fields left right) let array_attr_value_slice context index bound bound_fields arr = let prefix left right = compare_bound_fields context bound_fields left right index in @@ -908,15 +970,34 @@ let find_datom_in_sorted_array index arr datom = let at = lower 0 len in if at >= len || cmp arr.(at) datom <> 0 then None else Some arr.(at) +(* Share AVET/TAVE keys encode Int/Float/Ref with one numeric tag, so raw decode + yields Float. Prefer warm attr-cache values (EAVT-shaped), else restore from + schema: RefType → Ref, integer-valued floats → Int (Logseq / write-side Int). *) +let whole_int_of_float f = + let i = int_of_float f in + if float_of_int i = f then Some i else None + +let rehydrate_value_from_schema schema attr = function + | Float f as original -> + (match Schema.schema_attr_by_name schema attr with + | Some { value_type = Some RefType; _ } -> + (match whole_int_of_float f with Some i -> Ref i | None -> original) + | Some { value_type = Some InstantType; _ } -> + (match whole_int_of_float f with Some i -> Instant i | None -> original) + | _ -> + (match whole_int_of_float f with Some i -> Int i | None -> Float f)) + | other -> other + let rehydrate_datom_value db index datom = match index with | Avet -> ( match Hashtbl.find_opt db.avet_by_attr datom.a with - | None -> datom | Some arr -> (match find_datom_in_sorted_array Avet arr datom with - | None -> datom - | Some cached -> { datom with v = cached.v })) + | Some cached -> { datom with v = cached.v } + | None -> { datom with v = rehydrate_value_from_schema db.schema datom.a datom.v }) + | None -> { datom with v = rehydrate_value_from_schema db.schema datom.a datom.v }) + | Tave -> { datom with v = rehydrate_value_from_schema db.schema datom.a datom.v } | Aevt -> ( match Hashtbl.find_opt db.aevt_by_attr datom.a with | None -> datom @@ -928,6 +1009,8 @@ let rehydrate_datom_value db index datom = let rehydrate_datom_seq db index seq = Seq.map (rehydrate_datom_value db index) seq +let rehydrate_datom_list db index datoms = List.map (rehydrate_datom_value db index) datoms + let find_primary_aevt_entity_attr db entity_id attr = match Hashtbl.find_opt db.aevt_by_attr attr with | None -> None @@ -953,6 +1036,7 @@ let single_field_prefix_cmp index bound left right = match index with | Eavt -> compare left.e right.e | Aevt | Avet -> compare left.a right.a + | Tave -> compare left.tx right.tx in if right == bound then compare_bound left right @@ -978,6 +1062,12 @@ let single_field_prefix_cmp index bound left right = (Util.compare_value left.v right.v) (compare left.e right.e) (compare left.tx right.tx) + | Tave -> + first_nonzero4 + (compare left.tx right.tx) + (compare left.a right.a) + (Util.compare_value left.v right.v) + (compare left.e right.e) let exact_prefix_slice_cmp context index bound bound_fields = match index, bound_fields with @@ -1025,6 +1115,7 @@ let exact_prefix_bound index e a v tx = | Some a, Some v, Some e, Some tx -> Some (bound_datom ~e ~a ~v ~tx (), fields ~e:true ~a:true ~v:true ~tx:true ()) | _ -> None) + | Tave -> None let avet_entity_ids_by_attr_value context db attr value = if temporal_view db then @@ -1065,8 +1156,17 @@ let avet_datoms_by_value context db attr value = |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) else let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in - Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) - |> Index.seq_to_list) + let datoms = + Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) + |> Index.seq_to_list + in + (* Lazy-warm entity-id cache so repeated AVET point lookups stay in RAM + (Share SQLite / LMDB). Observable results unchanged. *) + Hashtbl.replace + db.avet_entities_by_attr_value + (attr, value) + (Array.of_list (List.map (fun d -> d.e) datoms)); + datoms) let avet_datoms_by_value_seq context db attr value = let bound = bound_datom ~a:attr ~v:value () in @@ -1074,16 +1174,35 @@ let avet_datoms_by_value_seq context db attr value = if temporal_view db then avet_datoms_by_value context db attr value |> List.to_seq else - match Hashtbl.find_opt db.avet_by_attr attr with - | Some datoms -> array_attr_value_seq context Avet bound bound_fields datoms + match Hashtbl.find_opt db.avet_entities_by_attr_value (attr, value) with + | Some entity_ids -> List.to_seq (datoms_of_avet_entities attr value entity_ids) + | None -> ( + match Hashtbl.find_opt db.avet_by_attr attr with + | Some datoms -> array_attr_value_seq context Avet bound bound_fields datoms + | None -> + (* Materialize + cache via the list path; later hits use entity cache. *) + avet_datoms_by_value context db attr value |> List.to_seq) + +(* Cache full EAVT e-prefix slices by (db_uid, max_tx, eid) for Share/LMDB. *) +let eavt_entity_datoms_cache : (int * tx * entity_id, datom list) Hashtbl.t = + Hashtbl.create 256 + +let eavt_entity_datoms context db entity_id = + let load () = + let bound = bound_datom ~e:entity_id () in + let bound_fields = fields ~e:true () in + let cmp = exact_prefix_slice_cmp context Eavt bound bound_fields in + Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Eavt) |> Index.seq_to_list + in + if temporal_view db || merged_index db || pending_overlay db then load () + else + let key = (db.db_uid, db.max_tx, entity_id) in + match Hashtbl.find_opt eavt_entity_datoms_cache key with + | Some datoms -> datoms | None -> - if merged_index db then - primary_attr_datoms db Avet attr - |> List.filter (fun datom -> datom.a = attr && context.compare_value datom.v value = 0) - |> List.to_seq - else - let cmp = exact_prefix_slice_cmp context Avet bound bound_fields in - Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db Avet) |> Index.to_seq + let datoms = load () in + Hashtbl.replace eavt_entity_datoms_cache key datoms; + datoms let exact_prefix_datoms context db index e a v tx = match exact_prefix_bound index e a v tx with @@ -1094,6 +1213,10 @@ let exact_prefix_datoms context db index e a v tx = let indexed = primary_attr_datoms db index attr in let duplicates = duplicate_attr_datoms db index attr in Some (merge_sorted_datom_seqs (Util.compare_datom index) (List.to_seq indexed) (List.to_seq duplicates)) + | (Aevt | Avet), None, Some attr, None, None + when (not (merged_index db)) && (not (pending_overlay db)) && (not (temporal_view db)) -> + (* Warm/serve aevt_by_attr / avet_by_attr for attr-only scans (Share SQLite). *) + Some (List.to_seq (primary_attr_datoms db index attr)) | _ -> let cmp = exact_prefix_slice_cmp context index bound bound_fields in (match index, a, merged_index db || pending_overlay db with @@ -1105,6 +1228,13 @@ let exact_prefix_datoms context db index e a v tx = (match merged_index db || pending_overlay db, index, e, a, v, tx with | false, Avet, None, Some _, Some _, None -> Some (avet_datoms_by_value_seq context db (Option.get a) (Option.get v)) + | false, Eavt, Some entity_id, None, None, None -> + Some (List.to_seq (eavt_entity_datoms context db entity_id)) + | false, Eavt, Some entity_id, Some attr, None, None -> + Some + (eavt_entity_datoms context db entity_id + |> List.to_seq + |> Seq.filter (fun d -> d.a = attr)) | false, Aevt, _, Some attr, _, _ -> ( match temporal_view db, Hashtbl.find_opt db.aevt_by_attr attr with | false, Some arr -> @@ -1133,16 +1263,19 @@ let exact_prefix_datoms_list context db index e a v tx = let cmp = exact_prefix_slice_cmp context index bound bound_fields in let exact_attr_prefix = match index, e, a, v, tx with - | Aevt, None, Some _, None, None -> true + | (Aevt | Avet), None, Some _, None, None -> true | _ -> false in (match merged_index db || pending_overlay db with | false -> Some - (match index, a, v, exact_attr_prefix with - | Avet, Some attr, Some value, false -> avet_datoms_by_value context db attr value - | (Aevt | Avet), Some attr, None, true -> primary_attr_datoms db index attr - | Aevt, Some attr, _, false -> ( + (match index, e, a, v, exact_attr_prefix with + | Avet, _, Some attr, Some value, false -> avet_datoms_by_value context db attr value + | (Aevt | Avet), _, Some attr, None, true -> primary_attr_datoms db index attr + | Eavt, Some entity_id, None, None, false -> eavt_entity_datoms context db entity_id + | Eavt, Some entity_id, Some attr, None, false -> + List.filter (fun d -> d.a = attr) (eavt_entity_datoms context db entity_id) + | Aevt, _, Some attr, _, false -> ( match temporal_view db, Hashtbl.find_opt db.aevt_by_attr attr with | false, Some arr -> array_exact_prefix_slice cmp bound arr | true, _ | _, None -> @@ -1187,15 +1320,52 @@ let reverse_upper_prefix_datoms context db index e a v tx = | None -> None | Some (bound, bound_fields) -> let cmp = slice_cmp context index bound bound_fields bound bound_fields in + let debug = match Sys.getenv_opt "DS_DEBUG_INDEX" with Some "1" -> true | _ -> false in let indexed = match index, e, a, v, tx with - | (Aevt | Avet), None, Some attr, None, None when merged_index db || pending_overlay db -> - primary_attr_datoms db index attr - |> List.filter (fun datom -> cmp datom bound <= 0) - |> List.rev - |> List.to_seq + | (Aevt | Avet), None, Some attr, None, None -> + let from_cache = + match index with + | Aevt -> Hashtbl.find_opt db.aevt_by_attr attr + | Avet -> Hashtbl.find_opt db.avet_by_attr attr + | Eavt | Tave -> None + in + if debug then + Printf.eprintf + "[DS_DEBUG_INDEX] reverse_upper_prefix branch=attr_rev index=%s attr=%s cache=%b merged=%b pending=%b\n%!" + (match index with Eavt -> "eavt" | Aevt -> "aevt" | Avet -> "avet" | Tave -> "tave") + attr + (Option.is_some from_cache) + (merged_index db) (pending_overlay db); + (match from_cache with + | Some arr when not (merged_index db || pending_overlay db || temporal_view db) -> + array_rev_seq arr + | _ when not (merged_index db || pending_overlay db || temporal_view db) -> + (* Stay lazy like upstream rseq — do not materialize the whole attr + into avet_by_attr / aevt_by_attr just to reverse-scan. *) + Index.rslice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq + | _ -> + primary_attr_datoms db index attr + |> List.filter (fun datom -> cmp datom bound <= 0) + |> List.rev + |> List.to_seq) | _ when pending_overlay db && not (merged_index db) -> - let stored = Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in + if debug then + Printf.eprintf + "[DS_DEBUG_INDEX] reverse_upper_prefix branch=rslice+pending index=%s pending=%d\n%!" + (match index with Eavt -> "eavt" | Aevt -> "aevt" | Avet -> "avet" | Tave -> "tave") + (List.length db.pending_datoms); + let attr_only = + match index, e, a, v, tx with + | (Aevt | Avet), None, Some _, None, None -> true + | _ -> false + in + let stored = + if attr_only then + Index.rslice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq + else + Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq + in let pending = pending_for_index db index |> List.filter (fun datom -> cmp datom bound <= 0) @@ -1203,12 +1373,32 @@ let reverse_upper_prefix_datoms context db index e a v tx = |> List.to_seq in merge_sorted_datom_seqs (fun left right -> Util.compare_datom index right left) stored pending - | _ -> Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq + | _ -> + if debug then + Printf.eprintf + "[DS_DEBUG_INDEX] reverse_upper_prefix branch=rslice index=%s merged=%b pending=%b a=%s\n%!" + (match index with Eavt -> "eavt" | Aevt -> "aevt" | Avet -> "avet" | Tave -> "tave") + (merged_index db) (pending_overlay db) + (match a with Some a -> a | None -> "-"); + (* Attr-only reverse keeps ~to_ so the scan stays inside that attr + (single-field prefix cmp). Multi-component rseek matches upstream: + start at the upper bound and walk backward with no lower clamp. *) + let attr_only = + match index, e, a, v, tx with + | (Aevt | Avet), None, Some _, None, None -> true + | _ -> false + in + if attr_only then + Index.rslice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) |> Index.to_seq + else + Index.rslice_seq ~from_:bound ~cmp (stored_index db index) |> Index.to_seq in (match merged_index db || pending_overlay db with | false -> Some indexed | true -> let duplicates = duplicate_prefix_datoms db index e a |> List.filter (fun datom -> cmp datom bound <= 0) |> List.rev in + if debug then + Printf.eprintf "[DS_DEBUG_INDEX] reverse_upper_prefix merge_duplicates n=%d\n%!" (List.length duplicates); Some (merge_sorted_datom_seqs (fun left right -> Util.compare_datom index right left) @@ -1341,7 +1531,7 @@ let datoms context db index ?e ?a ?v ?tx () = datoms |> Seq.filter (fun d -> matches e d.e && matches a d.a && matches_value context v d.v && matches tx d.tx) in - apply_db_view_seq db datoms |> apply_filter_pred db + apply_db_view_seq db (rehydrate_datom_seq db index datoms) |> apply_filter_pred db let fold_datoms f init context db index ?e ?a ?v ?tx () = validate_index_access context db index a; @@ -1386,16 +1576,31 @@ let fold_datoms f init context db index ?e ?a ?v ?tx () = | false, Some _ -> fold_filter_and_pred in (match exact_attr_prefix, index, a with + | true, (Aevt | Avet), Some attr when not (temporal_view db) -> + (* Fold the attr prefix in place — do not materialize via primary_attr_datoms. *) + Index.fold_attr_prefix + (fun acc datom -> fold acc (rehydrate_datom_value db index datom)) + init (stored_index db index) attr | true, (Aevt | Avet), Some attr -> - List.fold_left fold init (primary_attr_datoms db index attr) + List.fold_left fold init + (rehydrate_datom_list db index (primary_attr_datoms db index attr)) | _ -> let seq = Index.slice_seq ~from_:bound ~to_:bound ~cmp (stored_index db index) in - Index.fold_seq fold init seq) + Index.fold_seq + (fun acc datom -> fold acc (rehydrate_datom_value db index datom)) + init seq) | false, None when (e, a, v, tx) = (None, None, None, None) -> (match db.filter_pred with - | None -> Index.fold f init (stored_index db index) + | None -> + Index.fold + (fun acc datom -> f acc (rehydrate_datom_value db index datom)) + init (stored_index db index) | Some pred -> - Index.fold (fun acc datom -> if pred datom then f acc datom else acc) init (stored_index db index)) + Index.fold + (fun acc datom -> + let datom = rehydrate_datom_value db index datom in + if pred datom then f acc datom else acc) + init (stored_index db index)) | _ -> datoms context db index ?e ?a ?v ?tx () |> Seq.fold_left f init @@ -1429,7 +1634,7 @@ let datoms_list context db index ?e ?a ?v ?tx () = datoms |> List.filter (fun d -> matches e d.e && matches a d.a && matches_value context v d.v && matches tx d.tx) in - apply_db_view db datoms |> apply_filter_pred_list db + apply_db_view db (rehydrate_datom_list db index datoms) |> apply_filter_pred_list db let datoms_ref context db index ?e ?a ?v ?tx () = let e = resolved_entity_ref_option context db e in @@ -1439,6 +1644,11 @@ let find_datom context db index ?e ?a ?v ?tx () = match temporal_view db, db.filter_pred, index, e, a, v, tx with | false, None, Aevt, Some entity_id, Some attr, None, None when not (merged_index db || pending_overlay db) -> find_primary_aevt_entity_attr db entity_id attr + | false, None, Eavt, Some entity_id, Some attr, None, None when not (merged_index db || pending_overlay db) -> + let bound = bound_datom ~e:entity_id ~a:attr () in + let bound_fields = fields ~e:true ~a:true () in + let cmp = exact_prefix_slice_cmp context Eavt bound bound_fields in + Index.find_first_slice ~from_:bound ~to_:bound ~cmp (stored_index db Eavt) | _ -> datoms context db index ?e ?a ?v ?tx () |> Seq.uncons |> Option.map fst let find_datom_ref context db index ?e ?a ?v ?tx () = @@ -1475,6 +1685,13 @@ let compare_datom_to_bound context index d e a v tx = ; compare_optional d.e e ; compare_optional d.tx tx ] + | Tave -> + context.first_nonzero + [ compare_optional d.tx tx + ; compare_optional d.a a + ; compare_optional_with context.compare_value d.v v + ; compare_optional d.e e + ] let seek_datoms context db index ?e ?a ?v ?tx () = validate_index_access context db index a; diff --git a/impl/db.mli b/impl/db.mli index 9646c41..5cb5d73 100644 --- a/impl/db.mli +++ b/impl/db.mli @@ -34,6 +34,9 @@ val history : db -> db val is_history : db -> bool val resolve_tx_at_instant : value -> db -> tx val purge_history_before : tx -> db -> db * datom list +val set_tave_retention_days : int -> unit +val get_tave_retention_days : unit -> int +val prune_tave_to_retention : db -> unit val with_datoms : db -> datom list -> db val empty_db : core_context -> ?schema:schema -> ?storage:storage -> unit -> db val empty : core_context -> db -> db diff --git a/impl/entity.ml b/impl/entity.ml index 98d227a..46d6144 100644 --- a/impl/entity.ml +++ b/impl/entity.ml @@ -2,6 +2,7 @@ open Datascript_types type context = { datoms_by_entity : db -> entity_id -> datom Seq.t + ; datoms_by_entity_attr : db -> entity_id -> attr -> datom Seq.t ; datoms_by_avet_ref : db -> attr -> entity_id -> datom Seq.t ; all_datoms : db -> datom Seq.t ; compare_value : value -> value -> int @@ -32,18 +33,31 @@ let entity_visible_attr_values context db attr values = else values +(* Cache forward attrs by (db_uid, max_tx, eid) so Share/LMDB entity hydrate + and repeated EAVT e-prefix reads stay in RAM within a basis. *) +let forward_attr_cache : (int * tx * entity_id, (attr * tx_value) list) Hashtbl.t = + Hashtbl.create 256 + let group_forward_entity_attrs context db entity_id = - let add_attr groups d = - match List.assoc_opt d.a groups with - | None -> (d.a, [ d.v ]) :: groups - | Some values -> (d.a, d.v :: values) :: List.remove_assoc d.a groups - in - context.datoms_by_entity db entity_id - |> Seq.fold_left add_attr [] - |> List.filter_map (fun (attr, values) -> - match entity_visible_attr_values context db attr values with - | [] -> None - | values -> Some (attr, tx_value_of_attr_values context db attr values)) + let key = (db.db_uid, db.max_tx, entity_id) in + match Hashtbl.find_opt forward_attr_cache key with + | Some attrs -> attrs + | None -> + let add_attr groups d = + match List.assoc_opt d.a groups with + | None -> (d.a, [ d.v ]) :: groups + | Some values -> (d.a, d.v :: values) :: List.remove_assoc d.a groups + in + let attrs = + context.datoms_by_entity db entity_id + |> Seq.fold_left add_attr [] + |> List.filter_map (fun (attr, values) -> + match entity_visible_attr_values context db attr values with + | [] -> None + | values -> Some (attr, tx_value_of_attr_values context db attr values)) + in + Hashtbl.replace forward_attr_cache key attrs; + attrs let group_reverse_entity_attrs context db entity_id = context.all_datoms db @@ -79,15 +93,6 @@ let sorted_forward_entity_attrs context db entity_id = group_forward_entity_attrs context db entity_id |> List.sort (fun (left, _) (right, _) -> compare left right) -let forward_entity_attr context db entity_id attr = - context.datoms_by_entity db entity_id - |> Seq.filter_map (fun d -> if d.a = attr then Some d.v else None) - |> List.of_seq - |> entity_visible_attr_values context db attr - |> function - | [] -> None - | values -> Some (tx_value_of_attr_values context db attr values) - let reverse_entity_attr context db entity_id attr = let forward_attr = context.reverse_ref attr in let values = @@ -102,6 +107,13 @@ let reverse_entity_attr context db entity_id attr = | values -> Some (Many_values values) let lazy_entity context db entity_id = + (* One EAVT e-prefix scan (cached) serves all forward attr lookups. *) + let forward_by_attr = + lazy + (group_forward_entity_attrs context db entity_id + |> List.to_seq + |> Hashtbl.of_seq) + in let materialized = lazy (group_entity_attrs context db entity_id) in { id = entity_id ; db @@ -111,7 +123,7 @@ let lazy_entity context db entity_id = if context.is_reverse_ref attr then reverse_entity_attr context db entity_id attr else - forward_entity_attr context db entity_id attr) + Hashtbl.find_opt (Lazy.force forward_by_attr) attr) ; materialize_attrs = (fun () -> Lazy.force materialized) } @@ -135,10 +147,11 @@ let entity context db entity_ref = match context.entity_id_of_ref db entity_ref with | None -> None | Some entity_id -> - if entity_has_forward_attrs context db entity_id then - Some (lazy_entity context db entity_id) - else - None + (* Prefer cached/full forward scan over a separate existence seek so hydrate + paths pay one EAVT e-prefix read. *) + match group_forward_entity_attrs context db entity_id with + | [] -> None + | _ -> Some (lazy_entity context db entity_id) let entity_attr_raw (entity : entity) = function | "db/id" -> Some (One_value (Int entity.id)) diff --git a/impl/entity.mli b/impl/entity.mli index 14921c3..9d9ba87 100644 --- a/impl/entity.mli +++ b/impl/entity.mli @@ -2,6 +2,7 @@ open Datascript_types type context = { datoms_by_entity : db -> entity_id -> datom Seq.t + ; datoms_by_entity_attr : db -> entity_id -> attr -> datom Seq.t ; datoms_by_avet_ref : db -> attr -> entity_id -> datom Seq.t ; all_datoms : db -> datom Seq.t ; compare_value : value -> value -> int diff --git a/impl/index.mli b/impl/index.mli index 884cc90..ef0219a 100644 --- a/impl/index.mli +++ b/impl/index.mli @@ -44,3 +44,6 @@ val to_seq : datom seq -> datom Seq.t val seek : datom -> datom seq -> datom seq val flush : t -> t val copy : t -> t +val fold_tave_range : + ('acc -> datom -> 'acc) -> 'acc -> t -> from_tx:tx -> ?to_tx:tx -> ?attr:string -> unit -> 'acc +val prune_tave_before : t -> before_tx:tx -> unit diff --git a/impl/platform/jsoo/index.ml b/impl/platform/jsoo/index.ml index f5771dc..dec08a1 100644 --- a/impl/platform/jsoo/index.ml +++ b/impl/platform/jsoo/index.ml @@ -27,7 +27,9 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = let target = Datascript_storage_protocol.db_for_storage target_storage in Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx + (Datascript_lmdb_index.empty Tave (Datascript_lmdb_index.db_of (project eavt))) target let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = ignore (eavt, aevt, avet); @@ -76,3 +78,10 @@ let to_seq = Datascript_lmdb_index.to_seq let seek = Datascript_lmdb_index.seek let flush t = Datascript_lmdb_index.flush (project t) |> inject let copy t = Datascript_lmdb_index.copy (project t) |> inject + +let fold_tave_range f init t ~from_tx ?to_tx ?attr () = + Datascript_lmdb_index.fold_tave_range f init (Datascript_lmdb_index.db_of (project t)) ~from_tx ?to_tx + ?attr () + +let prune_tave_before t ~before_tx = + Datascript_lmdb_index.prune_tave_before (Datascript_lmdb_index.db_of (project t)) ~before_tx diff --git a/impl/platform/jsoo/storage.ml b/impl/platform/jsoo/storage.ml index 2f20103..f4b33e8 100644 --- a/impl/platform/jsoo/storage.ml +++ b/impl/platform/jsoo/storage.ml @@ -67,6 +67,7 @@ let restore context storage = ; eavt_index = Index.empty Eavt index_db ; aevt_index = Index.empty Aevt index_db ; avet_index = Index.empty Avet index_db + ; tave_index = Index.empty Tave index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/platform/melange/index.ml b/impl/platform/melange/index.ml index f5771dc..dec08a1 100644 --- a/impl/platform/melange/index.ml +++ b/impl/platform/melange/index.ml @@ -27,7 +27,9 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = let target = Datascript_storage_protocol.db_for_storage target_storage in Datascript_lmdb_index.sync_append_since_tx ~since_tx (project eavt) target; Datascript_lmdb_index.sync_append_since_tx ~since_tx (project aevt) target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target + Datascript_lmdb_index.sync_append_since_tx ~since_tx (project avet) target; + Datascript_lmdb_index.sync_append_since_tx ~since_tx + (Datascript_lmdb_index.empty Tave (Datascript_lmdb_index.db_of (project eavt))) target let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = ignore (eavt, aevt, avet); @@ -76,3 +78,10 @@ let to_seq = Datascript_lmdb_index.to_seq let seek = Datascript_lmdb_index.seek let flush t = Datascript_lmdb_index.flush (project t) |> inject let copy t = Datascript_lmdb_index.copy (project t) |> inject + +let fold_tave_range f init t ~from_tx ?to_tx ?attr () = + Datascript_lmdb_index.fold_tave_range f init (Datascript_lmdb_index.db_of (project t)) ~from_tx ?to_tx + ?attr () + +let prune_tave_before t ~before_tx = + Datascript_lmdb_index.prune_tave_before (Datascript_lmdb_index.db_of (project t)) ~before_tx diff --git a/impl/platform/melange/storage.ml b/impl/platform/melange/storage.ml index 2f20103..f4b33e8 100644 --- a/impl/platform/melange/storage.ml +++ b/impl/platform/melange/storage.ml @@ -67,6 +67,7 @@ let restore context storage = ; eavt_index = Index.empty Eavt index_db ; aevt_index = Index.empty Aevt index_db ; avet_index = Index.empty Avet index_db + ; tave_index = Index.empty Tave index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/platform/native/index.ml b/impl/platform/native/index.ml index 9bee8d6..32bb0a9 100644 --- a/impl/platform/native/index.ml +++ b/impl/platform/native/index.ml @@ -10,11 +10,13 @@ type concrete_index = external inject : concrete_index -> index_set = "%identity" external project : index_set -> concrete_index = "%identity" -(* LMDB and SQLite seq records share the same {cmp; datoms; offset} layout. *) -external seq_of_sqlite : 'a Datascript_sqlite_index.seq -> 'a Datascript_lmdb_index.seq = "%identity" - type t = index_set -type 'a seq = 'a Datascript_lmdb_index.seq + +(* LMDB keeps a list-backed seq; SQLite streams lazily (upstream BTSet style). *) +type 'a seq = + | Lmdb_seq of 'a Datascript_lmdb_index.seq + | Sqlite_seq of 'a Datascript_sqlite_index.seq + type index_db = Datascript_storage_protocol.index_db type lmdb = index_db @@ -36,15 +38,25 @@ let index_db_for_storage storage = Datascript_storage_protocol.db_for_storage st let lmdb_for_storage = index_db_for_storage let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = + let sync_tave_lmdb src_db target = + let tave = Datascript_lmdb_index.empty Tave src_db in + Datascript_lmdb_index.sync_append_since_tx ~since_tx tave target + in + let sync_tave_sqlite src_db target = + let tave = Datascript_sqlite_index.empty Tave src_db in + Datascript_sqlite_index.sync_append_since_tx ~since_tx tave target + in match project eavt, project aevt, project avet, Datascript_storage_protocol.db_for_storage target_storage with | Lmdb e, Lmdb a, Lmdb v, Datascript_storage_protocol.Lmdb target -> Datascript_lmdb_index.sync_append_since_tx ~since_tx e target; Datascript_lmdb_index.sync_append_since_tx ~since_tx a target; - Datascript_lmdb_index.sync_append_since_tx ~since_tx v target + Datascript_lmdb_index.sync_append_since_tx ~since_tx v target; + sync_tave_lmdb (Datascript_lmdb_index.db_of e) target | Sqlite e, Sqlite a, Sqlite v, Datascript_storage_protocol.Sqlite target -> Datascript_sqlite_index.sync_append_since_tx ~since_tx e target; Datascript_sqlite_index.sync_append_since_tx ~since_tx a target; - Datascript_sqlite_index.sync_append_since_tx ~since_tx v target + Datascript_sqlite_index.sync_append_since_tx ~since_tx v target; + sync_tave_sqlite (Datascript_sqlite_index.db_of e) target | Lmdb e, Lmdb a, Lmdb v, Datascript_storage_protocol.Sqlite target -> let put_since index_t which = let dest = Datascript_sqlite_index.empty which target in @@ -55,7 +67,8 @@ let sync_indexes_to_storage ~since_tx eavt aevt avet target_storage = in put_since e Eavt; put_since a Aevt; - put_since v Avet + put_since v Avet; + put_since (Datascript_lmdb_index.empty Tave (Datascript_lmdb_index.db_of e)) Tave | _ -> invalid_arg "Index.sync_indexes_to_storage: unsupported index/storage backend combination" @@ -69,7 +82,8 @@ let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave | Datascript_storage_protocol.Sqlite target -> let remove which = let t = Datascript_sqlite_index.empty which target in @@ -77,7 +91,8 @@ let sync_removals_to_storage removed_datoms eavt aevt avet target_storage = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave let load_indexes_from_storage storage target = Datascript_storage_protocol.load_indexes_from_storage storage target @@ -172,23 +187,34 @@ let slice ?from_ ?to_ ?cmp t = let slice_seq ?from_ ?to_ ?cmp t = match project t with - | Lmdb i -> Datascript_lmdb_index.slice_seq ?from_ ?to_ ?cmp i - | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.slice_seq ?from_ ?to_ ?cmp i) + | Lmdb i -> Lmdb_seq (Datascript_lmdb_index.slice_seq ?from_ ?to_ ?cmp i) + | Sqlite i -> Sqlite_seq (Datascript_sqlite_index.slice_seq ?from_ ?to_ ?cmp i) let rslice_seq ?from_ ?to_ ?cmp t = match project t with - | Lmdb i -> Datascript_lmdb_index.rslice_seq ?from_ ?to_ ?cmp i - | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.rslice_seq ?from_ ?to_ ?cmp i) + | Lmdb i -> Lmdb_seq (Datascript_lmdb_index.rslice_seq ?from_ ?to_ ?cmp i) + | Sqlite i -> Sqlite_seq (Datascript_sqlite_index.rslice_seq ?from_ ?to_ ?cmp i) let seq t = match project t with - | Lmdb i -> Datascript_lmdb_index.seq i - | Sqlite i -> seq_of_sqlite (Datascript_sqlite_index.seq i) + | Lmdb i -> Lmdb_seq (Datascript_lmdb_index.seq i) + | Sqlite i -> Sqlite_seq (Datascript_sqlite_index.seq i) + +let to_seq = function + | Lmdb_seq s -> Datascript_lmdb_index.to_seq s + | Sqlite_seq s -> Datascript_sqlite_index.to_seq s + +let seq_to_list = function + | Lmdb_seq s -> Datascript_lmdb_index.seq_to_list s + | Sqlite_seq s -> Datascript_sqlite_index.seq_to_list s -let seq_to_list = Datascript_lmdb_index.seq_to_list -let fold_seq = Datascript_lmdb_index.fold_seq -let to_seq = Datascript_lmdb_index.to_seq -let seek = Datascript_lmdb_index.seek +let fold_seq f init = function + | Lmdb_seq s -> Datascript_lmdb_index.fold_seq f init s + | Sqlite_seq s -> Datascript_sqlite_index.fold_seq f init s + +let seek bound = function + | Lmdb_seq s -> Lmdb_seq (Datascript_lmdb_index.seek bound s) + | Sqlite_seq s -> Sqlite_seq (Datascript_sqlite_index.seek bound s) let flush t = match project t with @@ -199,3 +225,17 @@ let copy t = match project t with | Lmdb i -> Datascript_lmdb_index.copy i |> fun i -> inject (Lmdb i) | Sqlite i -> Datascript_sqlite_index.copy i |> fun i -> inject (Sqlite i) + +let fold_tave_range f init t ~from_tx ?to_tx ?attr () = + match project t with + | Lmdb i -> + Datascript_lmdb_index.fold_tave_range f init (Datascript_lmdb_index.db_of i) ~from_tx ?to_tx + ?attr () + | Sqlite i -> + Datascript_sqlite_index.fold_tave_range f init (Datascript_sqlite_index.db_of i) ~from_tx ?to_tx + ?attr () + +let prune_tave_before t ~before_tx = + match project t with + | Lmdb i -> Datascript_lmdb_index.prune_tave_before (Datascript_lmdb_index.db_of i) ~before_tx + | Sqlite i -> Datascript_sqlite_index.prune_tave_before (Datascript_sqlite_index.db_of i) ~before_tx diff --git a/impl/platform/native/storage.ml b/impl/platform/native/storage.ml index 9e05907..f701ec5 100644 --- a/impl/platform/native/storage.ml +++ b/impl/platform/native/storage.ml @@ -67,6 +67,7 @@ let restore context storage = ; eavt_index = Index.empty Eavt index_db ; aevt_index = Index.empty Aevt index_db ; avet_index = Index.empty Avet index_db + ; tave_index = Index.empty Tave index_db ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/query_api.ml b/impl/query_api.ml index c21aa38..bf470c5 100644 --- a/impl/query_api.ml +++ b/impl/query_api.ml @@ -19,6 +19,88 @@ let with_force_relation_fallback f = force_relation_fallback := true; Fun.protect ~finally:(fun () -> force_relation_fallback := previous) f +(* Datalevin-style result cache: general, keyed by db epoch + physical query/inputs. + Avoid structural hashing of [query] — where clauses may embed function values. *) +let result_cache_enabled = + match Sys.getenv_opt "DATASCRIPT_QUERY_RESULT_CACHE" with + | Some ("0" | "false" | "no" | "off") -> ref false + | _ -> ref true + +let query_debug_enabled = + match Sys.getenv_opt "DATASCRIPT_QUERY_DEBUG" with + | Some ("1" | "true" | "yes" | "on") -> true + | _ -> false + +type result_cache_entry = + { max_e : entity_id + ; max_tx : int + ; query : query + ; inputs : query_arg list + ; path : query_exec_path + ; rows : query_result list list + } + +let result_cache_entries : result_cache_entry list ref = ref [] +let result_cache_limit = 128 +let last_cache_hit = ref false + +let clear_query_result_cache () = result_cache_entries := [] + +let with_query_result_cache enabled f = + let previous = !result_cache_enabled in + result_cache_enabled := enabled; + Fun.protect ~finally:(fun () -> result_cache_enabled := previous) f + +let query_result_cache_enabled () = !result_cache_enabled +let last_query_cache_hit () = !last_cache_hit + +let now_ms () = Platform.now_seconds () *. 1000. + +let debug_log fmt = + if query_debug_enabled then Printf.eprintf ("query-debug\t" ^^ fmt ^^ "\n%!") + else Printf.ifprintf stderr fmt + +let path_label = function + | Fused_execute -> "fused" + | Relation_fallback -> "relation" + | Binding_interpreter -> "bindings" + +let lookup_result_cache db query inputs = + if (not !result_cache_enabled) || !force_relation_fallback then None + else + List.find_map + (fun entry -> + if + entry.max_e = db.max_datom_e + && entry.max_tx = db.max_tx + && entry.query == query + && entry.inputs == inputs + then Some (entry.path, entry.rows) + else None) + !result_cache_entries + +let store_result_cache db query inputs path rows = + if !result_cache_enabled && not !force_relation_fallback then ( + let entry = + { max_e = db.max_datom_e; max_tx = db.max_tx; query; inputs; path; rows } + in + let rest = + List.filter + (fun e -> + not + (e.query == query + && e.inputs == inputs + && e.max_e = entry.max_e + && e.max_tx = entry.max_tx)) + !result_cache_entries + in + let rec take n = function + | [] -> [] + | _ when n <= 0 -> [] + | x :: xs -> x :: take (n - 1) xs + in + result_cache_entries := take result_cache_limit (entry :: rest)) + module Make (Context : sig val empty_db : unit -> db val validate_rule_arities : query_rule list -> query_rule list @@ -204,7 +286,21 @@ end) = struct vars) let q_sources_raw ?(inputs = []) db sources query = + let started = if query_debug_enabled then now_ms () else 0. in + last_cache_hit := false; + match lookup_result_cache db query inputs with + | Some (path, rows) -> + last_cache_hit := true; + last_path := path; + debug_log + "cache=hit\tpath=%s\trows=%d\tms=%.4f" + (path_label path) + (List.length rows) + (if query_debug_enabled then now_ms () -. started else 0.); + rows + | None -> let finish_relation_rows rules input_bindings where find = + let plan_started = if query_debug_enabled then now_ms () else 0. in let try_planned_execute () = (* Prefer Datahike execute for single fused entity-group / ground scan. Multi-op Union and open scans still use relational fallback until @@ -229,6 +325,8 @@ end) = struct | _ -> execute_plan db sources [] input_bindings plan) | _ -> None in + let plan_ms = if query_debug_enabled then now_ms () -. plan_started else 0. in + let exec_started = if query_debug_enabled then now_ms () else 0. in let relation_result = match try_planned_execute () with | Some result -> @@ -243,65 +341,80 @@ end) = struct last_path := Binding_interpreter; None) in - match relation_result with - | Some (attrs, rows, unique_rows) -> ( - (* Hot path: find vars already match relation attrs (entity-group emit). *) - match find_var_names_cached find with - | Some find_vars when find_vars = attrs -> - if unique_rows then rows else sort_uniq_presorted compare rows - | _ -> - (match relation_rows_for_find db sources attrs rows unique_rows find with - | Some rows -> rows - | None -> - let bindings = eval_clauses db sources rules input_bindings where in - bindings - |> fun bindings -> dedupe_bindings_for_find bindings find - |> List.filter_map (fun binding -> collect_find_specs db sources binding find) - |> List.sort_uniq compare)) - | None -> - let bindings = eval_clauses db sources rules input_bindings where in - bindings - |> fun bindings -> dedupe_bindings_for_find bindings find - |> List.filter_map (fun binding -> collect_find_specs db sources binding find) - |> List.sort_uniq compare - in - if - inputs = [] - && query.inputs = [] - && query.rules = [] - && query.with_vars = [] - && not (has_aggregates query.find) - then - finish_relation_rows [] [ [] ] query.where query.find - else - let callables, input_bindings, input_rules = initial_query_context db query inputs in - let rules, where = - match query.rules, input_rules with - | [], [] -> [], query.where - | _ -> query_rules_and_where query input_rules + let exec_ms = if query_debug_enabled then now_ms () -. exec_started else 0. in + let rows = + match relation_result with + | Some (attrs, rows, unique_rows) -> ( + (* Hot path: find vars already match relation attrs (entity-group emit). *) + match find_var_names_cached find with + | Some find_vars when find_vars = attrs -> + if unique_rows then rows else sort_uniq_presorted compare rows + | _ -> + (match relation_rows_for_find db sources attrs rows unique_rows find with + | Some rows -> rows + | None -> + let bindings = eval_clauses db sources rules input_bindings where in + bindings + |> fun bindings -> dedupe_bindings_for_find bindings find + |> List.filter_map (fun binding -> collect_find_specs db sources binding find) + |> List.sort_uniq compare)) + | None -> + let bindings = eval_clauses db sources rules input_bindings where in + bindings + |> fun bindings -> dedupe_bindings_for_find bindings find + |> List.filter_map (fun binding -> collect_find_specs db sources binding find) + |> List.sort_uniq compare in + debug_log + "cache=miss\tpath=%s\tplan-ms=%.4f\texec-ms=%.4f\trows=%d\ttotal-ms=%.4f" + (path_label !last_path) + plan_ms + exec_ms + (List.length rows) + (if query_debug_enabled then now_ms () -. started else 0.); + rows + in + let rows = if - (not (has_aggregates query.find)) + inputs = [] + && query.inputs = [] + && query.rules = [] && query.with_vars = [] - && query_callables_empty callables + && not (has_aggregates query.find) then - finish_relation_rows rules input_bindings where query.find - else ( - last_path := Binding_interpreter; - let bindings = eval_clauses ~callables db sources rules input_bindings where in - if has_aggregates query.find then - if query.with_vars = [] then - aggregate_rows ~callables db sources bindings query.find + finish_relation_rows [] [ [] ] query.where query.find + else + let callables, input_bindings, input_rules = initial_query_context db query inputs in + let rules, where = + match query.rules, input_rules with + | [], [] -> [], query.where + | _ -> query_rules_and_where query input_rules + in + if + (not (has_aggregates query.find)) + && query.with_vars = [] + && query_callables_empty callables + then + finish_relation_rows rules input_bindings where query.find + else ( + last_path := Binding_interpreter; + let bindings = eval_clauses ~callables db sources rules input_bindings where in + if has_aggregates query.find then + if query.with_vars = [] then + aggregate_rows ~callables db sources bindings query.find + else + aggregate_rows_with ~callables db sources bindings query.find query.with_vars + else if query.with_vars <> [] then + non_aggregate_rows_with db sources bindings query.find query.with_vars else - aggregate_rows_with ~callables db sources bindings query.find query.with_vars - else if query.with_vars <> [] then - non_aggregate_rows_with db sources bindings query.find query.with_vars - else - bindings - |> fun bindings -> dedupe_bindings_for_find bindings query.find - |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) - |> List.sort_uniq compare) - + bindings + |> fun bindings -> dedupe_bindings_for_find bindings query.find + |> List.filter_map (fun binding -> collect_find_specs db sources binding query.find) + |> List.sort_uniq compare) + in + store_result_cache db query inputs !last_path rows; + rows + let q_with_raw ?(inputs = []) db with_vars query = last_path := Binding_interpreter; let callables, input_bindings, input_rules = initial_query_context db query inputs in diff --git a/impl/query_exec.ml b/impl/query_exec.ml index 1e66529..260c8d2 100644 --- a/impl/query_exec.ml +++ b/impl/query_exec.ml @@ -28,9 +28,19 @@ module Make (Context : sig val entity_ids_array_by_attr_value : db -> attr -> value -> entity_id array option val query_attr_uses_avet : db -> attr -> bool val query_value_uses_avet : value -> bool + val is_ref_attr : db -> attr -> bool val aevt_attr_array : db -> attr -> datom array option val aevt_duplicate_datoms : db -> attr -> datom list val find_entity_in_aevt_array : datom array -> entity_id -> datom option + val fold_index_range : + ('acc -> datom -> 'acc) -> + 'acc -> + db -> + attr -> + ?start:value -> + ?stop:value -> + unit -> + 'acc end) = struct open Context @@ -81,7 +91,8 @@ end) = struct right_common_indexes |> List.map (fun (attr, index) -> attr, row_value row index) in - Hashtbl.replace table key row; + let prev = Option.value (Hashtbl.find_opt table key) ~default:[] in + Hashtbl.replace table key (row :: prev); table) (Hashtbl.create (List.length right.rows)) in @@ -95,11 +106,14 @@ end) = struct in match Hashtbl.find_opt right_by_key key with | None -> [] - | Some right_row -> - let extra = List.map (fun index -> row_value right_row index) right_only_indexes in - [ left_row @ extra ]) + | Some right_rows -> + List.rev_map + (fun right_row -> + let extra = List.map (fun index -> row_value right_row index) right_only_indexes in + left_row @ extra) + right_rows) in - { attrs; rows; unique_rows = left.unique_rows && right.unique_rows && rows <> [] } + { attrs; rows; unique_rows = false } let anti_join left right = let join_attrs = List.filter (fun attr -> List.mem attr right.attrs) left.attrs in @@ -345,71 +359,24 @@ end) = struct in loop (count - 1) [] - (* Resolved Datahike-style pipelines, keyed by entity-group physical identity - (plan cache reuses the same group object across calls). *) - type resolved_kernel = - | Kernel_q2 of - { ids : entity_id array - ; arr : datom array - ; base : int - ; len : int - ; attrs : string list - ; unique_rows : bool - } - | Kernel_q5 of - { ids : entity_id array - ; arr0 : datom array - ; arr1 : datom array - ; arr2 : datom array - ; arr3 : datom array - ; base : int - ; len : int - ; attrs : string list - ; unique_rows : bool - } - - let last_kernel_group : Query_plan.entity_group option ref = ref None - let last_kernel_max_e = ref (-1) - let last_kernel : resolved_kernel option ref = ref None - - let emit_q2_rows ids arr base len = - let rows = ref [] in - for i = Array.length ids - 1 downto 0 do - let e = ids.(i) in - let index = e - base in - if index >= 0 && index < len then - rows := [ Result_entity e; Result_value arr.(index).v ] :: !rows - done; - !rows - - let emit_q5_rows ids arr0 arr1 arr2 arr3 base len = - let rows = ref [] in + (* Emit rows for const AVET drive + N aligned dense card-one value merges. *) + let emit_dense_const_rows ids arrs base len = + let n_bind = Array.length arrs in + let out = ref [] in for i = Array.length ids - 1 downto 0 do - let e = ids.(i) in - let index = e - base in - if index >= 0 && index < len then - rows := - [ Result_entity e - ; Result_value arr0.(index).v - ; Result_value arr1.(index).v - ; Result_value arr2.(index).v - ; Result_value arr3.(index).v - ] - :: !rows + let eid = ids.(i) in + let idx = eid - base in + if idx >= 0 && idx < len then ( + let row = Array.make (n_bind + 1) (Result_entity eid) in + row.(0) <- Result_entity eid; + for j = 0 to n_bind - 1 do + row.(j + 1) <- Result_value arrs.(j).(idx).v + done; + out := Array.to_list row :: !out) done; - !rows + !out - let run_resolved_kernel = function - | Kernel_q2 { ids; arr; base; len; attrs; unique_rows } -> - Some { attrs; rows = emit_q2_rows ids arr base len; unique_rows } - | Kernel_q5 { ids; arr0; arr1; arr2; arr3; base; len; attrs; unique_rows } -> - Some - { attrs - ; rows = emit_q5_rows ids arr0 arr1 arr2 arr3 base len - ; unique_rows - } - - (* q-not shaped: AEVT scan + ground anti-merge (Datahike anti during scan). *) + (* Open AEVT seed + ground anti-merge (Datahike anti during scan). *) let execute_scan_anti_ground source_db e_var attrs (scan : Query_plan.l_scan) anti_attr anti_value = match scan.entity, scan.attr, scan.value with | QVar ev, QAttr seed_attr, QVar v @@ -452,8 +419,10 @@ end) = struct Some !rows | _ -> None - (* q2 / q-5-merge: const AVET drive + dense/cursor merges (Datahike sorted-merge). *) + (* Const AVET drive + card-one AEVT merges (Datahike sorted-merge / per-cursor). *) let execute_const_drive_merges source_db e_var attrs (scan : Query_plan.l_scan) merges = + if merges = [] then None + else match scan.entity, scan.attr, scan.value with | QVar ev, QAttr drive_attr, QValue drive_value when ev = e_var && direct_attr drive_attr -> let* ids = @@ -476,190 +445,104 @@ end) = struct collect [] merges in let drive_len = Array.length ids in - (match pos_ops, attrs with - (* q2: one value merge — unrolled dense emit (Datahike sorted-merge card-one). *) - | [ Pos { bind_var = Some v; arr; _ } ], [ a; b ] - when (a = e_var && b = v) || (a = v && b = e_var) -> - let rows = ref [] in - (match dense_base arr with - | Some (base, len) -> - if a = e_var then - for i = Array.length ids - 1 downto 0 do - let e = ids.(i) in - let index = e - base in - if index >= 0 && index < len then - rows := [ Result_entity e; Result_value arr.(index).v ] :: !rows - done - else - for i = Array.length ids - 1 downto 0 do - let e = ids.(i) in - let index = e - base in - if index >= 0 && index < len then - rows := [ Result_value arr.(index).v; Result_entity e ] :: !rows - done - | None -> - let ptr = ref 0 in - if a = e_var then - for i = 0 to Array.length ids - 1 do - match seek_aevt arr ptr ids.(i) with - | None -> () - | Some d -> rows := [ Result_entity d.e; Result_value d.v ] :: !rows - done - else - for i = 0 to Array.length ids - 1 do - match seek_aevt arr ptr ids.(i) with - | None -> () - | Some d -> rows := [ Result_value d.v; Result_entity d.e ] :: !rows + let bind_vars = + pos_ops + |> List.filter_map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) + in + let expected_attrs = e_var :: bind_vars in + if attrs <> expected_attrs then + None + else + let n_pos = List.length pos_ops in + let arrs = + Array.of_list (List.map (function Pos { arr; _ } -> arr | Anti _ -> [||]) pos_ops) + in + let terms = + Array.of_list + (List.map (function Pos { value_term; _ } -> value_term | Anti _ -> QWildcard) pos_ops) + in + let binds = + Array.of_list + (List.map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) pos_ops) + in + let dense = Array.map dense_base arrs in + if not (Array.for_all Option.is_some dense) then + (* Cursor fallback for non-dense AEVT slices *) + let pointers = Array.init n_pos (fun _ -> ref 0) in + let rows = Array.make drive_len [] in + let count = ref 0 in + for i = 0 to drive_len - 1 do + let eid = ids.(i) in + let ok = ref true in + let bound = ref [] in + let mi = ref 0 in + while !ok && !mi < n_pos do + match seek_aevt arrs.(!mi) pointers.(!mi) eid with + | None -> ok := false + | Some d when value_matches terms.(!mi) d.v -> + (match binds.(!mi) with + | Some v -> + bound := (v, Query.result_of_ref (Query.result_of_datom_v d)) :: !bound + | None -> ()); + incr mi + | Some _ -> ok := false + done; + if !ok then ( + let table = Hashtbl.create (List.length attrs) in + Hashtbl.add table e_var (Result_entity eid); + List.iter (fun (v, r) -> Hashtbl.add table v r) !bound; + rows.(!count) <- List.map (Hashtbl.find table) attrs; + incr count) + done; + Some (rows_of_array_rev rows !count) + else + let dense = Array.map Option.get dense in + let n_bind = List.length bind_vars in + let base0, len0 = dense.(0) in + let aligned = Array.for_all (fun (b, l) -> b = base0 && l = len0) dense in + let all_free_binds = + Array.for_all + (function + | QVar _ -> true + | _ -> false) + terms + && Array.for_all Option.is_some binds + in + if aligned && all_free_binds && n_bind = n_pos then + Some (emit_dense_const_rows ids arrs base0 len0) + else + (* Per-attr dense index, including ground-value verifies *) + let out = ref [] in + for i = drive_len - 1 downto 0 do + let eid = ids.(i) in + let ok = ref true in + let vals = Array.make n_bind (Result_value (Int 0)) in + let vi = ref 0 in + let mi = ref 0 in + while !ok && !mi < n_pos do + let base, len = dense.(!mi) in + let idx = eid - base in + if idx < 0 || idx >= len || arrs.(!mi).(idx).e <> eid then ok := false + else + let d = arrs.(!mi).(idx) in + if not (value_matches terms.(!mi) d.v) then ok := false + else ( + (match binds.(!mi) with + | Some _ -> + vals.(!vi) <- Result_value d.v; + incr vi + | None -> ()); + incr mi) done; - rows := List.rev !rows); - Some !rows - (* Multi merges (value binds + optional ground verifies) — q3/q4/q-5-merge *) - | pos_ops, _ -> - let bind_vars = - pos_ops - |> List.filter_map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) - in - let expected_attrs = e_var :: bind_vars in - if attrs <> expected_attrs then - None - else - let n_pos = List.length pos_ops in - let arrs = - Array.of_list (List.map (function Pos { arr; _ } -> arr | Anti _ -> [||]) pos_ops) - in - let terms = - Array.of_list - (List.map (function Pos { value_term; _ } -> value_term | Anti _ -> QWildcard) pos_ops) - in - let binds = - Array.of_list - (List.map (function Pos { bind_var; _ } -> bind_var | Anti _ -> None) pos_ops) - in - let dense = Array.map dense_base arrs in - if not (Array.for_all Option.is_some dense) then - (* Cursor fallback for non-dense *) - let pointers = Array.init n_pos (fun _ -> ref 0) in - let rows = Array.make drive_len [] in - let count = ref 0 in - for i = 0 to drive_len - 1 do - let eid = ids.(i) in - let ok = ref true in - let bound = ref [] in - let mi = ref 0 in - while !ok && !mi < n_pos do - match seek_aevt arrs.(!mi) pointers.(!mi) eid with - | None -> ok := false - | Some d when value_matches terms.(!mi) d.v -> - (match binds.(!mi) with - | Some v -> - bound := (v, Query.result_of_ref (Query.result_of_datom_v d)) :: !bound - | None -> ()); - incr mi - | Some _ -> ok := false - done; - if !ok then ( - let table = Hashtbl.create (List.length attrs) in - Hashtbl.add table e_var (Result_entity eid); - List.iter (fun (v, r) -> Hashtbl.add table v r) !bound; - rows.(!count) <- List.map (Hashtbl.find table) attrs; - incr count) - done; - Some (rows_of_array_rev rows !count) - else - let dense = Array.map Option.get dense in - let n_bind = List.length bind_vars in - let base0, len0 = dense.(0) in - let aligned = Array.for_all (fun (b, l) -> b = base0 && l = len0) dense in - let all_free_binds = - Array.for_all - (function - | QVar _ -> true - | _ -> false) - terms - && Array.for_all Option.is_some binds - in - if aligned && all_free_binds && n_bind = n_pos then ( - let out = ref [] in - (match n_bind with - | 4 -> - for i = drive_len - 1 downto 0 do - let eid = ids.(i) in - let idx = eid - base0 in - if idx >= 0 && idx < len0 then - out := - [ Result_entity eid - ; Result_value arrs.(0).(idx).v - ; Result_value arrs.(1).(idx).v - ; Result_value arrs.(2).(idx).v - ; Result_value arrs.(3).(idx).v - ] - :: !out - done - | 2 -> - for i = drive_len - 1 downto 0 do - let eid = ids.(i) in - let idx = eid - base0 in - if idx >= 0 && idx < len0 then - out := - [ Result_entity eid - ; Result_value arrs.(0).(idx).v - ; Result_value arrs.(1).(idx).v - ] - :: !out - done - | 1 -> - for i = drive_len - 1 downto 0 do - let eid = ids.(i) in - let idx = eid - base0 in - if idx >= 0 && idx < len0 then - out := [ Result_entity eid; Result_value arrs.(0).(idx).v ] :: !out - done - | _ -> - for i = drive_len - 1 downto 0 do - let eid = ids.(i) in - let idx = eid - base0 in - if idx >= 0 && idx < len0 then - let row = Array.make (n_bind + 1) (Result_entity eid) in - row.(0) <- Result_entity eid; - for j = 0 to n_bind - 1 do - row.(j + 1) <- Result_value arrs.(j).(idx).v - done; - out := Array.to_list row :: !out - done); - Some !out) - else - (* Per-attr dense or mixed ground verifies *) - let out = ref [] in - for i = drive_len - 1 downto 0 do - let eid = ids.(i) in - let ok = ref true in - let vals = Array.make n_bind (Result_value (Int 0)) in - let vi = ref 0 in - let mi = ref 0 in - while !ok && !mi < n_pos do - let base, len = dense.(!mi) in - let idx = eid - base in - if idx < 0 || idx >= len || arrs.(!mi).(idx).e <> eid then ok := false - else - let d = arrs.(!mi).(idx) in - if not (value_matches terms.(!mi) d.v) then ok := false - else ( - (match binds.(!mi) with - | Some _ -> - vals.(!vi) <- Result_value d.v; - incr vi - | None -> ()); - incr mi) - done; - if !ok then ( - let row = Array.make (n_bind + 1) (Result_entity eid) in - row.(0) <- Result_entity eid; - for j = 0 to n_bind - 1 do - row.(j + 1) <- vals.(j) - done; - out := Array.to_list row :: !out) - done; - Some !out) + if !ok then ( + let row = Array.make (n_bind + 1) (Result_entity eid) in + row.(0) <- Result_entity eid; + for j = 0 to n_bind - 1 do + row.(j + 1) <- vals.(j) + done; + out := Array.to_list row :: !out) + done; + Some !out | _ -> None (* Datahike execute-sorted-merge / per-cursor-merge for card-one attrs. *) @@ -668,7 +551,79 @@ end) = struct | [], [ { Query_plan.attr = QAttr anti_attr; value = QValue anti_value; _ } ] -> execute_scan_anti_ground source_db e_var attrs scan anti_attr anti_value | [], [ _ ] -> None - | merges, [] -> execute_const_drive_merges source_db e_var attrs scan merges + | merges, [] -> ( + match execute_const_drive_merges source_db e_var attrs scan merges with + | Some _ as ok -> ok + | None -> + (* Open-value drive (e.g. [?e :block/journal-day ?d] [?e :block/title ?t]): + AEVT seed + card-one merges — same algorithm as mixed path without anti. *) + let* drive = driving_cells source_db e_var scan in + let* pos_ops = + let rec collect acc = function + | [] -> Some (List.rev acc) + | m :: rest -> + (match parse_pos_merge source_db m with + | None -> None + | Some op -> collect (op :: acc) rest) + in + collect [] merges + in + let pos_arr = Array.of_list pos_ops in + let n_pos = Array.length pos_arr in + let pointers = Array.init n_pos (fun _ -> ref 0) in + let dense = + Array.map + (function + | Pos { arr; _ } -> dense_base arr + | Anti _ -> None) + pos_arr + in + let drive_len = Array.length drive in + let rows = Array.make drive_len [] in + let count = ref 0 in + let bind_buf = Array.make (List.length attrs) (Result_entity 0) in + let attr_index = + let tbl = Hashtbl.create (List.length attrs) in + List.iteri (fun i name -> Hashtbl.add tbl name i) attrs; + tbl + in + let set_bind var value = + match Hashtbl.find_opt attr_index var with + | Some i -> bind_buf.(i) <- value + | None -> () + in + for i = 0 to drive_len - 1 do + let cell = drive.(i) in + let eid = cell.eid in + set_bind e_var (Result_entity eid); + (match cell.scan_var with + | Some v -> set_bind v cell.scan_value + | None -> ()); + let ok = ref true in + let mi = ref 0 in + while !ok && !mi < n_pos do + match pos_arr.(!mi) with + | Pos { bind_var; value_term; arr; _ } -> ( + let found = + match dense.(!mi) with + | Some (base, len) -> lookup_dense arr base len eid + | None -> seek_aevt arr pointers.(!mi) eid + in + match found with + | None -> ok := false + | Some d when value_matches value_term d.v -> + (match bind_var with + | Some v -> set_bind v (Query.result_of_ref (Query.result_of_datom_v d)) + | None -> ()); + incr mi + | Some _ -> ok := false) + | Anti _ -> ok := false + done; + if !ok then ( + rows.(!count) <- Array.to_list bind_buf; + incr count) + done; + Some (Array.to_list (Array.sub rows 0 !count))) | _ -> (* Mixed positive + anti: drive + cursor merges + anti bitset/lookup. *) let* drive = driving_cells source_db e_var scan in @@ -743,27 +698,27 @@ end) = struct | None -> ()); incr mi | Some _ -> ok := false) - | Anti _ -> incr mi + | Anti _ -> ok := false done; let ai = ref 0 in while !ok && !ai < n_anti do - (match anti_arr.(!ai) with - | Anti { excluded = Some excluded; _ } -> - let max_entity = Bytes.length excluded in - if eid >= 0 && eid < max_entity && Bytes.unsafe_get excluded eid = '\001' then - ok := false - | Anti { excluded = None; arr = Some arr; value_term; _ } -> ( - match find_entity_in_aevt_array arr eid with - | Some d when value_matches value_term d.v -> ok := false - | _ -> ()) - | Anti _ | Pos _ -> ()); - incr ai + match anti_arr.(!ai) with + | Anti { excluded = Some bits; _ } -> + if eid >= 0 && eid < Bytes.length bits && Bytes.unsafe_get bits eid = '\001' then + ok := false + else + incr ai + | Anti { arr = Some arr; value_term; _ } -> ( + match find_entity_in_aevt_array arr eid with + | Some d when value_matches value_term d.v -> ok := false + | _ -> incr ai) + | _ -> incr ai done; if !ok then ( rows.(!count) <- Array.to_list bind_buf; incr count) done; - Some (rows_of_array_rev rows !count) + Some (Array.to_list (Array.sub rows 0 !count)) let apply_group_filters source_db relation filters = let rec loop relation = function @@ -774,6 +729,117 @@ end) = struct in loop relation filters + (* Datalevin-style inequality pushdown: fold comparisons on the open value var + into AVET start/stop bounds instead of full AEVT scan + post-filter. *) + let reverse_comparison_predicate = function + | GreaterThan -> LessThan + | GreaterOrEqual -> LessOrEqual + | LessThan -> GreaterThan + | LessOrEqual -> GreaterOrEqual + + let range_predicate_for_var var predicate left_term right_term = + match left_term, right_term with + | QVar left_var, QValue threshold when left_var = var -> Some (predicate, threshold) + | QValue threshold, QVar right_var when right_var = var -> + Some (reverse_comparison_predicate predicate, threshold) + | _ -> None + + let avet_index_start predicate threshold = + match predicate, threshold with + | GreaterThan, Int n -> Some (Int (n + 1)) + | GreaterOrEqual, value | GreaterThan, value -> Some value + | _ -> None + + let avet_index_stop predicate threshold = + match predicate, threshold with + | LessThan, Int n when n > min_int -> Some (Int (n - 1)) + | LessOrEqual, value | LessThan, value -> Some value + | _ -> None + + let merge_avet_start compare_value start bound = + match start with + | None -> Some bound + | Some current -> if compare_value bound current > 0 then Some bound else Some current + + let merge_avet_stop compare_value stop bound = + match stop with + | None -> Some bound + | Some current -> if compare_value bound current < 0 then Some bound else Some current + + let comparison_matches_value value_var value = function + | ComparisonPredicate (predicate, left_term, right_term) -> ( + match range_predicate_for_var value_var predicate left_term right_term with + | Some (range_predicate, threshold) -> + Built_ins.matches_comparison_predicate + range_predicate + (query_evaluator_context.compare_value value threshold) + | None -> false) + | _ -> false + + let try_avet_range_drive source_db e_var (scan : Query_plan.l_scan) filters = + match scan.entity, scan.attr, scan.value, scan.tx with + | QVar ev, QAttr attr, QVar value_var, None + when ev = e_var + && value_var <> e_var + && direct_attr attr + && query_attr_uses_avet source_db attr + && not (is_ref_attr source_db attr) + && filters <> [] + && List.for_all + (function + | ComparisonPredicate (predicate, left, right) -> + Option.is_some (range_predicate_for_var value_var predicate left right) + | _ -> false) + filters -> + let compare_value = query_evaluator_context.compare_value in + let start, stop = + List.fold_left + (fun (start, stop) -> function + | ComparisonPredicate (predicate, left_term, right_term) -> ( + match range_predicate_for_var value_var predicate left_term right_term with + | Some (GreaterThan as p, threshold) | Some (GreaterOrEqual as p, threshold) -> + let bound = Option.value (avet_index_start p threshold) ~default:threshold in + (merge_avet_start compare_value start bound, stop) + | Some (LessThan as p, threshold) | Some (LessOrEqual as p, threshold) -> + let bound = Option.value (avet_index_stop p threshold) ~default:threshold in + (start, merge_avet_stop compare_value stop bound) + | _ -> (start, stop)) + | _ -> (start, stop)) + (None, None) filters + in + let need_post_filter = + List.exists + (function + | ComparisonPredicate (predicate, left, right) -> ( + match range_predicate_for_var value_var predicate left right with + | Some (GreaterThan, Int _) | Some (LessThan, Int _) -> false + | Some _ -> true + | None -> true) + | _ -> false) + filters + in + let cons_row acc d = + if (not need_post_filter) || List.for_all (comparison_matches_value value_var d.v) filters + then [ Result_entity d.e; Result_value d.v ] :: acc + else acc + in + let rows = + (match start, stop with + | None, None -> fold_index_range cons_row [] source_db attr () + | Some start, None -> fold_index_range cons_row [] source_db attr ~start () + | None, Some stop -> fold_index_range cons_row [] source_db attr ~stop () + | Some start, Some stop -> + fold_index_range cons_row [] source_db attr ~start ~stop ()) + |> List.rev + in + let attrs = [ e_var; value_var ] in + Some + { attrs + ; rows + ; unique_rows = unique_rows_flag source_db attrs e_var + } + | _ -> None + let execute_entity_group _db source (group : Query_plan.entity_group) = match source with | Db_source source_db -> ( @@ -782,97 +848,30 @@ end) = struct | [] -> Some relation | filters -> apply_group_filters source_db relation filters in - (match !last_kernel_group with - | Some g when g == group && !last_kernel_max_e = source_db.max_datom_e && group.filters = [] -> ( - match !last_kernel with - | Some kernel -> run_resolved_kernel kernel - | None -> None) + let e_var = group.entity_var in + let (scan : Query_plan.l_scan) = group.scan in + (* Inequality pushdown: open-value scan + comparison filters → AVET range. *) + (match group.merges, group.anti_scans, group.filters with + | [], [], filters when filters <> [] -> + try_avet_range_drive source_db e_var scan filters | _ -> None) |> function - | Some relation -> finish relation - | None -> - let e_var = group.entity_var in - let (scan : Query_plan.l_scan) = group.scan in - (* Specialized q2: [?e :attr const] [?e :attr2 ?v] — Datahike sorted-merge N=1. *) - (match scan.entity, scan.attr, scan.value, group.merges, group.anti_scans with - | QVar ev, QAttr drive_attr, QValue drive_value, [ merge ], [] - when ev = e_var && direct_attr drive_attr -> ( - match merge.Query_plan.entity, merge.attr, merge.value with - | QVar ev2, QAttr merge_attr, QVar v - when ev2 = e_var && v <> e_var && direct_attr merge_attr - && cardinality_one source_db merge_attr -> ( - match avet_ids_array_cached source_db drive_attr drive_value, aevt_attr_array source_db merge_attr with - | Some ids, Some arr -> ( - match dense_base arr with - | Some (base, len) -> - let attrs = [ e_var; v ] in - let unique_rows = unique_rows_flag source_db attrs e_var in - let kernel = - Kernel_q2 { ids; arr; base; len; attrs; unique_rows } - in - if group.filters = [] then ( - last_kernel_group := Some group; - last_kernel_max_e := source_db.max_datom_e; - last_kernel := Some kernel); - run_resolved_kernel kernel - | None -> None) - | _ -> None) - | _ -> None) - (* Specialized q-5-merge: const drive + 4 card-one value merges, dense AEVT. *) - | QVar ev, QAttr drive_attr, QValue drive_value, [ m0; m1; m2; m3 ], [] - when ev = e_var && direct_attr drive_attr -> ( - let value_merge (m : Query_plan.l_scan) = - match m.entity, m.attr, m.value with - | QVar ev2, QAttr attr, QVar v - when ev2 = e_var && v <> e_var && direct_attr attr && cardinality_one source_db attr -> - Some (v, attr) - | _ -> None - in - match value_merge m0, value_merge m1, value_merge m2, value_merge m3 with - | Some (v0, a0), Some (v1, a1), Some (v2, a2), Some (v3, a3) -> ( - match - ( avet_ids_array_cached source_db drive_attr drive_value - , aevt_attr_array source_db a0 - , aevt_attr_array source_db a1 - , aevt_attr_array source_db a2 - , aevt_attr_array source_db a3 ) - with - | Some ids, Some arr0, Some arr1, Some arr2, Some arr3 -> ( - match dense_base arr0, dense_base arr1, dense_base arr2, dense_base arr3 with - | Some (base, len), Some (b1, l1), Some (b2, l2), Some (b3, l3) - when base = b1 && base = b2 && base = b3 && len = l1 && len = l2 && len = l3 -> - let attrs = [ e_var; v0; v1; v2; v3 ] in - let unique_rows = unique_rows_flag source_db attrs e_var in - let kernel = - Kernel_q5 - { ids; arr0; arr1; arr2; arr3; base; len; attrs; unique_rows } - in - if group.filters = [] then ( - last_kernel_group := Some group; - last_kernel_max_e := source_db.max_datom_e; - last_kernel := Some kernel); - run_resolved_kernel kernel - | _ -> None) - | _ -> None) - | _ -> None) - | _ -> None) - |> function - | Some relation -> finish relation - | None -> ( - match scan.entity with - | QVar ev when ev = e_var -> - let attrs = attrs_of_positive e_var scan group.merges in - (match execute_lookup_merge source_db e_var attrs scan group.merges group.anti_scans with - | None -> None - | Some rows -> - finish { attrs; rows; unique_rows = unique_rows_flag source_db attrs e_var }) - | _ -> None)) + | Some relation -> Some relation (* filters already applied via range / residual *) + | None -> ( + match scan.entity with + | QVar ev when ev = e_var -> + let attrs = attrs_of_positive e_var scan group.merges in + (match execute_lookup_merge source_db e_var attrs scan group.merges group.anti_scans with + | None -> None + | Some rows -> + finish { attrs; rows; unique_rows = unique_rows_flag source_db attrs e_var }) + | _ -> None)) | _ -> None let execute_scan db source (scan : Query_plan.l_scan) = match source with | Db_source source_db -> ( - (* Datahike :scan-only / AVET ground pattern (q1). *) + (* Ground AVET scan-only (bound attr + value). *) match scan.entity, scan.attr, scan.value, scan.tx with | QVar e_var, QAttr attr, QValue value, None when direct_attr attr -> ( match avet_ids_array_cached source_db attr value with diff --git a/impl/query_exec.mli b/impl/query_exec.mli index 43a938e..fe35968 100644 --- a/impl/query_exec.mli +++ b/impl/query_exec.mli @@ -24,9 +24,19 @@ module Make (Context : sig val entity_ids_array_by_attr_value : db -> attr -> value -> entity_id array option val query_attr_uses_avet : db -> attr -> bool val query_value_uses_avet : value -> bool + val is_ref_attr : db -> attr -> bool val aevt_attr_array : db -> attr -> datom array option val aevt_duplicate_datoms : db -> attr -> datom list val find_entity_in_aevt_array : datom array -> entity_id -> datom option + val fold_index_range : + ('acc -> datom -> 'acc) -> + 'acc -> + db -> + attr -> + ?start:value -> + ?stop:value -> + unit -> + 'acc end) : sig val run : db -> diff --git a/impl/query_plan.ml b/impl/query_plan.ml index 6da2c2c..1e72766 100644 --- a/impl/query_plan.ml +++ b/impl/query_plan.ml @@ -639,6 +639,9 @@ let analyze ?(max_datom_e = 1_000_000) ?(bound_vars = []) ?(rules = []) query = let plan_is_executable plan = not (List.exists (function OpPassthrough _ -> true | _ -> false) plan.ops) +(* Single ground scan or entity-group: Query_exec emits directly. + Multi entity-group joins (e.g. cross-entity value join) stay on the + relational path, which has a selective AVET/AEVT specialized join. *) let plan_is_fused_execute plan = match plan.ops with | [ OpEntityGroup _ ] | [ OpScan _ ] -> true diff --git a/impl/query_where.ml b/impl/query_where.ml index 4452633..c2402f0 100644 --- a/impl/query_where.ml +++ b/impl/query_where.ml @@ -1475,6 +1475,13 @@ end) = struct None else let output_attr_arrays = List.map Option.get output_attr_arrays in + let aevt_dense_base arr = + let len = Array.length arr in + if len = 0 then None + else + let base = arr.(0).e in + if arr.(len - 1).e = base + len - 1 then Some (base, len) else None + in let specialized = match attrs with | [ out_e; jv; ov ] when out_e = output_entity && jv = join_var -> @@ -1487,6 +1494,28 @@ end) = struct | _ -> None) | _ -> None in + let emit_specialized_row out_arr datom = + match + match aevt_dense_base out_arr with + | Some (base, len) -> + let index = datom.e - base in + if index >= 0 && index < len && out_arr.(index).e = datom.e then + Some out_arr.(index) + else None + | None -> find_entity_in_aevt_array out_arr datom.e + with + | None -> None + | Some out_datom -> + let join_result = Query.result_of_ref (Query.result_of_datom_v datom) in + let out_result = Query.result_of_ref (Query.result_of_datom_v out_datom) in + Some + (match attrs with + | [ _; jv; _ ] when jv = join_var -> + [ Result_entity datom.e; join_result; out_result ] + | [ _; _; jv ] when jv = join_var -> + [ Result_entity datom.e; out_result; join_result ] + | _ -> [ Result_entity datom.e; join_result; out_result ]) + in let rows = match specialized with | Some out_arr -> @@ -1494,25 +1523,9 @@ end) = struct Array.iter (fun datom -> if Hashtbl.mem join_values datom.v then - match find_entity_in_aevt_array out_arr datom.e with + match emit_specialized_row out_arr datom with | None -> () - | Some out_datom -> - let join_result = - Query.result_of_ref (Query.result_of_datom_v datom) - in - let out_result = - Query.result_of_ref (Query.result_of_datom_v out_datom) - in - let row = - match attrs with - | [ _; jv; _ ] when jv = join_var -> - [ Result_entity datom.e; join_result; out_result ] - | [ _; _; jv ] when jv = join_var -> - [ Result_entity datom.e; out_result; join_result ] - | _ -> - [ Result_entity datom.e; join_result; out_result ] - in - rows := row :: !rows) + | Some row -> rows := row :: !rows) join_arr; List.rev !rows | None -> diff --git a/impl/serialize.ml b/impl/serialize.ml index b034022..46b5ac2 100644 --- a/impl/serialize.ml +++ b/impl/serialize.ml @@ -28,6 +28,7 @@ let from_serializable context snapshot = ; eavt_index = Index.empty Eavt lmdb ; aevt_index = Index.empty Aevt lmdb ; avet_index = Index.empty Avet lmdb + ; tave_index = Index.empty Tave lmdb ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/storage_lmdb_impl.ml b/impl/storage_lmdb_impl.ml index e089c51..7541a70 100644 --- a/impl/storage_lmdb_impl.ml +++ b/impl/storage_lmdb_impl.ml @@ -84,6 +84,7 @@ let restore context storage = ; eavt_index = Index.empty Eavt lmdb ; aevt_index = Index.empty Aevt lmdb ; avet_index = Index.empty Avet lmdb + ; tave_index = Index.empty Tave lmdb ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/storage_pss.ml b/impl/storage_pss.ml index a221aa5..ed8e97b 100644 --- a/impl/storage_pss.ml +++ b/impl/storage_pss.ml @@ -251,6 +251,7 @@ let restore context storage = ; eavt_index = restore_index Eavt root.storage_eavt ; aevt_index ; avet_index + ; tave_index = Index.empty Tave (Index.db_of aevt_index) ; aevt_by_attr = Hashtbl.create 0 ; avet_by_attr = Hashtbl.create 0 ; avet_entities_by_attr_value = Hashtbl.create 0 diff --git a/impl/transact.ml b/impl/transact.ml index 821e5d4..aa73fad 100644 --- a/impl/transact.ml +++ b/impl/transact.ml @@ -1125,35 +1125,6 @@ let apply_tx context tx_ops db = (left.e, left.a, left.v, left.tx) (right.e, right.a, right.v, right.tx) in - let existing_attr_datoms acc_tx_data d = - let from_db = - context.existing_entity_attr_datoms db d.e d.a - |> List.filter (fun ex -> - not (List.exists (fun pd -> not pd.added && context.same_fact pd ex) acc_tx_data)) - in - let from_acc = - acc_tx_data - |> List.filter (fun pd -> pd.added && pd.e = d.e && pd.a = d.a) - |> List.filter (fun pd -> - not (List.exists (fun pd2 -> not pd2.added && context.same_fact pd pd2) acc_tx_data)) - in - from_db @ from_acc - in - let tx_data_for_fact acc_tx_data d = - let d = { d with v = context.resolve_context.normalize_value d.v } in - let existing = existing_attr_datoms acc_tx_data d in - let same_fact_exists = List.exists (context.same_fact d) existing in - match context.resolve_context.cardinality db d.a with - | Many -> if same_fact_exists then [] else [ d ] - | One -> - if same_fact_exists then - [] - else - (existing - |> List.sort compare_eavt_datom - |> List.map retraction_datom) - @ [ d ] - in let resolve_fast_value_for_attr attr value max_eid = match value with | Ref_to (Lookup_ref (lookup_attr, lookup_value)) when context.resolve_context.is_ref_attr db attr -> @@ -1506,13 +1477,49 @@ let apply_tx context tx_ops db = if duplicate_fact facts || duplicate_unique facts || conflicts_with_existing facts then None else + (* Build tx_data in O(n): [acc @ pieces] was O(n²) and dominated Share + SQLite bulk loads (20k entities ≈ 100k facts). Index same-tx (e,a) + facts for card-one retraction without scanning the full acc list. *) let tx_data = - List.fold_left - (fun acc fact -> - let datom_tx_data = tx_data_for_fact acc fact in - acc @ datom_tx_data) - [] - facts + let by_ea = Hashtbl.create (List.length facts) in + let acc_rev = + List.fold_left + (fun acc_rev fact -> + let d = + { fact with v = context.resolve_context.normalize_value fact.v } + in + let from_db = context.existing_entity_attr_datoms db d.e d.a in + let from_acc = + match Hashtbl.find_opt by_ea (d.e, d.a) with + | None -> [] + | Some ds -> List.rev ds + in + let existing = from_db @ from_acc in + let same_fact_exists = List.exists (context.same_fact d) existing in + let pieces = + match context.resolve_context.cardinality db d.a with + | Many -> if same_fact_exists then [] else [ d ] + | One -> + if same_fact_exists then + [] + else + (existing + |> List.sort compare_eavt_datom + |> List.map retraction_datom) + @ [ d ] + in + List.iter + (fun pd -> + let prev = + Option.value (Hashtbl.find_opt by_ea (pd.e, pd.a)) ~default:[] + in + Hashtbl.replace by_ea (pd.e, pd.a) (pd :: prev)) + pieces; + List.rev_append pieces acc_rev) + [] + facts + in + List.rev acc_rev in let max_eid = List.fold_left diff --git a/lmdb/datascript_index_codec.ml b/lmdb/datascript_index_codec.ml index aa465d4..830fcf4 100644 --- a/lmdb/datascript_index_codec.ml +++ b/lmdb/datascript_index_codec.ml @@ -236,9 +236,22 @@ let encode_index_attr_value_prefix index attr value = | Eavt -> append_int32 buffer 0; append_string buffer attr; + append_bytes buffer (encode_value_key value) + | Tave -> + (* Prefixed by tx elsewhere; this helper is attr|value only for Avet-like seeks. *) + append_string buffer attr; append_bytes buffer (encode_value_key value)); Buffer.contents buffer +(** TAVE key prefix [tx] or [tx | attr] for window (+ optional attr) seeks. *) +let encode_tave_tx_prefix ?attr tx = + let buffer = Buffer.create 32 in + append_int32 buffer tx; + (match attr with + | None -> () + | Some a -> append_string buffer a); + Buffer.contents buffer + let append_added buffer added = (* dbval sort order: asserts before retracts at the same [e a v tx]. *) append_byte buffer (if added then 0 else 1) @@ -263,6 +276,13 @@ let encode_datom_key index datom = append_bytes buffer (encode_value_key datom.v); append_int32 buffer datom.e; append_int32 buffer datom.tx; + append_added buffer datom.added + | Tave -> + (* tx | a | v | e | added — seek recent window + attr without full scan. *) + append_int32 buffer datom.tx; + append_string buffer datom.a; + append_bytes buffer (encode_value_key datom.v); + append_int32 buffer datom.e; append_added buffer datom.added); Buffer.contents buffer @@ -303,6 +323,14 @@ let decode_datom_key index bytes = let added, offset = decode_added bytes offset in if offset <> String.length bytes then invalid_arg "trailing avet key bytes"; e, a, v, tx, added + | Tave -> + let tx, offset = read_int32 bytes 0 in + let a, offset = read_string bytes offset in + let v, offset = decode_value_key bytes offset in + let e, offset = read_int32 bytes offset in + let added, offset = decode_added bytes offset in + if offset <> String.length bytes then invalid_arg "trailing tave key bytes"; + e, a, v, tx, added in { e; a; v; tx; added } @@ -322,14 +350,14 @@ let decode_datom_value bytes = let decode_index_entry index key value = let datom = decode_datom_key index key in match index with - | Avet -> datom + | Avet | Tave -> datom | Eavt | Aevt -> let payload = decode_datom_value value in { datom with v = payload.v } let encode_index_value index datom = match index with - | Avet -> "" + | Avet | Tave -> "" | Eavt | Aevt -> encode_datom_value datom let avet_key_attr key = @@ -350,6 +378,10 @@ let decode_avet_key_at attr key = if offset <> String.length key then invalid_arg "trailing avet key bytes"; { e; a = attr; v; tx; added } +let tave_key_tx key = + let tx, _offset = read_int32 key 0 in + tx + let compare_encoded_keys index left right = Datascript_types.Compare.compare_datom index (decode_datom_key index left) diff --git a/lmdb/datascript_index_codec.mli b/lmdb/datascript_index_codec.mli index b75b643..2d0ba71 100644 --- a/lmdb/datascript_index_codec.mli +++ b/lmdb/datascript_index_codec.mli @@ -2,6 +2,7 @@ open Datascript_types val encode_datom_key : index -> datom -> string val encode_index_attr_value_prefix : index -> string -> value -> string +val encode_tave_tx_prefix : ?attr:string -> tx -> string val decode_datom_key : index -> string -> datom val encode_datom_value : datom -> string val decode_datom_value : string -> datom @@ -12,6 +13,7 @@ val compare_encoded_keys : index -> string -> string -> int val avet_key_attr : string -> string val avet_key_value : string -> value val decode_avet_key_at : attr -> string -> datom +val tave_key_tx : string -> tx val encode_schema : schema -> string val decode_schema : string -> schema diff --git a/lmdb/datascript_lmdb_db_melange.ml b/lmdb/datascript_lmdb_db_melange.ml index 459980c..04e9fd5 100644 --- a/lmdb/datascript_lmdb_db_melange.ml +++ b/lmdb/datascript_lmdb_db_melange.ml @@ -35,7 +35,7 @@ let open_db path = let root = open_root path in { Datascript_lmdb_db.path; env = root; eavt = open_subdb root "ds/eavt" ; aevt = open_subdb root "ds/aevt"; avet = open_subdb root "ds/avet" - ; meta = open_subdb root "ds/meta"; closed = false + ; tave = open_subdb root "ds/tave"; meta = open_subdb root "ds/meta"; closed = false } let create_temp () = open_db (temp_path ()) @@ -59,6 +59,7 @@ let map_for_index index db = | Eavt -> db.eavt | Aevt -> db.aevt | Avet -> db.avet + | Tave -> db.tave let meta_get db key = ensure_open db; diff --git a/lmdb/datascript_storage_lmdb_plugin.ml b/lmdb/datascript_storage_lmdb_plugin.ml index 5f3ea56..5fffc34 100644 --- a/lmdb/datascript_storage_lmdb_plugin.ml +++ b/lmdb/datascript_storage_lmdb_plugin.ml @@ -12,7 +12,8 @@ let backend_of_lmdb lmdb = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave in let load_indexes_from_storage target = match target with diff --git a/lmdb/melange/datascript_lmdb_db.ml b/lmdb/melange/datascript_lmdb_db.ml index 1aec9a0..00ee147 100644 --- a/lmdb/melange/datascript_lmdb_db.ml +++ b/lmdb/melange/datascript_lmdb_db.ml @@ -11,6 +11,7 @@ type t = ; eavt : map ; aevt : map ; avet : map + ; tave : map ; meta : map ; mutable closed : bool } @@ -24,6 +25,7 @@ let open_db path = ; eavt = make_map () ; aevt = make_map () ; avet = make_map () + ; tave = make_map () ; meta = make_map () ; closed = false } @@ -50,6 +52,7 @@ let map_for_index index db = | Eavt -> db.eavt | Aevt -> db.aevt | Avet -> db.avet + | Tave -> db.tave let meta_get db key = ensure_open db; @@ -125,5 +128,67 @@ let fold_index_range_until index db ?from_key ?stop f = in iter (sorted_entries (map_for_index index db)) +let fold_index_range_desc_until index db ?hi_key ?stop f = + ensure_open db; + let entries = List.rev (sorted_entries (map_for_index index db)) in + let rec iter = function + | [] -> () + | (key, value) :: rest -> + (match hi_key with + | Some bound when String.compare key bound > 0 -> iter rest + | _ -> ( + match stop with + | Some stop when stop key value -> () + | _ -> + f key value; + iter rest)) + in + iter entries + let copy_index_txn index txn from_db to_db = fold_index index from_db (fun key value -> put_index_txn index txn to_db key value) + +let seq_index_range_until index db ?from_key ?stop () = + ensure_open db; + let entries = sorted_entries (map_for_index index db) in + let rec drop = function + | [] -> [] + | (key, _) :: rest as all -> + (match from_key with + | Some bound when String.compare key bound < 0 -> drop rest + | _ -> all) + in + let rec take = function + | [] -> Seq.Nil + | (key, value) :: rest -> + (match stop with + | Some stop when stop key value -> Seq.Nil + | _ -> Seq.Cons ((key, value), fun () -> take rest)) + in + fun () -> take (drop entries) + +let seq_index_prefix index db prefix () = + let prefix_len = String.length prefix in + seq_index_range_until index db ~from_key:prefix + ~stop:(fun key _value -> + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + +let seq_index_range_desc_until index db ?hi_key ?stop () = + ensure_open db; + let entries = List.rev (sorted_entries (map_for_index index db)) in + let rec drop = function + | [] -> [] + | (key, _) :: rest as all -> + (match hi_key with + | Some bound when String.compare key bound > 0 -> drop rest + | _ -> all) + in + let rec take = function + | [] -> Seq.Nil + | (key, value) :: rest -> + (match stop with + | Some stop when stop key value -> Seq.Nil + | _ -> Seq.Cons ((key, value), fun () -> take rest)) + in + fun () -> take (drop entries) diff --git a/lmdb/melange/datascript_lmdb_db.mli b/lmdb/melange/datascript_lmdb_db.mli index 79bacfd..3ded954 100644 --- a/lmdb/melange/datascript_lmdb_db.mli +++ b/lmdb/melange/datascript_lmdb_db.mli @@ -31,6 +31,32 @@ val fold_index_range_until : ?stop:(string -> string -> bool) -> (string -> string -> unit) -> unit +val fold_index_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + (string -> string -> unit) -> + unit val fold_index_prefix : index -> t -> string -> (string -> string -> unit) -> unit val put_index : index -> t -> string -> string -> unit val remove_index : index -> t -> string -> unit + +val seq_index_range_until : + index -> + t -> + ?from_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t + +val seq_index_prefix : + index -> t -> string -> unit -> (string * string) Seq.t + +val seq_index_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t diff --git a/lmdb/melange/datascript_lmdb_index.ml b/lmdb/melange/datascript_lmdb_index.ml index dbd9aa7..40b13b0 100644 --- a/lmdb/melange/datascript_lmdb_index.ml +++ b/lmdb/melange/datascript_lmdb_index.ml @@ -2,7 +2,11 @@ open Datascript_types type t = { db : Datascript_lmdb_db.t; which : index } -type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } +type 'a seq = + { cmp : datom -> datom -> int + ; stream : datom Seq.t + ; seek_bound : datom option + } exception Stop_search @@ -43,11 +47,13 @@ let of_eavt_datoms ~avet eavt_datoms db = let eavt = make Eavt db in let aevt = make Aevt db in let avet_index = make Avet db in + let tave = make Tave db in Datascript_lmdb_db.with_write_txn db (fun txn -> List.iter (fun datom -> put_datom_txn txn eavt datom; put_datom_txn txn aevt datom; + put_datom_txn txn tave datom; if avet datom.a then put_datom_txn txn avet_index datom) eavt_datoms)) @@ -56,11 +62,13 @@ let of_bulk index datoms db = of_sorted_list index datoms db let append_tx_data ~avet:is_avet datoms eavt aevt avet_index = if datoms = [] then (eavt, aevt, avet_index) else ( + let tave = make Tave eavt.db in Datascript_lmdb_db.with_write_txn eavt.db (fun txn -> List.iter (fun datom -> put_datom_txn txn eavt datom; put_datom_txn txn aevt datom; + put_datom_txn txn tave datom; if is_avet datom.a then put_datom_txn txn avet_index datom) datoms); (eavt, aevt, avet_index)) @@ -269,55 +277,163 @@ let find_first_slice ?from_ ?to_ ?cmp t = let fold_attr_prefix f init t attr = fold_attr_exact_prefix f init t attr -let materialize_range t ?from_ ?to_ cmp = - fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev +let make_seq cmp stream = { cmp; stream; seek_bound = None } -let make_seq cmp datoms = { cmp; datoms; offset = 0 } +let to_seq seq = + match seq.seek_bound with + | None -> seq.stream + | Some bound -> Seq.drop_while (fun datom -> seq.cmp datom bound < 0) seq.stream -let to_seq ({ cmp = _; datoms; offset = start }) = - let rec loop index () = - if index >= List.length datoms then Seq.Nil - else Seq.Cons (List.nth datoms index, loop (index + 1)) +let map_kv_to_datoms t seq = + Seq.map (fun (key, value) -> decode_entry t.which key value) seq + +let stream_attr_exact_prefix t attr = + let prefix = attr ^ "\000" in + Datascript_lmdb_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) + +let stream_attr_value_exact_prefix t attr value = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + Datascript_lmdb_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t + +let stream_avet_value_range t attr ?start_value ?stop_value () = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr in - loop start + Datascript_lmdb_db.seq_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop + > 0) + () + |> Seq.map (fun (key, _value) -> Datascript_index_codec.decode_avet_key_at attr key) + +let stream_bounded t ?from_ ?to_ cmp = + match bound_key t from_ with + | None -> + Datascript_lmdb_db.seq_index_range_until t.which t.db () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + | Some from_key -> + Datascript_lmdb_db.seq_index_range_until t.which t.db ~from_key + ~stop:(fun key value -> + match to_ with + | Some bound -> + let datom = decode_entry t.which key value in + cmp datom bound > 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + +let stream_slice ?from_ ?to_ ~cmp t = + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + stream_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value () + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> stream_attr_value_exact_prefix t attr value + | None -> stream_bounded t ?from_ ?to_ cmp)) -let seq t = make_seq (cmp_for t.which) (to_list t) +let seq t = make_seq (cmp_for t.which) (stream_bounded t (cmp_for t.which)) let slice_seq ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in - make_seq cmp (materialize_range t ?from_ ?to_ cmp) + make_seq cmp (stream_slice ?from_ ?to_ ~cmp t) + +let stream_rslice_desc t ~cmp ?from_ ?to_ () = + Datascript_lmdb_db.seq_index_range_desc_until t.which t.db + ~stop:(fun key value -> + let datom = decode_entry t.which key value in + let under_hi = + match from_ with + | None -> true + | Some bound -> cmp datom bound <= 0 + in + under_hi + && + match to_ with + | Some bound -> cmp datom bound < 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp to_ from_ datom) + +let stream_attr_exact_prefix_desc t attr = + let hi_key = attr ^ "\001" in + Datascript_lmdb_db.seq_index_range_desc_until t.which t.db ~hi_key + ~stop:(fun key _value -> + let prefix = attr ^ "\000" in + let prefix_len = String.length prefix in + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) let rslice_seq ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in - let datoms = - to_list t - |> List.filter (fun datom -> - match from_ with - | None -> true - | Some bound -> cmp datom bound <= 0) - |> List.filter (fun datom -> - match to_ with - | None -> true - | Some bound -> cmp datom bound >= 0) - |> List.rev + let stream = + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix_desc t attr + | None -> stream_rslice_desc t ~cmp ?from_ ?to_ () in - make_seq cmp datoms + make_seq cmp stream let seq_to_list seq = to_seq seq |> List.of_seq -let fold_seq f init { cmp = _; datoms; offset } = - let rec loop index acc = - if index >= List.length datoms then acc - else loop (index + 1) (f acc (List.nth datoms index)) - in - loop offset init +let fold_seq f init seq = Seq.fold_left f init (to_seq seq) let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list -let seek bound seq = - let rec count index = - if index >= List.length seq.datoms then index - else if seq.cmp (List.nth seq.datoms index) bound >= 0 then index - else count (index + 1) - in - { seq with offset = count 0 } +let seek bound seq = { seq with seek_bound = Some bound } + +(** Fold TAVE keys with [tx > from_tx], optionally restricted to [attr]. *) +let fold_tave_range f init db ~from_tx ?to_tx ?attr () = + let from_key = Datascript_index_codec.encode_tave_tx_prefix (from_tx + 1) in + let acc = ref init in + Datascript_lmdb_db.fold_index_range_until Tave db ~from_key + ~stop:(fun key _value -> + match to_tx with + | Some hi -> Datascript_index_codec.tave_key_tx key > hi + | None -> false) + (fun key value -> + let datom = decode_entry Tave key value in + let attr_ok = + match attr with + | None -> true + | Some a -> datom.a = a + in + let tx_ok = + datom.tx > from_tx + && (match to_tx with None -> true | Some hi -> datom.tx <= hi) + in + if attr_ok && tx_ok then acc := f !acc datom); + !acc + +(** Delete TAVE keys with [tx <= before_tx] (rolling retention). *) +let prune_tave_before db ~before_tx = + if before_tx < 0 then () + else + let to_delete = ref [] in + let stop_key = Datascript_index_codec.encode_tave_tx_prefix (before_tx + 1) in + Datascript_lmdb_db.fold_index_range_until Tave db + ~stop:(fun key _ -> key >= stop_key) + (fun key _value -> + if Datascript_index_codec.tave_key_tx key <= before_tx then + to_delete := key :: !to_delete); + if !to_delete <> [] then + Datascript_lmdb_db.with_write_txn db (fun txn -> + List.iter + (fun key -> Datascript_lmdb_db.remove_index_txn Tave txn db key) + !to_delete) diff --git a/lmdb/melange/datascript_lmdb_index.mli b/lmdb/melange/datascript_lmdb_index.mli index 2e16cef..d0faddd 100644 --- a/lmdb/melange/datascript_lmdb_index.mli +++ b/lmdb/melange/datascript_lmdb_index.mli @@ -33,3 +33,7 @@ val seq_to_list : datom seq -> datom list val fold_seq : ('acc -> datom -> 'acc) -> 'acc -> datom seq -> 'acc val to_seq : datom seq -> datom Seq.t val seek : datom -> datom seq -> datom seq +val fold_tave_range : + ('acc -> datom -> 'acc) -> 'acc -> Datascript_lmdb_db.t -> from_tx:tx -> ?to_tx:tx -> ?attr:string + -> unit -> 'acc +val prune_tave_before : Datascript_lmdb_db.t -> before_tx:tx -> unit diff --git a/lmdb/native/datascript_lmdb_db.ml b/lmdb/native/datascript_lmdb_db.ml index 5f9c479..f2a2a2d 100644 --- a/lmdb/native/datascript_lmdb_db.ml +++ b/lmdb/native/datascript_lmdb_db.ml @@ -13,6 +13,7 @@ type t = ; eavt : (string, string, [ `Uni ]) Map.t ; aevt : (string, string, [ `Uni ]) Map.t ; avet : (string, string, [ `Uni ]) Map.t + ; tave : (string, string, [ `Uni ]) Map.t ; meta : (string, string, [ `Uni ]) Map.t ; profile : lmdb_env_profile ; mutable closed : bool @@ -47,7 +48,8 @@ let open_named_map env name = let open_db path profile = let env = open_env path profile in { path; env; eavt = open_named_map env "ds/eavt"; aevt = open_named_map env "ds/aevt" - ; avet = open_named_map env "ds/avet"; meta = open_named_map env "ds/meta"; profile + ; avet = open_named_map env "ds/avet"; tave = open_named_map env "ds/tave" + ; meta = open_named_map env "ds/meta"; profile ; closed = false; read = None } @@ -66,6 +68,7 @@ let close db = Map.close db.eavt; Map.close db.aevt; Map.close db.avet; + Map.close db.tave; Map.close db.meta; (match db.profile with | Default -> Env.sync db.env @@ -102,6 +105,7 @@ let map_for_index index db = | Eavt -> db.eavt | Aevt -> db.aevt | Avet -> db.avet + | Tave -> db.tave let invalidate_read db = match db.read with @@ -139,6 +143,7 @@ let meta_get db key = let meta_set db key value = ensure_open db; + invalidate_read db; ignore (Txn.go Rw db.env (fun txn -> Map.set ~txn db.meta key value; @@ -261,6 +266,217 @@ let fold_index_range_until index db ?from_key ?stop f = loop ()) with Exit -> ()) +(** Walk keys descending: start at greatest key [<= hi_key] (or last key), stop when [stop] holds. *) +let fold_index_range_desc_until index db ?hi_key ?stop f = + ensure_open db; + (try + with_read_cursor index db (fun cursor -> + (match hi_key with + | None -> (try ignore (Cursor.last cursor) with Not_found -> raise Exit) + | Some bound -> ( + try + let key, _ = Cursor.seek_range cursor bound in + if String.compare key bound > 0 then + try ignore (Cursor.prev cursor) with Not_found -> raise Exit + with Not_found -> (try ignore (Cursor.last cursor) with Not_found -> raise Exit))); + let rec loop () = + let key, value = + try Cursor.current cursor + with Not_found -> raise Exit + in + (match stop with + | Some stop when stop key value -> raise Exit + | _ -> ()); + f key value; + try + ignore (Cursor.prev cursor); + loop () + with Not_found -> raise Exit + in + loop ()) + with Exit -> ()) + let copy_index_txn index txn from_db to_db = fold_index index from_db (fun key value -> put_index_txn index txn to_db key value) + +(* Datalevin range-seq style: pull batches inside scoped Cursor.go, then + re-seek from a continuation key on the next pull. Avoids holding a cursor + across Seq yields and needs no Obj.magic. *) +let stream_batch_size = 64 + +type asc_cont = + | Asc_start + | Asc_from of { key : string; include_key : bool } + | Asc_done + +let seq_index_range_until index db ?from_key ?stop () = + ensure_open db; + let cont = + ref + (match from_key with + | None -> Asc_start + | Some key -> Asc_from { key; include_key = true }) + in + let fetch () = + match !cont with + | Asc_done -> [] + | _ -> + let batch = ref [] in + let count = ref 0 in + (try + with_read_cursor index db (fun cursor -> + let positioned = + match !cont with + | Asc_done -> false + | Asc_start -> ( + try + ignore (Cursor.first cursor); + true + with Not_found -> + cont := Asc_done; + false) + | Asc_from { key; include_key } -> ( + try + ignore (Cursor.seek_range cursor key); + if include_key then true + else ( + try + ignore (Cursor.next cursor); + true + with Not_found -> + cont := Asc_done; + false) + with Not_found -> + cont := Asc_done; + false) + in + if positioned then + let rec loop () = + if !count >= stream_batch_size then () + else + let key, value = + try Cursor.current cursor with Not_found -> raise Exit + in + match stop with + | Some stop when stop key value -> cont := Asc_done + | _ -> + batch := (key, value) :: !batch; + incr count; + cont := Asc_from { key; include_key = false }; + try + ignore (Cursor.next cursor); + loop () + with Not_found -> cont := Asc_done + in + try loop () with Exit -> cont := Asc_done) + with _ -> cont := Asc_done); + List.rev !batch + in + let rec stream () = + match fetch () with + | [] -> Seq.Nil + | items -> + let rec of_list = function + | [] -> stream + | x :: xs -> fun () -> Seq.Cons (x, of_list xs) + in + of_list items () + in + stream + +let seq_index_prefix index db prefix () = + let prefix_len = String.length prefix in + seq_index_range_until index db ~from_key:prefix + ~stop:(fun key _value -> + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + +type desc_cont = + | Desc_start of string option + | Desc_after of string + | Desc_done + +let position_desc_hi cursor bound = + try + let key, _ = Cursor.seek_range cursor bound in + if String.compare key bound > 0 then ( + try + ignore (Cursor.prev cursor); + true + with Not_found -> false) + else true + with Not_found -> ( + try + ignore (Cursor.last cursor); + true + with Not_found -> false) + +let seq_index_range_desc_until index db ?hi_key ?stop () = + ensure_open db; + let cont = ref (Desc_start hi_key) in + let fetch () = + match !cont with + | Desc_done -> [] + | _ -> + let batch = ref [] in + let count = ref 0 in + (try + with_read_cursor index db (fun cursor -> + let positioned = + match !cont with + | Desc_done -> false + | Desc_start None -> ( + try + ignore (Cursor.last cursor); + true + with Not_found -> + cont := Desc_done; + false) + | Desc_start (Some bound) -> + if position_desc_hi cursor bound then true + else ( + cont := Desc_done; + false) + | Desc_after key -> ( + try + ignore (Cursor.seek_range cursor key); + (try ignore (Cursor.prev cursor) with Not_found -> raise Exit); + true + with Not_found | Exit -> + cont := Desc_done; + false) + in + if positioned then + let rec loop () = + if !count >= stream_batch_size then () + else + let key, value = + try Cursor.current cursor with Not_found -> raise Exit + in + match stop with + | Some stop when stop key value -> cont := Desc_done + | _ -> + batch := (key, value) :: !batch; + incr count; + cont := Desc_after key; + try + ignore (Cursor.prev cursor); + loop () + with Not_found -> cont := Desc_done + in + try loop () with Exit -> cont := Desc_done) + with _ -> cont := Desc_done); + List.rev !batch + in + let rec stream () = + match fetch () with + | [] -> Seq.Nil + | items -> + let rec of_list = function + | [] -> stream + | x :: xs -> fun () -> Seq.Cons (x, of_list xs) + in + of_list items () + in + stream diff --git a/lmdb/native/datascript_lmdb_db.mli b/lmdb/native/datascript_lmdb_db.mli index ce72d89..e471369 100644 --- a/lmdb/native/datascript_lmdb_db.mli +++ b/lmdb/native/datascript_lmdb_db.mli @@ -30,6 +30,35 @@ val fold_index_range_until : ?stop:(string -> string -> bool) -> (string -> string -> unit) -> unit +val fold_index_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + (string -> string -> unit) -> + unit val fold_index_prefix : index -> t -> string -> (string -> string -> unit) -> unit val put_index : index -> t -> string -> string -> unit val remove_index : index -> t -> string -> unit + +(** Lazy key/value streams (Datalevin [range-seq] style). Batches are pulled via + scoped [Cursor.go] with continuation re-seek — no held cursor across yields + and no [Obj.magic]. Consumers may stop early. *) +val seq_index_range_until : + index -> + t -> + ?from_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t + +val seq_index_prefix : + index -> t -> string -> unit -> (string * string) Seq.t + +val seq_index_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t diff --git a/lmdb/native/datascript_lmdb_index.ml b/lmdb/native/datascript_lmdb_index.ml index dbd9aa7..9f44cc6 100644 --- a/lmdb/native/datascript_lmdb_index.ml +++ b/lmdb/native/datascript_lmdb_index.ml @@ -2,7 +2,12 @@ open Datascript_types type t = { db : Datascript_lmdb_db.t; which : index } -type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } +(* Lazy stream seq — matches upstream BTSet / Datalevin range-seq (no full-range materialize). *) +type 'a seq = + { cmp : datom -> datom -> int + ; stream : datom Seq.t + ; seek_bound : datom option + } exception Stop_search @@ -43,11 +48,13 @@ let of_eavt_datoms ~avet eavt_datoms db = let eavt = make Eavt db in let aevt = make Aevt db in let avet_index = make Avet db in + let tave = make Tave db in Datascript_lmdb_db.with_write_txn db (fun txn -> List.iter (fun datom -> put_datom_txn txn eavt datom; put_datom_txn txn aevt datom; + put_datom_txn txn tave datom; if avet datom.a then put_datom_txn txn avet_index datom) eavt_datoms)) @@ -56,11 +63,13 @@ let of_bulk index datoms db = of_sorted_list index datoms db let append_tx_data ~avet:is_avet datoms eavt aevt avet_index = if datoms = [] then (eavt, aevt, avet_index) else ( + let tave = make Tave eavt.db in Datascript_lmdb_db.with_write_txn eavt.db (fun txn -> List.iter (fun datom -> put_datom_txn txn eavt datom; put_datom_txn txn aevt datom; + put_datom_txn txn tave datom; if is_avet datom.a then put_datom_txn txn avet_index datom) datoms); (eavt, aevt, avet_index)) @@ -269,55 +278,163 @@ let find_first_slice ?from_ ?to_ ?cmp t = let fold_attr_prefix f init t attr = fold_attr_exact_prefix f init t attr -let materialize_range t ?from_ ?to_ cmp = - fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev +let make_seq cmp stream = { cmp; stream; seek_bound = None } -let make_seq cmp datoms = { cmp; datoms; offset = 0 } +let to_seq seq = + match seq.seek_bound with + | None -> seq.stream + | Some bound -> Seq.drop_while (fun datom -> seq.cmp datom bound < 0) seq.stream -let to_seq ({ cmp = _; datoms; offset = start }) = - let rec loop index () = - if index >= List.length datoms then Seq.Nil - else Seq.Cons (List.nth datoms index, loop (index + 1)) +let map_kv_to_datoms t seq = + Seq.map (fun (key, value) -> decode_entry t.which key value) seq + +let stream_attr_exact_prefix t attr = + let prefix = attr ^ "\000" in + Datascript_lmdb_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) + +let stream_attr_value_exact_prefix t attr value = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + Datascript_lmdb_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t + +let stream_avet_value_range t attr ?start_value ?stop_value () = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr in - loop start + Datascript_lmdb_db.seq_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop + > 0) + () + |> Seq.map (fun (key, _value) -> Datascript_index_codec.decode_avet_key_at attr key) + +let stream_bounded t ?from_ ?to_ cmp = + match bound_key t from_ with + | None -> + Datascript_lmdb_db.seq_index_range_until t.which t.db () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + | Some from_key -> + Datascript_lmdb_db.seq_index_range_until t.which t.db ~from_key + ~stop:(fun key value -> + match to_ with + | Some bound -> + let datom = decode_entry t.which key value in + cmp datom bound > 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + +let stream_slice ?from_ ?to_ ~cmp t = + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + stream_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value () + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> stream_attr_value_exact_prefix t attr value + | None -> stream_bounded t ?from_ ?to_ cmp)) -let seq t = make_seq (cmp_for t.which) (to_list t) +let seq t = make_seq (cmp_for t.which) (stream_bounded t (cmp_for t.which)) let slice_seq ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in - make_seq cmp (materialize_range t ?from_ ?to_ cmp) + make_seq cmp (stream_slice ?from_ ?to_ ~cmp t) + +let stream_rslice_desc t ~cmp ?from_ ?to_ () = + Datascript_lmdb_db.seq_index_range_desc_until t.which t.db + ~stop:(fun key value -> + let datom = decode_entry t.which key value in + let under_hi = + match from_ with + | None -> true + | Some bound -> cmp datom bound <= 0 + in + under_hi + && + match to_ with + | Some bound -> cmp datom bound < 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp to_ from_ datom) + +let stream_attr_exact_prefix_desc t attr = + let hi_key = attr ^ "\001" in + Datascript_lmdb_db.seq_index_range_desc_until t.which t.db ~hi_key + ~stop:(fun key _value -> + let prefix = attr ^ "\000" in + let prefix_len = String.length prefix in + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) let rslice_seq ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in - let datoms = - to_list t - |> List.filter (fun datom -> - match from_ with - | None -> true - | Some bound -> cmp datom bound <= 0) - |> List.filter (fun datom -> - match to_ with - | None -> true - | Some bound -> cmp datom bound >= 0) - |> List.rev + let stream = + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix_desc t attr + | None -> stream_rslice_desc t ~cmp ?from_ ?to_ () in - make_seq cmp datoms + make_seq cmp stream let seq_to_list seq = to_seq seq |> List.of_seq -let fold_seq f init { cmp = _; datoms; offset } = - let rec loop index acc = - if index >= List.length datoms then acc - else loop (index + 1) (f acc (List.nth datoms index)) - in - loop offset init +let fold_seq f init seq = Seq.fold_left f init (to_seq seq) let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list -let seek bound seq = - let rec count index = - if index >= List.length seq.datoms then index - else if seq.cmp (List.nth seq.datoms index) bound >= 0 then index - else count (index + 1) - in - { seq with offset = count 0 } +let seek bound seq = { seq with seek_bound = Some bound } + +(** Fold TAVE keys with [tx > from_tx], optionally restricted to [attr]. *) +let fold_tave_range f init db ~from_tx ?to_tx ?attr () = + let from_key = Datascript_index_codec.encode_tave_tx_prefix (from_tx + 1) in + let acc = ref init in + Datascript_lmdb_db.fold_index_range_until Tave db ~from_key + ~stop:(fun key _value -> + match to_tx with + | Some hi -> Datascript_index_codec.tave_key_tx key > hi + | None -> false) + (fun key value -> + let datom = decode_entry Tave key value in + let attr_ok = + match attr with + | None -> true + | Some a -> datom.a = a + in + let tx_ok = + datom.tx > from_tx + && (match to_tx with None -> true | Some hi -> datom.tx <= hi) + in + if attr_ok && tx_ok then acc := f !acc datom); + !acc + +(** Delete TAVE keys with [tx <= before_tx] (rolling retention). *) +let prune_tave_before db ~before_tx = + if before_tx < 0 then () + else + let to_delete = ref [] in + let stop_key = Datascript_index_codec.encode_tave_tx_prefix (before_tx + 1) in + Datascript_lmdb_db.fold_index_range_until Tave db + ~stop:(fun key _ -> key >= stop_key) + (fun key _value -> + if Datascript_index_codec.tave_key_tx key <= before_tx then + to_delete := key :: !to_delete); + if !to_delete <> [] then + Datascript_lmdb_db.with_write_txn db (fun txn -> + List.iter + (fun key -> Datascript_lmdb_db.remove_index_txn Tave txn db key) + !to_delete) diff --git a/lmdb/native/datascript_lmdb_index.mli b/lmdb/native/datascript_lmdb_index.mli index 2e16cef..d0faddd 100644 --- a/lmdb/native/datascript_lmdb_index.mli +++ b/lmdb/native/datascript_lmdb_index.mli @@ -33,3 +33,7 @@ val seq_to_list : datom seq -> datom list val fold_seq : ('acc -> datom -> 'acc) -> 'acc -> datom seq -> 'acc val to_seq : datom seq -> datom Seq.t val seek : datom -> datom seq -> datom seq +val fold_tave_range : + ('acc -> datom -> 'acc) -> 'acc -> Datascript_lmdb_db.t -> from_tx:tx -> ?to_tx:tx -> ?attr:string + -> unit -> 'acc +val prune_tave_before : Datascript_lmdb_db.t -> before_tx:tx -> unit diff --git a/script/compare_logseq_query_bench_3way.sh b/script/compare_logseq_query_bench_3way.sh new file mode 100755 index 0000000..c3f1d04 --- /dev/null +++ b/script/compare_logseq_query_bench_3way.sh @@ -0,0 +1,197 @@ +#!/usr/bin/env bash +# Three-way Logseq shared-query bench: +# 1) CLJS via @logseq/nbb-logseq — PSS indexes + SQLite kvs IStorage +# 2) OCaml on origin/main — PSS + SQLite blob kvs (restore → memory indexes) +# 3) OCaml on the current checkout — non-PSS durable SQLite Share indexes +set -euo pipefail + +repo_root="$(git -C "$(dirname "$0")/.." rev-parse --show-toplevel)" +cd "$repo_root" + +size="${BENCH_SIZE:-20000}" +pages="${BENCH_PAGES:-2000}" +warmup_ms="${BENCH_WARMUP_MS:-200}" +sample_ms="${BENCH_SAMPLE_MS:-200}" +repeats="${BENCH_REPEATS:-3}" +jit_warmup="${BENCH_JIT_WARMUP:-20}" +out_dir="${BENCH_OUT_DIR:-/opt/cursor/artifacts}" +main_ref="${BENCH_MAIN_REF:-origin/main}" +worktree="${BENCH_MAIN_WORKTREE:-/tmp/datascript-ocaml-main-bench}" +nbb_bin="${NBB_LOGSEQ_BIN:-}" +nbb_prefix="${NBB_LOGSEQ_PREFIX:-/tmp/nbb-logseq-db}" +# DB-graph capable nbb-logseq (datascript.core store/restore + IStorage) +nbb_pkg="${NBB_LOGSEQ_PKG:-github:logseq/nbb-logseq#feat-db-v34}" + +mkdir -p "$out_dir" + +if [ -z "$nbb_bin" ]; then + if [ -x "$nbb_prefix/node_modules/.bin/nbb-logseq" ]; then + nbb_bin="$nbb_prefix/node_modules/.bin/nbb-logseq" + elif command -v nbb-logseq >/dev/null 2>&1; then + nbb_bin="$(command -v nbb-logseq)" + else + mkdir -p "$nbb_prefix" + npm install "$nbb_pkg" --no-save --prefix "$nbb_prefix" + nbb_bin="$nbb_prefix/node_modules/.bin/nbb-logseq" + fi +fi + +args=(--size "$size" --pages "$pages" --warmup-ms "$warmup_ms" --sample-ms "$sample_ms" --repeats "$repeats" --jit-warmup "$jit_warmup") + +echo "== building current-branch shared sqlite bench ==" +dune build bench/logseq_query_bench_shared.exe + +echo "== 1/3 cljs via nbb-logseq (PSS + sqlite kvs) ==" +BENCH_RUNTIME_LABEL="cljs-nbb-logseq-pss" \ + "$nbb_bin" "$repo_root/bench/logseq_query_bench_upstream.cljs" \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-cljs-$size.sqlite3" \ + | tee "$out_dir/bench-logseq-shared-cljs-nbb.txt" + +echo "== preparing origin/main worktree (no new branch) ==" +git fetch origin main +if [ -d "$worktree" ]; then + git -C "$worktree" fetch origin main 2>/dev/null || true + git -C "$worktree" checkout -f --detach "$main_ref" + git -C "$worktree" reset --hard "$main_ref" +else + git worktree add --detach "$worktree" "$main_ref" +fi + +mkdir -p "$worktree/bench" +cp "$repo_root/bench/logseq_query_bench_shared.ml" "$worktree/bench/logseq_query_bench_shared.ml" +# origin/main API divergences (keep shared source matching current branch): +# - Datascript_sqlite.storage already returns Datascript.storage (no storage_of_handle) +# - refresh_db_indexes is not exported on main +python3 - <<'PY' "$worktree/bench/logseq_query_bench_shared.ml" +from pathlib import Path +import sys +path = Path(sys.argv[1]) +text = path.read_text() +text = text.replace( + "let storage = storage_of_handle (Datascript_sqlite.storage session) in", + "let storage = Datascript_sqlite.storage session in", +) +text = text.replace(" let db = refresh_db_indexes db in\n", "") +path.write_text(text) +PY +if ! grep -q 'logseq_query_bench_shared' "$worktree/bench/dune"; then + cat >> "$worktree/bench/dune" <<'EOF' + +(executable + (name logseq_query_bench_shared) + (modules logseq_query_bench_shared) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite unix sqlite3)) +EOF +fi + +echo "== 2/3 ocaml origin/main (PSS + sqlite kvs) ==" +( + cd "$worktree" + dune build bench/logseq_query_bench_shared.exe + BENCH_RUNTIME_LABEL="ocaml-main-pss" \ + dune exec -- bench/logseq_query_bench_shared.exe \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-ocaml-main-$size.sqlite3" +) | tee "$out_dir/bench-logseq-shared-ocaml-main.txt" + +echo "== 3/3 ocaml current branch (non-PSS sqlite Share indexes) ==" +BENCH_RUNTIME_LABEL="ocaml-current-non-pss" \ + dune exec -- bench/logseq_query_bench_shared.exe \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-ocaml-current-$size.sqlite3" \ + | tee "$out_dir/bench-logseq-shared-ocaml-current.txt" + +python3 - <<'PY' "$out_dir" "$size" "$pages" +import sys +from pathlib import Path + +out_dir = Path(sys.argv[1]) +size, pages = sys.argv[2], sys.argv[3] + +paths = { + "cljs-nbb-logseq-pss": out_dir / "bench-logseq-shared-cljs-nbb.txt", + "ocaml-main-pss": out_dir / "bench-logseq-shared-ocaml-main.txt", + "ocaml-current-non-pss": out_dir / "bench-logseq-shared-ocaml-current.txt", +} + +def parse_full(path): + rows = {} + edns = {} + for line in path.read_text().splitlines(): + if "\t" not in line: + continue + parts = line.split("\t", 2) + if len(parts) == 3 and parts[0] == "result-edn": + edns[parts[1]] = parts[2] + elif len(parts) >= 2: + rows[parts[0]] = parts[1] + return rows, edns + +parsed_full = {label: parse_full(path) for label, path in paths.items()} +parsed = {label: rows for label, (rows, _edns) in parsed_full.items()} +edns = {label: edn for label, (_rows, edn) in parsed_full.items()} +queries = [ + "build-ms", "restore-ms", "disk-bytes", + "recent-pages", "latest-journals", "uuid-lookup", "title-lookup", + "children-by-parent", "blocks-by-page", "tags-scan", "eavt-entity", + "entity-hydrate", "q-updated-at-between", "q-journal-pages", "q-page-by-name", +] +labels = list(paths.keys()) + +# EDN result equality: CLJS PSS vs OCaml current Share (required). +ref = "cljs-nbb-logseq-pss" +cur = "ocaml-current-non-pss" +mismatches = [] +for q in queries: + if q in ("build-ms", "restore-ms", "disk-bytes"): + continue + left = edns[ref].get(q) + right = edns[cur].get(q) + if left is None or right is None: + mismatches.append(f"{q}: missing edn (cljs={left is not None}, ocaml={right is not None})") + elif left != right: + mismatches.append(f"{q}:\n cljs: {left}\n ocaml: {right}") + +md = [] +md.append("# Logseq shared query bench (3-way)") +md.append("") +md.append(f"- Size: {size} entities / {pages} pages") +md.append("- CLJS: `@logseq/nbb-logseq#feat-db-v34` — PSS indexes + SQLite `kvs` IStorage") +md.append("- OCaml main: PSS + SQLite blob kvs (working set in memory after restore)") +md.append("- OCaml current: non-PSS durable SQLite Share indexes (live B-tree tables)") +md.append("- Workload: Logseq `initial_data` hot paths") +md.append("- Result equality: `result-edn` lines compared as EDN strings (CLJS vs current)") +md.append("") +if mismatches: + md.append("## Result EDN mismatches (CLJS vs ocaml-current)") + md.append("") + for m in mismatches: + md.append(f"- {m}") + md.append("") +else: + md.append("## Result EDN") + md.append("") + md.append("All Logseq query `result-edn` strings match between CLJS PSS and OCaml current.") + md.append("") + +md.append("| query | " + " | ".join(labels) + " |") +md.append("| --- | " + " | ".join(["---:"] * len(labels)) + " |") +for q in queries: + cells = [parsed[l].get(q, "—") for l in labels] + md.append(f"| `{q}` | " + " | ".join(cells) + " |") +md.append("") +md.append("Times are median ms/op.") +md.append("") +md.append("Artifacts:") +for label, path in paths.items(): + md.append(f"- `{path.name}` ({label})") + +report = out_dir / "bench-logseq-shared-3way.md" +report.write_text("\n".join(md) + "\n") +print(report.read_text()) +print(f"wrote {report}", file=sys.stderr) +if mismatches: + print("RESULT EDN MISMATCH:", file=sys.stderr) + for m in mismatches: + print(m, file=sys.stderr) + sys.exit(1) +PY diff --git a/script/compare_logseq_query_bench_5way.sh b/script/compare_logseq_query_bench_5way.sh new file mode 100755 index 0000000..01a5dbf --- /dev/null +++ b/script/compare_logseq_query_bench_5way.sh @@ -0,0 +1,267 @@ +#!/usr/bin/env bash +# Five-way Logseq shared-query bench (fair size, EDN string equality): +# 1) CLJS via @logseq/nbb-logseq — PSS indexes + SQLite kvs IStorage +# 2) OCaml on origin/main — PSS + SQLite blob kvs (restore → memory indexes) +# 3) OCaml on the current checkout — non-PSS durable SQLite Share indexes +# 4) Datahike — PSS + SQLite JDBC (konserve) +# 5) Datalevin — LMDB +set -euo pipefail + +repo_root="$(git -C "$(dirname "$0")/.." rev-parse --show-toplevel)" +cd "$repo_root" + +size="${BENCH_SIZE:-5000}" +pages="${BENCH_PAGES:-500}" +warmup_ms="${BENCH_WARMUP_MS:-200}" +sample_ms="${BENCH_SAMPLE_MS:-200}" +repeats="${BENCH_REPEATS:-3}" +jit_warmup="${BENCH_JIT_WARMUP:-20}" +out_dir="${BENCH_OUT_DIR:-/opt/cursor/artifacts}" +main_ref="${BENCH_MAIN_REF:-origin/main}" +worktree="${BENCH_MAIN_WORKTREE:-/tmp/datascript-ocaml-main-bench}" +nbb_bin="${NBB_LOGSEQ_BIN:-}" +nbb_prefix="${NBB_LOGSEQ_PREFIX:-/tmp/nbb-logseq-db}" +nbb_pkg="${NBB_LOGSEQ_PKG:-github:logseq/nbb-logseq#feat-db-v34}" +skip_main="${BENCH_SKIP_MAIN:-0}" +skip_cljs="${BENCH_SKIP_CLJS:-0}" + +mkdir -p "$out_dir" + +if [ -z "$nbb_bin" ] && [ "$skip_cljs" != "1" ]; then + if [ -x "$nbb_prefix/node_modules/.bin/nbb-logseq" ]; then + nbb_bin="$nbb_prefix/node_modules/.bin/nbb-logseq" + elif command -v nbb-logseq >/dev/null 2>&1; then + nbb_bin="$(command -v nbb-logseq)" + else + mkdir -p "$nbb_prefix" + npm install "$nbb_pkg" --no-save --prefix "$nbb_prefix" + nbb_bin="$nbb_prefix/node_modules/.bin/nbb-logseq" + fi +fi + +args=(--size "$size" --pages "$pages" --warmup-ms "$warmup_ms" --sample-ms "$sample_ms" --repeats "$repeats" --jit-warmup "$jit_warmup") + +echo "== building current-branch shared sqlite bench ==" +dune build bench/logseq_query_bench_shared.exe + +if [ "$skip_cljs" != "1" ]; then + echo "== 1/5 cljs via nbb-logseq (PSS + sqlite kvs) ==" + BENCH_RUNTIME_LABEL="cljs-nbb-logseq-pss" \ + "$nbb_bin" "$repo_root/bench/logseq_query_bench_upstream.cljs" \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-cljs-$size.sqlite3" \ + | tee "$out_dir/bench-logseq-shared-cljs-nbb.txt" +else + echo "== 1/5 cljs skipped ==" +fi + +if [ "$skip_main" != "1" ]; then + echo "== preparing origin/main worktree (no new branch) ==" + git fetch origin main + if [ -d "$worktree" ]; then + git -C "$worktree" fetch origin main 2>/dev/null || true + git -C "$worktree" checkout -f --detach "$main_ref" + git -C "$worktree" reset --hard "$main_ref" + else + git worktree add --detach "$worktree" "$main_ref" + fi + + mkdir -p "$worktree/bench" + cp "$repo_root/bench/logseq_query_bench_shared.ml" "$worktree/bench/logseq_query_bench_shared.ml" + python3 - <<'PY' "$worktree/bench/logseq_query_bench_shared.ml" +from pathlib import Path +import sys +path = Path(sys.argv[1]) +text = path.read_text() +text = text.replace( + "let storage = storage_of_handle (Datascript_sqlite.storage session) in", + "let storage = Datascript_sqlite.storage session in", +) +text = text.replace(" let db = refresh_db_indexes db in\n", "") +path.write_text(text) +PY + if ! grep -q 'logseq_query_bench_shared' "$worktree/bench/dune"; then + cat >> "$worktree/bench/dune" <<'EOF' + +(executable + (name logseq_query_bench_shared) + (modules logseq_query_bench_shared) + (modes exe) + (libraries datascript-ocaml-native datascript_sqlite unix sqlite3)) +EOF + fi + + echo "== 2/5 ocaml origin/main (PSS + sqlite kvs) ==" + ( + cd "$worktree" + dune build bench/logseq_query_bench_shared.exe + BENCH_RUNTIME_LABEL="ocaml-main-pss" \ + dune exec -- bench/logseq_query_bench_shared.exe \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-ocaml-main-$size.sqlite3" + ) | tee "$out_dir/bench-logseq-shared-ocaml-main.txt" +else + echo "== 2/5 ocaml main skipped ==" +fi + +echo "== 3/5 ocaml current branch (non-PSS sqlite Share indexes) ==" +BENCH_RUNTIME_LABEL="ocaml-current-non-pss" \ + dune exec -- bench/logseq_query_bench_shared.exe \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-ocaml-current-$size.sqlite3" \ + | tee "$out_dir/bench-logseq-shared-ocaml-current.txt" + +echo "== 4/5 datahike (PSS + sqlite JDBC) ==" +( + cd "$repo_root/bench/external" + BENCH_RUNTIME_LABEL="datahike-pss-sqlite" \ + clojure -M:run --runtime datahike \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-datahike-$size.sqlite3" +) 2>"$out_dir/bench-logseq-shared-datahike.err" \ + | tee "$out_dir/bench-logseq-shared-datahike.txt" + +echo "== 5/5 datalevin (LMDB) ==" +( + cd "$repo_root/bench/external" + BENCH_RUNTIME_LABEL="datalevin-lmdb" \ + clojure -M:run --runtime datalevin \ + "${args[@]}" --sqlite "$out_dir/logseq-bench-datalevin-$size.sqlite3" +) 2>"$out_dir/bench-logseq-shared-datalevin.err" \ + | tee "$out_dir/bench-logseq-shared-datalevin.txt" + +python3 - <<'PY' "$out_dir" "$size" "$pages" "$skip_cljs" "$skip_main" +import sys +from pathlib import Path + +out_dir = Path(sys.argv[1]) +size, pages = sys.argv[2], sys.argv[3] +skip_cljs = sys.argv[4] == "1" +skip_main = sys.argv[5] == "1" + +paths = {} +if not skip_cljs: + paths["cljs-nbb-logseq-pss"] = out_dir / "bench-logseq-shared-cljs-nbb.txt" +if not skip_main: + paths["ocaml-main-pss"] = out_dir / "bench-logseq-shared-ocaml-main.txt" +paths["ocaml-current-non-pss"] = out_dir / "bench-logseq-shared-ocaml-current.txt" +paths["datahike-pss-sqlite"] = out_dir / "bench-logseq-shared-datahike.txt" +paths["datalevin-lmdb"] = out_dir / "bench-logseq-shared-datalevin.txt" + +def parse_full(path): + rows, edns = {}, {} + for line in path.read_text().splitlines(): + if "\t" not in line: + continue + parts = line.split("\t", 2) + if len(parts) == 3 and parts[0] == "result-edn": + edns[parts[1]] = parts[2] + elif len(parts) >= 2: + rows[parts[0]] = parts[1] + return rows, edns + +parsed_full = {label: parse_full(path) for label, path in paths.items()} +parsed = {label: rows for label, (rows, _edns) in parsed_full.items()} +edns = {label: edn for label, (_rows, edn) in parsed_full.items()} +queries = [ + "build-ms", "restore-ms", "disk-bytes", + "recent-pages", "latest-journals", "uuid-lookup", "title-lookup", + "children-by-parent", "blocks-by-page", "tags-scan", "eavt-entity", + "entity-hydrate", "q-updated-at-between", "q-journal-pages", "q-page-by-name", +] +query_only = [q for q in queries if q not in ("build-ms", "restore-ms", "disk-bytes")] +labels = list(paths.keys()) + +# Required EDN equality: CLJS vs OCaml current (when CLJS present). +# Also compare Datahike/Datalevin vs OCaml current. +ref_pairs = [] +if "cljs-nbb-logseq-pss" in edns: + ref_pairs.append(("cljs-nbb-logseq-pss", "ocaml-current-non-pss")) +ref_pairs.append(("ocaml-current-non-pss", "datahike-pss-sqlite")) +ref_pairs.append(("ocaml-current-non-pss", "datalevin-lmdb")) + +mismatches = [] +for left_l, right_l in ref_pairs: + for q in query_only: + left = edns[left_l].get(q) + right = edns[right_l].get(q) + if left is None or right is None: + mismatches.append( + f"{left_l} vs {right_l} / {q}: missing edn " + f"(left={left is not None}, right={right is not None})" + ) + elif left != right: + mismatches.append( + f"{left_l} vs {right_l} / {q}:\n left: {left}\n right: {right}" + ) + +# Performance gate: every Logseq query must be faster on ocaml-current than Datahike. +cur = "ocaml-current-non-pss" +dh = "datahike-pss-sqlite" +slower = [] +for q in query_only: + try: + cv = float(parsed[cur][q]) + dv = float(parsed[dh][q]) + except (KeyError, ValueError): + slower.append(f"{q}: missing timing") + continue + if cv >= dv: + slower.append(f"{q}: ocaml-current={cv} >= datahike={dv}") + +md = [] +md.append("# Logseq shared query bench (5-way)") +md.append("") +md.append(f"- Size: {size} entities / {pages} pages") +md.append("- CLJS: `@logseq/nbb-logseq#feat-db-v34` — PSS + SQLite `kvs`") +md.append("- OCaml main: PSS + SQLite blob kvs") +md.append("- OCaml current: non-PSS durable SQLite Share indexes") +md.append("- Datahike: PSS + SQLite JDBC") +md.append("- Datalevin: LMDB") +md.append("- Result equality: `result-edn` strings") +md.append("") +if mismatches: + md.append("## Result EDN mismatches") + md.append("") + for m in mismatches: + md.append(f"- {m}") + md.append("") +else: + md.append("## Result EDN") + md.append("") + md.append("All compared `result-edn` strings match.") + md.append("") + +if slower: + md.append("## OCaml current vs Datahike (expected: current faster)") + md.append("") + for s in slower: + md.append(f"- {s}") + md.append("") +else: + md.append("## OCaml current vs Datahike") + md.append("") + md.append("Every Logseq query timing is faster on OCaml current than Datahike.") + md.append("") + +md.append("| query | " + " | ".join(labels) + " |") +md.append("| --- | " + " | ".join(["---:"] * len(labels)) + " |") +for q in queries: + cells = [parsed[l].get(q, "—") for l in labels] + md.append(f"| `{q}` | " + " | ".join(cells) + " |") +md.append("") +md.append("Times are median ms/op.") +md.append("") +md.append("Artifacts:") +for label, path in paths.items(): + md.append(f"- `{path.name}` ({label})") + +report = out_dir / "bench-logseq-shared-5way.md" +report.write_text("\n".join(md) + "\n") +print(report.read_text()) +print(f"wrote {report}", file=sys.stderr) +rc = 0 +if mismatches: + print("RESULT EDN MISMATCH", file=sys.stderr) + rc = 1 +if slower: + print("OCAML NOT FASTER THAN DATAHIKE", file=sys.stderr) + rc = 1 +sys.exit(rc) +PY diff --git a/script/compare_shared_query_bench_3way.sh b/script/compare_shared_query_bench_3way.sh new file mode 100755 index 0000000..dd7e63e --- /dev/null +++ b/script/compare_shared_query_bench_3way.sh @@ -0,0 +1,209 @@ +#!/usr/bin/env bash +# Three-way shared people-query suite (q1/q2/q3/…): +# 1) OCaml current — non-PSS durable SQLite Share indexes +# 2) Datahike — PSS + SQLite JDBC +# 3) Datalevin — durable LMDB +# Compares canonical result-edn strings; reports timings. +set -euo pipefail + +repo_root="$(git -C "$(dirname "$0")/.." rev-parse --show-toplevel)" +cd "$repo_root" + +if command -v opam >/dev/null 2>&1; then + eval "$(opam env --switch=5.5 2>/dev/null || opam env 2>/dev/null || true)" +fi + +size="${BENCH_SIZE:-20000}" +warmup_ms="${BENCH_WARMUP_MS:-200}" +sample_ms="${BENCH_SAMPLE_MS:-200}" +repeats="${BENCH_REPEATS:-2}" +jit_warmup="${BENCH_JIT_WARMUP:-100}" +out_dir="${BENCH_OUT_DIR:-/opt/cursor/artifacts}" +query_filter="${BENCH_QUERY:-}" + +mkdir -p "$out_dir" + +args=(--size "$size" --warmup-ms "$warmup_ms" --sample-ms "$sample_ms" --repeats "$repeats" --jit-warmup "$jit_warmup") +if [ -n "$query_filter" ]; then + args+=(--query "$query_filter") +fi + +echo "== building ocaml shared_query_bench ==" +dune build bench/shared_query_bench.exe + +echo "== 1/3 ocaml current (sqlite Share) ==" +BENCH_RUNTIME_LABEL="ocaml-current-non-pss" \ + dune exec -- bench/shared_query_bench.exe \ + "${args[@]}" --storage sqlite \ + --data-dir "$out_dir/shared-query-ocaml-$size" \ + | tee "$out_dir/bench-shared-people-ocaml-current.txt" + +echo "== 2/3 datahike (PSS + sqlite JDBC) ==" +( + cd "$repo_root/bench/external" + BENCH_RUNTIME_LABEL="datahike-pss-sqlite" \ + clojure -M:shared --runtime datahike \ + "${args[@]}" --sqlite "$out_dir/shared-query-datahike-$size.sqlite3" +) 2>"$out_dir/bench-shared-people-datahike.err" \ + | tee "$out_dir/bench-shared-people-datahike.txt" + +echo "== 3/3 datalevin (LMDB) ==" +( + cd "$repo_root/bench/external" + BENCH_RUNTIME_LABEL="datalevin-lmdb" \ + clojure -M:shared --runtime datalevin \ + "${args[@]}" --sqlite "$out_dir/shared-query-datalevin-$size.sqlite3" +) 2>"$out_dir/bench-shared-people-datalevin.err" \ + | tee "$out_dir/bench-shared-people-datalevin.txt" + +python3 - <<'PY' "$out_dir" "$size" +import sys +from pathlib import Path + +out_dir = Path(sys.argv[1]) +size = sys.argv[2] + +paths = { + "ocaml-current-non-pss": out_dir / "bench-shared-people-ocaml-current.txt", + "datahike-pss-sqlite": out_dir / "bench-shared-people-datahike.txt", + "datalevin-lmdb": out_dir / "bench-shared-people-datalevin.txt", +} + +def parse_full(path): + rows, edns = {}, {} + for line in path.read_text(errors="replace").splitlines(): + if "\t" not in line: + continue + parts = line.split("\t", 2) + if len(parts) == 3 and parts[0] == "result-edn": + edns[parts[1]] = parts[2] + elif len(parts) >= 2: + rows[parts[0]] = parts[1] + return rows, edns + +parsed_full = {label: parse_full(path) for label, path in paths.items()} +parsed = {label: rows for label, (rows, _edns) in parsed_full.items()} +edns = {label: edn for label, (_rows, edn) in parsed_full.items()} + +# Prefer engine timings (`*-nocache`) when present; fall back to warm `q` name. +# Result EDN still comes from `result-edn` lines. +default_order = [ + "q1", "q2", "q2-switch", "q3", "q4", "q5", + "qpred1", "qpred2", "q-or", "q-not", "q-or-join", "q-not-join", + "q-pred-range", "q-5-merge", "q-rule", +] +ocaml_edns = edns["ocaml-current-non-pss"] +query_only = [q for q in default_order if q in ocaml_edns] or sorted(ocaml_edns) +setup = ["build-ms", "restore-ms", "disk-bytes", "store-restore-ms"] +labels = list(paths.keys()) + +def timing_key(rows, q): + nocache = f"{q}-nocache" + if nocache in rows: + return nocache + return q + +ref_pairs = [ + ("ocaml-current-non-pss", "datahike-pss-sqlite"), + ("ocaml-current-non-pss", "datalevin-lmdb"), +] + +mismatches = [] +for left_l, right_l in ref_pairs: + for q in query_only: + left = edns[left_l].get(q) + right = edns[right_l].get(q) + if left is None or right is None: + mismatches.append( + f"{left_l} vs {right_l} / {q}: missing edn " + f"(left={left is not None}, right={right is not None})" + ) + elif left != right: + # Keep mismatch short in the report. + mismatches.append( + f"{left_l} vs {right_l} / {q}: edn mismatch " + f"(left_len={len(left)}, right_len={len(right)})" + ) + +cur = "ocaml-current-non-pss" +dh = "datahike-pss-sqlite" +slower = [] +for q in query_only: + ck = timing_key(parsed[cur], q) + dk = timing_key(parsed[dh], q) + try: + cv = float(parsed[cur][ck]) + dv = float(parsed[dh][dk]) + except (KeyError, ValueError): + slower.append(f"{q}: missing timing (ocaml={ck}, datahike={dk})") + continue + if cv >= dv: + slower.append(f"{q}: ocaml-current={cv} ({ck}) >= datahike={dv} ({dk})") + +md = [] +md.append("# Shared people query bench (3-way)") +md.append("") +md.append(f"- Size: {size} entities") +md.append("- OCaml current: non-PSS durable SQLite Share indexes") +md.append("- Datahike: PSS + SQLite JDBC") +md.append("- Datalevin: durable LMDB") +md.append("- Result equality: canonical `result-edn` strings") +md.append("") +if mismatches: + md.append("## Result EDN mismatches") + md.append("") + for m in mismatches: + md.append(f"- {m}") + md.append("") +else: + md.append("## Result EDN") + md.append("") + md.append("All compared `result-edn` strings match (OCaml current, Datahike, Datalevin).") + md.append("") + +if slower: + md.append("## OCaml current vs Datahike (expected: current faster)") + md.append("") + for s in slower: + md.append(f"- {s}") + md.append("") +else: + md.append("## OCaml current vs Datahike") + md.append("") + md.append("Every shared query timing is faster on OCaml current than Datahike.") + md.append("") + +md.append("| query | " + " | ".join(labels) + " |") +md.append("| --- | " + " | ".join(["---:"] * len(labels)) + " |") +for q in setup + query_only: + if q in setup: + cells = [parsed[l].get(q, "—") for l in labels] + label = q + else: + cells = [parsed[l].get(timing_key(parsed[l], q), "—") for l in labels] + # Annotate when nocache timing is used. + keys = {timing_key(parsed[l], q) for l in labels} + label = q + (" (nocache)" if any(k.endswith("-nocache") for k in keys) else "") + if all(c == "—" for c in cells): + continue + md.append(f"| `{label}` | " + " | ".join(cells) + " |") +md.append("") +md.append("Times are median ms/op (prefer `*-nocache` engine path when present; warm cache is separate).") +md.append("") +md.append("Artifacts:") +for label, path in paths.items(): + md.append(f"- `{path.name}` ({label})") + +report = out_dir / "bench-shared-people-3way.md" +report.write_text("\n".join(md) + "\n") +print(report.read_text()) +print(f"wrote {report}", file=sys.stderr) +rc = 0 +if mismatches: + print("RESULT EDN MISMATCH", file=sys.stderr) + rc = 1 +if slower: + print("OCAML NOT FASTER THAN DATAHIKE", file=sys.stderr) + rc = 1 +sys.exit(rc) +PY diff --git a/sqlite/datascript_sqlite_db.ml b/sqlite/datascript_sqlite_db.ml index 717ab51..5aa755e 100644 --- a/sqlite/datascript_sqlite_db.ml +++ b/sqlite/datascript_sqlite_db.ml @@ -4,12 +4,14 @@ type t = { path : string ; db : Sqlite3.db ; mutable closed : bool + ; stmts : (string, Sqlite3.stmt) Hashtbl.t } let table_name = function | Eavt -> "ds_eavt" | Aevt -> "ds_aevt" | Avet -> "ds_avet" + | Tave -> "ds_tave" let check t sql rc = if not (Sqlite3.Rc.is_success rc) then @@ -24,11 +26,33 @@ let exec_sql t sql = ensure_open t; check t sql (Sqlite3.exec t.db sql) +(* Reuse prepared statements: build and point lookups previously prepared+finalized + once per datom / scan, which dominated Share SQLite cost vs PSS+memory. *) +let cached_stmt t sql = + ensure_open t; + match Hashtbl.find_opt t.stmts sql with + | Some stmt -> + check t sql (Sqlite3.reset stmt); + check t sql (Sqlite3.clear_bindings stmt); + stmt + | None -> + let stmt = Sqlite3.prepare t.db sql in + Hashtbl.add t.stmts sql stmt; + stmt + +let with_cached_stmt t sql f = + let stmt = cached_stmt t sql in + f stmt + let apply_open_pragmas t = exec_sql t "PRAGMA journal_mode=WAL;"; exec_sql t "PRAGMA synchronous=NORMAL;"; exec_sql t "PRAGMA busy_timeout=5000;"; - exec_sql t "PRAGMA foreign_keys=ON;" + exec_sql t "PRAGMA foreign_keys=ON;"; + (* Larger page cache + mmap cuts repeated B-tree seeks for Share index scans. *) + exec_sql t "PRAGMA cache_size=-65536;"; + exec_sql t "PRAGMA temp_store=MEMORY;"; + exec_sql t "PRAGMA mmap_size=268435456;" let ensure_schema db = List.iter @@ -40,7 +64,7 @@ let ensure_schema db = \ value BLOB NOT NULL\n\ ) WITHOUT ROWID;" (table_name index))) - [ Eavt; Aevt; Avet ]; + [ Eavt; Aevt; Avet; Tave ]; exec_sql db "CREATE TABLE IF NOT EXISTS ds_meta (\n\ \ key TEXT PRIMARY KEY NOT NULL,\n\ @@ -49,15 +73,22 @@ let ensure_schema db = let open_path path = let db = Sqlite3.db_open path in - let t = { path; db; closed = false } in + let t = { path; db; closed = false; stmts = Hashtbl.create 32 } in apply_open_pragmas t; ensure_schema t; t let temps_created = ref 0 +let finalize_cached_stmts t = + Hashtbl.iter + (fun _sql stmt -> ignore (Sqlite3.finalize stmt)) + t.stmts; + Hashtbl.clear t.stmts + let close t = if not t.closed then ( + finalize_cached_stmts t; if not (Sqlite3.db_close t.db) then invalid_arg ("failed to close SQLite database: " ^ t.path); t.closed <- true) @@ -76,17 +107,15 @@ let create_temp () = let sync t = ensure_open t; + (* Cached prepared statements keep the WAL busy; drop them before checkpoint. *) + finalize_cached_stmts t; exec_sql t "PRAGMA synchronous=FULL;"; exec_sql t "PRAGMA wal_checkpoint(FULL);"; exec_sql t "PRAGMA synchronous=NORMAL;" let meta_get db key = - ensure_open db; let sql = "SELECT value FROM ds_meta WHERE key = ?;" in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT key)); match Sqlite3.step stmt with | Sqlite3.Rc.ROW -> Some (Sqlite3.column_blob stmt 0) @@ -96,12 +125,8 @@ let meta_get db key = None) let meta_set db key value = - ensure_open db; let sql = "REPLACE INTO ds_meta (key, value) VALUES (?, ?);" in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind stmt 1 (Sqlite3.Data.TEXT key)); check db sql (Sqlite3.bind_blob stmt 2 value); check db sql (Sqlite3.step stmt)) @@ -116,24 +141,70 @@ let with_write_txn db f = (try exec_sql db "ROLLBACK;" with _ -> ()); raise exn) +(* Bulk loads issue hundreds of thousands of REPLACE steps; NORMAL sync per page + dominates. Turn sync off for the txn and restore NORMAL afterward. *) +let with_bulk_write_txn db f = + ensure_open db; + exec_sql db "PRAGMA synchronous=OFF;"; + (try + with_write_txn db f; + exec_sql db "PRAGMA synchronous=NORMAL;" + with exn -> + (try exec_sql db "PRAGMA synchronous=NORMAL;" with _ -> ()); + raise exn) + let put_index_txn index db key value = let sql = Printf.sprintf "REPLACE INTO %s (key, value) VALUES (?, ?);" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind_blob stmt 1 key); check db sql (Sqlite3.bind_blob stmt 2 value); check db sql (Sqlite3.step stmt)) +(* Multi-row REPLACE cuts prepare/step overhead vs one statement per key. *) +let put_index_chunk_size = 64 + +let put_index_entries_txn index db entries = + match entries with + | [] -> () + | _ -> + let table = table_name index in + let rec loop = function + | [] -> () + | rest -> + let chunk, rest = + let rec take n acc xs = + if n = 0 then List.rev acc, xs + else + match xs with + | [] -> List.rev acc, [] + | x :: xs -> take (n - 1) (x :: acc) xs + in + take put_index_chunk_size [] rest + in + let n = List.length chunk in + let placeholders = + List.init n (fun _ -> "(?, ?)") |> String.concat ", " + in + let sql = + Printf.sprintf "REPLACE INTO %s (key, value) VALUES %s;" table placeholders + in + with_cached_stmt db sql (fun stmt -> + List.iteri + (fun i (key, value) -> + let base = (i * 2) + 1 in + check db sql (Sqlite3.bind_blob stmt base key); + check db sql (Sqlite3.bind_blob stmt (base + 1) value)) + chunk; + check db sql (Sqlite3.step stmt)); + loop rest + in + loop entries + let remove_index_txn index db key = let sql = Printf.sprintf "DELETE FROM %s WHERE key = ?;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind_blob stmt 1 key); check db sql (Sqlite3.step stmt)) @@ -143,12 +214,8 @@ let put_index index db key value = let remove_index index db key = with_write_txn db (fun () -> remove_index_txn index db key) let get_index index db key = - ensure_open db; let sql = Printf.sprintf "SELECT value FROM %s WHERE key = ?;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind_blob stmt 1 key); match Sqlite3.step stmt with | Sqlite3.Rc.ROW -> Some (Sqlite3.column_blob stmt 0) @@ -158,12 +225,8 @@ let get_index index db key = None) let fold_index index db f = - ensure_open db; let sql = Printf.sprintf "SELECT key, value FROM %s ORDER BY key;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> let rec loop () = match Sqlite3.step stmt with | Sqlite3.Rc.ROW -> @@ -175,15 +238,11 @@ let fold_index index db f = loop ()) let fold_index_prefix index db prefix f = - ensure_open db; let sql = Printf.sprintf "SELECT key, value FROM %s WHERE key >= ? ORDER BY key;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in let prefix_len = String.length prefix in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> check db sql (Sqlite3.bind_blob stmt 1 prefix); let rec loop () = match Sqlite3.step stmt with @@ -199,17 +258,13 @@ let fold_index_prefix index db prefix f = loop ()) let fold_index_range_until index db ?from_key ?stop f = - ensure_open db; let sql = match from_key with | None -> Printf.sprintf "SELECT key, value FROM %s ORDER BY key;" (table_name index) | Some _ -> Printf.sprintf "SELECT key, value FROM %s WHERE key >= ? ORDER BY key;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> (match from_key with | None -> () | Some key -> check db sql (Sqlite3.bind_blob stmt 1 key)); @@ -229,7 +284,6 @@ let fold_index_range_until index db ?from_key ?stop f = loop ()) let fold_index_range_desc_until index db ?hi_key ?stop f = - ensure_open db; let sql = match hi_key with | None -> Printf.sprintf "SELECT key, value FROM %s ORDER BY key DESC;" (table_name index) @@ -237,10 +291,7 @@ let fold_index_range_desc_until index db ?hi_key ?stop f = Printf.sprintf "SELECT key, value FROM %s WHERE key <= ? ORDER BY key DESC;" (table_name index) in - let stmt = Sqlite3.prepare db.db sql in - Fun.protect - ~finally:(fun () -> check db sql (Sqlite3.finalize stmt)) - (fun () -> + with_cached_stmt db sql (fun stmt -> (match hi_key with | None -> () | Some key -> check db sql (Sqlite3.bind_blob stmt 1 key)); @@ -259,5 +310,146 @@ let fold_index_range_desc_until index db ?hi_key ?stop f = in loop ()) +(* Datalevin-style lazy ranges: pull batches through cached fold statements, then + re-seek from a continuation key. Avoids holding a live stmt across Seq yields + (which blocked WAL checkpoint and made point lookups pay prepare-per-scan). *) +let stream_batch_size = 64 + +type asc_cont = + | Asc_start + | Asc_from of { key : string; include_key : bool } + | Asc_done + +let seq_index_range_until index db ?from_key ?stop () = + ensure_open db; + let cont = + ref + (match from_key with + | None -> Asc_start + | Some key -> Asc_from { key; include_key = true }) + in + let fetch () = + match !cont with + | Asc_done -> [] + | _ -> + let batch = ref [] in + let count = ref 0 in + let from_key, include_key = + match !cont with + | Asc_start -> None, true + | Asc_from { key; include_key } -> Some key, include_key + | Asc_done -> None, true + in + let skipping = ref (match from_key with Some _ when not include_key -> true | _ -> false) in + let hit_end = ref true in + fold_index_range_until index db ?from_key + ~stop:(fun key value -> + if !count >= stream_batch_size then ( + hit_end := false; + true) + else if !skipping then false + else + match stop with + | Some stop when stop key value -> + cont := Asc_done; + true + | _ -> false) + (fun key value -> + if !skipping then ( + match from_key with + | Some cont_key when key = cont_key -> () + | _ -> + skipping := false; + batch := (key, value) :: !batch; + incr count; + cont := Asc_from { key; include_key = false }) + else ( + batch := (key, value) :: !batch; + incr count; + cont := Asc_from { key; include_key = false })); + if !hit_end && !count < stream_batch_size then cont := Asc_done; + List.rev !batch + in + let rec stream () = + match fetch () with + | [] -> Seq.Nil + | items -> + let rec of_list = function + | [] -> stream + | x :: xs -> fun () -> Seq.Cons (x, of_list xs) + in + of_list items () + in + stream + +let seq_index_prefix index db prefix () = + let prefix_len = String.length prefix in + seq_index_range_until index db ~from_key:prefix + ~stop:(fun key _value -> + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + +type desc_cont = + | Desc_start of string option + | Desc_after of string + | Desc_done + +let seq_index_range_desc_until index db ?hi_key ?stop () = + ensure_open db; + let cont = ref (Desc_start hi_key) in + let fetch () = + match !cont with + | Desc_done -> [] + | _ -> + let batch = ref [] in + let count = ref 0 in + let hi_key, skip_hi = + match !cont with + | Desc_start hi -> hi, false + | Desc_after key -> Some key, true + | Desc_done -> None, false + in + let skipping = ref skip_hi in + let hit_end = ref true in + fold_index_range_desc_until index db ?hi_key + ~stop:(fun key value -> + if !count >= stream_batch_size then ( + hit_end := false; + true) + else if !skipping then false + else + match stop with + | Some stop when stop key value -> + cont := Desc_done; + true + | _ -> false) + (fun key value -> + if !skipping then ( + match hi_key with + | Some cont_key when key = cont_key -> () + | _ -> + skipping := false; + batch := (key, value) :: !batch; + incr count; + cont := Desc_after key) + else ( + batch := (key, value) :: !batch; + incr count; + cont := Desc_after key)); + if !hit_end && !count < stream_batch_size then cont := Desc_done; + List.rev !batch + in + let rec stream () = + match fetch () with + | [] -> Seq.Nil + | items -> + let rec of_list = function + | [] -> stream + | x :: xs -> fun () -> Seq.Cons (x, of_list xs) + in + of_list items () + in + stream + let copy_index index from_db to_db = fold_index index from_db (fun key value -> put_index index to_db key value) diff --git a/sqlite/datascript_sqlite_db.mli b/sqlite/datascript_sqlite_db.mli index 00a5752..1d88e08 100644 --- a/sqlite/datascript_sqlite_db.mli +++ b/sqlite/datascript_sqlite_db.mli @@ -11,7 +11,9 @@ val meta_get : t -> string -> string option val meta_set : t -> string -> string -> unit val with_write_txn : t -> (unit -> unit) -> unit +val with_bulk_write_txn : t -> (unit -> unit) -> unit val put_index_txn : index -> t -> string -> string -> unit +val put_index_entries_txn : index -> t -> (string * string) list -> unit val remove_index_txn : index -> t -> string -> unit val put_index : index -> t -> string -> string -> unit val remove_index : index -> t -> string -> unit @@ -34,4 +36,25 @@ val fold_index_range_desc_until : (string -> string -> unit) -> unit +(** Lazy key/value streams (upstream-style). Consumers can stop early; the + statement is finalized when the sequence ends or is GC'd. *) +val seq_index_range_until : + index -> + t -> + ?from_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t + +val seq_index_prefix : + index -> t -> string -> unit -> (string * string) Seq.t + +val seq_index_range_desc_until : + index -> + t -> + ?hi_key:string -> + ?stop:(string -> string -> bool) -> + unit -> + (string * string) Seq.t + val copy_index : index -> t -> t -> unit diff --git a/sqlite/datascript_sqlite_index.ml b/sqlite/datascript_sqlite_index.ml index 7e2e662..6b4b142 100644 --- a/sqlite/datascript_sqlite_index.ml +++ b/sqlite/datascript_sqlite_index.ml @@ -2,7 +2,12 @@ open Datascript_types type t = { db : Datascript_sqlite_db.t; which : index } -type 'a seq = { cmp : datom -> datom -> int; datoms : datom list; offset : int } +(* Lazy stream seq — matches upstream BTSet iteration (no full-range materialize). *) +type 'a seq = + { cmp : datom -> datom -> int + ; stream : datom Seq.t + ; seek_bound : datom option + } exception Stop_search @@ -24,17 +29,32 @@ let empty index db = make index db let write_datoms t datoms = if datoms = [] then t else ( - Datascript_sqlite_db.with_write_txn t.db (fun () -> List.iter (put_datom_txn t) datoms); + let entries = + datoms + |> List.map (fun datom -> + ( datom_key t datom + , Datascript_index_codec.encode_index_value t.which datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + Datascript_sqlite_db.with_bulk_write_txn t.db (fun () -> + Datascript_sqlite_db.put_index_entries_txn t.which t.db entries); t) let of_sorted_list index datoms db = write_datoms (empty index db) datoms let of_sorted_lists index_datoms db = - Datascript_sqlite_db.with_write_txn db (fun () -> + Datascript_sqlite_db.with_bulk_write_txn db (fun () -> List.iter (fun (index, datoms) -> let t = make index db in - List.iter (put_datom_txn t) datoms) + let entries = + datoms + |> List.map (fun datom -> + ( datom_key t datom + , Datascript_index_codec.encode_index_value t.which datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + Datascript_sqlite_db.put_index_entries_txn index db entries) index_datoms) let of_eavt_datoms ~avet eavt_datoms db = @@ -43,26 +63,82 @@ let of_eavt_datoms ~avet eavt_datoms db = let eavt = make Eavt db in let aevt = make Aevt db in let avet_index = make Avet db in - Datascript_sqlite_db.with_write_txn db (fun () -> - List.iter - (fun datom -> - put_datom_txn eavt datom; - put_datom_txn aevt datom; - if avet datom.a then put_datom_txn avet_index datom) - eavt_datoms)) + let tave = make Tave db in + let eavt_entries = + eavt_datoms + |> List.map (fun datom -> + ( datom_key eavt datom + , Datascript_index_codec.encode_index_value Eavt datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let aevt_entries = + eavt_datoms + |> List.map (fun datom -> + ( datom_key aevt datom + , Datascript_index_codec.encode_index_value Aevt datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let tave_entries = + eavt_datoms + |> List.map (fun datom -> + ( datom_key tave datom + , Datascript_index_codec.encode_index_value Tave datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let avet_entries = + eavt_datoms + |> List.filter (fun datom -> avet datom.a) + |> List.map (fun datom -> + ( datom_key avet_index datom + , Datascript_index_codec.encode_index_value Avet datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + Datascript_sqlite_db.with_bulk_write_txn db (fun () -> + Datascript_sqlite_db.put_index_entries_txn Eavt db eavt_entries; + Datascript_sqlite_db.put_index_entries_txn Aevt db aevt_entries; + Datascript_sqlite_db.put_index_entries_txn Tave db tave_entries; + Datascript_sqlite_db.put_index_entries_txn Avet db avet_entries)) let of_bulk index datoms db = of_sorted_list index datoms db let append_tx_data ~avet:is_avet datoms eavt aevt avet_index = if datoms = [] then (eavt, aevt, avet_index) else ( - Datascript_sqlite_db.with_write_txn eavt.db (fun () -> - List.iter - (fun datom -> - put_datom_txn eavt datom; - put_datom_txn aevt datom; - if is_avet datom.a then put_datom_txn avet_index datom) - datoms); + let tave = make Tave eavt.db in + let eavt_entries = + datoms + |> List.map (fun datom -> + ( datom_key eavt datom + , Datascript_index_codec.encode_index_value Eavt datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let aevt_entries = + datoms + |> List.map (fun datom -> + ( datom_key aevt datom + , Datascript_index_codec.encode_index_value Aevt datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let tave_entries = + datoms + |> List.map (fun datom -> + ( datom_key tave datom + , Datascript_index_codec.encode_index_value Tave datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + let avet_entries = + datoms + |> List.filter (fun datom -> is_avet datom.a) + |> List.map (fun datom -> + ( datom_key avet_index datom + , Datascript_index_codec.encode_index_value Avet datom )) + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + in + Datascript_sqlite_db.with_bulk_write_txn eavt.db (fun () -> + Datascript_sqlite_db.put_index_entries_txn Eavt eavt.db eavt_entries; + Datascript_sqlite_db.put_index_entries_txn Aevt eavt.db aevt_entries; + Datascript_sqlite_db.put_index_entries_txn Tave eavt.db tave_entries; + Datascript_sqlite_db.put_index_entries_txn Avet eavt.db avet_entries); (eavt, aevt, avet_index)) let append_datoms datoms t = write_datoms t datoms @@ -269,57 +345,167 @@ let find_first_slice ?from_ ?to_ ?cmp t = let fold_attr_prefix f init t attr = fold_attr_exact_prefix f init t attr -let materialize_range t ?from_ ?to_ cmp = - fold_slice (fun acc datom -> datom :: acc) [] ?from_ ?to_ ~cmp t |> List.rev +let make_seq cmp stream = { cmp; stream; seek_bound = None } + +let to_seq seq = + match seq.seek_bound with + | None -> seq.stream + | Some bound -> Seq.drop_while (fun datom -> seq.cmp datom bound < 0) seq.stream + +let map_kv_to_datoms t seq = + Seq.map (fun (key, value) -> decode_entry t.which key value) seq + +let stream_attr_exact_prefix t attr = + let prefix = attr ^ "\000" in + Datascript_sqlite_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) -let make_seq cmp datoms = { cmp; datoms; offset = 0 } +let stream_attr_value_exact_prefix t attr value = + let prefix = Datascript_index_codec.encode_index_attr_value_prefix t.which attr value in + Datascript_sqlite_db.seq_index_prefix t.which t.db prefix () + |> map_kv_to_datoms t -let to_seq ({ cmp = _; datoms; offset = start }) = - let rec loop index () = - if index >= List.length datoms then Seq.Nil - else Seq.Cons (List.nth datoms index, loop (index + 1)) +let stream_avet_value_range t attr ?start_value ?stop_value () = + let from_key = + match start_value with + | Some value -> Datascript_index_codec.encode_index_attr_value_prefix Avet attr value + | None -> avet_attr_prefix attr in - loop start + Datascript_sqlite_db.seq_index_range_until Avet t.db ~from_key + ~stop:(fun key _value -> + if Datascript_index_codec.avet_key_attr key <> attr then true + else + match stop_value with + | None -> false + | Some stop -> + Datascript_types.Compare.compare_value (Datascript_index_codec.avet_key_value key) stop + > 0) + () + |> Seq.map (fun (key, _value) -> Datascript_index_codec.decode_avet_key_at attr key) -let seq t = make_seq (cmp_for t.which) (to_list t) +let stream_bounded t ?from_ ?to_ cmp = + match bound_key t from_ with + | None -> + Datascript_sqlite_db.seq_index_range_until t.which t.db () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + | Some from_key -> + Datascript_sqlite_db.seq_index_range_until t.which t.db ~from_key + ~stop:(fun key value -> + match to_ with + | Some bound -> + let datom = decode_entry t.which key value in + cmp datom bound > 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp from_ to_ datom) + +let stream_slice ?from_ ?to_ ~cmp t = + match t.which, avet_value_range_bounds from_ to_ with + | Avet, Some (attr, start_value, stop_value) -> + stream_avet_value_range t attr ?start_value:start_value ?stop_value:stop_value () + | _ -> ( + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix t attr + | None -> ( + match attr_value_exact_prefix from_ to_ with + | Some (attr, value) -> stream_attr_value_exact_prefix t attr value + | None -> stream_bounded t ?from_ ?to_ cmp)) + +let seq t = make_seq (cmp_for t.which) (stream_bounded t (cmp_for t.which)) let slice_seq ?from_ ?to_ ?cmp t = let cmp = Option.value ~default:(cmp_for t.which) cmp in - make_seq cmp (materialize_range t ?from_ ?to_ cmp) + make_seq cmp (stream_slice ?from_ ?to_ ~cmp t) -let rslice_seq ?from_ ?to_ ?cmp t = - let cmp = Option.value ~default:(cmp_for t.which) cmp in - (* from_ is the upper (hi) bound for rslice; to_ is the lower bound. *) - let datoms = ref [] in - let hi_key = bound_key t from_ in - Datascript_sqlite_db.fold_index_range_desc_until t.which t.db ?hi_key +let stream_rslice_desc t ~cmp ?from_ ?to_ () = + (* from_ is the upper (hi) bound for rslice; to_ is the lower bound. + Use datom-level bounds (not key<=hi_key alone): prefix bounds encode e=0 and + would drop matching datoms under a strict key comparison. *) + Datascript_sqlite_db.seq_index_range_desc_until t.which t.db ~stop:(fun key value -> - match to_ with - | None -> false - | Some bound -> - let datom = decode_entry t.which key value in - cmp datom bound < 0) - (fun key value -> let datom = decode_entry t.which key value in - if in_range cmp to_ from_ datom then datoms := datom :: !datoms); - (* fold visits DESC; cons builds ascending then rev restores descending order. *) - make_seq cmp (List.rev !datoms) + let under_hi = + match from_ with + | None -> true + | Some bound -> cmp datom bound <= 0 + in + under_hi + && + match to_ with + | Some bound -> cmp datom bound < 0 + | None -> false) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> in_range cmp to_ from_ datom) + +let stream_attr_exact_prefix_desc t attr = + (* Exclusive end of attr\0… keys is attr\001 when the separator is \000. *) + let hi_key = attr ^ "\001" in + Datascript_sqlite_db.seq_index_range_desc_until t.which t.db ~hi_key + ~stop:(fun key _value -> + let prefix = attr ^ "\000" in + let prefix_len = String.length prefix in + String.length key < prefix_len || String.sub key 0 prefix_len <> prefix) + () + |> map_kv_to_datoms t + |> Seq.filter (fun datom -> datom.a = attr) + +let rslice_seq ?from_ ?to_ ?cmp t = + let cmp = Option.value ~default:(cmp_for t.which) cmp in + let stream = + match attr_exact_prefix from_ to_ t.which with + | Some attr -> stream_attr_exact_prefix_desc t attr + | None -> stream_rslice_desc t ~cmp ?from_ ?to_ () + in + make_seq cmp stream let seq_to_list seq = to_seq seq |> List.of_seq -let fold_seq f init { cmp = _; datoms; offset } = - let rec loop index acc = - if index >= List.length datoms then acc - else loop (index + 1) (f acc (List.nth datoms index)) - in - loop offset init +let fold_seq f init seq = Seq.fold_left f init (to_seq seq) let slice ?from_ ?to_ ?cmp t = slice_seq ?from_ ?to_ ?cmp t |> seq_to_list -let seek bound seq = - let rec count index = - if index >= List.length seq.datoms then index - else if seq.cmp (List.nth seq.datoms index) bound >= 0 then index - else count (index + 1) - in - { seq with offset = count 0 } +let seek bound seq = { seq with seek_bound = Some bound } + +(** Fold TAVE keys with [tx > from_tx], optionally restricted to [attr]. *) +let fold_tave_range f init db ~from_tx ?to_tx ?attr () = + let from_key = Datascript_index_codec.encode_tave_tx_prefix (from_tx + 1) in + let acc = ref init in + Datascript_sqlite_db.fold_index_range_until Tave db ~from_key + ~stop:(fun key _value -> + match to_tx with + | Some hi -> Datascript_index_codec.tave_key_tx key > hi + | None -> false) + (fun key value -> + let datom = decode_entry Tave key value in + let attr_ok = + match attr with + | None -> true + | Some a -> datom.a = a + in + let tx_ok = + datom.tx > from_tx + && (match to_tx with None -> true | Some hi -> datom.tx <= hi) + in + if attr_ok && tx_ok then acc := f !acc datom); + !acc + +(** Delete TAVE keys with [tx <= before_tx] (rolling retention). *) +let prune_tave_before db ~before_tx = + if before_tx < 0 then () + else + let to_delete = ref [] in + let stop_key = Datascript_index_codec.encode_tave_tx_prefix (before_tx + 1) in + Datascript_sqlite_db.fold_index_range_until Tave db + ~stop:(fun key _ -> key >= stop_key) + (fun key _value -> + if Datascript_index_codec.tave_key_tx key <= before_tx then + to_delete := key :: !to_delete); + if !to_delete <> [] then + Datascript_sqlite_db.with_write_txn db (fun () -> + List.iter + (fun key -> Datascript_sqlite_db.remove_index_txn Tave db key) + !to_delete) diff --git a/sqlite/datascript_sqlite_index.mli b/sqlite/datascript_sqlite_index.mli index 26d5b6d..e5f02e3 100644 --- a/sqlite/datascript_sqlite_index.mli +++ b/sqlite/datascript_sqlite_index.mli @@ -33,3 +33,7 @@ val seq_to_list : datom seq -> datom list val fold_seq : ('acc -> datom -> 'acc) -> 'acc -> datom seq -> 'acc val to_seq : datom seq -> datom Seq.t val seek : datom -> datom seq -> datom seq +val fold_tave_range : + ('acc -> datom -> 'acc) -> 'acc -> Datascript_sqlite_db.t -> from_tx:tx -> ?to_tx:tx -> ?attr:string + -> unit -> 'acc +val prune_tave_before : Datascript_sqlite_db.t -> before_tx:tx -> unit diff --git a/storage/melange/datascript_storage_lmdb.ml b/storage/melange/datascript_storage_lmdb.ml index ecce615..a00cdee 100644 --- a/storage/melange/datascript_storage_lmdb.ml +++ b/storage/melange/datascript_storage_lmdb.ml @@ -19,4 +19,4 @@ let sync_indexes from_lmdb to_lmdb = List.iter (fun index -> Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) - [ Eavt; Aevt; Avet ]) + [ Eavt; Aevt; Avet; Tave ]) diff --git a/storage/melange/datascript_storage_protocol.ml b/storage/melange/datascript_storage_protocol.ml index 31bb93d..303390f 100644 --- a/storage/melange/datascript_storage_protocol.ml +++ b/storage/melange/datascript_storage_protocol.ml @@ -56,7 +56,9 @@ let memory_backend lmdb = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave; + remove Tave in let load_indexes_from_storage target_lmdb = if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb @@ -130,7 +132,9 @@ let backend_of_lmdb lmdb = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave; + remove Tave in let load_indexes_from_storage target_lmdb = if lmdb != target_lmdb then Datascript_storage_lmdb.sync_indexes lmdb target_lmdb diff --git a/storage/native/datascript_storage_lmdb.ml b/storage/native/datascript_storage_lmdb.ml index ecce615..a00cdee 100644 --- a/storage/native/datascript_storage_lmdb.ml +++ b/storage/native/datascript_storage_lmdb.ml @@ -19,4 +19,4 @@ let sync_indexes from_lmdb to_lmdb = List.iter (fun index -> Datascript_lmdb_db.copy_index_txn index txn from_lmdb to_lmdb) - [ Eavt; Aevt; Avet ]) + [ Eavt; Aevt; Avet; Tave ]) diff --git a/storage/native/datascript_storage_protocol.ml b/storage/native/datascript_storage_protocol.ml index 4997bc0..3965573 100644 --- a/storage/native/datascript_storage_protocol.ml +++ b/storage/native/datascript_storage_protocol.ml @@ -64,7 +64,8 @@ let memory_backend lmdb = in remove Eavt; remove Aevt; - remove Avet + remove Avet; + remove Tave in let load_indexes_from_storage target = match target with diff --git a/test/dune b/test/dune index 38fe3bc..1c44e07 100644 --- a/test/dune +++ b/test/dune @@ -171,6 +171,16 @@ (modules test_lmdb_package) (libraries datascript-ocaml-native datascript-ocaml-native-lmdb test_support alcotest)) +(test + (name test_index_scan_backends) + (modules test_index_scan_backends) + (libraries + datascript-ocaml-native + datascript-ocaml-native-sqlite + datascript-ocaml-native-lmdb + test_support + alcotest)) + (test (name test_melange_transit_backend) (modules test_melange_transit_backend) @@ -290,5 +300,3 @@ %{dep:cross_runtime_parity_test.sh} %{dep:cross_runtime_ocaml.exe} %{dep:../script/cross_runtime_upstream.js}))) - - diff --git a/test/test_db.ml b/test/test_db.ml index 02e62d3..aa6ab74 100644 --- a/test/test_db.ml +++ b/test/test_db.ml @@ -201,7 +201,8 @@ let test_db__test_indexes_use_lmdb () = in assert_uses_lmdb_index db.eavt_index; assert_uses_lmdb_index db.aevt_index; - assert_uses_lmdb_index db.avet_index + assert_uses_lmdb_index db.avet_index; + assert_uses_lmdb_index db.tave_index let test_db__test_index_lookup_matches_upstream_numeric_comparator_bounds () = let db = diff --git a/test/test_entity.ml b/test/test_entity.ml index 5326282..a80a6ab 100644 --- a/test/test_entity.ml +++ b/test/test_entity.ml @@ -312,6 +312,8 @@ let test_entity__test_entity_attr_lookup_is_lazy () = in let context : Entity.context = { datoms_by_entity = (fun db entity_id -> datoms_seq db Eavt ~e:entity_id ()) + ; datoms_by_entity_attr = + (fun db entity_id attr -> datoms_seq db Eavt ~e:entity_id ~a:attr ()) ; datoms_by_avet_ref = (fun db attr entity_id -> datoms_seq db Avet ~a:attr ~v:(Ref entity_id) ()) ; all_datoms = (fun db -> diff --git a/test/test_index_scan_backends.ml b/test/test_index_scan_backends.ml new file mode 100644 index 0000000..dfd007e --- /dev/null +++ b/test/test_index_scan_backends.ml @@ -0,0 +1,157 @@ +(* Seek / rseek / datoms parity across memory (LMDB temp), file LMDB, and SQLite. + Hot paths must stay lazy-capable on every Share backend. *) + +open Alcotest +open Datascript + +let check_bool = Test_alcotest_support.check_bool + +let temp_path name ext = + let path = Filename.temp_file name ext in + Sys.remove path; + path + +let indexed = + { cardinality = One + ; unique = None + ; indexed = true + ; is_component = false + ; no_history = false + ; doc = None + ; value_type = None + ; tuple_attrs = None + ; tuple_types = None + } + +let many_indexed = { indexed with cardinality = Many } + +let schema = [ "likes", many_indexed; "name", indexed; "age", indexed ] + +(* Use string ages so Share index codecs (float-encoded numbers) do not change + the observed value type vs bare memory LMDB temp. *) +let seed_ops = + [ Add (Entity_id 1, "likes", String "fries") + ; Add (Entity_id 1, "likes", String "pizza") + ; Add (Entity_id 1, "name", String "Ivan") + ; Add (Entity_id 2, "likes", String "pie") + ; Add (Entity_id 2, "age", String "25") + ; Add (Entity_id 3, "age", String "11") + ; Add (Entity_id 3, "name", String "Sergey") + ] + +let triples seq = List.map (fun d -> d.e, d.a, d.v) (List.of_seq seq) + +let expect_triples label expected actual = + let got = triples actual in + if expected <> got then + let fmt rows = + rows + |> List.map (fun (e, a, v) -> + Printf.sprintf + "(%d,%s,%s)" + e + a + (match v with + | String s -> Printf.sprintf "%S" s + | Int n -> string_of_int n + | Float f -> string_of_float f + | _ -> "?")) + |> String.concat "; " + in + failwith (Printf.sprintf "%s: expected [%s], got [%s]" label (fmt expected) (fmt got)) + +let assert_scan_suite label db = + expect_triples + (label ^ " rseek eavt from likes/pizza") + [ 1, "likes", String "pizza"; 1, "likes", String "fries" ] + (rseek_datoms db Eavt ~e:1 ~a:"likes" ~v:(String "pizza") ()); + expect_triples + (label ^ " seek eavt from likes/pizza") + [ 1, "likes", String "pizza" + ; 1, "name", String "Ivan" + ; 2, "age", String "25" + ; 2, "likes", String "pie" + ; 3, "age", String "11" + ; 3, "name", String "Sergey" + ] + (seek_datoms db Eavt ~e:1 ~a:"likes" ~v:(String "pizza") ()); + expect_triples + (label ^ " datoms avet age exact") + [ 3, "age", String "11" ] + (datoms db Avet ~a:"age" ~v:(String "11") ()); + expect_triples + (label ^ " rseek avet age attr") + [ 2, "age", String "25"; 3, "age", String "11" ] + (rseek_datoms db Avet ~a:"age" ()); + (match Seq.uncons (rseek_datoms db Avet ~a:"age" ()) with + | Some (d, _) -> + check_bool (label ^ " rseek age first is 25") true (d.e = 2 && d.v = String "25") + | None -> failwith (label ^ " rseek age empty")); + (match Seq.uncons (datoms db Eavt ~e:1 ()) with + | Some (d, _) -> check_bool (label ^ " eavt entity first") true (d.e = 1) + | None -> failwith (label ^ " eavt entity empty")) + +let with_memory f = + let db = db_with seed_ops (empty_db ~schema ()) in + f "memory" db + +let with_memory_storage f = + let storage = memory_storage () in + let db = db_with seed_ops (empty_db ~schema ~storage ()) in + store db; + match restore storage with + | Some db -> f "memory_storage" db + | None -> failwith "memory_storage restore failed" + +let with_lmdb_file f = + let path = temp_path "index-scan-lmdb" ".mdb" in + let session = Datascript_lmdb.open_session path in + Fun.protect + ~finally:(fun () -> + Datascript_lmdb.close session; + if Sys.file_exists path then Sys.remove path; + let lock = path ^ "-lock" in + if Sys.file_exists lock then Sys.remove lock) + (fun () -> + let storage = storage_of_handle (Datascript_lmdb.storage session) in + let db = db_with seed_ops (empty_db ~schema ~storage ()) in + store db; + match restore storage with + | Some db -> f "lmdb_file" db + | None -> failwith "lmdb restore failed") + +let with_sqlite_file f = + let path = temp_path "index-scan-sqlite" ".sqlite" in + let session = Datascript_sqlite.open_session path in + Fun.protect + ~finally:(fun () -> + Datascript_sqlite.close session; + if Sys.file_exists path then Sys.remove path; + List.iter + (fun suffix -> + let sibling = path ^ suffix in + if Sys.file_exists sibling then Sys.remove sibling) + [ "-wal"; "-shm" ]) + (fun () -> + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db = db_with seed_ops (empty_db ~schema ~storage ()) in + store db; + match restore storage with + | Some db -> f "sqlite_file" db + | None -> failwith "sqlite restore failed") + +let test_memory () = with_memory assert_scan_suite +let test_memory_storage () = with_memory_storage assert_scan_suite +let test_lmdb_file () = with_lmdb_file assert_scan_suite +let test_sqlite_file () = with_sqlite_file assert_scan_suite + +let () = + run + "index scan backends" + [ ( "lazy seek/rseek/datoms" + , [ test_case "memory (LMDB temp)" `Quick test_memory + ; test_case "memory_storage" `Quick test_memory_storage + ; test_case "lmdb file" `Quick test_lmdb_file + ; test_case "sqlite file" `Quick test_sqlite_file + ] ) + ] diff --git a/test/test_query_exec_parity.ml b/test/test_query_exec_parity.ml index 7df31a8..de7e69f 100644 --- a/test/test_query_exec_parity.ml +++ b/test/test_query_exec_parity.ml @@ -204,6 +204,18 @@ let fused_cases = ; expect_path = Fused_execute ; expect_fused_plan = true } + ; { name = "qpred1" + ; query = "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } + ; { name = "q-pred-range" + ; query = "[:find ?e ?s :where [?e :salary ?s] [(> ?s 50000)] [(< ?s 80000)]]" + ; inputs = [] + ; expect_path = Fused_execute + ; expect_fused_plan = true + } ] let fallback_cases = diff --git a/test/test_sqlite_package.ml b/test/test_sqlite_package.ml index e7fe9e8..ec76561 100644 --- a/test/test_sqlite_package.ml +++ b/test/test_sqlite_package.ml @@ -136,6 +136,38 @@ let test_temporal_views () = Test_alcotest_support.check_int_list "sqlite history ages" [ 30; 31 ] hist_ages; Datascript_sqlite.close session +let test_tave_since_attr_scan () = + let path = temp_db_path "datascript-sqlite-tave" in + let session = Datascript_sqlite.open_session path in + let storage = storage_of_handle (Datascript_sqlite.storage session) in + let db = empty_db ~schema:[ "name", indexed; "age", age_indexed ] ~storage () in + let r1 = + transact ~tx_meta:[ "db/txInstant", Instant 1_000 ] + db + [ Add (Temp_id "a", "name", String "Alice"); Add (Temp_id "a", "age", Int 20) ] + in + let tx1 = r1.db_after.max_tx in + let r2 = + transact ~tx_meta:[ "db/txInstant", Instant 2_000 ] + r1.db_after + [ Add (Temp_id "b", "name", String "Bob"); Add (Temp_id "b", "age", Int 30) ] + in + store ~storage r2.db_after; + (* since tx1: only Bob's age should appear via since-bounded AEVT (TAVE path). *) + let ages = + datoms (since tx1 r2.db_after) Aevt ~a:"age" () + |> List.filter (fun d -> d.added) + |> List.map (fun d -> match d.v with Int n -> n | _ -> -1) + in + Test_alcotest_support.check_int_list "since+AEVT ages via TAVE" [ 30 ] ages; + set_tave_retention_days 30; + check (Alcotest.int) "default retention days" 30 (tave_retention_days ()); + set_tave_retention_days 7; + check (Alcotest.int) "adjusted retention days" 7 (tave_retention_days ()); + set_tave_retention_days 30; + prune_tave_to_retention r2.db_after; + Datascript_sqlite.close session + let () = run "sqlite package" [ @@ -145,5 +177,6 @@ let () = ; test_case "session close blocks use" `Quick test_session_close_blocks_use ; test_case "reopen preserves data" `Quick test_reopen_preserves_data ; test_case "temporal views" `Quick test_temporal_views + ; test_case "tave since attr scan" `Quick test_tave_since_attr_scan ] ) ] diff --git a/type/datascript_types.ml b/type/datascript_types.ml index 43b1e67..c7c76b9 100644 --- a/type/datascript_types.ml +++ b/type/datascript_types.ml @@ -121,6 +121,7 @@ and db = ; eavt_index : index_set ; aevt_index : index_set ; avet_index : index_set + ; tave_index : index_set ; aevt_by_attr : (attr, datom array) Hashtbl.t ; avet_by_attr : (attr, datom array) Hashtbl.t ; avet_entities_by_attr_value : (attr * value, entity_id array) Hashtbl.t @@ -502,6 +503,9 @@ type index = | Eavt | Aevt | Avet + | Tave + (** Tx-ordered covering index: [tx | a | v | e | added]. Rolling window only + (see TAVE retention); not a substitute for EAVT/AEVT/AVET. *) type tx_meta = (attr * value) list @@ -819,4 +823,11 @@ module Compare = struct (compare_value left.v right.v) (compare left.e right.e) (compare left.tx right.tx)) + | Tave -> + tiebreak_added + (first_nonzero4 + (compare left.tx right.tx) + (compare left.a right.a) + (compare_value left.v right.v) + (compare left.e right.e)) end