diff --git a/impl/datascript.ml b/impl/datascript.ml index b853d84..d845a44 100644 --- a/impl/datascript.ml +++ b/impl/datascript.ml @@ -52,7 +52,37 @@ let normalize_datom_for_schema = Db_impl.normalize_datom_for_schema let refresh_db_indexes = Db_impl.refresh_indexes let refresh_db_indexes_with_added_datoms = Db_impl.refresh_indexes_with_added_datoms -let refresh_db_indexes_with_tx_data = Db_impl.refresh_indexes_with_tx_data + +(* Shared per-transaction memo (see Transact.tx_memo); populated through the + memo-aware refresh_db_indexes_with_tx_data below and consulted by + add_active_datom_with_report_db. Only read while apply_tx has it active. *) +let transact_tx_memo : Transact.tx_memo = + { active = false; base_max_eid = 0; datoms = Hashtbl.create 8 } + +let tx_memo_apply tx_data = + if transact_tx_memo.active then + List.iter + (fun d -> + if d.e > transact_tx_memo.base_max_eid + && d.e <= Db_impl.max_allocatable_entity_id + then + let key = d.e, d.a in + let bucket = + Option.value (Hashtbl.find_opt transact_tx_memo.datoms key) + ~default:[] + in + let bucket = + if d.added then d :: bucket + else + List.filter (fun x -> Util.compare_value x.v d.v <> 0) bucket + in + Hashtbl.replace transact_tx_memo.datoms key bucket) + tx_data + +let refresh_db_indexes_with_tx_data db tx_data = + let db = Db_impl.refresh_indexes_with_tx_data db tx_data in + tx_memo_apply tx_data; + db let empty_db ?(schema = []) ?storage () = Db_impl.empty_db db_core_context ~schema ?storage () @@ -485,8 +515,27 @@ let add_active_datom_with_report_db ?(allow_tuple = false) ?(validate_value = tr | Some existing when existing.e <> d.e -> invalid_arg "unique constraint" | Some _ | None -> ()); + (* tx-fresh entities (e allocated inside this transaction) cannot exist + in the pre-tx index, so their same-fact and entity/attr lookups are + answered from the tx memo instead of descending the index trees. *) + (* Transaction entities live above max_allocatable_entity_id and can + already carry index datoms from earlier transactions, so they are + never memo-fresh. *) + let tx_fresh_bucket = + if transact_tx_memo.active && d.e > transact_tx_memo.base_max_eid + && d.e <= Db_impl.max_allocatable_entity_id + then + Some + (Option.value + (Hashtbl.find_opt transact_tx_memo.datoms (d.e, d.a)) + ~default:[]) + else None + in let same_fact_exists = - find_eavt_exact db d.e d.a d.v |> Option.is_some + match tx_fresh_bucket with + | Some bucket -> + List.exists (fun existing -> compare_value existing.v d.v = 0) bucket + | None -> find_eavt_exact db d.e d.a d.v |> Option.is_some in if same_fact_exists then db, [] @@ -494,7 +543,13 @@ let add_active_datom_with_report_db ?(allow_tuple = false) ?(validate_value = tr let tx_data = match cardinality schema_db d.a with | Many -> [ d ] - | One -> sorted_retractions tx (entity_attr_datoms_db db d.e d.a) @ [ d ] + | One -> + let existing = + match tx_fresh_bucket with + | Some bucket -> bucket + | None -> entity_attr_datoms_db db d.e d.a + in + sorted_retractions tx existing @ [ d ] in (* Index decisions use schema_db (the current schema, which may have been updated by schema datoms earlier in this transaction); the working db @@ -755,6 +810,7 @@ let transact_apply_context : Transact_impl.apply_context = ; refresh_db_indexes_with_added_datoms ; refresh_db_indexes_with_tx_data ; refresh_db_identity + ; tx_memo = transact_tx_memo } let apply_tx tx_ops db = diff --git a/impl/schema.ml b/impl/schema.ml index a924ad5..54bee52 100644 --- a/impl/schema.ml +++ b/impl/schema.ml @@ -47,15 +47,35 @@ let schema_attr_is_tuple = function | Some { tuple_attrs = Some _; _ } -> true | _ -> false +(* Schema assoc lists are immutable, so physical equality on the list is a + valid staleness check: any schema update produces a new list (same trick + as Schema_access.schema_attr). This runs once per index datom insert, so + the per-schema result is precomputed for every attr instead of scanned. *) +let avet_tbl_schema : schema ref = ref [] +let avet_tbl : (attr, bool) Hashtbl.t ref = ref (Hashtbl.create 0) + let schema_attr_is_avet_accessible schema attr = - attr = "db/ident" - || schema_attr_is_tuple (schema_attr_by_name schema attr) - || - match schema_attr_by_name schema attr with - | Some { value_type = Some RefType; _ } - | Some { unique = Some _; _ } - | Some { indexed = true; _ } -> true - | _ -> false + if attr = "db/ident" then true + else begin + if not (schema == !avet_tbl_schema) then begin + let tbl = Hashtbl.create (List.length schema) in + List.iter + (fun (attr, spec) -> + if not (Hashtbl.mem tbl attr) then + Hashtbl.add tbl attr + (schema_attr_is_tuple (Some spec) + || + match spec with + | { value_type = Some RefType; _ } + | { unique = Some _; _ } + | { indexed = true; _ } -> true + | _ -> false)) + schema; + avet_tbl := tbl; + avet_tbl_schema := schema + end; + Option.value (Hashtbl.find_opt !avet_tbl attr) ~default:false + end let schema_has_no_history schema attr = match List.assoc_opt attr schema with diff --git a/impl/transact.ml b/impl/transact.ml index f9aa8b2..9f8939c 100644 --- a/impl/transact.ml +++ b/impl/transact.ml @@ -396,6 +396,20 @@ let remap_tempid_entity old_e new_e tempids = } +(* Per-transaction memo of datoms added to entities allocated inside this + transaction (base_max_eid < e <= max_allocatable_entity_id): they cannot + exist in the pre-tx index, so same-fact and entity/attr lookups for them + can be answered from this table instead of descending the index trees. + Bulk seed transactions (imports) consist almost entirely of such datoms. + Transaction entities (e >= tx0) are excluded: they are ids, not freshly + allocated entities, and may already carry index datoms from earlier + transactions. *) +type tx_memo = + { mutable active : bool + ; mutable base_max_eid : entity_id + ; datoms : (entity_id * attr, datom list) Hashtbl.t + } + type apply_context = { resolve_context : context ; is_filtered : db -> bool @@ -430,10 +444,38 @@ type apply_context = ; refresh_db_indexes_with_added_datoms : db -> datom list -> db ; refresh_db_indexes_with_tx_data : db -> datom list -> db ; refresh_db_identity : db -> db + ; tx_memo : tx_memo } let apply_tx context tx_ops db = if context.is_filtered db then invalid_arg "filtered db is read-only"; + let tx_memo = context.tx_memo in + (* The memo record is shared by every transaction, so a nested transaction + (a Call fn that transacts) or an exception raised mid-tx must not leak + this transaction's state into the outer one: save any enclosing state + and restore it when this transaction ends or aborts. *) + let saved_memo = + if tx_memo.active then + Some (tx_memo.base_max_eid, Hashtbl.copy tx_memo.datoms) + else None + in + let restore_memo () = + match saved_memo with + | Some (base_max_eid, datoms) -> + Hashtbl.reset tx_memo.datoms; + Hashtbl.iter (Hashtbl.replace tx_memo.datoms) datoms; + tx_memo.base_max_eid <- base_max_eid + | None -> + (* The outermost transaction is over: the memo table is dead state + until the next transaction and would otherwise retain every datom + of the transaction that just ran. *) + tx_memo.active <- false; + Hashtbl.reset tx_memo.datoms + in + Fun.protect ~finally:restore_memo @@ fun () -> + tx_memo.base_max_eid <- db.max_eid; + Hashtbl.reset tx_memo.datoms; + tx_memo.active <- true; (* Mid-tx schema refresh is incremental: schema datoms appended to tx_data are recorded here and each refresh folds only the entities touched by the datoms seen since the previous refresh, instead of rescanning all @@ -1851,24 +1893,27 @@ let apply_tx context tx_ops db = ; tx_fns = !current_tx_fns } in - ( (match fast_tx_data with - | Some _ -> - db_after - |> (fun db -> context.refresh_db_indexes_with_tx_data db tx_data) - |> context.refresh_db_identity - | None -> - db_after - |> (fun db -> - if List.exists tx_op_affects_schema tx_ops then - { datoms with - schema = db.schema - ; max_eid = db.max_eid - ; max_tx = db.max_tx - ; tx_fns = db.tx_fns - } - else - context.refresh_db_indexes_with_tx_data db tx_data) - |> context.refresh_db_identity) - , tempid_map_order tempids - , tx_data - ) + let result = + ( (match fast_tx_data with + | Some _ -> + db_after + |> (fun db -> context.refresh_db_indexes_with_tx_data db tx_data) + |> context.refresh_db_identity + | None -> + db_after + |> (fun db -> + if List.exists tx_op_affects_schema tx_ops then + { datoms with + schema = db.schema + ; max_eid = db.max_eid + ; max_tx = db.max_tx + ; tx_fns = db.tx_fns + } + else + context.refresh_db_indexes_with_tx_data db tx_data) + |> context.refresh_db_identity) + , tempid_map_order tempids + , tx_data + ) + in + result diff --git a/impl/transact.mli b/impl/transact.mli index 487c04a..31ebce7 100644 --- a/impl/transact.mli +++ b/impl/transact.mli @@ -48,6 +48,18 @@ val remap_datom_entity : context -> entity_id -> entity_id -> datom -> datom val remap_resolved_tx_value : context -> entity_id -> entity_id -> tx_value -> tx_value val remap_tempid_entity : entity_id -> entity_id -> tempid_map -> tempid_map +(* Per-transaction memo of datoms added to entities allocated inside this + transaction (base_max_eid < e <= max_allocatable_entity_id): they cannot + exist in the pre-tx index, so same-fact and entity/attr lookups for them + can be answered from this table instead of descending the index trees. + Transaction entities (e >= tx0) are excluded: they may already carry + index datoms from earlier transactions. *) +type tx_memo = + { mutable active : bool + ; mutable base_max_eid : entity_id + ; datoms : (entity_id * attr, datom list) Hashtbl.t + } + type apply_context = { resolve_context : context ; is_filtered : db -> bool @@ -82,6 +94,7 @@ type apply_context = ; refresh_db_indexes_with_added_datoms : db -> datom list -> db ; refresh_db_indexes_with_tx_data : db -> datom list -> db ; refresh_db_identity : db -> db + ; tx_memo : tx_memo } val apply_tx : apply_context -> tx_op list -> db -> db * (string * entity_id) list * datom list diff --git a/impl/util.ml b/impl/util.ml index 9e7c7b0..5880185 100644 --- a/impl/util.ml +++ b/impl/util.ml @@ -110,37 +110,44 @@ let split_keyword keyword = let name = String.sub keyword (index + 1) (String.length keyword - index - 1) in namespace, name -(* compare [off..off+len) slices of two strings without allocation *) -let compare_slice (s : string) (soff : int) (slen : int) (t : string) - (toff : int) (tlen : int) : int = - let rec loop i = - if i >= slen && i >= tlen then 0 - else if i >= slen then -1 - else if i >= tlen then 1 - else - let c = Char.compare s.[soff + i] t.[toff + i] in - if c <> 0 then c else loop (i + 1) - in - loop 0 - (* Upstream compares attr keywords with compare-keywords: no-namespace attrs sort first, otherwise (ns, name) pairwise. Compare with a plain string sort here would order "logseq.property.class/extends" before "logseq.property/built-in?" ('.' < '/'), which both diverges from the runtime index order upstream and writes a leaf order the CLJS storage reader cannot binary-search. - Slice-wise comparison keeps the same order without allocating the - (ns, name) pair for every index compare. *) + + The (ns, name) pairwise order equals a byte compare on a normalized + key: replace the last '/' by '\x00' (or prepend '\x00' when the attr + has no '/'). '\x00' sorts below every byte in an attr and below '/', + so a shorter ns that is a prefix of the other always loses to it, and + a missing ns sorts first — exactly the pairwise order. Keys are + memoized by attr content since index comparators see the same small + set of attrs over and over. *) +(* Bounded: keyword values also flow through compare_attr, so an unlimited + vocabulary would grow this table without bound; past the cap, keys are + recomputed per call. *) +let attr_key_tbl_cap = 65536 +let attr_key_tbl : (attr, attr) Hashtbl.t = Hashtbl.create 256 + +let attr_key attr = + match Hashtbl.find_opt attr_key_tbl attr with + | Some key -> key + | None -> + let key = + match String.rindex_opt attr '/' with + | None -> "\x00" ^ attr + | Some i -> + String.init (String.length attr) (fun j -> + if j = i then '\x00' else attr.[j]) + in + if Hashtbl.length attr_key_tbl < attr_key_tbl_cap then + Hashtbl.replace attr_key_tbl attr key; + key + let compare_attr left right = - let li = match String.rindex_opt left '/' with Some i -> i | None -> -1 in - let ri = match String.rindex_opt right '/' with Some i -> i | None -> -1 in - (* ns = [0, li) for li >= 0 else ""; name = [li+1, len) *) - let c = compare_slice left 0 (max li 0) right 0 (max ri 0) in - if c <> 0 then c - else - let loff, roff = li + 1, ri + 1 in - compare_slice left loff (String.length left - loff) right roff - (String.length right - roff) + if left == right || String.equal left right then 0 + else String.compare (attr_key left) (attr_key right) let rec compare_list_items_with compare_item left right = match left, right with diff --git a/test/test_datascript.ml b/test/test_datascript.ml index 458fdde..bb39c5a 100644 --- a/test/test_datascript.ml +++ b/test/test_datascript.ml @@ -2314,6 +2314,24 @@ let test_transact__test_resolve_current_tx () = [ "db/current-tx", tx0 + 1; "entity", 1 ] report.tempids +let test_transact__test_tx_entity_cardinality () = + (* Datoms on a transaction entity created by an earlier transaction + already live in the index: a cardinality-one update on it in a later + transaction must retract the previous value — tx ids are above + max_allocatable_entity_id, not transaction-fresh entities. *) + let schema = [ "note", indexed ] in + let report1 = + transact (empty_db ~schema ()) [ Add (CurrentTx, "note", String "v1") ] + in + let tx_eid = Option.get (resolve_tempid report1.tempids "db/current-tx") in + let report2 = + transact report1.db_after [ Add (Entity_id tx_eid, "note", String "v2") ] + in + assert_equal_triples + "cardinality-one update on a past tx entity retracts the old value" + [ tx_eid, "note", String "v2" ] + (datoms report2.db_after Eavt ~e:tx_eid ~a:"note" ()) + let test_current_tx_string_aliases_resolve_in_transactions () = let report = transact @@ -17560,6 +17578,7 @@ let () = test_transact_report_exposes_tempids (); test_resolve_tempid_reads_tx_report_tempids (); test_transact__test_resolve_current_tx (); + test_transact__test_tx_entity_cardinality (); test_current_tx_string_aliases_resolve_in_transactions (); test_current_tx_string_aliases_can_be_value_only (); test_current_tx_colon_string_alias_resolves_in_transactions ();