Skip to content

Commit 4fdeee6

Browse files
polytypicpolytypic
committed
Add -diff base.json switch to diff against base results from file
1 parent f55f88f commit 4fdeee6

File tree

9 files changed

+184
-29
lines changed

9 files changed

+184
-29
lines changed

‎CHANGES.md

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
1-
# Release notes
1+
## Next release
22

3-
All notable changes to this project will be documented in this file.
3+
- Add `-diff base.json` switch to diff against base results from file
4+
(@polytypic)
45

56
## 0.1.1
67

‎lib/cmd.ml

Lines changed: 71 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -1,15 +1,70 @@
1-
let run ~benchmarks ?(budgetf = 0.025) ?(filters = []) ?(debug = false)
1+
let print_diff base next =
2+
let open Data in
3+
Option.pair (Results.parse base) (Results.parse next)
4+
|> Option.iter @@ fun (base, next) ->
5+
List.zip_by Benchmark.compare_by_name base next
6+
|> List.iter @@ fun ((base : Benchmark.t), (next : Benchmark.t)) ->
7+
Printf.printf "%s:\n" base.name;
8+
List.zip_by Metric.compare_by_name base.metrics next.metrics
9+
|> List.iter @@ fun ((base : Metric.t), (next : Metric.t)) ->
10+
Printf.printf " %s:\n" base.name;
11+
if base.trend <> next.trend || base.units <> next.units then
12+
Printf.printf " %.2f %s\n" next.value next.units
13+
else
14+
let times = next.value /. base.value in
15+
if
16+
(next.trend = `Higher_is_better && times < 0.95)
17+
|| (next.trend = `Lower_is_better && 1.05 < times)
18+
then
19+
Printf.printf
20+
" %.2f %s = \x1b[1;31m%.2f\x1b\x1b[0;39;49m x %.2f %s\n"
21+
next.value next.units times base.value base.units
22+
else if
23+
(next.trend = `Higher_is_better && 1.05 < times)
24+
|| (next.trend = `Lower_is_better && times < 0.95)
25+
then
26+
Printf.printf
27+
" %.2f %s = \x1b[1;32m%.2f\x1b\x1b[0;39;49m x %.2f %s\n"
28+
next.value next.units times base.value base.units
29+
else
30+
Printf.printf
31+
" %.2f %s = \x1b[1;33m%.2f\x1b\x1b[0;39;49m x %.2f %s\n"
32+
next.value next.units times base.value base.units
33+
34+
let run_benchmark ~budgetf ~debug (name, fn) =
35+
if debug then
36+
(* I wish there was a way to tell dune not to capture stderr. *)
37+
Printf.printf "Running: %s\n%!" name;
38+
`Assoc [ ("name", `String name); ("metrics", `List (fn ~budgetf)) ]
39+
40+
let build_filter = function
41+
| [] -> Fun.const true
42+
| filters -> begin
43+
let regexps = filters |> List.map Str.regexp in
44+
fun (name, _) ->
45+
regexps
46+
|> List.exists @@ fun regexp ->
47+
match Str.search_forward regexp name 0 with
48+
| _ -> true
49+
| exception Not_found -> false
50+
end
51+
52+
let run ~benchmarks ?(budgetf = 0.025) ?(filters = []) ?(debug = false) ?diff
253
?(argv = Sys.argv) ?(flush = true) () =
354
let budgetf = ref budgetf in
455
let filters = ref filters in
556
let debug = ref debug in
57+
let diff = ref diff in
658

759
let rec specs =
860
[
961
("-budget", Arg.Set_float budgetf, "seconds\t Budget for a benchmark");
1062
( "-debug",
1163
Arg.Set debug,
1264
"\t Print progress information to help debugging" );
65+
( "-diff",
66+
Arg.String (fun path -> diff := Some path),
67+
"path.json\t Show diff against specified base results" );
1368
("-help", Unit help, "\t Show this help message");
1469
("--help", Unit help, "\t Show this help message");
1570
]
@@ -30,35 +85,24 @@ let run ~benchmarks ?(budgetf = 0.025) ?(filters = []) ?(debug = false)
3085
in
3186
Arg.parse_argv argv specs (fun filter -> filters := filter :: !filters) "";
3287

33-
let budgetf = !budgetf in
34-
35-
if budgetf < 0.0 || 60.0 *. 60.0 < budgetf then
88+
if !budgetf < 0.0 || 60.0 *. 60.0 < !budgetf then
3689
invalid_arg "budgetf out of range";
3790

38-
let run (name, fn) =
39-
if !debug then
40-
(* I wish there was a way to tell dune not to capture stderr. *)
41-
Printf.printf "Running: %s\n%!" name;
42-
let metrics = fn ~budgetf in
43-
`Assoc [ ("name", `String name); ("metrics", `List metrics) ]
44-
in
45-
46-
let filter =
47-
match !filters with
48-
| [] -> Fun.const true
49-
| filters -> begin
50-
let regexps = filters |> List.map Str.regexp in
51-
fun (name, _) ->
52-
regexps
53-
|> List.exists @@ fun regexp ->
54-
match Str.search_forward regexp name 0 with
55-
| _ -> true
56-
| exception Not_found -> false
57-
end
91+
let results =
92+
`Assoc
93+
[
94+
( "results",
95+
`List
96+
(benchmarks
97+
|> List.filter (build_filter !filters)
98+
|> List.map (run_benchmark ~debug:!debug ~budgetf:!budgetf)) );
99+
]
58100
in
59101

60-
`Assoc
61-
[ ("results", `List (benchmarks |> List.filter filter |> List.map run)) ]
62-
|> Yojson.Safe.pretty_print ~std:true Format.std_formatter;
102+
begin
103+
match !diff with
104+
| None -> Yojson.Safe.pretty_print ~std:true Format.std_formatter results
105+
| Some fname -> print_diff (Yojson.Safe.from_file fname) results
106+
end;
63107

64108
if flush then Format.print_flush ()

‎lib/data.ml

Lines changed: 52 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
1+
open Option.Syntax
2+
3+
module Trend = struct
4+
type t = [ `Lower_is_better | `Higher_is_better ]
5+
6+
let parse =
7+
Json.as_string >=> function
8+
| "lower-is-better" -> Some `Lower_is_better
9+
| "higher-is-better" -> Some `Higher_is_better
10+
| _ -> None
11+
end
12+
13+
module Metric = struct
14+
type units = string
15+
16+
type t = {
17+
name : string;
18+
value : float;
19+
units : units;
20+
trend : Trend.t;
21+
description : string;
22+
}
23+
24+
let parse =
25+
(Json.prop "name" >=> Json.as_string
26+
& Json.prop "value" >=> Json.as_float
27+
& Json.prop "units" >=> Json.as_string
28+
& Json.prop "trend" >=> Trend.parse
29+
& Json.prop "description" >=> Json.as_string)
30+
>+> fun (name :: value :: units :: trend :: description) ->
31+
{ name; value; units; trend; description }
32+
33+
let compare_by_name x y = String.compare x.name y.name
34+
end
35+
36+
module Benchmark = struct
37+
type t = { name : string; metrics : Metric.t list }
38+
39+
let parse =
40+
(Json.prop "name" >=> Json.as_string
41+
& Json.prop "metrics" >=> Json.as_list >+> List.filter_map Metric.parse)
42+
>+> fun (name :: metrics) -> { name; metrics }
43+
44+
let compare_by_name x y = String.compare x.name y.name
45+
end
46+
47+
module Results = struct
48+
type t = Benchmark.t list
49+
50+
let parse =
51+
Json.prop "results" >=> Json.as_list >+> List.filter_map Benchmark.parse
52+
end

‎lib/infix_pair.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
type ('a, 'b) t = ( :: ) of 'a * 'b

‎lib/json.ml

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
open Option.Syntax
2+
3+
type t = Yojson.Safe.t
4+
5+
let as_assoc = function `Assoc assoc -> Some assoc | (_ : t) -> None
6+
let prop key = as_assoc >=> List.assoc_opt key
7+
let as_list = function `List list -> Some list | (_ : t) -> None
8+
let as_string = function `String string -> Some string | (_ : t) -> None
9+
let as_float = function `Float float -> Some float | (_ : t) -> None

‎lib/list.ml

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
include Stdlib.List
2+
3+
let zip_by (type t) (compare : t -> _) xs ys =
4+
let (module S) = Set.make compare in
5+
let ys = S.of_list ys in
6+
xs |> filter_map @@ fun x -> S.find_opt x ys |> Option.map @@ fun y -> (x, y)

‎lib/multicore_bench.mli

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -142,6 +142,7 @@ module Cmd : sig
142142
?budgetf:float ->
143143
?filters:string list ->
144144
?debug:bool ->
145+
?diff:string ->
145146
?argv:string array ->
146147
?flush:bool ->
147148
unit ->
@@ -159,6 +160,12 @@ module Cmd : sig
159160
suites. If any regular expression matches the name of benchmark, then
160161
that benchmark will be run. Defaults to [[]].
161162
163+
- [~debug]: Print progress information to help debugging. Defaults to
164+
[false].
165+
166+
- [~diff]: Name of JSON file of results to show diff against. Defaults to
167+
[None].
168+
162169
- [~argv]: Array of command line arguments. Defaults to [Sys.argv].
163170
164171
- [~flush]: Whether to flush the standard output after writing it.

‎lib/option.ml

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
include Stdlib.Option
2+
3+
let pair x y = match (x, y) with Some x, Some y -> Some (x, y) | _ -> None
4+
5+
module Syntax = struct
6+
let ( & ) l r x =
7+
match l x with
8+
| None -> None
9+
| Some l -> begin
10+
match r x with None -> None | Some r -> Some Infix_pair.(l :: r)
11+
end
12+
13+
let ( let* ) = bind
14+
let ( >>= ) = bind
15+
let ( >=> ) f g x = f x >>= g
16+
let ( let+ ) x f = map f x
17+
let ( >>+ ) = ( let+ )
18+
let ( >+> ) f g x = f x >>+ g
19+
let pure = some
20+
let ( and* ) = pair
21+
let ( and+ ) = pair
22+
end

‎lib/set.ml

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
include Stdlib.Set
2+
3+
let ordered_type (type t) (compare : t -> _) =
4+
(module struct
5+
type nonrec t = t
6+
7+
let compare = compare
8+
end : OrderedType
9+
with type t = t)
10+
11+
let make (type t) (compare : t -> _) =
12+
let (module Elt) = ordered_type compare in
13+
(module Make (Elt) : Stdlib.Set.S with type elt = t)

0 commit comments

Comments
 (0)