nixify
This commit is contained in:
@@ -0,0 +1,413 @@
|
||||
(* fuzz the tables and matchers generated *)
|
||||
open Match
|
||||
|
||||
module Buffer: sig
|
||||
type 'a t
|
||||
val create: ?capacity:int -> unit -> 'a t
|
||||
val reset: 'a t -> unit
|
||||
val size: 'a t -> int
|
||||
val get: 'a t -> int -> 'a
|
||||
val set: 'a t -> int -> 'a -> unit
|
||||
val push: 'a t -> 'a -> unit
|
||||
end = struct
|
||||
type 'a t =
|
||||
{ mutable size: int
|
||||
; mutable data: 'a array }
|
||||
let mk_array n = Array.make n (Obj.magic 0)
|
||||
let create ?(capacity = 10) () =
|
||||
if capacity < 0 then invalid_arg "Buffer.make";
|
||||
{size = 0; data = mk_array capacity}
|
||||
let reset b = b.size <- 0
|
||||
let size b = b.size
|
||||
let get b n =
|
||||
if n >= size b then invalid_arg "Buffer.get";
|
||||
b.data.(n)
|
||||
let set b n x =
|
||||
if n >= size b then invalid_arg "Buffer.set";
|
||||
b.data.(n) <- x
|
||||
let push b x =
|
||||
let cap = Array.length b.data in
|
||||
if size b = cap then begin
|
||||
let data = mk_array (2 * cap + 1) in
|
||||
Array.blit b.data 0 data 0 cap;
|
||||
b.data <- data
|
||||
end;
|
||||
let sz = size b in
|
||||
b.size <- sz + 1;
|
||||
set b sz x
|
||||
end
|
||||
|
||||
let binop_state n op s1 s2 =
|
||||
let key = K (op, s1, s2) in
|
||||
try StateMap.find key n.statemap
|
||||
with Not_found -> atom_state n Tmp
|
||||
|
||||
type id = int
|
||||
type term_data =
|
||||
| Binop of op * id * id
|
||||
| Leaf of atomic_pattern
|
||||
type term =
|
||||
{ id: id
|
||||
; data: term_data
|
||||
; state: p state }
|
||||
|
||||
let pp_term fmt (ta, id) =
|
||||
let fpf x = Format.fprintf fmt x in
|
||||
let rec pp _fmt id =
|
||||
match ta.(id).data with
|
||||
| Leaf (Con c) -> fpf "%Ld" c
|
||||
| Leaf AnyCon -> fpf "$%d" id
|
||||
| Leaf Tmp -> fpf "%%%d" id
|
||||
| Binop (op, id1, id2) ->
|
||||
fpf "@[(%s@%d:%d @[<hov>%a@ %a@])@]"
|
||||
(show_op op) id ta.(id).state.id
|
||||
pp id1 pp id2
|
||||
in pp fmt id
|
||||
|
||||
(* A term pool is a deduplicated set of term
|
||||
* that maintains nodes numbering using the
|
||||
* statemap passed at creation time *)
|
||||
module TermPool = struct
|
||||
type t =
|
||||
{ terms: term Buffer.t
|
||||
; hcons: (term_data, id) Hashtbl.t
|
||||
; numbr: numberer }
|
||||
|
||||
let create numbr =
|
||||
{ terms = Buffer.create ()
|
||||
; hcons = Hashtbl.create 100
|
||||
; numbr }
|
||||
let reset tp =
|
||||
Buffer.reset tp.terms;
|
||||
Hashtbl.clear tp.hcons
|
||||
|
||||
let size tp = Buffer.size tp.terms
|
||||
let term tp id = Buffer.get tp.terms id
|
||||
|
||||
let mk_leaf tp atm =
|
||||
let data = Leaf atm in
|
||||
match Hashtbl.find tp.hcons data with
|
||||
| id -> term tp id
|
||||
| exception Not_found ->
|
||||
let id = Buffer.size tp.terms in
|
||||
let state = atom_state tp.numbr atm in
|
||||
Buffer.push tp.terms {id; data; state};
|
||||
Hashtbl.add tp.hcons data id;
|
||||
term tp id
|
||||
let mk_binop tp op t1 t2 =
|
||||
let data = Binop (op, t1.id, t2.id) in
|
||||
match Hashtbl.find tp.hcons data with
|
||||
| id -> term tp id
|
||||
| exception Not_found ->
|
||||
let id = Buffer.size tp.terms in
|
||||
let state =
|
||||
binop_state tp.numbr op t1.state t2.state
|
||||
in
|
||||
Buffer.push tp.terms {id; data; state};
|
||||
Hashtbl.add tp.hcons data id;
|
||||
term tp id
|
||||
|
||||
let rec add_pattern tp = function
|
||||
| Bnr (op, p1, p2) ->
|
||||
let t1 = add_pattern tp p1 in
|
||||
let t2 = add_pattern tp p2 in
|
||||
mk_binop tp op t1 t2
|
||||
| Atm atm -> mk_leaf tp atm
|
||||
| Var (_, atm) -> add_pattern tp (Atm atm)
|
||||
|
||||
let explode_term tp id =
|
||||
let rec aux tms n id =
|
||||
let t = term tp id in
|
||||
match t.data with
|
||||
| Leaf _ -> (n, {t with id = n} :: tms)
|
||||
| Binop (op, id1, id2) ->
|
||||
let n1, tms = aux tms n id1 in
|
||||
let n = n1 + 1 in
|
||||
let n2, tms = aux tms n id2 in
|
||||
let n = n2 + 1 in
|
||||
(n, { t with data = Binop (op, n1, n2)
|
||||
; id = n } :: tms)
|
||||
in
|
||||
let n, tms = aux [] 0 id in
|
||||
Array.of_list (List.rev tms), n
|
||||
end
|
||||
|
||||
module R = Random
|
||||
|
||||
(* uniform pick in a list *)
|
||||
let list_pick l =
|
||||
let rec aux n l x =
|
||||
match l with
|
||||
| [] -> x
|
||||
| y :: l ->
|
||||
if R.int (n + 1) = 0 then
|
||||
aux (n + 1) l y
|
||||
else
|
||||
aux (n + 1) l x
|
||||
in
|
||||
match l with
|
||||
| [] -> invalid_arg "list_pick"
|
||||
| x :: l -> aux 1 l x
|
||||
|
||||
let term_pick ~numbr =
|
||||
let ops =
|
||||
if numbr.ops = [] then
|
||||
numbr.ops <-
|
||||
(StateMap.fold (fun k _ ops ->
|
||||
match k with
|
||||
| K (op, _, _) -> op :: ops)
|
||||
numbr.statemap [] |> setify);
|
||||
numbr.ops
|
||||
in
|
||||
let rec gen depth =
|
||||
(* exponential probability for leaves to
|
||||
* avoid skewing towards shallow terms *)
|
||||
let atm_prob = 0.75 ** float_of_int depth in
|
||||
if R.float 1.0 <= atm_prob || ops = [] then
|
||||
let atom, st = list_pick numbr.atoms in
|
||||
(st, Atm atom)
|
||||
else
|
||||
let op = list_pick ops in
|
||||
let s1, t1 = gen (depth - 1) in
|
||||
let s2, t2 = gen (depth - 1) in
|
||||
( binop_state numbr op s1 s2
|
||||
, Bnr (op, t1, t2) )
|
||||
in fun ~depth -> gen depth
|
||||
|
||||
exception FuzzError
|
||||
|
||||
let rec pattern_depth = function
|
||||
| Bnr (_, p1, p2) ->
|
||||
1 + max (pattern_depth p1) (pattern_depth p2)
|
||||
| Atm _ -> 0
|
||||
| Var (_, atm) -> pattern_depth (Atm atm)
|
||||
|
||||
let ( %% ) a b =
|
||||
1e2 *. float_of_int a /. float_of_int b
|
||||
|
||||
let progress ?(width = 50) msg pct =
|
||||
Format.eprintf "\x1b[2K\r%!";
|
||||
let progress_bar fmt =
|
||||
let n =
|
||||
let fwidth = float_of_int width in
|
||||
1 + int_of_float (pct *. fwidth /. 1e2)
|
||||
in
|
||||
Format.fprintf fmt " %s%s %.0f%%@?"
|
||||
(String.concat "" (List.init n (fun _ -> "▒")))
|
||||
(String.make (max 0 (width - n)) '-')
|
||||
pct
|
||||
in
|
||||
Format.kfprintf progress_bar
|
||||
Format.err_formatter msg
|
||||
|
||||
let fuzz_numberer rules numbr =
|
||||
(* pick twice the max pattern depth so we
|
||||
* have a chance to find non-trivial numbers
|
||||
* for the atomic patterns in the rules *)
|
||||
let depth =
|
||||
List.fold_left (fun depth r ->
|
||||
max depth (pattern_depth r.pattern))
|
||||
0 rules * 2
|
||||
in
|
||||
(* fuzz until the term pool we are constructing
|
||||
* is no longer growing fast enough; or we just
|
||||
* went through sufficiently many iterations *)
|
||||
let max_iter = 1_000_000 in
|
||||
let low_insert_rate = 1e-2 in
|
||||
let tp = TermPool.create numbr in
|
||||
let rec loop new_stats i =
|
||||
let (_, _, insert_rate) = new_stats in
|
||||
if insert_rate <= low_insert_rate then () else
|
||||
if i >= max_iter then () else
|
||||
(* periodically update stats *)
|
||||
let new_stats =
|
||||
let (num, cnt, rate) = new_stats in
|
||||
if num land 1023 = 0 then
|
||||
let rate =
|
||||
0.5 *. (rate +. float_of_int cnt /. 1023.)
|
||||
in
|
||||
progress " insert_rate=%.1f%%"
|
||||
(i %% max_iter) (rate *. 1e2);
|
||||
(num + 1, 0, rate)
|
||||
else new_stats
|
||||
in
|
||||
(* create a term and check that its number is
|
||||
* accurate wrt the rules *)
|
||||
let st, term = term_pick ~numbr ~depth in
|
||||
let state_matched =
|
||||
List.filter_map (fun cu ->
|
||||
match cu with
|
||||
| Top ("$" | "%") -> None
|
||||
| Top name -> Some name
|
||||
| _ -> None)
|
||||
st.point |> setify
|
||||
in
|
||||
let rule_matched =
|
||||
List.filter_map (fun r ->
|
||||
if pattern_match r.pattern term then
|
||||
Some r.name
|
||||
else None)
|
||||
rules |> setify
|
||||
in
|
||||
if state_matched <> rule_matched then begin
|
||||
let open Format in
|
||||
let pp_str_list =
|
||||
let pp_sep fmt () = fprintf fmt ",@ " in
|
||||
pp_print_list ~pp_sep pp_print_string
|
||||
in
|
||||
eprintf "@.@[<v2>fuzz error for %s"
|
||||
(show_pattern term);
|
||||
eprintf "@ @[state matched: %a@]"
|
||||
pp_str_list state_matched;
|
||||
eprintf "@ @[rule matched: %a@]"
|
||||
pp_str_list rule_matched;
|
||||
eprintf "@]@.";
|
||||
raise FuzzError;
|
||||
end;
|
||||
if state_matched = [] then
|
||||
loop new_stats (i + 1)
|
||||
else
|
||||
(* add to the term pool *)
|
||||
let old_size = TermPool.size tp in
|
||||
let _ = TermPool.add_pattern tp term in
|
||||
let new_stats =
|
||||
let (num, cnt, rate) = new_stats in
|
||||
if TermPool.size tp <> old_size then
|
||||
(num + 1, cnt + 1, rate)
|
||||
else
|
||||
(num + 1, cnt, rate)
|
||||
in
|
||||
loop new_stats (i + 1)
|
||||
in
|
||||
loop (1, 0, 1.0) 0;
|
||||
Format.eprintf
|
||||
"@.@[ generated %.3fMiB of test terms@]@."
|
||||
(float_of_int (Obj.reachable_words (Obj.repr tp))
|
||||
/. 128. /. 1024.);
|
||||
tp
|
||||
|
||||
let rec run_matcher stk m (ta, id as t) =
|
||||
let state id = ta.(id).state.id in
|
||||
match m.Action.node with
|
||||
| Action.Switch cases ->
|
||||
let m =
|
||||
try List.assoc (state id) cases
|
||||
with Not_found -> failwith "no switch case"
|
||||
in
|
||||
run_matcher stk m t
|
||||
| Action.Push (sym, m) ->
|
||||
let l, r =
|
||||
match ta.(id).data with
|
||||
| Leaf _ -> failwith "push on leaf"
|
||||
| Binop (_, l, r) -> (l, r)
|
||||
in
|
||||
if sym && state l > state r
|
||||
then run_matcher (l :: stk) m (ta, r)
|
||||
else run_matcher (r :: stk) m (ta, l)
|
||||
| Action.Pop m -> begin
|
||||
match stk with
|
||||
| id :: stk -> run_matcher stk m (ta, id)
|
||||
| [] -> failwith "pop on empty stack"
|
||||
end
|
||||
| Action.Set (v, m) ->
|
||||
(v, id) :: run_matcher stk m t
|
||||
| Action.Stop -> []
|
||||
|
||||
let rec term_match p (ta, id) =
|
||||
let (|>>) x f =
|
||||
match x with None -> None | Some x -> f x
|
||||
in
|
||||
let atom_match a =
|
||||
match ta.(id).data with
|
||||
| Leaf a' -> pattern_match (Atm a) (Atm a')
|
||||
| Binop _ -> pattern_match (Atm a) (Atm Tmp)
|
||||
in
|
||||
match p with
|
||||
| Var (v, a) when atom_match a ->
|
||||
Some [(v, id)]
|
||||
| Atm a when atom_match a -> Some []
|
||||
| (Atm _ | Var _) -> None
|
||||
| Bnr (op, pl, pr) -> begin
|
||||
match ta.(id).data with
|
||||
| Binop (op', idl, idr) when op' = op ->
|
||||
term_match pl (ta, idl) |>> fun l1 ->
|
||||
term_match pr (ta, idr) |>> fun l2 ->
|
||||
Some (l1 @ l2)
|
||||
| _ -> None
|
||||
end
|
||||
|
||||
let test_matchers tp numbr rules =
|
||||
let {statemap = sm; states = sa; _} = numbr in
|
||||
let total = ref 0 in
|
||||
let matchers =
|
||||
let htbl = Hashtbl.create (Array.length sa) in
|
||||
List.map (fun r -> (r.name, r.pattern)) rules |>
|
||||
group_by_fst |>
|
||||
List.iter (fun (r, ps) ->
|
||||
total := !total + List.length ps;
|
||||
let pm = (ps, lr_matcher sm sa rules r) in
|
||||
sa |> Array.iter (fun s ->
|
||||
if List.mem (Top r) s.point then
|
||||
Hashtbl.add htbl s.id pm));
|
||||
htbl
|
||||
in
|
||||
let seen = Hashtbl.create !total in
|
||||
for id = 0 to TermPool.size tp - 1 do
|
||||
if id land 1023 = 0 ||
|
||||
id = TermPool.size tp - 1 then begin
|
||||
progress
|
||||
" coverage=%.1f%%"
|
||||
(id %% TermPool.size tp)
|
||||
(Hashtbl.length seen %% !total)
|
||||
end;
|
||||
let t = TermPool.explode_term tp id in
|
||||
Hashtbl.find_all matchers
|
||||
(TermPool.term tp id).state.id |>
|
||||
List.iter (fun (ps, m) ->
|
||||
let norm = List.fast_sort compare in
|
||||
let ok =
|
||||
match norm (run_matcher [] m t) with
|
||||
| asn -> `Match (List.exists (fun p ->
|
||||
match term_match p t with
|
||||
| None -> false
|
||||
| Some asn' ->
|
||||
if asn = norm asn' then begin
|
||||
Hashtbl.replace seen p ();
|
||||
true
|
||||
end else false) ps)
|
||||
| exception e -> `RunFailure e
|
||||
in
|
||||
if ok <> `Match true then begin
|
||||
let open Format in
|
||||
let pp_asn fmt asn =
|
||||
fprintf fmt "@[<h>";
|
||||
pp_print_list
|
||||
~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
|
||||
(fun fmt (v, d) ->
|
||||
fprintf fmt "@[%s←%d@]" v d)
|
||||
fmt asn;
|
||||
fprintf fmt "@]"
|
||||
in
|
||||
eprintf "@.@[<v2>matcher error for";
|
||||
eprintf "@ @[%a@]" pp_term t;
|
||||
begin match ok with
|
||||
| `RunFailure e ->
|
||||
eprintf "@ @[exception: %s@]"
|
||||
(Printexc.to_string e)
|
||||
| `Match (* false *) _ ->
|
||||
let asn = run_matcher [] m t in
|
||||
eprintf "@ @[assignment: %a@]"
|
||||
pp_asn asn;
|
||||
eprintf "@ @[<v2>could not match";
|
||||
List.iter (fun p ->
|
||||
eprintf "@ + @[%s@]"
|
||||
(show_pattern p)) ps;
|
||||
eprintf "@]"
|
||||
end;
|
||||
eprintf "@]@.";
|
||||
raise FuzzError
|
||||
end)
|
||||
done;
|
||||
Format.eprintf "@."
|
||||
|
||||
|
||||
Reference in New Issue
Block a user