~james/reorder

feat(core): initialise tso checking and fence synthesis

commit
908ea7335d65c52f45e8387f6c42e462b25a624a browse tree
author
james <j@cpl0.zip>
signature
Verified ~james signed with a key registered by ~james
date
2026-10-16 13:37 UTC

33 files changed, +2061 −0

.gitignore added

@@ -0,0 +1,2 @@
1+_build/
2+build/

Makefile added

@@ -0,0 +1,11 @@
1+.PHONY: all check demo
2+
3+all:
4+ dune build @all
5+
6+check:
7+ dune runtest --force --no-buffer
8+
9+demo: all
10+ _build/default/main.exe repair cases/peterson.sexp --out build/repair --animate
11+ _build/default/main.exe contrast build/repair/witness.sexp build/repair/repair.sexp --animate

cases/buffering.sexp added

@@ -0,0 +1,11 @@
1+(case
2+ (name "store buffering")
3+ (names x y)
4+ (bound 8)
5+ (threads
6+ ((store 0 1)
7+ (load 1 0))
8+ ((store 1 1)
9+ (load 0 0)))
10+ (candidates (0 1) (1 1))
11+ (goal (outcome (registers (0 0 0) (1 0 0)) (memory ) (drained false))))

cases/fenced.sexp added

@@ -0,0 +1,13 @@
1+(case
2+ (name "store buffering with explicit fences")
3+ (names x y)
4+ (bound 10)
5+ (threads
6+ ((store 0 1)
7+ (fence)
8+ (load 1 0))
9+ ((store 1 1)
10+ (fence)
11+ (load 0 0)))
12+ (candidates )
13+ (goal (outcome (registers (0 0 0) (1 0 0)) (memory ) (drained false))))

cases/fifo.sexp added

@@ -0,0 +1,11 @@
1+(case
2+ (name "FIFO publication order")
3+ (names x y)
4+ (bound 8)
5+ (threads
6+ ((store 0 1)
7+ (store 1 1))
8+ ((load 1 0)
9+ (load 0 1)))
10+ (candidates )
11+ (goal (outcome (registers (1 0 1) (1 1 0)) (memory ) (drained false))))

cases/forwarding.sexp added

@@ -0,0 +1,11 @@
1+(case
2+ (name "newest buffered store wins")
3+ (names x)
4+ (bound 7)
5+ (threads
6+ ((store 0 1)
7+ (store 0 2)
8+ (load 0 0))
9+ ((move 0 0)))
10+ (candidates )
11+ (goal (outcome (registers (0 0 1)) (memory ) (drained false))))

cases/peterson.sexp added

@@ -0,0 +1,25 @@
1+(case
2+ (name "Peterson mutual exclusion")
3+ (names flag0 flag1 turn)
4+ (bound 14)
5+ (threads
6+ ((store 0 1)
7+ (store 2 1)
8+ (load 1 0)
9+ (branch 0 0 6)
10+ (load 2 1)
11+ (branch 1 1 2)
12+ (enter)
13+ (leave)
14+ (store 0 0))
15+ ((store 1 1)
16+ (store 2 0)
17+ (load 0 0)
18+ (branch 0 0 6)
19+ (load 2 1)
20+ (branch 1 0 2)
21+ (enter)
22+ (leave)
23+ (store 1 0)))
24+ (candidates (0 1) (0 2) (1 1) (1 2))
25+ (goal overlap))

cases/spinlock.sexp added

@@ -0,0 +1,17 @@
1+(case
2+ (name "atomic exchange spinlock")
3+ (names lock)
4+ (bound 14)
5+ (threads
6+ ((exchange 0 0 1)
7+ (branch 0 1 0)
8+ (enter)
9+ (leave)
10+ (store 0 0))
11+ ((exchange 0 0 1)
12+ (branch 0 1 0)
13+ (enter)
14+ (leave)
15+ (store 0 0)))
16+ (candidates )
17+ (goal overlap))

check.ml added

@@ -0,0 +1,168 @@
1+let checks = ref 0
2+let visited = ref 0
3+
4+let require condition message =
5+ if not condition then failwith message;
6+ incr checks
7+
8+let rejects action message =
9+ let failed = try action (); false with Invalid_argument _ | Failure _ -> true in
10+ require failed message
11+
12+let read name = Syntax.load ("cases/" ^ name ^ ".sexp")
13+
14+let laws () =
15+ let source = Layout.generate ~timeout:300000 ^ Store.read "smt/machine.smt2" ^
16+ "\n" ^ Store.read "smt/laws.smt2" in
17+ let answers = Sexp.parse (Solver.script source) in
18+ require (answers = List.init 16 (fun _ -> Sexp.Atom "unsat")) "SMT machine laws";
19+ print_endline "16 SMT machine laws passed"
20+
21+let codec () =
22+ List.iter (fun text ->
23+ let value = Sexp.Atom text in
24+ require (Sexp.one (Sexp.print value) = value) "string round trip")
25+ [""; "hello"; "with spaces"; "a\"b\\c"; "a\nb\tc"; "lambda \206\187"];
26+ List.iter (fun text -> rejects (fun () -> ignore (Sexp.one text)) "malformed expression")
27+ ["("; ")"; "(a"; "\"unfinished"; "a b"; "\"\\z\""];
28+ require (Sexp.word (Sexp.Atom "#xffffffffffffffff") = -1L) "unsigned 64-bit model value";
29+ List.iter (fun name ->
30+ let case = read name in
31+ require (Syntax.decode (Syntax.encode case) = case) "case round trip")
32+ ["buffering"; "forwarding"; "fifo"; "fenced"; "peterson"; "spinlock"]
33+
34+let fixtures () =
35+ List.iter (fun (name, expected) ->
36+ let case = read name in
37+ let result = Engine.check case Syntax.Tso in
38+ let reachable, count = Machine.reachable case Syntax.Tso [] case.bound in
39+ visited := !visited + count;
40+ require ((result.witness <> None) = expected && reachable = expected) ("fixture " ^ name);
41+ Option.iter (fun witness ->
42+ let states, _ = Engine.replay witness in
43+ require (Machine.bad case states.(witness.bound)) "witness final state";
44+ require (List.length (View.frame ~width:148 witness witness.bound) < 52) "trace display height") result.witness;
45+ Printf.printf "%-12s %-5s %5d reference states\n%!" name
46+ (if result.witness = None then "unsat" else "sat") count)
47+ ["buffering", true; "forwarding", false; "fifo", false;
48+ "fenced", false; "peterson", true; "spinlock", false]
49+
50+let differential () =
51+ let random = Random.State.make [|731|] in
52+ let choose n = Random.State.int random n in
53+ let instruction () = match choose 5 with
54+ | 0 -> Syntax.Store (choose 2, Int64.of_int (choose 3))
55+ | 1 -> Syntax.Load (choose 2, choose 2)
56+ | 2 -> Syntax.Move (choose 2, Int64.of_int (choose 3))
57+ | 3 -> Syntax.Fence
58+ | _ -> Syntax.Exchange (choose 2, choose 2, 1L) in
59+ for number = 0 to 17 do
60+ let case = {
61+ Syntax.name=Printf.sprintf "generated%d" number; names=[|"x"; "y"|]; bound=6;
62+ threads=Array.init 2 (fun _ -> Array.init 2 (fun _ -> instruction ()));
63+ candidates=[]; goal=Syntax.Outcome {
64+ registers=[0, 0, Int64.of_int (choose 2); 1, 0, Int64.of_int (choose 2)];
65+ memory=[]; drained=false};
66+ } in
67+ List.iter (fun model ->
68+ let expected, count = Machine.reachable case model [] case.bound in
69+ visited := !visited + count;
70+ let result = Engine.check case model in
71+ require ((result.witness <> None) = expected) "seeded differential query") [Syntax.Sc; Syntax.Tso]
72+ done;
73+ print_endline "36 seeded SMT queries matched exhaustive reference execution"
74+
75+let buffers () =
76+ let stores = Array.init 10 (fun value -> Syntax.Store (0, Int64.of_int value)) in
77+ let case = {Syntax.name="ring wrap"; names=[|"x"|]; bound=22;
78+ threads=[|Array.append stores [|Syntax.Load (0, 0)|]; [|Syntax.Move (0, -1L)|]|];
79+ candidates=[]; goal=Syntax.Outcome {registers=[0, 0, 9L; 1, 0, -1L]; memory=[]; drained=false}} in
80+ List.iter (fun drained ->
81+ let actors = Array.of_list (List.concat (List.init drained (fun _ -> [0; 2])) @
82+ List.init (11 - drained) (fun _ -> 0) @ [1]) in
83+ let result = Engine.check ~bound:(Array.length actors) ~fixed:actors case Syntax.Tso in
84+ require (result.witness <> None) "ring reuse and last buffered write") [9; 10];
85+ let initial = Machine.initial case in
86+ let state = ref initial in
87+ for _ = 0 to 7 do
88+ match Machine.step case Syntax.Tso [] !state 0 with
89+ | Some (next, _) -> state := next | None -> failwith "unexpected full buffer"
90+ done;
91+ require (Machine.step case Syntax.Tso [] !state 0 = None) "full FIFO blocks ninth store";
92+ require (initial.pc = [|0; 0|] && initial.buffers = [|[]; []|]) "transition preserves previous state";
93+ require (Machine.step case Syntax.Tso [] initial 2 = None) "empty FIFO cannot drain"
94+
95+let outcomes () =
96+ let case = read "buffering" in
97+ let sc = Engine.outcomes case Syntax.Sc in
98+ let tso = Engine.outcomes case Syntax.Tso in
99+ require (sc = [0L, 1L; 1L, 0L; 1L, 1L]) "SC outcome enumeration";
100+ require (tso = [0L, 0L; 0L, 1L; 1L, 0L; 1L, 1L]) "TSO outcome enumeration";
101+ print_endline "complete register outcome sets: SC=3, TSO=4"
102+
103+let graph () =
104+ let case = read "peterson" in
105+ let graph = Machine.explore case Syntax.Tso [] in
106+ require (List.length graph.violations > 0) "unfenced graph exposes overlap";
107+ let seen = Hashtbl.create (Array.length graph.states) in
108+ Array.iter (fun state -> Hashtbl.add seen state ()) graph.states;
109+ let edges = ref 0 in
110+ Array.iter (fun state ->
111+ for actor = 0 to 3 do
112+ match Machine.step case Syntax.Tso [] state actor with
113+ | None -> ()
114+ | Some (next, _) -> incr edges; require (Hashtbl.mem seen next) "closed graph successor"
115+ done) graph.states;
116+ require (!edges = graph.edges) "graph edge count";
117+ rejects (fun () -> ignore (Machine.explore ~limit:10 case Syntax.Tso [])) "exploration limit is explicit";
118+ Printf.printf "unfenced graph closed: %d states, %d edges, %d violating states\n%!"
119+ (Array.length graph.states) graph.edges (List.length graph.violations)
120+
121+let validation () =
122+ let case = read "buffering" in
123+ List.iter (fun case -> rejects (fun () -> Syntax.validate case) "invalid case") [
124+ {case with bound=0}; {case with bound=65}; {case with names=[||]};
125+ {case with threads=[||]}; {case with candidates=[0, 9]};
126+ {case with candidates=[0, 1; 0, 1]};
127+ {case with threads=[|[|Syntax.Load (0, 4)|]; case.threads.(1)|]};
128+ {case with threads=[|[|Syntax.Branch (0, 0L, 3)|]; case.threads.(1)|]}];
129+ rejects (fun () -> ignore (Engine.check ~fixed:[|0|] case Syntax.Tso)) "fixed schedule bound mismatch"
130+
131+let repair folder =
132+ let case = read "peterson" in
133+ let report = match Engine.repair case folder with
134+ | Some report -> report | None -> failwith "expected repair" in
135+ require (List.length report.fences = 2) "minimum repair has two fences";
136+ let checked = Engine.audit (Filename.concat folder "repair.sexp") (Filename.concat folder "audit") in
137+ require (report = checked) "repair certificate audit";
138+ List.iter (fun fences ->
139+ let found, _ = Machine.reachable case Syntax.Tso fences case.bound in
140+ require found "every cheaper fence placement still fails") ([] :: List.map (fun location -> [location]) case.candidates);
141+ let graph = Machine.explore case Syntax.Tso report.fences in
142+ require (graph.violations = []) "repaired complete state graph excludes overlap";
143+ let witness = Engine.load_witness (Filename.concat folder "witness.sexp") in
144+ let fixed = Machine.reschedule case report.fences witness.actors in
145+ Engine.validate_schedule case report.fences fixed;
146+ let states, _ = Machine.replay case Syntax.Tso report.fences fixed in
147+ require (not (Machine.bad case states.(Array.length states - 1))) "repaired requested schedule avoids overlap";
148+ rejects (fun () -> ignore (Engine.replay {witness with actors=[|2|]})) "tampered witness rejected";
149+ let unrepairable = {(read "buffering") with candidates=[]} in
150+ require (Engine.repair unrepairable (Filename.concat folder "impossible") = None) "unrepairable case terminates";
151+ Printf.printf "minimum repair checked: 2 fences; repaired graph closed with %d states and no overlap\n%!"
152+ (Array.length graph.states)
153+
154+let () =
155+ let started = Unix.gettimeofday () in
156+ let folder = Filename.concat (Filename.get_temp_dir_name ()) (Printf.sprintf "reorder%d" (Unix.getpid ())) in
157+ Store.mkdir folder;
158+ codec ();
159+ laws ();
160+ fixtures ();
161+ differential ();
162+ buffers ();
163+ outcomes ();
164+ graph ();
165+ validation ();
166+ repair folder;
167+ Printf.printf "%d checks passed; %d bounded reference states; %.1fs\n%!"
168+ !checks !visited (Unix.gettimeofday () -. started)

dune added

@@ -0,0 +1,17 @@
1+(library
2+ (name core)
3+ (wrapped false)
4+ (modules store sexp syntax machine layout solver engine view)
5+ (libraries unix))
6+
7+(executable
8+ (name main)
9+ (public_name reorder)
10+ (modules main)
11+ (libraries core unix))
12+
13+(test
14+ (name check)
15+ (modules check)
16+ (libraries core unix)
17+ (deps (glob_files cases/*.sexp) (glob_files smt/*.smt2)))

dune-project added

@@ -0,0 +1,7 @@
1+(lang dune 3.20)
2+(name reorder)
3+(generate_opam_files true)
4+(package
5+ (name reorder)
6+ (synopsis "Bounded x86-TSO checking and minimum fence synthesis")
7+ (depends (ocaml (>= 5.5))))

engine.ml added

@@ -0,0 +1,241 @@
1+type witness = {
2+ case : Syntax.t;
3+ model : Syntax.model;
4+ bound : int;
5+ fences : Syntax.location list;
6+ actors : int array;
7+}
8+type result = { witness : witness option; query : Solver.query }
9+type phase = Searching of int * Syntax.location list
10+ | Counterexample of witness | Excluded of int | Refining of int
11+ | Verified of Syntax.location list * int * int
12+type repair = {
13+ case : Syntax.t;
14+ fences : Syntax.location list;
15+ clauses : int list list;
16+ rounds : int;
17+ bound : int;
18+ states : int;
19+}
20+
21+let decision = function
22+ | Solver.Unknown reason -> failwith ("solver returned unknown: " ^ reason)
23+ | answer -> answer
24+
25+let verify case model fences bound values =
26+ let rec split count prefix = function
27+ | rest when count = 0 -> List.rev prefix, rest
28+ | value :: rest -> split (count - 1) (value :: prefix) rest
29+ | [] -> failwith "incomplete scheduler model"
30+ in
31+ let actors, observations = split bound [] values in
32+ let actors = Array.of_list (List.map (fun value -> Int64.to_int (Solver.bits value)) actors) in
33+ let states, _ = Machine.replay case model fences actors in
34+ let expected = List.concat (Array.to_list (Array.map Machine.observations states)) in
35+ if List.map Solver.bits observations <> expected then
36+ failwith "solver model disagrees with independent state-by-state replay";
37+ actors, states
38+
39+let witness_sexp (witness : witness) =
40+ let open Sexp in
41+ List [Atom "witness"; List [Atom "version"; i 1];
42+ List [Atom "case"; Syntax.encode witness.case];
43+ List [Atom "model"; a (Syntax.model_name witness.model)];
44+ List [Atom "bound"; i witness.bound];
45+ List (Atom "fences" :: List.map (fun (t, pc) -> List [i t; i pc]) witness.fences);
46+ List (Atom "actors" :: Array.to_list (Array.map i witness.actors))]
47+
48+let fields tag = function
49+ | Sexp.List (Sexp.Atom name :: fields) when name = tag -> fields
50+ | _ -> invalid_arg ("expected " ^ tag)
51+let single key fields = match Sexp.field key fields with
52+ | [value] -> value | _ -> invalid_arg ("invalid field " ^ key)
53+
54+let replay (witness : witness) =
55+ Syntax.validate witness.case;
56+ Syntax.validate {witness.case with candidates=witness.fences};
57+ if witness.bound < 1 || witness.bound > 64 || Array.length witness.actors <> witness.bound then
58+ invalid_arg "witness length differs from its bound";
59+ let states, events = Machine.replay witness.case witness.model witness.fences witness.actors in
60+ if not (Machine.bad witness.case states.(Array.length states - 1)) then
61+ invalid_arg "witness does not reach the requested outcome";
62+ states, events
63+
64+let load_witness path =
65+ let fields = fields "witness" (Sexp.one (Store.read path)) in
66+ if Sexp.integer (single "version" fields) <> 1 then invalid_arg "unsupported witness version";
67+ let witness = {
68+ case = Syntax.decode (single "case" fields);
69+ model = Syntax.model (Sexp.atom (single "model" fields));
70+ bound = Sexp.integer (single "bound" fields);
71+ fences = List.map Syntax.location (Sexp.field "fences" fields);
72+ actors = Array.of_list (List.map Sexp.integer (Sexp.field "actors" fields));
73+ } in
74+ ignore (replay witness);
75+ witness
76+
77+let save folder result =
78+ Store.mkdir folder;
79+ Store.write (Filename.concat folder "query.smt2") (Solver.standalone result.query);
80+ let path = Filename.concat folder "witness.sexp" in
81+ match result.witness with
82+ | Some witness -> Store.write path (Sexp.print (witness_sexp witness) ^ "\n")
83+ | None -> if Sys.file_exists path then Sys.remove path
84+
85+let check ?(timeout=300000) ?(tick=fun () -> ()) ?bound ?(fences=[]) ?folder ?fixed case model =
86+ let bound = Option.value bound ~default:case.Syntax.bound in
87+ let query = Solver.compile ~timeout ?fixed case model fences bound in
88+ let witness = match decision (Solver.solve ~timeout ~tick query) with
89+ | Solver.Unsat -> None
90+ | Solver.Sat values ->
91+ let actors, states = verify case model fences bound values in
92+ if not (Machine.bad case states.(bound)) then failwith "invalid final model state";
93+ Some {case; model; bound; fences; actors}
94+ | Solver.Unknown _ -> assert false in
95+ let result = {witness; query} in
96+ Option.iter (fun folder -> save folder result) folder;
97+ result
98+
99+let blockers (witness : witness) =
100+ let states, _ = Machine.replay witness.case Syntax.Tso [] witness.actors in
101+ let result = ref [] in
102+ Array.iteri (fun i actor ->
103+ if actor < 2 && states.(i).buffers.(actor) <> [] then
104+ List.iteri (fun candidate location ->
105+ if location = (actor, states.(i).pc.(actor)) then result := candidate :: !result)
106+ witness.case.candidates) witness.actors;
107+ List.sort_uniq compare !result
108+
109+let repair_sexp (repair : repair) =
110+ let open Sexp in
111+ List [Atom "repair"; List [Atom "case"; Syntax.encode repair.case];
112+ List [Atom "rounds"; i repair.rounds];
113+ List [Atom "bound"; i repair.bound]; List [Atom "states"; i repair.states];
114+ List (Atom "fences" :: List.map (fun (t, pc) -> List [i t; i pc]) repair.fences);
115+ List (Atom "clauses" :: List.map (fun clause -> List (List.map i clause)) repair.clauses)]
116+
117+let load_repair path =
118+ let fields = fields "repair" (Sexp.one (Store.read path)) in
119+ let repair = {
120+ case = Syntax.decode (single "case" fields);
121+ rounds = Sexp.integer (single "rounds" fields);
122+ bound = Sexp.integer (single "bound" fields);
123+ states = Sexp.integer (single "states" fields);
124+ fences = List.map Syntax.location (Sexp.field "fences" fields);
125+ clauses = List.map (fun clause -> List.map Sexp.integer (Sexp.list clause)) (Sexp.field "clauses" fields);
126+ } in
127+ if repair.bound < repair.case.bound || repair.bound > 64 || repair.states < 1 ||
128+ repair.rounds <> List.length repair.clauses + 1 ||
129+ List.sort_uniq compare repair.fences <> List.sort compare repair.fences ||
130+ not (List.for_all (fun location -> List.mem location repair.case.candidates) repair.fences)
131+ then invalid_arg "invalid repair certificate";
132+ repair
133+
134+let repair ?(timeout=300000) ?(tick=fun () -> ()) ?(notify=fun _ -> ()) case folder =
135+ Store.mkdir folder;
136+ List.iter (fun name ->
137+ let path = Filename.concat folder name in
138+ if Sys.file_exists path then Sys.remove path) ["repair.sexp"; "witness.sexp"];
139+ let count = List.length case.Syntax.candidates in
140+ let clauses = ref [] in
141+ let rounds = ref 0 in
142+ let search_bound = ref case.bound in
143+ let rec search budget =
144+ if budget > count then failwith "fence search exhausted";
145+ let candidate = Solver.candidate ~count ~budget !clauses in
146+ Store.write (Filename.concat folder "synthesis.smt2") (Solver.standalone candidate);
147+ match decision (Solver.solve ~timeout ~tick candidate) with
148+ | Solver.Unsat -> notify (Excluded budget); search (budget + 1)
149+ | Solver.Sat values ->
150+ let selected = List.filter_map Fun.id (List.mapi (fun i value ->
151+ if Solver.truth value then Some (List.nth case.candidates i) else None) values) in
152+ notify (Searching (budget, selected));
153+ let target = Filename.concat folder (Printf.sprintf "round%02d" !rounds) in
154+ let bounded = check ~timeout ~tick ~bound:!search_bound ~fences:selected ~folder:target case Syntax.Tso in
155+ let result, closure = match bounded.witness with
156+ | Some _ -> bounded, None
157+ | None ->
158+ let graph = Machine.explore case Syntax.Tso selected in
159+ match Machine.counterexample graph with
160+ | None -> bounded, Some graph
161+ | Some actors ->
162+ search_bound := max !search_bound (Array.length actors);
163+ notify (Refining !search_bound);
164+ let deeper = check ~timeout ~tick ~bound:(Array.length actors)
165+ ~fixed:actors ~fences:selected ~folder:target case Syntax.Tso in
166+ if deeper.witness = None then failwith "graph counterexample has no SMT execution";
167+ deeper, None
168+ in
169+ incr rounds;
170+ begin match result.witness with
171+ | None ->
172+ let lower = Solver.candidate ~count ~budget:(List.length selected - 1) !clauses in
173+ begin match decision (Solver.solve ~timeout ~tick lower) with
174+ | Solver.Unsat -> () | _ -> failwith "minimum fence certificate is satisfiable"
175+ end;
176+ Store.write (Filename.concat folder "minimal.smt2") (Solver.standalone lower);
177+ let graph = match closure with Some graph -> graph | None -> assert false in
178+ let report = {case; fences = selected; clauses = !clauses; rounds = !rounds;
179+ bound= !search_bound; states=Array.length graph.states} in
180+ Store.write (Filename.concat folder "repair.sexp") (Sexp.print (repair_sexp report) ^ "\n");
181+ notify (Verified (selected, report.bound, report.states));
182+ Some report
183+ | Some witness ->
184+ if !rounds = 1 then Store.write (Filename.concat folder "witness.sexp")
185+ (Sexp.print (witness_sexp witness) ^ "\n");
186+ notify (Counterexample witness);
187+ let clause = blockers witness in
188+ if clause = [] then None else begin
189+ if List.mem clause !clauses then failwith "repeated excluded counterexample";
190+ clauses := !clauses @ [clause];
191+ search budget
192+ end
193+ end
194+ | Solver.Unknown _ -> assert false
195+ in
196+ search 0
197+
198+let certify ?(timeout=300000) ?(tick=fun () -> ()) path =
199+ let report = load_repair path in
200+ List.iteri (fun i clause ->
201+ let path = Filename.concat (Filename.dirname path) (Printf.sprintf "round%02d/witness.sexp" i) in
202+ let witness = load_witness path in
203+ if witness.case <> report.case || witness.model <> Syntax.Tso || witness.bound > report.bound || blockers witness <> clause then
204+ invalid_arg "counterexample does not support its fence constraint") report.clauses;
205+ let lower = Solver.candidate ~count:(List.length report.case.candidates)
206+ ~budget:(List.length report.fences - 1) report.clauses in
207+ begin match decision (Solver.solve ~timeout ~tick lower) with
208+ | Solver.Unsat -> () | _ -> invalid_arg "minimum fence count is unsupported"
209+ end;
210+ let graph = Machine.explore report.case Syntax.Tso report.fences in
211+ if graph.violations <> [] || Array.length graph.states <> report.states then
212+ invalid_arg "repair state graph does not support the certificate";
213+ report
214+
215+let audit ?(timeout=300000) ?(tick=fun () -> ()) path folder =
216+ let report = certify ~timeout ~tick path in
217+ let verified = check ~timeout ~tick ~bound:report.bound ~fences:report.fences ~folder report.case Syntax.Tso in
218+ if verified.witness <> None then invalid_arg "repair still admits the forbidden outcome";
219+ report
220+
221+let validate_schedule ?(timeout=300000) case fences actors =
222+ let bound = Array.length actors in
223+ let query = Solver.compile ~timeout ~fixed:actors ~require_goal:false case Syntax.Tso fences bound in
224+ match decision (Solver.solve ~timeout query) with
225+ | Solver.Sat values -> ignore (verify case Syntax.Tso fences bound values)
226+ | _ -> failwith "repaired schedule has no matching SMT execution"
227+
228+let outcomes ?(timeout=300000) ?(tick=fun () -> ()) case model =
229+ let case = {case with Syntax.goal = Syntax.Outcome {registers=[]; memory=[]; drained=false}} in
230+ let rec loop found =
231+ if List.length found = 16 then failwith "outcome enumeration exceeded sixteen distinct register pairs";
232+ let query = Solver.compile ~timeout ~blocks:found case model [] case.bound in
233+ match decision (Solver.solve ~timeout ~tick query) with
234+ | Solver.Unsat -> List.sort_uniq compare found
235+ | Solver.Sat values ->
236+ let _, states = verify case model [] case.bound values in
237+ let final = states.(case.bound) in
238+ loop ((final.regs.(0).(0), final.regs.(1).(0)) :: found)
239+ | Solver.Unknown _ -> assert false
240+ in
241+ loop []

engine.mli added

@@ -0,0 +1,33 @@
1+type witness = {
2+ case : Syntax.t;
3+ model : Syntax.model;
4+ bound : int;
5+ fences : Syntax.location list;
6+ actors : int array;
7+}
8+type result = { witness : witness option; query : Solver.query }
9+type phase = Searching of int * Syntax.location list
10+ | Counterexample of witness | Excluded of int | Refining of int
11+ | Verified of Syntax.location list * int * int
12+type repair = {
13+ case : Syntax.t;
14+ fences : Syntax.location list;
15+ clauses : int list list;
16+ rounds : int;
17+ bound : int;
18+ states : int;
19+}
20+val check : ?timeout:int -> ?tick:(unit -> unit) -> ?bound:int ->
21+ ?fences:Syntax.location list -> ?folder:string -> ?fixed:int array ->
22+ Syntax.t -> Syntax.model -> result
23+val witness_sexp : witness -> Sexp.t
24+val load_witness : string -> witness
25+val replay : witness -> Machine.t array * Machine.event array
26+val save : string -> result -> unit
27+val repair : ?timeout:int -> ?tick:(unit -> unit) -> ?notify:(phase -> unit) ->
28+ Syntax.t -> string -> repair option
29+val load_repair : string -> repair
30+val certify : ?timeout:int -> ?tick:(unit -> unit) -> string -> repair
31+val audit : ?timeout:int -> ?tick:(unit -> unit) -> string -> string -> repair
32+val validate_schedule : ?timeout:int -> Syntax.t -> Syntax.location list -> int array -> unit
33+val outcomes : ?timeout:int -> ?tick:(unit -> unit) -> Syntax.t -> Syntax.model -> (int64 * int64) list

layout.ml added

@@ -0,0 +1,53 @@
1+let join = String.concat " "
2+
3+let structure name constructor fields =
4+ let width = List.fold_left (fun sum (_, _, size) -> sum + size) 0 fields in
5+ let arguments = join (List.map (fun (field, kind, _) -> Printf.sprintf "(%s %s)" field kind) fields) in
6+ let values = join (List.map (fun (field, _, _) -> field) fields) in
7+ let high = ref (width - 1) in
8+ let selectors = List.map (fun (field, kind, size) ->
9+ let low = !high - size + 1 in
10+ let result = Printf.sprintf
11+ "(define-fun %s ((cells %s)) %s ((_ extract %d %d) cells))" field name kind !high low in
12+ high := low - 1;
13+ result) fields in
14+ [Printf.sprintf "(define-sort %s () (_ BitVec %d))" name width;
15+ Printf.sprintf "(define-fun %s (%s) %s (concat %s))" constructor arguments name values] @ selectors
16+
17+let record name prefix element count size =
18+ let fields = List.init count (fun i -> Printf.sprintf "%s%d" prefix i, element, size) in
19+ let lines = structure name prefix fields in
20+ let value = ref (Printf.sprintf "(%s%d cells)" prefix (count - 1)) in
21+ for i = count - 2 downto 0 do
22+ value := Printf.sprintf "(ite (= i #x%02x) (%s%d cells) %s)" i prefix i !value
23+ done;
24+ let fields = List.init count (fun i ->
25+ Printf.sprintf "(ite (= i #x%02x) v (%s%d cells))" i prefix i) in
26+ lines @ [Printf.sprintf "(define-fun at ((cells %s) (i Index)) %s\n %s)" name element !value;
27+ Printf.sprintf "(define-fun update ((cells %s) (i Index) (v %s)) %s\n (%s %s))"
28+ name element name prefix (join fields)]
29+
30+let generate ~timeout =
31+ if timeout <= 0 then invalid_arg "timeout must be positive";
32+ let lines = ["(set-logic QF_BV)"; "(set-option :produce-models true)";
33+ Printf.sprintf "(set-option :timeout %d)" timeout;
34+ "(define-sort Index () (_ BitVec 8))"; "(define-sort Word () (_ BitVec 64))"] @
35+ record "Slots" "indices" "Index" 16 8 @
36+ record "Words" "words" "Word" 16 64 @
37+ record "Queues" "queues" "Words" 2 1024 @
38+ record "Positions" "positions" "Slots" 2 128 @
39+ structure "State" "state" [
40+ "memory", "Words", 1024; "registers", "Words", 1024;
41+ "counters", "Slots", 128; "heads", "Slots", 128; "tails", "Slots", 128;
42+ "addresses", "Positions", 256; "values", "Queues", 2048;
43+ "positions", "Positions", 256; "critical", "Slots", 128] in
44+ let constants = List.map (fun (name, kind, constructor, value, count) ->
45+ Printf.sprintf "(define-fun %s () %s\n (%s %s))" name kind constructor
46+ (join (List.init count (fun _ -> value)))) [
47+ "zeros", "Words", "words", "#x0000000000000000", 16;
48+ "slots", "Slots", "indices", "#x00", 16;
49+ "absent", "Slots", "indices", "#xff", 16;
50+ "emptyqueues", "Queues", "queues", "zeros", 2;
51+ "emptypositions", "Positions", "positions", "slots", 2;
52+ "unseen", "Positions", "positions", "absent", 2] in
53+ String.concat "\n\n" (lines @ constants) ^ "\n"

layout.mli added

@@ -0,0 +1 @@
1+val generate : timeout:int -> string

machine.ml added

@@ -0,0 +1,183 @@
1+type origin = Memory | Buffer
2+type event = Idle | Drain of int * int * int64
3+ | Issue of int * int * Syntax.instruction * origin option
4+type t = {
5+ pc : int array;
6+ regs : int64 array array;
7+ memory : int64 array;
8+ buffers : (int * int64) list array;
9+ critical : bool array;
10+}
11+
12+let initial (case : Syntax.t) = {
13+ pc = [|0; 0|]; regs = Array.init 2 (fun _ -> Array.make 4 0L);
14+ memory = Array.make (Array.length case.names) 0L;
15+ buffers = [|[]; []|]; critical = [|false; false|];
16+}
17+
18+let copy state = {
19+ pc = Array.copy state.pc; regs = Array.map Array.copy state.regs;
20+ memory = Array.copy state.memory; buffers = Array.copy state.buffers;
21+ critical = Array.copy state.critical;
22+}
23+
24+let step (case : Syntax.t) memory_model fences state actor =
25+ let open Syntax in
26+ if actor < 0 || actor > 4 then invalid_arg "invalid scheduler choice";
27+ if actor = 4 then Some (state, Idle) else
28+ let t = actor mod 2 in
29+ let out = copy state in
30+ if actor >= 2 then
31+ match state.buffers.(t) with
32+ | [] -> None
33+ | (a, v) :: tail ->
34+ out.buffers.(t) <- tail;
35+ out.memory.(a) <- v;
36+ Some (out, Drain (t, a, v))
37+ else
38+ let pc = state.pc.(t) in
39+ if pc >= Array.length case.threads.(t) ||
40+ (List.mem (t, pc) fences && state.buffers.(t) <> []) then None
41+ else begin
42+ let ins = case.threads.(t).(pc) in
43+ out.pc.(t) <- pc + 1;
44+ let done_ origin = Some (out, Issue (t, pc, ins, origin)) in
45+ match ins with
46+ | Store (a, v) ->
47+ if List.length state.buffers.(t) = 8 then None
48+ else begin
49+ if memory_model = Sc then out.memory.(a) <- v
50+ else out.buffers.(t) <- state.buffers.(t) @ [a, v];
51+ done_ None
52+ end
53+ | Load (a, r) ->
54+ let value, origin = List.fold_left (fun (value, origin) (address, stored) ->
55+ if address = a then stored, Buffer else value, origin)
56+ (state.memory.(a), Memory) state.buffers.(t) in
57+ out.regs.(t).(r) <- value;
58+ done_ (Some origin)
59+ | Fence -> if state.buffers.(t) <> [] then None else done_ None
60+ | Move (r, v) -> out.regs.(t).(r) <- v; done_ None
61+ | Branch (r, v, target) ->
62+ if state.regs.(t).(r) = v then out.pc.(t) <- target;
63+ done_ None
64+ | Enter -> out.critical.(t) <- true; done_ None
65+ | Leave -> out.critical.(t) <- false; done_ None
66+ | Exchange (a, r, v) ->
67+ if state.buffers.(t) <> [] then None else begin
68+ out.regs.(t).(r) <- state.memory.(a);
69+ out.memory.(a) <- v;
70+ done_ None
71+ end
72+ end
73+
74+let replay case model fences actors =
75+ let states = Array.make (Array.length actors + 1) (initial case) in
76+ let events = Array.make (Array.length actors) Idle in
77+ Array.iteri (fun i actor ->
78+ match step case model fences states.(i) actor with
79+ | None -> invalid_arg (Printf.sprintf "disabled transition at step %d" i)
80+ | Some (state, event) -> states.(i + 1) <- state; events.(i) <- event) actors;
81+ states, events
82+
83+let observations state =
84+ List.map Int64.of_int (Array.to_list state.pc) @
85+ Array.to_list state.regs.(0) @ Array.to_list state.regs.(1) @
86+ Array.to_list state.memory @
87+ Array.to_list (Array.map (fun queue -> Int64.of_int (List.length queue)) state.buffers) @
88+ Array.to_list (Array.map (fun active -> if active then 1L else 0L) state.critical)
89+
90+let bad (case : Syntax.t) state =
91+ match case.goal with
92+ | Syntax.Overlap -> state.critical.(0) && state.critical.(1)
93+ | Syntax.Outcome goal ->
94+ Array.for_all (fun t -> state.pc.(t) = Array.length case.threads.(t)) [|0; 1|] &&
95+ List.for_all (fun (t, r, v) -> state.regs.(t).(r) = v) goal.registers &&
96+ List.for_all (fun (a, v) -> state.memory.(a) = v) goal.memory &&
97+ (not goal.drained || Array.for_all ((=) []) state.buffers)
98+
99+let reachable case model fences bound =
100+ let start = initial case in
101+ let todo = Queue.create () in
102+ let seen = Hashtbl.create 512 in
103+ Queue.add (start, 0) todo;
104+ Hashtbl.add seen start ();
105+ let rec search () =
106+ if Queue.is_empty todo then false, Hashtbl.length seen else
107+ let state, depth = Queue.take todo in
108+ if bad case state then true, Hashtbl.length seen else begin
109+ if depth < bound then
110+ for actor = 0 to 3 do
111+ match step case model fences state actor with
112+ | Some (next, _) when not (Hashtbl.mem seen next) ->
113+ Hashtbl.add seen next ();
114+ Queue.add (next, depth + 1) todo
115+ | _ -> ()
116+ done;
117+ search ()
118+ end
119+ in
120+ search ()
121+
122+let reschedule case fences requested =
123+ let state = ref (initial case) in
124+ let actors = ref [] in
125+ let execute actor = match step case Syntax.Tso fences !state actor with
126+ | None -> false
127+ | Some (next, _) -> state := next; actors := actor :: !actors; true
128+ in
129+ Array.iter (fun actor ->
130+ if not (execute actor) then begin
131+ if actor < 2 then begin
132+ while (!state).buffers.(actor) <> [] do
133+ if not (execute (actor + 2)) then failwith "cannot drain pending store"
134+ done
135+ end;
136+ if not (execute actor) then ignore (execute 4)
137+ end) requested;
138+ Array.of_list (List.rev !actors)
139+
140+type graph = { states : t array; parents : (int * int) array; edges : int; violations : int list }
141+
142+let explore ?(limit=250000) ?(visit=fun _ _ -> ()) case model fences =
143+ let start = initial case in
144+ let todo = Queue.create () in
145+ let seen = Hashtbl.create 2048 in
146+ let states = ref [] in
147+ let violations = ref [] in
148+ let edges = ref 0 in
149+ let insert state parent actor =
150+ let id = Hashtbl.length seen in
151+ if id >= limit then failwith "state graph exceeds the exploration limit";
152+ Hashtbl.add seen state id;
153+ states := (id, state, parent, actor) :: !states;
154+ Queue.add (id, state) todo;
155+ visit state (id + 1)
156+ in
157+ insert start (-1) 4;
158+ while not (Queue.is_empty todo) do
159+ let id, state = Queue.take todo in
160+ if bad case state then violations := id :: !violations;
161+ for actor = 0 to 3 do
162+ match step case model fences state actor with
163+ | None -> ()
164+ | Some (next, _) ->
165+ incr edges;
166+ if not (Hashtbl.mem seen next) then insert next id actor
167+ done
168+ done;
169+ let values = Array.make (Hashtbl.length seen) start in
170+ let parents = Array.make (Array.length values) (-1, 4) in
171+ List.iter (fun (id, state, parent, actor) ->
172+ values.(id) <- state; parents.(id) <- parent, actor) !states;
173+ {states=values; parents; edges= !edges; violations=List.rev !violations}
174+
175+let counterexample graph =
176+ match graph.violations with
177+ | [] -> None
178+ | id :: _ ->
179+ let rec path id actors =
180+ let parent, actor = graph.parents.(id) in
181+ if parent < 0 then Array.of_list actors else path parent (actor :: actors)
182+ in
183+ Some (path id [])

machine.mli added

@@ -0,0 +1,21 @@
1+type origin = Memory | Buffer
2+type event = Idle | Drain of int * int * int64
3+ | Issue of int * int * Syntax.instruction * origin option
4+type t = {
5+ pc : int array;
6+ regs : int64 array array;
7+ memory : int64 array;
8+ buffers : (int * int64) list array;
9+ critical : bool array;
10+}
11+val initial : Syntax.t -> t
12+val step : Syntax.t -> Syntax.model -> Syntax.location list -> t -> int -> (t * event) option
13+val replay : Syntax.t -> Syntax.model -> Syntax.location list -> int array -> t array * event array
14+val observations : t -> int64 list
15+val bad : Syntax.t -> t -> bool
16+val reachable : Syntax.t -> Syntax.model -> Syntax.location list -> int -> bool * int
17+val reschedule : Syntax.t -> Syntax.location list -> int array -> int array
18+type graph = { states : t array; parents : (int * int) array; edges : int; violations : int list }
19+val explore : ?limit:int -> ?visit:(t -> int -> unit) -> Syntax.t ->
20+ Syntax.model -> Syntax.location list -> graph
21+val counterexample : graph -> int array option

main.ml added

@@ -0,0 +1,130 @@
1+let () =
2+ let exit_code = ref 0 in
3+ try
4+ if Array.length Sys.argv < 2 then
5+ invalid_arg "usage: reorder check|repair|replay|contrast|compare|graph|audit|laws|layout|emit [file] [options]";
6+ let command = Sys.argv.(1) in
7+ let files = ref [] in
8+ let model = ref Syntax.Tso in
9+ let bound = ref None in
10+ let fences = ref [] in
11+ let folder = ref None in
12+ let animate = ref false in
13+ let delay = ref 0.7 in
14+ let width = ref 148 in
15+ let timeout = ref 300000 in
16+ let location text = match String.split_on_char ':' text with
17+ | [t; pc] -> int_of_string t, int_of_string pc
18+ | _ -> invalid_arg "fence locations use thread:instruction" in
19+ let options = [
20+ "--model", Arg.String (fun text -> model := Syntax.model text), "sc or tso";
21+ "--bound", Arg.Int (fun value -> bound := Some value), "maximum scheduler transitions";
22+ "--fence", Arg.String (fun text -> fences := !fences @ [location text]), "thread:instruction";
23+ "--out", Arg.String (fun path -> folder := Some path), "output file or directory";
24+ "--animate", Arg.Set animate, "animate actual execution and solver progress";
25+ "--delay", Arg.Set_float delay, "seconds per displayed transition";
26+ "--width", Arg.Set_int width, "terminal width between 78 and 180 columns";
27+ "--timeout", Arg.Set_int timeout, "solver budget in milliseconds";
28+ ] in
29+ let current = ref 1 in
30+ Arg.parse_argv ~current Sys.argv options (fun path -> files := !files @ [path]) "reorder";
31+ if !timeout < 1 || !timeout > 3600000 then invalid_arg "timeout outside 1..3600000 milliseconds";
32+ let file () = match !files with path :: _ -> path | [] -> invalid_arg "missing input file" in
33+ let output fallback = Option.value !folder ~default:fallback in
34+ let load () =
35+ let case = Syntax.load (file ()) in
36+ let case = match !bound with None -> case | Some bound -> {case with Syntax.bound} in
37+ Syntax.validate case;
38+ case in
39+ let with_view case action =
40+ let view = View.create ~width:!width ~delay:!delay ~animate:!animate case in
41+ Fun.protect ~finally:(fun () -> View.finish view) (fun () -> action view) in
42+ let report case result =
43+ Printf.printf "%s\nmodel=%s bound=%d buffer<=8\n" (View.headline case.Syntax.name)
44+ (Syntax.model_name !model) case.bound;
45+ match result.Engine.witness with
46+ | None -> print_endline "UNSAT requested outcome excluded within the bound"
47+ | Some witness ->
48+ Printf.printf "SAT %d transitions; independent replay passed\n"
49+ (Array.fold_left (fun n actor -> if actor = 4 then n else n + 1) 0 witness.actors);
50+ exit_code := 1 in
51+ begin match command with
52+ | "check" ->
53+ let case = load () in
54+ let result = with_view case (fun view ->
55+ Engine.check ~timeout:!timeout ~tick:(fun () -> View.tick view)
56+ ~fences:!fences ~folder:(output "build/check") case !model) in
57+ report case result
58+ | "repair" ->
59+ let case = load () in
60+ let result = with_view case (fun view ->
61+ Engine.repair ~timeout:!timeout ~tick:(fun () -> View.tick view)
62+ ~notify:(View.notify view) case (output "build/repair")) in
63+ begin match result with
64+ | None -> print_endline "No repair exists at the candidate locations"; exit_code := 1
65+ | Some result ->
66+ Printf.printf "Minimum repair: %d fences; bound %d; %d checked counterexamples\n"
67+ (List.length result.fences) result.bound (List.length result.clauses)
68+ end
69+ | "replay" ->
70+ let witness = Engine.load_witness (file ()) in
71+ with_view witness.case (fun view -> View.play view witness)
72+ | "contrast" ->
73+ let witness_path, repair_path = match !files with
74+ | [left; right] -> left, right | _ -> invalid_arg "contrast needs a witness and a repair" in
75+ let witness = Engine.load_witness witness_path in
76+ let repair = Engine.certify ~timeout:!timeout repair_path in
77+ with_view witness.case (fun view -> View.contrast view witness repair)
78+ | "compare" ->
79+ let case = load () in
80+ with_view case (fun view ->
81+ View.phase view "enumerating sequentially consistent outcomes";
82+ let sc = Engine.outcomes ~timeout:!timeout ~tick:(fun () -> View.tick view) case Syntax.Sc in
83+ View.phase view "enumerating TSO outcomes";
84+ let tso = Engine.outcomes ~timeout:!timeout ~tick:(fun () -> View.tick view) case Syntax.Tso in
85+ View.outcomes view sc tso)
86+ | "graph" ->
87+ let case = load () in
88+ let fences = match !files with
89+ | [_; path] ->
90+ let repair = Engine.certify ~timeout:!timeout path in
91+ if case <> repair.case then invalid_arg "graph and repair cases differ";
92+ repair.fences
93+ | [_] -> !fences
94+ | _ -> invalid_arg "graph expects a case and an optional repair" in
95+ with_view case (fun view -> ignore (View.graph view fences))
96+ | "audit" ->
97+ let repair = Engine.audit ~timeout:!timeout (file ()) (output "build/audit") in
98+ Printf.printf "repair verified at bound %d\n%d witnesses replayed; lower-budget certificate UNSAT\n"
99+ repair.bound (List.length repair.clauses)
100+ | "layout" ->
101+ let path = output "build/layout.smt2" in
102+ Store.write path (Layout.generate ~timeout:!timeout);
103+ print_endline path
104+ | "emit" ->
105+ let case = load () in
106+ let query = Solver.compile ~timeout:!timeout case !model !fences case.bound in
107+ let path = output "build/query.smt2" in
108+ Store.write path (Solver.standalone query);
109+ print_endline path
110+ | "laws" ->
111+ let root = Store.root () in
112+ let text = Layout.generate ~timeout:!timeout ^
113+ Store.read (Filename.concat root "smt/machine.smt2") ^ "\n" ^
114+ Store.read (Filename.concat root "smt/laws.smt2") in
115+ Store.write (output "build/laws.smt2") text;
116+ let responses = Sexp.parse (Solver.script ~timeout:!timeout text) in
117+ if responses <> List.init 16 (fun _ -> Sexp.Atom "unsat") then failwith "machine law check failed";
118+ print_endline "16 SMT machine laws verified"
119+ | _ -> invalid_arg "unknown command"
120+ end;
121+ exit !exit_code
122+ with
123+ | Invalid_argument message | Failure message | Sys_error message ->
124+ Printf.eprintf "reorder: %s\n" message;
125+ exit 2
126+ | Unix.Unix_error (error, operation, _) ->
127+ Printf.eprintf "reorder: %s: %s\n" operation (Unix.error_message error);
128+ exit 2
129+ | Arg.Bad message -> prerr_string message; exit 2
130+ | Arg.Help message -> print_string message

reorder.opam added

@@ -0,0 +1,23 @@
1+# This file is generated by dune, edit dune-project instead
2+opam-version: "2.0"
3+synopsis: "Bounded x86-TSO checking and minimum fence synthesis"
4+depends: [
5+ "dune" {>= "3.20"}
6+ "ocaml" {>= "5.5"}
7+ "odoc" {with-doc}
8+]
9+build: [
10+ ["dune" "subst"] {dev}
11+ [
12+ "dune"
13+ "build"
14+ "-p"
15+ name
16+ "-j"
17+ jobs
18+ "@install"
19+ "@runtest" {with-test}
20+ "@doc" {with-doc}
21+ ]
22+]
23+x-maintenance-intent: ["(latest)"]

sexp.ml added

@@ -0,0 +1,111 @@
1+type t = Atom of string | List of t list
2+
3+let parse text =
4+ let length = String.length text in
5+ let position = ref 0 in
6+ let fail message = invalid_arg (Printf.sprintf "%s at byte %d" message !position) in
7+ let rec space () =
8+ if !position < length then
9+ match text.[!position] with
10+ | ' ' | '\n' | '\r' | '\t' -> incr position; space ()
11+ | _ -> ()
12+ in
13+ let quoted () =
14+ incr position;
15+ let buffer = Buffer.create 32 in
16+ let rec loop () =
17+ if !position = length then fail "unterminated string";
18+ let character = text.[!position] in
19+ incr position;
20+ match character with
21+ | '"' -> Buffer.contents buffer
22+ | '\\' ->
23+ if !position = length then fail "incomplete escape";
24+ let escaped = match text.[!position] with
25+ | 'n' -> '\n' | 'r' -> '\r' | 't' -> '\t'
26+ | '"' -> '"' | '\\' -> '\\'
27+ | _ -> fail "unsupported escape"
28+ in
29+ incr position;
30+ Buffer.add_char buffer escaped;
31+ loop ()
32+ | character -> Buffer.add_char buffer character; loop ()
33+ in
34+ loop ()
35+ in
36+ let rec value () =
37+ space ();
38+ if !position = length then fail "expected expression";
39+ match text.[!position] with
40+ | '(' ->
41+ incr position;
42+ let rec items result =
43+ space ();
44+ if !position = length then fail "unterminated list";
45+ if text.[!position] = ')' then begin
46+ incr position;
47+ List (List.rev result)
48+ end else items (value () :: result)
49+ in
50+ items []
51+ | ')' -> fail "unexpected closing parenthesis"
52+ | '"' -> Atom (quoted ())
53+ | _ ->
54+ let start = !position in
55+ while !position < length && not (List.mem text.[!position] ['('; ')'; ' '; '\n'; '\r'; '\t']) do
56+ incr position
57+ done;
58+ Atom (String.sub text start (!position - start))
59+ in
60+ let rec values result =
61+ space ();
62+ if !position = length then List.rev result else values (value () :: result)
63+ in
64+ values []
65+
66+let one text = match parse text with
67+ | [value] -> value
68+ | _ -> invalid_arg "expected one expression"
69+
70+let rec print = function
71+ | Atom text ->
72+ if text <> "" && not (String.exists (fun c -> List.mem c ['('; ')'; ' '; '\n'; '\r'; '\t'; '"'; '\\']) text)
73+ then text else begin
74+ let buffer = Buffer.create (String.length text + 2) in
75+ Buffer.add_char buffer '"';
76+ String.iter (function
77+ | '"' -> Buffer.add_string buffer "\\\""
78+ | '\\' -> Buffer.add_string buffer "\\\\"
79+ | '\n' -> Buffer.add_string buffer "\\n"
80+ | '\r' -> Buffer.add_string buffer "\\r"
81+ | '\t' -> Buffer.add_string buffer "\\t"
82+ | c -> Buffer.add_char buffer c) text;
83+ Buffer.add_char buffer '"';
84+ Buffer.contents buffer
85+ end
86+ | List values -> "(" ^ String.concat " " (List.map print values) ^ ")"
87+
88+let atom = function Atom text -> text | _ -> invalid_arg "expected atom"
89+let list = function List values -> values | _ -> invalid_arg "expected list"
90+let field name values =
91+ let matches = List.filter_map (function
92+ | List (Atom key :: values) when key = name -> Some values
93+ | _ -> None) values
94+ in
95+ match matches with
96+ | [values] -> values
97+ | [] -> invalid_arg ("missing field " ^ name)
98+ | _ -> invalid_arg ("duplicate field " ^ name)
99+
100+let integer value = int_of_string (atom value)
101+let word = function
102+ | Atom text when String.starts_with ~prefix:"#x" text ->
103+ Int64.of_string ("0x" ^ String.sub text 2 (String.length text - 2))
104+ | Atom text when String.starts_with ~prefix:"#b" text ->
105+ Int64.of_string ("0b" ^ String.sub text 2 (String.length text - 2))
106+ | Atom text -> Int64.of_string text
107+ | List [Atom "-"; Atom text] -> Int64.neg (Int64.of_string text)
108+ | _ -> invalid_arg "invalid scalar"
109+let a text = Atom text
110+let i value = Atom (string_of_int value)
111+let w value = Atom (Printf.sprintf "0x%016Lx" value)

sexp.mli added

@@ -0,0 +1,12 @@
1+type t = Atom of string | List of t list
2+val parse : string -> t list
3+val one : string -> t
4+val print : t -> string
5+val atom : t -> string
6+val list : t -> t list
7+val field : string -> t list -> t list
8+val integer : t -> int
9+val word : t -> int64
10+val a : string -> t
11+val i : int -> t
12+val w : int64 -> t

smt/fences.smt2 added

@@ -0,0 +1,6 @@
1+(set-logic QF_LIA)
2+(set-option :produce-models true)
3+(set-option :timeout 60000)
4+
5+(define-fun weight ((enabled Bool)) Int
6+ (ite enabled 1 0))

smt/laws.smt2 added

@@ -0,0 +1,98 @@
1+(declare-const s State)
2+(declare-const t Index)
3+(declare-const other Index)
4+(declare-const a Index)
5+(declare-const v Word)
6+(declare-const r Index)
7+(declare-const destination Index)
8+
9+(assert (bvult t #x02))
10+(assert (bvult other #x02))
11+(assert (bvult a #x10))
12+(assert (bvult r #x04))
13+(assert (bvule (at (heads s) t) (at (tails s) t)))
14+(assert (bvult (at (tails s) t) #x40))
15+(assert (bvult (pending s t) #x08))
16+(assert (distinct other t))
17+
18+(push 1)
19+(assert (distinct (read (write s t a v) t a) v))
20+(check-sat)
21+(pop 1)
22+
23+(push 1)
24+(assert (distinct (memory (write s t a v)) (memory s)))
25+(check-sat)
26+(pop 1)
27+
28+(push 1)
29+(assert (distinct (pending (write s t a v) t) (bvadd (pending s t) #x01)))
30+(check-sat)
31+(pop 1)
32+
33+(push 1)
34+(assert (distinct (pending (write s t a v) other) (pending s other)))
35+(check-sat)
36+(pop 1)
37+
38+(push 1)
39+(assert (bvugt (pending s t) #x00))
40+(assert (distinct (pending (drain s t) t) (bvsub (pending s t) #x01)))
41+(check-sat)
42+(pop 1)
43+
44+(push 1)
45+(assert (distinct (pending (drain s t) other) (pending s other)))
46+(check-sat)
47+(pop 1)
48+
49+(push 1)
50+(assert (distinct (reg (put s t r v) t r) v))
51+(check-sat)
52+(pop 1)
53+
54+(push 1)
55+(assert (distinct (pc (advance s t destination) t) destination))
56+(check-sat)
57+(pop 1)
58+
59+(push 1)
60+(assert (distinct (pc (advance s t destination) other) (pc s other)))
61+(check-sat)
62+(pop 1)
63+
64+(push 1)
65+(assert (distinct (at (critical (mark s t #x01)) t) #x01))
66+(check-sat)
67+(pop 1)
68+
69+(push 1)
70+(assert (distinct (at (memory (exchange s t a r v)) a) v))
71+(check-sat)
72+(pop 1)
73+
74+(push 1)
75+(assert (distinct (reg (exchange s t a r v) t r) (at (memory s) a)))
76+(check-sat)
77+(pop 1)
78+
79+(push 1)
80+(assert (distinct (reg (load-step s t a r) t r) (read s t a)))
81+(check-sat)
82+(pop 1)
83+
84+(push 1)
85+(assert (distinct (memory (load-step s t a r)) (memory s)))
86+(check-sat)
87+(pop 1)
88+
89+(push 1)
90+(assert (distinct (pending (fence-step s t) t) (pending s t)))
91+(check-sat)
92+(pop 1)
93+
94+(push 1)
95+(assert (= (pending s t) #x00))
96+(assert (distinct (at (memory (store-step s t a v true)) a) v))
97+(check-sat)
98+(pop 1)

smt/machine.smt2 added

@@ -0,0 +1,88 @@
1+(define-fun initial () State
2+ (state zeros zeros slots slots slots emptypositions emptyqueues unseen slots))
3+
4+(define-fun pc ((s State) (t Index)) Index
5+ (at (counters s) t))
6+
7+(define-fun reg ((s State) (t Index) (r Index)) Word
8+ (at (registers s) (bvadd (bvmul #x08 t) r)))
9+
10+(define-fun pending ((s State) (t Index)) Index
11+ (bvsub (at (tails s) t) (at (heads s) t)))
12+
13+(define-fun read ((s State) (t Index) (a Index)) Word
14+ (let ((index (at (at (positions s) t) a)))
15+ (ite (and (bvuge index (at (heads s) t))
16+ (bvult index (at (tails s) t)))
17+ (at (at (values s) t) (bvand index #x07))
18+ (at (memory s) a))))
19+
20+(define-fun advance ((s State) (t Index) (p Index)) State
21+ (state (memory s) (registers s) (update (counters s) t p)
22+ (heads s) (tails s) (addresses s) (values s) (positions s) (critical s)))
23+
24+(define-fun put ((s State) (t Index) (r Index) (v Word)) State
25+ (state (memory s) (update (registers s) (bvadd (bvmul #x08 t) r) v)
26+ (counters s) (heads s) (tails s)
27+ (addresses s) (values s) (positions s) (critical s)))
28+
29+(define-fun write ((s State) (t Index) (a Index) (v Word)) State
30+ (let ((index (at (tails s) t)))
31+ (state (memory s) (registers s) (counters s) (heads s)
32+ (update (tails s) t (bvadd index #x01))
33+ (update (addresses s) t (update (at (addresses s) t) (bvand index #x07) a))
34+ (update (values s) t (update (at (values s) t) (bvand index #x07) v))
35+ (update (positions s) t (update (at (positions s) t) a index))
36+ (critical s))))
37+
38+(define-fun drain ((s State) (t Index)) State
39+ (let ((index (at (heads s) t)))
40+ (state
41+ (update (memory s)
42+ (at (at (addresses s) t) (bvand index #x07))
43+ (at (at (values s) t) (bvand index #x07)))
44+ (registers s) (counters s)
45+ (update (heads s) t (bvadd index #x01)) (tails s)
46+ (addresses s) (values s) (positions s) (critical s))))
47+
48+(define-fun mark ((s State) (t Index) (v Index)) State
49+ (state (memory s) (registers s) (counters s)
50+ (heads s) (tails s) (addresses s) (values s) (positions s)
51+ (update (critical s) t v)))
52+
53+(define-fun exchange ((s State) (t Index) (a Index) (r Index) (v Word)) State
54+ (state (update (memory s) a v)
55+ (update (registers s) (bvadd (bvmul #x08 t) r) (at (memory s) a))
56+ (counters s) (heads s) (tails s)
57+ (addresses s) (values s) (positions s) (critical s)))
58+
59+(define-fun store-step ((s State) (t Index) (a Index) (v Word) (sc Bool)) State
60+ (let ((next (write s t a v)))
61+ (advance (ite sc (drain next t) next) t (bvadd (pc s t) #x01))))
62+
63+(define-fun load-step ((s State) (t Index) (a Index) (r Index)) State
64+ (advance (put s t r (read s t a)) t (bvadd (pc s t) #x01)))
65+
66+(define-fun fence-step ((s State) (t Index)) State
67+ (advance s t (bvadd (pc s t) #x01)))
68+
69+(define-fun move-step ((s State) (t Index) (r Index) (v Word)) State
70+ (advance (put s t r v) t (bvadd (pc s t) #x01)))
71+
72+(define-fun branch-step
73+ ((s State) (t Index) (r Index) (v Word) (target Index)) State
74+ (advance s t (ite (= (reg s t r) v) target (bvadd (pc s t) #x01))))
75+
76+(define-fun enter-step ((s State) (t Index)) State
77+ (advance (mark s t #x01) t (bvadd (pc s t) #x01)))
78+
79+(define-fun leave-step ((s State) (t Index)) State
80+ (advance (mark s t #x00) t (bvadd (pc s t) #x01)))
81+
82+(define-fun exchange-step
83+ ((s State) (t Index) (a Index) (r Index) (v Word)) State
84+ (advance (exchange s t a r v) t (bvadd (pc s t) #x01)))
85+
86+(define-fun overlap ((s State)) Bool
87+ (and (= (at (critical s) #x00) #x01)
88+ (= (at (critical s) #x01) #x01)))

solver.ml added

@@ -0,0 +1,208 @@
1+type value = Bits of int64 | Truth of bool
2+type answer = Sat of value list | Unsat | Unknown of string
3+type query = { source : string; probes : (string * string) list }
4+
5+let strategy = "(check-sat-using (then simplify solve-eqs bit-blast sat))"
6+let bits = function Bits value -> value | _ -> invalid_arg "expected bitvector"
7+let truth = function Truth value -> value | _ -> invalid_arg "expected boolean"
8+let index value = Printf.sprintf "#x%02x" value
9+let word value = Printf.sprintf "#x%016Lx" value
10+let all = function [] -> "true" | values -> "(and " ^ String.concat " " values ^ ")"
11+let any = function [] -> "false" | values -> "(or " ^ String.concat " " values ^ ")"
12+let equal_state left right = all (List.map (fun field ->
13+ Printf.sprintf "(= (%s %s) (%s %s))" field left field right)
14+ ["memory"; "registers"; "counters"; "heads"; "tails"; "addresses"; "values"; "positions"; "critical"])
15+
16+let command source =
17+ if String.starts_with ~prefix:"(set-logic QF_BV)" source then strategy else "(check-sat)"
18+
19+let connection ~timeout ~tick action =
20+ let input_read, input_write = Unix.pipe ~cloexec:true () in
21+ let output_read, output_write = Unix.pipe ~cloexec:true () in
22+ let executable = Option.value (Sys.getenv_opt "Z3") ~default:"z3" in
23+ let pid = Unix.create_process executable [|executable; "-in"; "-smt2"|]
24+ input_read output_write output_write in
25+ Unix.close input_read;
26+ Unix.close output_write;
27+ let input = Unix.out_channel_of_descr input_write in
28+ let pending = ref "" in
29+ let deadline = Unix.gettimeofday () +. float_of_int timeout /. 1000. +. 30. in
30+ let chunk = Bytes.create 8192 in
31+ let read () =
32+ if Unix.gettimeofday () > deadline then failwith "solver transport timed out";
33+ tick ();
34+ let ready, _, _ = Unix.select [output_read] [] [] 0.1 in
35+ if ready = [] then None else
36+ let size = Unix.read output_read chunk 0 (Bytes.length chunk) in
37+ if size = 0 then Some "" else Some (Bytes.sub_string chunk 0 size)
38+ in
39+ let rec line () = match String.index_opt !pending '\n' with
40+ | Some ending ->
41+ let result = String.sub !pending 0 ending in
42+ pending := String.sub !pending (ending + 1) (String.length !pending - ending - 1);
43+ result
44+ | None -> match read () with
45+ | None -> line ()
46+ | Some "" -> failwith ("solver closed its output: " ^ !pending)
47+ | Some text -> pending := !pending ^ text; line ()
48+ in
49+ let finish () =
50+ let buffer = Buffer.create 4096 in
51+ Buffer.add_string buffer !pending;
52+ pending := "";
53+ let rec loop () = match read () with
54+ | None -> loop ()
55+ | Some "" -> Buffer.contents buffer
56+ | Some text -> Buffer.add_string buffer text; loop ()
57+ in
58+ loop ()
59+ in
60+ let reaped = ref false in
61+ Fun.protect ~finally:(fun () ->
62+ close_out_noerr input;
63+ Unix.close output_read;
64+ if not !reaped then begin
65+ (try Unix.kill pid Sys.sigkill with Unix.Unix_error (Unix.ESRCH, _, _) -> ());
66+ ignore (Unix.waitpid [] pid)
67+ end) (fun () ->
68+ let result = action input line finish in
69+ let _, status = Unix.waitpid [] pid in
70+ reaped := true;
71+ if status <> Unix.WEXITED 0 then failwith "solver process failed";
72+ result)
73+
74+let script ?(timeout=300000) ?(tick=fun () -> ()) source =
75+ connection ~timeout ~tick (fun input _ finish ->
76+ output_string input (source ^ "\n(exit)\n");
77+ flush input;
78+ finish ())
79+
80+let solve ?(timeout=300000) ?(tick=fun () -> ()) query =
81+ connection ~timeout ~tick (fun input line finish ->
82+ output_string input query.source;
83+ List.iteri (fun i (kind, term) ->
84+ Printf.fprintf input "(define-fun q%d () %s %s)\n" i kind term) query.probes;
85+ output_string input (command query.source ^ "\n");
86+ flush input;
87+ let status = String.trim (line ()) in
88+ begin match status with
89+ | "sat" when query.probes <> [] ->
90+ let names = List.init (List.length query.probes) (Printf.sprintf "q%d") in
91+ Printf.fprintf input "(get-value (%s))\n" (String.concat " " names)
92+ | "unknown" -> output_string input "(get-info :reason-unknown)\n"
93+ | "sat" | "unsat" -> ()
94+ | _ -> failwith ("invalid solver response: " ^ status)
95+ end;
96+ output_string input "(exit)\n";
97+ flush input;
98+ let response = finish () in
99+ match status with
100+ | "unsat" -> Unsat
101+ | "unknown" -> Unknown response
102+ | _ when query.probes = [] -> Sat []
103+ | _ ->
104+ let entries = Sexp.list (Sexp.one response) in
105+ let table = Hashtbl.create (List.length entries) in
106+ List.iter (function
107+ | Sexp.List [Sexp.Atom name; value] ->
108+ let value = match value with
109+ | Sexp.Atom "true" -> Truth true
110+ | Sexp.Atom "false" -> Truth false
111+ | value -> Bits (Sexp.word value) in
112+ Hashtbl.add table name value
113+ | _ -> failwith "invalid model entry") entries;
114+ Sat (List.init (List.length query.probes) (fun i -> Hashtbl.find table (Printf.sprintf "q%d" i))))
115+
116+let instruction state t =
117+ let open Syntax in
118+ let call name values = Printf.sprintf "(%s-step %s %s%s)" name state (index t)
119+ (if values = [] then "" else " " ^ String.concat " " values) in
120+ function
121+ | Store (a, v) -> [Printf.sprintf "(bvult (pending %s %s) #x08)" state (index t)],
122+ (fun sc -> call "store" [index a; word v; string_of_bool sc])
123+ | Load (a, r) -> [], (fun _ -> call "load" [index a; index r])
124+ | Fence -> [Printf.sprintf "(= (pending %s %s) #x00)" state (index t)],
125+ (fun _ -> call "fence" [])
126+ | Move (r, v) -> [], (fun _ -> call "move" [index r; word v])
127+ | Branch (r, v, pc) -> [], (fun _ -> call "branch" [index r; word v; index pc])
128+ | Enter -> [], (fun _ -> call "enter" [])
129+ | Leave -> [], (fun _ -> call "leave" [])
130+ | Exchange (a, r, v) -> [Printf.sprintf "(= (pending %s %s) #x00)" state (index t)],
131+ (fun _ -> call "exchange" [index a; index r; word v])
132+
133+let property (case : Syntax.t) state =
134+ match case.goal with
135+ | Syntax.Overlap -> Printf.sprintf "(overlap %s)" state
136+ | Syntax.Outcome goal ->
137+ let finished = List.init 2 (fun t -> Printf.sprintf "(= (pc %s %s) %s)"
138+ state (index t) (index (Array.length case.threads.(t)))) in
139+ let registers = List.map (fun (t, r, v) -> Printf.sprintf "(= (reg %s %s %s) %s)"
140+ state (index t) (index r) (word v)) goal.registers in
141+ let memory = List.map (fun (a, v) -> Printf.sprintf "(= (at (memory %s) %s) %s)"
142+ state (index a) (word v)) goal.memory in
143+ let drained = if not goal.drained then [] else List.init 2 (fun t ->
144+ Printf.sprintf "(= (pending %s %s) #x00)" state (index t)) in
145+ all (finished @ registers @ memory @ drained)
146+
147+let observations (case : Syntax.t) state =
148+ List.init 2 (fun t -> "Index", Printf.sprintf "(pc %s %s)" state (index t)) @
149+ List.init 8 (fun i -> "Word", Printf.sprintf "(reg %s %s %s)" state (index (i / 4)) (index (i mod 4))) @
150+ List.init (Array.length case.names) (fun a -> "Word", Printf.sprintf "(at (memory %s) %s)" state (index a)) @
151+ List.init 2 (fun t -> "Index", Printf.sprintf "(pending %s %s)" state (index t)) @
152+ List.init 2 (fun t -> "Index", Printf.sprintf "(at (critical %s) %s)" state (index t))
153+
154+let compile ?(timeout=300000) ?fixed ?(require_goal=true) ?(blocks=[]) case model fences bound =
155+ Syntax.validate case;
156+ if bound < 1 || bound > 64 then invalid_arg "step bound outside 1..64";
157+ List.iter (fun (t, pc) ->
158+ if t < 0 || t > 1 || pc < 0 || pc >= Array.length case.Syntax.threads.(t)
159+ then invalid_arg "invalid fence location") fences;
160+ Option.iter (fun actors ->
161+ if Array.length actors <> bound || Array.exists (fun a -> a < 0 || a > 4) actors
162+ then invalid_arg "invalid fixed schedule") fixed;
163+ let buffer = Buffer.create 65536 in
164+ Buffer.add_string buffer (Layout.generate ~timeout);
165+ Buffer.add_string buffer (Store.read (Filename.concat (Store.root ()) "smt/machine.smt2"));
166+ let add line = Buffer.add_string buffer (line ^ "\n") in
167+ add ("(declare-const s0 State)\n(assert " ^ equal_state "s0" "initial" ^ ")");
168+ for step = 0 to bound - 1 do
169+ let state = Printf.sprintf "s%d" step in
170+ let next = Printf.sprintf "s%d" (step + 1) in
171+ let actor = Printf.sprintf "a%d" step in
172+ add (Printf.sprintf "(declare-const %s State)\n(declare-const %s Index)" next actor);
173+ let alternatives = List.concat (List.init 2 (fun t ->
174+ let instructions = Array.to_list (Array.mapi (fun pc ins ->
175+ let guards, call = instruction state t ins in
176+ let guards = if List.mem (t, pc) fences then
177+ Printf.sprintf "(= (pending %s %s) #x00)" state (index t) :: guards else guards in
178+ all (Printf.sprintf "(= (pc %s %s) %s)" state (index t) (index pc) ::
179+ equal_state next (call (model = Syntax.Sc)) :: guards)) case.threads.(t)) in
180+ [all [Printf.sprintf "(= %s %s)" actor (index t); any instructions];
181+ all [Printf.sprintf "(= %s %s)" actor (index (t + 2));
182+ Printf.sprintf "(bvugt (pending %s %s) #x00)" state (index t);
183+ equal_state next (Printf.sprintf "(drain %s %s)" state (index t))]])) in
184+ add ("(assert " ^ any (alternatives @ [all ["(= " ^ actor ^ " #x04)"; equal_state next state]]) ^ ")");
185+ if step > 0 && fixed = None then
186+ add (Printf.sprintf "(assert (=> (= %s #x04) (= a%d #x04)))" actor (step - 1));
187+ Option.iter (fun actors -> add (Printf.sprintf "(assert (= %s %s))" actor (index actors.(step)))) fixed
188+ done;
189+ let final = Printf.sprintf "s%d" bound in
190+ if require_goal then add ("(assert " ^ property case final ^ ")");
191+ List.iter (fun (left, right) -> add ("(assert " ^ any [
192+ Printf.sprintf "(distinct (reg %s #x00 #x00) %s)" final (word left);
193+ Printf.sprintf "(distinct (reg %s #x01 #x00) %s)" final (word right)] ^ ")")) blocks;
194+ let probes = List.init bound (fun i -> "Index", Printf.sprintf "a%d" i) @
195+ List.concat (List.init (bound + 1) (fun i -> observations case (Printf.sprintf "s%d" i))) in
196+ {source = Buffer.contents buffer; probes}
197+
198+let candidate ~count ~budget clauses =
199+ let lines = ref [Store.read (Filename.concat (Store.root ()) "smt/fences.smt2")] in
200+ let add line = lines := line :: !lines in
201+ for i = 0 to count - 1 do add (Printf.sprintf "(declare-const f%d Bool)" i) done;
202+ let weights = List.init count (Printf.sprintf "(weight f%d)") in
203+ add (Printf.sprintf "(assert (<= (+ 0 %s) %d))" (String.concat " " weights) budget);
204+ List.iter (fun clause -> add ("(assert " ^ any (List.map (Printf.sprintf "f%d") clause) ^ ")")) clauses;
205+ {source = String.concat "\n" (List.rev !lines) ^ "\n";
206+ probes = List.init count (fun i -> "Bool", Printf.sprintf "f%d" i)}
207+
208+let standalone query = query.source ^ command query.source ^ "\n"

solver.mli added

@@ -0,0 +1,12 @@
1+type value = Bits of int64 | Truth of bool
2+type answer = Sat of value list | Unsat | Unknown of string
3+type query = { source : string; probes : (string * string) list }
4+val strategy : string
5+val solve : ?timeout:int -> ?tick:(unit -> unit) -> query -> answer
6+val script : ?timeout:int -> ?tick:(unit -> unit) -> string -> string
7+val compile : ?timeout:int -> ?fixed:int array -> ?require_goal:bool ->
8+ ?blocks:(int64 * int64) list -> Syntax.t -> Syntax.model -> Syntax.location list -> int -> query
9+val candidate : count:int -> budget:int -> int list list -> query
10+val standalone : query -> string
11+val bits : value -> int64
12+val truth : value -> bool

store.ml added

@@ -0,0 +1,32 @@
1+let read path =
2+ let channel = open_in_bin path in
3+ Fun.protect ~finally:(fun () -> close_in_noerr channel) (fun () ->
4+ really_input_string channel (in_channel_length channel))
5+
6+let rec mkdir path =
7+ if path <> "." && not (Sys.file_exists path) then begin
8+ mkdir (Filename.dirname path);
9+ Unix.mkdir path 0o755
10+ end
11+
12+let write path text =
13+ mkdir (Filename.dirname path);
14+ let channel = open_out_bin path in
15+ Fun.protect ~finally:(fun () -> close_out_noerr channel) (fun () ->
16+ output_string channel text)
17+
18+let root () =
19+ let rec find path =
20+ if Sys.file_exists (Filename.concat path "smt/machine.smt2") then path
21+ else
22+ let parent = Filename.dirname path in
23+ if parent = path then invalid_arg "cannot locate smt/machine.smt2"
24+ else find parent
25+ in
26+ match Sys.getenv_opt "REORDER_ROOT" with
27+ | Some path -> find path
28+ | None ->
29+ try find (Sys.getcwd ()) with Invalid_argument _ ->
30+ let executable = if Filename.is_relative Sys.executable_name then
31+ Filename.concat (Sys.getcwd ()) Sys.executable_name else Sys.executable_name in
32+ find (Filename.dirname executable)

store.mli added

@@ -0,0 +1,4 @@
1+val read : string -> string
2+val write : string -> string -> unit
3+val mkdir : string -> unit
4+val root : unit -> string

syntax.ml added

@@ -0,0 +1,132 @@
1+type instruction =
2+ | Store of int * int64 | Load of int * int | Fence
3+ | Move of int * int64 | Branch of int * int64 * int
4+ | Enter | Leave | Exchange of int * int * int64
5+
6+type goal = Overlap | Outcome of {
7+ registers : (int * int * int64) list;
8+ memory : (int * int64) list;
9+ drained : bool;
10+}
11+
12+type model = Sc | Tso
13+type location = int * int
14+type t = {
15+ name : string;
16+ names : string array;
17+ bound : int;
18+ threads : instruction array array;
19+ candidates : location list;
20+ goal : goal;
21+}
22+
23+let model = function "sc" -> Sc | "tso" -> Tso | _ -> invalid_arg "unknown memory model"
24+let model_name = function Sc -> "sc" | Tso -> "tso"
25+let location value = match Sexp.list value with
26+ | [t; pc] -> Sexp.integer t, Sexp.integer pc
27+ | _ -> invalid_arg "invalid fence location"
28+
29+let instruction value =
30+ let open Sexp in
31+ match value with
32+ | Store (a, v) -> List [Atom "store"; i a; w v]
33+ | Load (a, r) -> List [Atom "load"; i a; i r]
34+ | Fence -> List [Atom "fence"]
35+ | Move (r, v) -> List [Atom "move"; i r; w v]
36+ | Branch (r, v, target) -> List [Atom "branch"; i r; w v; i target]
37+ | Enter -> List [Atom "enter"]
38+ | Leave -> List [Atom "leave"]
39+ | Exchange (a, r, v) -> List [Atom "exchange"; i a; i r; w v]
40+
41+let decode_instruction value =
42+ let open Sexp in
43+ match list value with
44+ | [Atom "store"; a; v] -> Store (integer a, word v)
45+ | [Atom "load"; a; r] -> Load (integer a, integer r)
46+ | [Atom "fence"] -> Fence
47+ | [Atom "move"; r; v] -> Move (integer r, word v)
48+ | [Atom "branch"; r; v; target] -> Branch (integer r, word v, integer target)
49+ | [Atom "enter"] -> Enter
50+ | [Atom "leave"] -> Leave
51+ | [Atom "exchange"; a; r; v] -> Exchange (integer a, integer r, word v)
52+ | _ -> invalid_arg "invalid instruction"
53+
54+let validate case =
55+ let check condition message = if not condition then invalid_arg message in
56+ check (Array.length case.threads = 2) "exactly two threads required";
57+ check (Array.length case.names > 0 && Array.length case.names <= 16) "address count outside 1..16";
58+ check (case.bound > 0 && case.bound <= 64) "step bound outside 1..64";
59+ let address a = check (a >= 0 && a < Array.length case.names) "address outside model" in
60+ let register r = check (r >= 0 && r < 4) "register outside model" in
61+ Array.iter (fun program ->
62+ check (Array.length program > 0 && Array.length program <= 64) "thread length outside 1..64";
63+ Array.iter (function
64+ | Store (a, _) -> address a
65+ | Load (a, r) | Exchange (a, r, _) -> address a; register r
66+ | Move (r, _) -> register r
67+ | Branch (r, _, target) -> register r;
68+ check (target >= 0 && target <= Array.length program) "branch target outside thread"
69+ | Fence | Enter | Leave -> ()) program) case.threads;
70+ let thread t = check (t >= 0 && t < 2) "thread outside model" in
71+ List.iter (fun (t, pc) -> thread t;
72+ check (pc >= 0 && pc < Array.length case.threads.(t)) "fence outside thread") case.candidates;
73+ check (List.length case.candidates = List.length (List.sort_uniq compare case.candidates)) "duplicate fence";
74+ match case.goal with
75+ | Overlap -> ()
76+ | Outcome goal ->
77+ List.iter (fun (t, r, _) -> thread t; register r) goal.registers;
78+ List.iter (fun (a, _) -> address a) goal.memory
79+
80+let singleton = function [value] -> value | _ -> invalid_arg "expected one field value"
81+
82+let decode value =
83+ let open Sexp in
84+ let fields = match value with
85+ | List (Atom "case" :: fields) -> fields
86+ | _ -> invalid_arg "expected case"
87+ in
88+ let get key = singleton (field key fields) in
89+ let goal = match field "goal" fields with
90+ | [Atom "overlap"] -> Overlap
91+ | [List (Atom "outcome" :: fields)] ->
92+ let registers = List.map (fun value -> match list value with
93+ | [t; r; v] -> integer t, integer r, word v
94+ | _ -> invalid_arg "invalid register goal") (field "registers" fields) in
95+ let memory = List.map (fun value -> match list value with
96+ | [a; v] -> integer a, word v
97+ | _ -> invalid_arg "invalid memory goal") (field "memory" fields) in
98+ let drained = match field "drained" fields with
99+ | [Atom "true"] -> true | [Atom "false"] -> false
100+ | _ -> invalid_arg "invalid drain flag" in
101+ Outcome {registers; memory; drained}
102+ | _ -> invalid_arg "invalid goal"
103+ in
104+ let case = {
105+ name = atom (get "name");
106+ names = Array.of_list (List.map atom (field "names" fields));
107+ bound = integer (get "bound");
108+ threads = Array.of_list (List.map (fun thread ->
109+ Array.of_list (List.map decode_instruction (list thread))) (field "threads" fields));
110+ candidates = List.map location (field "candidates" fields);
111+ goal;
112+ } in
113+ validate case;
114+ case
115+
116+let encode case =
117+ let open Sexp in
118+ let goal = match case.goal with
119+ | Overlap -> Atom "overlap"
120+ | Outcome goal -> List [Atom "outcome";
121+ List (Atom "registers" :: List.map (fun (t, r, v) -> List [i t; i r; w v]) goal.registers);
122+ List (Atom "memory" :: List.map (fun (a, v) -> List [i a; w v]) goal.memory);
123+ List [Atom "drained"; Atom (string_of_bool goal.drained)]] in
124+ List [Atom "case"; List [Atom "name"; Atom case.name];
125+ List (Atom "names" :: Array.to_list (Array.map a case.names));
126+ List [Atom "bound"; i case.bound];
127+ List (Atom "threads" :: Array.to_list (Array.map (fun thread ->
128+ List (Array.to_list (Array.map instruction thread))) case.threads));
129+ List (Atom "candidates" :: List.map (fun (t, pc) -> List [i t; i pc]) case.candidates);
130+ List [Atom "goal"; goal]]
131+
132+let load path = decode (Sexp.one (Store.read path))

syntax.mli added

@@ -0,0 +1,30 @@
1+type instruction =
2+ | Store of int * int64 | Load of int * int | Fence
3+ | Move of int * int64 | Branch of int * int64 * int
4+ | Enter | Leave | Exchange of int * int * int64
5+
6+type goal = Overlap | Outcome of {
7+ registers : (int * int * int64) list;
8+ memory : (int * int64) list;
9+ drained : bool;
10+}
11+
12+type model = Sc | Tso
13+type location = int * int
14+type t = {
15+ name : string;
16+ names : string array;
17+ bound : int;
18+ threads : instruction array array;
19+ candidates : location list;
20+ goal : goal;
21+}
22+
23+val validate : t -> unit
24+val decode : Sexp.t -> t
25+val encode : t -> Sexp.t
26+val load : string -> t
27+val instruction : instruction -> Sexp.t
28+val location : Sexp.t -> location
29+val model : string -> model
30+val model_name : model -> string

toolchain.json added

@@ -0,0 +1,19 @@
1+{
2+ "solver": "Z3",
3+ "version": "5.1.0",
4+ "language": "SMT-LIB 2",
5+ "basis": "https://www.cl.cam.ac.uk/~pes20/weakmemory/cacm.pdf",
6+ "semantics": "two threads, atomic 64-bit cells, FIFO store buffers, local forwarding, mfence and atomic exchange",
7+ "bounds": {
8+ "threads": 2,
9+ "registers": 4,
10+ "buffer": 8,
11+ "steps": 64
12+ },
13+ "ocaml": "5.5.0",
14+ "dune": "3.24.2",
15+ "driver": "OCaml",
16+ "solver_strategy": "simplify, solve-eqs, bit-blast, sat",
17+ "timeout_ms": 300000,
18+ "repair": "counterexample-guided synthesis refined by complete finite execution graphs"
19+}

view.ml added

@@ -0,0 +1,319 @@
1+type t = {
2+ width : int;
3+ delay : float;
4+ animate : bool;
5+ case : Syntax.t;
6+ started : float;
7+ mutable last_draw : float;
8+ mutable last_rows : int;
9+ mutable title : string;
10+ mutable fences : Syntax.location list;
11+ mutable budget : int;
12+ mutable round : int;
13+ mutable excluded : int list;
14+}
15+
16+let headline text =
17+ String.split_on_char ' ' text
18+ |> List.map (fun word ->
19+ match String.uppercase_ascii word with
20+ | "SC" | "TSO" | "SMT" | "FIFO" | "CPU" as acronym -> acronym
21+ | _ -> String.capitalize_ascii word)
22+ |> String.concat " "
23+
24+let fit width text =
25+ if String.length text <= width then text ^ String.make (width - String.length text) ' '
26+ else String.sub text 0 (max 0 (width - 3)) ^ "..."
27+let line width = String.make width '-'
28+let columns width left right =
29+ let size = (width - 3) / 2 in
30+ let height = max (List.length left) (List.length right) in
31+ List.init height (fun i ->
32+ let at values = if i < List.length values then List.nth values i else "" in
33+ fit size (at left) ^ " | " ^ fit size (at right))
34+let label (case : Syntax.t) address = case.names.(address)
35+let number value = if value >= 0L && value < 1000000L then Int64.to_string value
36+ else Printf.sprintf "0x%016Lx" value
37+
38+let instruction (case : Syntax.t) =
39+ let open Syntax in
40+ function
41+ | Store (a, v) -> Printf.sprintf "mov [%s], %s" (label case a) (number v)
42+ | Load (a, r) -> Printf.sprintf "mov r%d, [%s]" r (label case a)
43+ | Fence -> "mfence"
44+ | Move (r, v) -> Printf.sprintf "mov r%d, %s" r (number v)
45+ | Branch (r, v, target) -> Printf.sprintf "if r%d == %s goto %02d" r (number v) target
46+ | Enter -> "enter critical section"
47+ | Leave -> "leave critical section"
48+ | Exchange (a, r, v) -> Printf.sprintf "xchg [%s], %s -> r%d" (label case a) (number v) r
49+
50+let registers state t = String.concat " " (List.init 4 (fun r ->
51+ Printf.sprintf "r%d=%s" r (number state.Machine.regs.(t).(r))))
52+let queue case entries = match entries with
53+ | [] -> "[ empty ]"
54+ | entries -> String.concat " -> " (List.map (fun (a, v) ->
55+ Printf.sprintf "[ %s=%s ]" (label case a) (number v)) entries)
56+let memory case state = String.concat " " (List.init (Array.length case.Syntax.names) (fun a ->
57+ Printf.sprintf "[ %s = %s ]" (label case a) (number state.Machine.memory.(a))))
58+
59+let program case fences state t =
60+ let pc = state.Machine.pc.(t) in
61+ let active = if state.critical.(t) then " Inside Critical Section" else "" in
62+ let head = [Printf.sprintf "Thread %d pc=%02d%s" t pc active; registers state t; ""] in
63+ let code = case.Syntax.threads.(t) in
64+ let first = max 0 (min (pc - 3) (Array.length code - 9)) in
65+ head @ List.concat (List.init (min 9 (Array.length code)) (fun offset ->
66+ let i = first + offset in
67+ let fence = if not (List.mem (t, i) fences) then [] else
68+ [Printf.sprintf " mfence%s" (if i = pc && state.buffers.(t) <> [] then " < waiting for store buffer" else "")] in
69+ fence @ [Printf.sprintf "%s %02d %s" (if i = pc then ">" else " ") i (instruction case code.(i))])) @
70+ [""; "FIFO Store Buffer oldest -> newest"; queue case state.buffers.(t)]
71+
72+let event case before after = function
73+ | Machine.Idle -> "scheduler idle"
74+ | Machine.Drain (t, a, v) ->
75+ Printf.sprintf "T%d drains %s=%s from its FIFO buffer into shared memory" t (label case a) (number v)
76+ | Machine.Issue (t, _, Syntax.Load (a, r), Some origin) ->
77+ let source = match origin with Machine.Memory -> "shared memory" | Machine.Buffer -> "its latest buffered write" in
78+ let stale = List.exists (fun (address, _) -> address = a) before.Machine.buffers.(1 - t) in
79+ Printf.sprintf "T%d reads %s=%s into r%d from %s%s" t (label case a)
80+ (number after.Machine.regs.(t).(r)) r source
81+ (if stale && origin = Machine.Memory then " while the other thread has a pending write" else "")
82+ | Machine.Issue (t, pc, ins, _) ->
83+ Printf.sprintf "T%d issues pc=%02d %s" t pc (instruction case ins)
84+
85+let timeline actors count =
86+ let first = max 0 (count - 24) in
87+ let cells = List.init (count - first) (fun i ->
88+ let actor = actors.(first + i) in
89+ match actor with 0 -> "T0" | 1 -> "T1" | 2 -> "F0" | 3 -> "F1" | _ -> "..") in
90+ ["Schedule T=Instruction F=FIFO Drain";
91+ String.concat " " (List.init (count - first) (fun i -> Printf.sprintf "%02d" (first + i + 1)));
92+ String.concat " " cells]
93+
94+let frame ~width (witness : Engine.witness) index =
95+ let states, events = Engine.replay witness in
96+ if index < 0 || index >= Array.length states then invalid_arg "trace frame outside execution";
97+ let state = states.(index) in
98+ let status = if state.critical.(0) && state.critical.(1) then "Mutual Exclusion Violated"
99+ else if index = witness.bound then "Requested Outcome Reached" else "Execution in Progress" in
100+ let description = if index = 0 then "All registers, memory cells and store buffers start empty"
101+ else event witness.case states.(index - 1) state events.(index - 1) in
102+ let heading = ["Reorder " ^ headline witness.case.name;
103+ Printf.sprintf "model=%s transition=%02d/%02d bound=%d independent replay=passed"
104+ (Syntax.model_name witness.model) index witness.bound witness.bound;
105+ line width; status; ""] in
106+ heading @ columns width (program witness.case witness.fences state 0) (program witness.case witness.fences state 1) @
107+ [""; line width; "Shared Memory"; memory witness.case state; "";
108+ "Current Transition"; description; ""] @ timeline witness.actors index
109+
110+let colour text =
111+ let paint code text = "\027[" ^ code ^ "m" ^ text ^ "\027[0m" in
112+ let code =
113+ if String.contains text '>' && String.starts_with ~prefix:">" (String.trim text) then "1;34"
114+ else if String.starts_with ~prefix:"Mutual Exclusion Violated" text then "1;31"
115+ else if String.starts_with ~prefix:"Minimum Repair Verified" text then "1;32"
116+ else if String.starts_with ~prefix:"Thread 0" text then "1;34"
117+ else if String.starts_with ~prefix:"Thread 1" text then "1;35"
118+ else if String.starts_with ~prefix:"Reorder" text then "1" else "30" in
119+ match String.index_opt text '|' with
120+ | None -> paint code text
121+ | Some middle ->
122+ let left = String.sub text 0 middle in
123+ let right = String.sub text (middle + 1) (String.length text - middle - 1) in
124+ paint "34" left ^ paint "30" "|" ^ paint "35" right
125+
126+let draw view lines =
127+ let buffer = Buffer.create 16384 in
128+ let write text =
129+ let text = fit view.width text in
130+ let last = ref (String.length text) in
131+ while !last > 0 && text.[!last - 1] = ' ' do decr last done;
132+ Buffer.add_string buffer (if view.animate then colour text else String.sub text 0 !last)
133+ in
134+ if view.animate then begin
135+ let rows = Array.of_list lines in
136+ for row = 0 to max view.last_rows (Array.length rows) - 1 do
137+ Printf.bprintf buffer "\027[%d;1H\027[2K" (row + 1);
138+ if row < Array.length rows then write rows.(row)
139+ done;
140+ Buffer.add_string buffer "\027[1;1H"
141+ end else
142+ List.iter (fun text -> write text; Buffer.add_char buffer '\n') lines;
143+ output_string stdout (Buffer.contents buffer);
144+ flush stdout;
145+ view.last_rows <- List.length lines;
146+ view.last_draw <- Unix.gettimeofday ()
147+
148+let create ?(width=140) ?(delay=0.7) ~animate case =
149+ if width < 78 || width > 180 || delay < 0. || delay > 10. then invalid_arg "invalid display dimensions or delay";
150+ if animate then begin print_string "\027[2J\027[H\027[?25l"; flush stdout end;
151+ {width; delay; animate; case; started=Unix.gettimeofday (); last_draw=0.; last_rows=0;
152+ title="Preparing SMT query"; fences=[]; budget=0; round=0; excluded=[]}
153+
154+let tick view =
155+ let now = Unix.gettimeofday () in
156+ if view.animate && now -. view.last_draw >= 0.35 then begin
157+ let state = Machine.initial view.case in
158+ let selected = String.concat " " (List.map (fun (t, pc) -> Printf.sprintf "T%d@%02d" t pc) view.fences) in
159+ draw view (["Reorder " ^ headline view.case.name; line view.width;
160+ Printf.sprintf "%s elapsed %.1fs" view.title (now -. view.started);
161+ Printf.sprintf "verification round %d fence budget %d selected %s" view.round view.budget
162+ (if selected = "" then "none" else selected);
163+ ""] @ columns view.width (program view.case view.fences state 0) (program view.case view.fences state 1) @
164+ [""; line view.width;
165+ "Counterexample Constraints";
166+ "Lower budgets excluded: " ^ String.concat ", " (List.map string_of_int view.excluded);
167+ "SMT query running; elapsed time measures actual solver work"])
168+ end
169+
170+let finish view =
171+ if view.animate then begin
172+ Printf.printf "\027[%d;1H\027[0m\027[?25h" (view.last_rows + 1);
173+ flush stdout
174+ end
175+
176+let phase view title =
177+ view.title <- title;
178+ view.last_draw <- 0.;
179+ tick view
180+
181+let play view witness =
182+ let _, events = Engine.replay witness in
183+ for index = 0 to witness.Engine.bound do
184+ if index = 0 || index = witness.bound || events.(index - 1) <> Machine.Idle then begin
185+ draw view (frame ~width:view.width witness index);
186+ if view.animate then Unix.sleepf view.delay
187+ end
188+ done
189+
190+let notify view = function
191+ | Engine.Searching (budget, fences) ->
192+ view.round <- view.round + 1;
193+ view.budget <- budget;
194+ view.fences <- fences;
195+ view.title <- "Searching for a violating execution";
196+ if view.animate then (view.last_draw <- 0.; tick view)
197+ else Printf.printf "round %d budget %d fences %s\n%!" view.round budget
198+ (String.concat ", " (List.map (fun (t, pc) -> Printf.sprintf "T%d@%d" t pc) fences))
199+ | Engine.Counterexample witness ->
200+ if view.animate then begin
201+ let faster = {view with delay=min 0.18 view.delay} in
202+ play faster witness;
203+ view.last_rows <- faster.last_rows;
204+ view.last_draw <- faster.last_draw
205+ end else print_endline "SAT counterexample replay checked"
206+ | Engine.Excluded budget ->
207+ view.excluded <- view.excluded @ [budget];
208+ if not view.animate then Printf.printf "budget %d excluded\n%!" budget
209+ | Engine.Refining bound ->
210+ view.title <- Printf.sprintf "Graph counterexample extends the SMT bound to %d" bound;
211+ if not view.animate then print_endline view.title
212+ | Engine.Verified (fences, bound, states) ->
213+ view.fences <- fences;
214+ view.title <- "Minimum Repair Verified";
215+ let state = Machine.initial view.case in
216+ draw view (["Reorder " ^ headline view.case.name; line view.width;
217+ "Minimum Repair Verified";
218+ Printf.sprintf "%d fences bound %d %d actual verification queries"
219+ (List.length fences) bound view.round;
220+ Printf.sprintf "Closed graph: %d reachable states, no violating state" states; ""] @
221+ columns view.width (program view.case fences state 0) (program view.case fences state 1) @
222+ [""; "Counterexample replay passed; lower-budget SMT certificate is UNSAT"])
223+
224+let compact case state =
225+ [Printf.sprintf "T0 pc=%02d %s" state.Machine.pc.(0)
226+ (if state.critical.(0) then "Inside" else "Outside"); registers state 0;
227+ "T0 buffer " ^ queue case state.buffers.(0); "";
228+ Printf.sprintf "T1 pc=%02d %s" state.pc.(1)
229+ (if state.critical.(1) then "Inside" else "Outside"); registers state 1;
230+ "T1 buffer " ^ queue case state.buffers.(1); ""; memory case state;
231+ ""; if state.critical.(0) && state.critical.(1) then "Overlap" else "No overlap in this state"]
232+
233+let contrast view (witness : Engine.witness) (repair : Engine.repair) =
234+ if witness.case <> repair.case then invalid_arg "comparison cases differ";
235+ let original, _ = Engine.replay witness in
236+ let fixed = Machine.reschedule witness.case repair.fences witness.actors in
237+ Engine.validate_schedule witness.case repair.fences fixed;
238+ let repaired, _ = Machine.replay witness.case Syntax.Tso repair.fences fixed in
239+ for index = 0 to witness.bound do
240+ if index = 0 || index = witness.bound || witness.actors.(index - 1) <> 4 then begin
241+ let prefix = Machine.reschedule witness.case repair.fences (Array.sub witness.actors 0 index) in
242+ let corrected = repaired.(Array.length prefix) in
243+ let left = ["Original Execution"; line ((view.width - 3) / 2)] @ compact witness.case original.(index) in
244+ let right = ["Minimum Fence Repair"; line ((view.width - 3) / 2)] @ compact witness.case corrected in
245+ draw view (["Reorder Original and Repaired Executions";
246+ Printf.sprintf "requested transition %02d/%02d pending writes drain before fenced instructions" index witness.bound;
247+ line view.width; ""] @ columns view.width left right @
248+ [""; line view.width;
249+ "left: replayed solver counterexample right: separately SMT-checked repaired execution";
250+ Printf.sprintf "Minimum repair certificate: %d fences, UNSAT at bound %d"
251+ (List.length repair.fences) repair.bound]);
252+ if view.animate then Unix.sleepf view.delay
253+ end
254+ done
255+
256+let outcomes view sc tso =
257+ let values = List.sort_uniq compare (sc @ tso) in
258+ let rows = List.map (fun ((left, right) as pair) -> Printf.sprintf "%-12s%-12s%-12s%s"
259+ (number left) (number right)
260+ (if List.mem pair sc then "allowed" else "excluded")
261+ (if List.mem pair tso then "allowed" else "excluded")) values in
262+ let initial = Machine.initial view.case in
263+ draw view (["Reorder Sequential Consistency Versus TSO"; line view.width;
264+ "Register Outcome Enumeration Complete"; ""] @
265+ columns view.width (program view.case [] initial 0) (program view.case [] initial 1) @
266+ [""; line view.width; "Each row is a distinct pair of final register values";
267+ "T0:r0 T1:r0 SC TSO"] @ rows)
268+
269+let graph view fences =
270+ if view.case.goal <> Syntax.Overlap then invalid_arg "graph view requires a mutual-exclusion property";
271+ let rows = Array.length view.case.threads.(0) + 1 in
272+ let cols = Array.length view.case.threads.(1) + 1 in
273+ let counts = Array.init rows (fun _ -> Array.make cols 0) in
274+ let unsafe = Array.init rows (fun _ -> Array.make cols false) in
275+ let occupancy = Array.make 4 0 in
276+ let depths = Array.init 2 (fun _ -> Array.make 9 0) in
277+ let render count complete edges violations =
278+ let grid = ["PC0 vs PC1 " ^ String.concat "" (List.init cols (fun pc -> Printf.sprintf "%6d" pc))] @
279+ List.init rows (fun row -> Printf.sprintf "%9d " row ^
280+ String.concat "" (List.init cols (fun col ->
281+ if counts.(row).(col) = 0 then " ."
282+ else Printf.sprintf "%5d%s" counts.(row).(col) (if unsafe.(row).(col) then "!" else " ")))) in
283+ let selected = String.concat ", " (List.map (fun (t, pc) -> Printf.sprintf "T%d@%02d" t pc) fences) in
284+ let occupancy = [""; "Critical Section Occupancy"] @
285+ List.mapi (fun i name -> Printf.sprintf "%-18s %5d states" name occupancy.(i))
286+ ["Both Outside"; "T0 Inside"; "T1 Inside"; "Both Inside"] in
287+ let queues = [""; "FIFO Depth T0 States T1 States"] @
288+ List.init 9 (fun depth -> Printf.sprintf "%10d %12d %12d" depth depths.(0).(depth) depths.(1).(depth)) in
289+ let programs = ["Fence Placement"] @
290+ program view.case fences (Machine.initial view.case) 0 @ [""] @
291+ program view.case fences (Machine.initial view.case) 1 in
292+ draw view (["Reorder Finite Execution State Exploration"; line view.width;
293+ "Program Counter Occupancy each cell counts distinct reachable machine states";
294+ "! marks a cell containing a mutual-exclusion violation"; ""] @ columns view.width (grid @ occupancy @ queues) programs @
295+ [""; line view.width;
296+ (if complete then Printf.sprintf "Reachable states %d transitions %d violating states %d" count edges violations
297+ else Printf.sprintf "Reachable states %d transition totals available at graph closure" count);
298+ "Fences: " ^ (if selected = "" then "none" else selected);
299+ if complete then "State Graph Closed every enabled successor is already represented"
300+ else "Exploring actual enabled instruction and FIFO-drain transitions"])
301+ in
302+ let visit state count =
303+ let row, col = state.Machine.pc.(0), state.pc.(1) in
304+ counts.(row).(col) <- counts.(row).(col) + 1;
305+ let active = (if state.critical.(0) then 1 else 0) + (if state.critical.(1) then 2 else 0) in
306+ occupancy.(active) <- occupancy.(active) + 1;
307+ for thread = 0 to 1 do
308+ let depth = List.length state.buffers.(thread) in
309+ depths.(thread).(depth) <- depths.(thread).(depth) + 1
310+ done;
311+ if state.critical.(0) && state.critical.(1) then unsafe.(row).(col) <- true;
312+ if view.animate && count mod 25 = 0 then begin
313+ render count false 0 0;
314+ Unix.sleepf (min 0.12 view.delay)
315+ end
316+ in
317+ let graph = Machine.explore ~visit view.case Syntax.Tso fences in
318+ render (Array.length graph.states) true graph.edges (List.length graph.violations);
319+ graph

view.mli added

@@ -0,0 +1,12 @@
1+type t
2+val headline : string -> string
3+val create : ?width:int -> ?delay:float -> animate:bool -> Syntax.t -> t
4+val tick : t -> unit
5+val notify : t -> Engine.phase -> unit
6+val frame : width:int -> Engine.witness -> int -> string list
7+val play : t -> Engine.witness -> unit
8+val contrast : t -> Engine.witness -> Engine.repair -> unit
9+val outcomes : t -> (int64 * int64) list -> (int64 * int64) list -> unit
10+val finish : t -> unit
11+val phase : t -> string -> unit
12+val graph : t -> Syntax.location list -> Machine.graph