296 lines
13 KiB
OCaml
296 lines
13 KiB
OCaml
open Vanity
|
|
|
|
type profile = {
|
|
name : string;
|
|
flags : Pipeline.optimisation_flags;
|
|
relation : Relation.relation;
|
|
}
|
|
|
|
type output_mode =
|
|
| Text
|
|
| Json
|
|
|
|
let safe_flags =
|
|
{ Pipeline.default_flags with unsafe_repr_eq = false; unsafe_strict_unroll = false; unsafe_effect_drop = false }
|
|
|
|
let profiles =
|
|
[
|
|
{ name = "safe"; flags = safe_flags; relation = Relation.Boxed_unboxed };
|
|
{ name = "specialise-only"; flags = { safe_flags with inline = false; repr_lower = false }; relation = Relation.Baseline };
|
|
{ name = "inline-no-repr-leak"; flags = { safe_flags with inline = true }; relation = Relation.Boxed_unboxed };
|
|
{ name = "unsafe-inline"; flags = { safe_flags with unsafe_repr_eq = true }; relation = Relation.Boxed_unboxed };
|
|
{ name = "unsafe-unbox"; flags = Pipeline.default_flags; relation = Relation.Boxed_unboxed };
|
|
{ name = "unsafe-strictness"; flags = { safe_flags with inline = false; unsafe_strict_unroll = true }; relation = Relation.Boxed_unboxed };
|
|
{ name = "unsafe-effects"; flags = { safe_flags with unsafe_effect_drop = true }; relation = Relation.Boxed_unboxed };
|
|
]
|
|
|
|
let json_escape s =
|
|
let b = Buffer.create (String.length s + 16) in
|
|
String.iter
|
|
(function
|
|
| '"' -> Buffer.add_string b "\\\""
|
|
| '\\' -> Buffer.add_string b "\\\\"
|
|
| '\n' -> Buffer.add_string b "\\n"
|
|
| '\r' -> Buffer.add_string b "\\r"
|
|
| '\t' -> Buffer.add_string b "\\t"
|
|
| c -> Buffer.add_char b c)
|
|
s;
|
|
Buffer.contents b
|
|
|
|
let json_string s = "\"" ^ json_escape s ^ "\""
|
|
let json_bool b = if b then "true" else "false"
|
|
let json_list xs = "[" ^ String.concat "," xs ^ "]"
|
|
|
|
let json_field name value =
|
|
json_string name ^ ":" ^ value
|
|
|
|
let json_object fields =
|
|
"{" ^ String.concat "," fields ^ "}"
|
|
|
|
let option_default all selected =
|
|
match selected with
|
|
| [] -> all
|
|
| _ -> List.rev selected
|
|
|
|
let find_named kind name xs get_name =
|
|
match List.find_opt (fun x -> String.equal (get_name x) name) xs with
|
|
| Some x -> x
|
|
| None ->
|
|
prerr_endline ("unknown " ^ kind ^ " " ^ name);
|
|
exit 2
|
|
|
|
let selected_cases names =
|
|
option_default Corpus.all (List.map (fun name -> find_named "case" name Corpus.all (fun c -> c.Corpus.name)) names)
|
|
|
|
let selected_profiles names =
|
|
option_default profiles (List.map (fun name -> find_named "profile" name profiles (fun p -> p.name)) names)
|
|
|
|
let failed_invariants audit =
|
|
audit.Audit.invariants
|
|
|> List.filter (fun result -> not result.Audit.passed)
|
|
|> List.map (fun result -> Audit.invariant_kind_to_string result.Audit.kind)
|
|
|
|
let emit_plain_obligations audit =
|
|
if audit.Audit.obligations = [] then "obligations none"
|
|
else
|
|
"obligations\n" ^
|
|
(audit.Audit.obligations
|
|
|> List.map (fun result ->
|
|
let o = result.Audit.obligation in
|
|
o.Pipeline.pass ^ " " ^
|
|
Reporting.obligation_kind_to_string o.Pipeline.kind ^ " " ^
|
|
Audit.obligation_status_to_string result.Audit.status ^ " " ^
|
|
result.Audit.note)
|
|
|> String.concat "\n")
|
|
|
|
let emit_plain_invariants audit =
|
|
"invariants\n" ^
|
|
(audit.Audit.invariants
|
|
|> List.map (fun result ->
|
|
Audit.invariant_kind_to_string result.Audit.kind ^ " " ^
|
|
(if result.Audit.passed then "ok" else "failed") ^ " " ^
|
|
result.Audit.detail)
|
|
|> String.concat "\n")
|
|
|
|
let emit_plain_boundaries audit =
|
|
"pass observations\n" ^
|
|
(audit.Audit.pass_boundaries
|
|
|> List.map (fun (boundary : Audit.pass_boundary) -> boundary.Audit.pass ^ " " ^ boundary.Audit.verdict)
|
|
|> String.concat "\n")
|
|
|
|
let run_case_text ~details case =
|
|
let audit = Audit.audit_case case in
|
|
let failed = failed_invariants audit in
|
|
Printf.printf
|
|
"case %s\nclassification %s\nverdict %s\nsource %s\ntarget %s\nfailed invariants %s\n"
|
|
case.Corpus.name
|
|
(Audit.failure_mode_to_string audit.Audit.failure_mode)
|
|
(Reporting.verdict_to_string audit.Audit.comparison.Relation.verdict)
|
|
(Reporting.string_of_source_trace audit.Audit.source_trace)
|
|
(Reporting.string_of_target_trace audit.Audit.target_trace)
|
|
(if failed = [] then "none" else String.concat ", " failed);
|
|
if details || audit.Audit.failure_mode <> Audit.Preserved then begin
|
|
Printf.printf "\n%s\n\n" (Reporting.emit_pipeline_visualisation audit.Audit.compiled);
|
|
Printf.printf "%s\n\n" (emit_plain_boundaries audit);
|
|
Printf.printf "%s\n\n" (emit_plain_invariants audit);
|
|
Printf.printf "%s\n" (emit_plain_obligations audit)
|
|
end;
|
|
Printf.printf "\n"
|
|
|
|
let outcome_json_source outcome =
|
|
json_string (Reporting.string_of_source_outcome outcome)
|
|
|
|
let outcome_json_target outcome =
|
|
json_string (Reporting.string_of_target_outcome outcome)
|
|
|
|
let obligation_json result =
|
|
let o = result.Audit.obligation in
|
|
json_object
|
|
[
|
|
json_field "pass" (json_string o.Pipeline.pass);
|
|
json_field "kind" (json_string (Reporting.obligation_kind_to_string o.Pipeline.kind));
|
|
json_field "status" (json_string (Audit.obligation_status_to_string result.Audit.status));
|
|
json_field "subject" (json_string o.Pipeline.subject);
|
|
json_field "detail" (json_string o.Pipeline.detail);
|
|
json_field "note" (json_string result.Audit.note);
|
|
]
|
|
|
|
let invariant_json result =
|
|
json_object
|
|
[
|
|
json_field "kind" (json_string (Audit.invariant_kind_to_string result.Audit.kind));
|
|
json_field "passed" (json_bool result.Audit.passed);
|
|
json_field "detail" (json_string result.Audit.detail);
|
|
]
|
|
|
|
let boundary_json (boundary : Audit.pass_boundary) =
|
|
json_object
|
|
[
|
|
json_field "pass" (json_string boundary.Audit.pass);
|
|
json_field "observation" (json_string boundary.Audit.verdict);
|
|
json_field "effects" (string_of_int boundary.Audit.effects);
|
|
]
|
|
|
|
let audit_json audit =
|
|
json_object
|
|
[
|
|
json_field "case" (json_string audit.Audit.case.Corpus.name);
|
|
json_field "summary" (json_string audit.Audit.case.Corpus.summary);
|
|
json_field "classification" (json_string (Audit.failure_mode_to_string audit.Audit.failure_mode));
|
|
json_field "verdict" (json_string (Reporting.verdict_to_string audit.Audit.comparison.Relation.verdict));
|
|
json_field "source" (json_string (Reporting.string_of_source_trace audit.Audit.source_trace));
|
|
json_field "target" (json_string (Reporting.string_of_target_trace audit.Audit.target_trace));
|
|
json_field "pipeline"
|
|
(json_object
|
|
[
|
|
json_field "source" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.source_program));
|
|
json_field "specialise" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.specialised));
|
|
json_field "inline" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.inlined));
|
|
json_field "effect" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.effect_rewritten));
|
|
json_field "repr_lower" (json_string (Target.string_of_term audit.Audit.compiled.Pipeline.target_program));
|
|
]);
|
|
json_field "pass_boundaries" (json_list (List.map boundary_json audit.Audit.pass_boundaries));
|
|
json_field "invariants" (json_list (List.map invariant_json audit.Audit.invariants));
|
|
json_field "obligations" (json_list (List.map obligation_json audit.Audit.obligations));
|
|
]
|
|
|
|
let run_case_json case =
|
|
audit_json (Audit.audit_case case)
|
|
|
|
let failure_json failure =
|
|
json_object
|
|
[
|
|
json_field "original_type" (json_string (Types.string_of_typ failure.Gen.original.Gen.ty));
|
|
json_field "original_term" (json_string (Source.string_of_term failure.Gen.original.Gen.term));
|
|
json_field "minimal_type" (json_string (Types.string_of_typ failure.Gen.minimal.Gen.ty));
|
|
json_field "minimal_term" (json_string (Source.string_of_term failure.Gen.minimal.Gen.term));
|
|
json_field "verdict" (json_string (Reporting.verdict_to_string failure.Gen.comparison.Relation.verdict));
|
|
json_field "source_effects" (string_of_int failure.Gen.comparison.Relation.source_effects);
|
|
json_field "target_effects" (string_of_int failure.Gen.comparison.Relation.target_effects);
|
|
]
|
|
|
|
let run_profile_text ~details ~count ~max_depth profile =
|
|
let result = Gen.run_campaign profile.flags profile.relation ~count ~max_depth () in
|
|
Printf.printf
|
|
"profile %s\nrelation %s\nrelated %d/%d\nviolations %d\n"
|
|
profile.name
|
|
(Reporting.string_of_relation profile.relation)
|
|
result.Gen.related
|
|
result.Gen.total
|
|
(result.Gen.total - result.Gen.related);
|
|
if details && result.Gen.failures <> [] then begin
|
|
Printf.printf "minimal failures\n";
|
|
result.Gen.failures
|
|
|> List.to_seq
|
|
|> Seq.take 5
|
|
|> Seq.iter (fun failure ->
|
|
Printf.printf
|
|
"type %s\nterm %s\nverdict %s\n\n"
|
|
(Types.string_of_typ failure.Gen.minimal.Gen.ty)
|
|
(Source.string_of_term failure.Gen.minimal.Gen.term)
|
|
(Reporting.verdict_to_string failure.Gen.comparison.Relation.verdict))
|
|
end;
|
|
Printf.printf "\n"
|
|
|
|
let run_profile_json ~count ~max_depth profile =
|
|
let result = Gen.run_campaign profile.flags profile.relation ~count ~max_depth () in
|
|
json_object
|
|
[
|
|
json_field "profile" (json_string profile.name);
|
|
json_field "relation" (json_string (Reporting.string_of_relation profile.relation));
|
|
json_field "total" (string_of_int result.Gen.total);
|
|
json_field "related" (string_of_int result.Gen.related);
|
|
json_field "violations" (string_of_int (result.Gen.total - result.Gen.related));
|
|
json_field "failures" (json_list (List.map failure_json result.Gen.failures));
|
|
]
|
|
|
|
let list_available () =
|
|
print_endline "cases";
|
|
List.iter (fun case -> print_endline (" " ^ case.Corpus.name)) Corpus.all;
|
|
print_endline "";
|
|
print_endline "profiles";
|
|
List.iter (fun profile -> print_endline (" " ^ profile.name)) profiles
|
|
|
|
let () =
|
|
let mode = ref Text in
|
|
let details = ref false in
|
|
let list_only = ref false in
|
|
let run_corpus = ref true in
|
|
let run_profiles = ref true in
|
|
let case_names = ref [] in
|
|
let profile_names = ref [] in
|
|
let count = ref 160 in
|
|
let max_depth = ref 4 in
|
|
let add_case name = case_names := name :: !case_names in
|
|
let add_profile name = profile_names := name :: !profile_names in
|
|
let specs =
|
|
[
|
|
("--case", Arg.String add_case, "run one corpus case by name; repeatable");
|
|
("--profile", Arg.String add_profile, "run one campaign profile by name; repeatable");
|
|
("--cases", Arg.Clear run_profiles, "run selected corpus cases without campaign profiles");
|
|
("--profiles", Arg.Clear run_corpus, "run selected campaign profiles without corpus cases");
|
|
("--count", Arg.Set_int count, "set generated campaign specimen count");
|
|
("--max-depth", Arg.Set_int max_depth, "set generated campaign term/type depth");
|
|
("--details", Arg.Set details, "print pass observations, invariants, obligations, and shrunk failures");
|
|
("--json", Arg.Unit (fun () -> mode := Json), "emit machine-readable JSON");
|
|
("--list", Arg.Set list_only, "list available cases and profiles");
|
|
]
|
|
in
|
|
Arg.parse specs (fun name -> add_case name) "vanity [--case name] [--profile name] [--details] [--json]";
|
|
if !list_only then list_available ()
|
|
else
|
|
let cases = if !run_corpus then selected_cases !case_names else [] in
|
|
let selected_profiles = if !run_profiles then selected_profiles !profile_names else [] in
|
|
match !mode with
|
|
| Text ->
|
|
if !details then Printf.printf "%s\n\n" (Audit.emit_relation_ledger ());
|
|
if cases <> [] then begin
|
|
Printf.printf "corpus\n\n";
|
|
List.iter (run_case_text ~details:!details) cases
|
|
end;
|
|
if selected_profiles <> [] then begin
|
|
Printf.printf "profiles\n\n";
|
|
List.iter (run_profile_text ~details:!details ~count:!count ~max_depth:!max_depth) selected_profiles
|
|
end
|
|
| Json ->
|
|
let case_json = List.map run_case_json cases in
|
|
let profile_json = List.map (run_profile_json ~count:!count ~max_depth:!max_depth) selected_profiles in
|
|
print_endline
|
|
(json_object
|
|
[
|
|
json_field "version" (json_string Project.version);
|
|
json_field "relation_ledger"
|
|
(json_list
|
|
(List.map
|
|
(fun entry ->
|
|
json_object
|
|
[
|
|
json_field "pass" (json_string entry.Audit.pass);
|
|
json_field "relation" (json_string entry.Audit.relation);
|
|
json_field "condition" (json_string entry.Audit.condition);
|
|
])
|
|
Audit.relation_ledger));
|
|
json_field "cases" (json_list case_json);
|
|
json_field "profiles" (json_list profile_json);
|
|
])
|