aboutsummaryrefslogtreecommitdiffstats
path: root/bin/bench.ml
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--bin/bench.ml202
1 files changed, 0 insertions, 202 deletions
diff --git a/bin/bench.ml b/bin/bench.ml
deleted file mode 100644
index 8f496f2..0000000
--- a/bin/bench.ml
+++ /dev/null
@@ -1,202 +0,0 @@
-open Relational_engine
-
-(* helpers *)
-
-let time label f =
- let t0 = Unix.gettimeofday () in
- f ();
- let elapsed = Unix.gettimeofday () -. t0 in
- Printf.printf " %-60s %.4f s\n%!" label elapsed
-
-let mk_int (n : int) : Conventions.AbstractValue.t = Obj.magic n
-
-let make_tuple relation pairs =
- let attributes =
- List.fold_left
- (fun acc (k, v) ->
- Tuple.AttributeMap.add k { Attribute.value = mk_int v } acc)
- Tuple.AttributeMap.empty
- pairs
- in
- { Tuple.relation; attributes }
-
-let unwrap label = function
- | Ok v -> v
- | Error _ -> failwith label
-
-let get_rel db name =
- match Manipulation.Memory.get_relation db ~name with
- | Some r -> r
- | None -> failwith ("relation not found: " ^ name)
-
-(* database setup *)
-
-(*
- Schema:
- Department { dept_id }
- Employee { emp_id, dept_id }
-
- Constraint on Employee:
- Exists d in Department, MemberOf Department (dept_id = Var "dept_id")
-
- This is a classic FK: every employee must reference an existing department.
- On the sublanguages branch, deleting a referenced Department triggers a
- cascade re-check of affected Employee tuples and rejects the delete.
- On master (no cascade), the delete succeeds unconditionally.
-*)
-let setup storage ~n_depts ~employees_per_dept =
- let db =
- unwrap "create_database"
- (Manipulation.Memory.create_database storage ~name:"bench")
- in
- let db =
- fst (unwrap "create Department"
- (Manipulation.Memory.create_relation storage db ~name:"Department"
- ~schema:(Schema.empty |> Schema.add "dept_id" "natural")))
- in
- let db =
- fst (unwrap "create Employee"
- (Manipulation.Memory.create_relation storage db ~name:"Employee"
- ~schema:(Schema.empty
- |> Schema.add "emp_id" "natural"
- |> Schema.add "dept_id" "natural")))
- in
- let fk_body =
- Constraint.Exists {
- variable = "d";
- quantifier = "Department";
- body = Constraint.MemberOf {
- target = "Department";
- binding = Constraint.BindingMap.singleton "dept_id" (Constraint.Var "dept_id");
- };
- }
- in
- let db =
- unwrap "register_constraint"
- (Manipulation.Memory.register_constraint storage db
- ~constraint_name:"fk_dept"
- ~relation_name:"Employee"
- ~body:fk_body)
- in
- let dept_tuples =
- List.init n_depts (fun i ->
- make_tuple "Department" [("dept_id", i + 1)])
- in
- let db =
- let (db, _, _) = unwrap "insert departments"
- (Manipulation.Memory.create_tuples storage db
- (get_rel db "Department") dept_tuples)
- in db
- in
- let emp_tuples =
- List.init (n_depts * employees_per_dept) (fun i ->
- make_tuple "Employee" [
- ("emp_id", i + 1);
- ("dept_id", (i mod n_depts) + 1);
- ])
- in
- let db =
- let (db, _, _) = unwrap "insert employees"
- (Manipulation.Memory.create_tuples storage db
- (get_rel db "Employee") emp_tuples)
- in db
- in
- db
-
-(* benchmark cases *)
-
-(*
- Attempt to delete each department that has employees referencing it.
-
- sublanguages: retract_tuple runs the cascade check — uses polarity analysis
- to identify Employee as the constrained relation, then focused_filter to
- narrow the scan to only employees with dept_id = deleted dept_id. Finds a
- match → returns ConstraintViolation. Delete is rejected.
-
- master: no cascade logic; retract_tuple succeeds unconditionally and db
- becomes inconsistent.
-
- db is not threaded through since on sublanguages every delete is rejected
- (db state is unchanged after each Error), and on master we deliberately
- want to measure per-delete cost against a consistent employee set.
-*)
-let bench_retract_referenced storage db ~n_depts =
- let rel = get_rel db "Department" in
- for i = 1 to n_depts do
- let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", i)]) in
- ignore (Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash)
- done
-
-(*
- Delete departments that have NO referencing employees. Neither branch
- needs to scan Employee tuples (focused_filter finds no matches), so this
- measures raw retract_tuple cost: Merkle tree update + storage write.
-
- We thread db through the loop so each delete builds on the previous state
- and only one live tree version accumulates in memory at a time.
-
- Orphan dept ids start at offset to avoid colliding with the employee-owned
- depts (1..n_depts).
-*)
-let bench_retract_unreferenced storage db ~n_depts ~offset =
- let orphan_tuples =
- List.init n_depts (fun i ->
- make_tuple "Department" [("dept_id", offset + i + 1)])
- in
- let db =
- let (db, _, _) = unwrap "insert orphan depts"
- (Manipulation.Memory.create_tuples storage db
- (get_rel db "Department") orphan_tuples)
- in db
- in
- let _db =
- List.fold_left (fun db i ->
- let rel = get_rel db "Department" in
- let hash = Hashing.hash_tuple (make_tuple "Department" [("dept_id", offset + i)]) in
- match Manipulation.Memory.retract_tuple storage db rel ~tuple_hash:hash with
- | Ok (db, _) -> db
- | Error _ -> db)
- db
- (List.init n_depts (fun i -> i + 1))
- in
- ()
-
-(* entry point *)
-
-let () =
- let n_depts = 100 in
- let employees_per_dept = 200 in
- let total_employees = n_depts * employees_per_dept in
-
- Printf.printf "\nSakura constraint benchmark\n";
- Printf.printf " Departments : %d\n" n_depts;
- Printf.printf " Employees/dept : %d (%d total)\n\n"
- employees_per_dept total_employees;
-
- let make_storage () =
- match Management.Physical.Memory.create () with
- | Ok s -> s
- | Error _ -> failwith "create storage"
- in
-
- (* Warmup build — not measured *)
- let storage = make_storage () in
- ignore (setup storage ~n_depts ~employees_per_dept);
-
- (* Fresh storage for measured runs *)
- let storage = make_storage () in
- let db = setup storage ~n_depts ~employees_per_dept in
-
- Printf.printf "Scenarios:\n";
-
- time (Printf.sprintf
- "retract %d referenced depts (cascade check, violations expected)"
- n_depts)
- (fun () -> bench_retract_referenced storage db ~n_depts);
-
- time (Printf.sprintf
- "retract %d unreferenced depts (no matching employees)"
- n_depts)
- (fun () -> bench_retract_unreferenced storage db ~n_depts ~offset:1_000_000);
-
- Printf.printf "\n"
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 06:53:20 +0000