simon/ocaml-containers
1
0
Fork 0
mirror of https://github.com/c-cube/ocaml-containers.git synced 2025-12-06 11:15:31 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

use benchmark 1.4, with the upstreamed tree system

Browse source
This commit is contained in:
Simon Cruanes 2015-01-15 18:21:29 +01:00
parent f2890c56a6
commit 9e290d3ff6
2 changed files with 63 additions and 307 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

252
benchs/CCBench.ml
View file

@ -1,252 +0,0 @@
(*
copyright (c) 2013-2014, simon cruanes
all rights reserved.
redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
redistributions of source code must retain the above copyright notice, this
list of conditions and the following disclaimer. redistributions in binary
form must reproduce the above copyright notice, this list of conditions and the
following disclaimer in the documentation and/or other materials provided with
the distribution.
this software is provided by the copyright holders and contributors "as is" and
any express or implied warranties, including, but not limited to, the implied
warranties of merchantability and fitness for a particular purpose are
disclaimed. in no event shall the copyright holder or contributors be liable
for any direct, indirect, incidental, special, exemplary, or consequential
damages (including, but not limited to, procurement of substitute goods or
services; loss of use, data, or profits; or business interruption) however
caused and on any theory of liability, whether in contract, strict liability,
or tort (including negligence or otherwise) arising in any way out of the use
of this software, even if advised of the possibility of such damage.
*)
(** {1 helpers for benchmarks} *)
let print_line_ fmt () =
Format.pp_print_string fmt (CCString.repeat "*" 80);
Format.pp_print_newline fmt ()
let print_list_ ?(sep=", ") pp_item fmt l =
let rec print fmt l = match l with
| x::((_::_) as l) ->
pp_item fmt x;
Format.pp_print_string fmt sep;
Format.pp_print_cut fmt ();
print fmt l
| x::[] -> pp_item fmt x
| [] -> ()
in
print fmt l
(** {2 Bench Tree} *)
module SMap = Map.Make(String)
type single_bench = unit -> Benchmark.samples
type bench =
| Multiple of bench list * bench SMap.t
| Bench of single_bench
| WithInt of ((int -> bench) * int) list
let is_multiple = function
| Multiple _ -> true
| _ -> false
let rec merge_ t1 t2 = match t1, t2 with
| Multiple (l, map), ((Bench _ | WithInt _) as x) ->
Multiple (x :: l, map)
| Multiple (l1, m1), Multiple (l2, m2) ->
let m = SMap.merge
(fun _ o1 o2 -> merge_opt_ o1 o2)
m1 m2
in
Multiple (l1 @ l2, m)
| (Bench _ | WithInt _), Multiple _ -> merge_ t2 t1
| Bench _, _
| WithInt _, _ ->
Multiple ([t1; t2], SMap.empty) (* composite *)
and merge_opt_ o1 o2 = match o1, o2 with
| None, None -> None
| Some o, None
| None, Some o -> Some o
| Some o1, Some o2 -> Some (merge_ o1 o2)
let mk_list = function
| [] -> invalid_arg "mk_list"
| x :: tail -> List.fold_left merge_ x tail
let raw f = Bench f
let throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x =
Bench (fun () ->
Benchmark.throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat time ?name f x)
let throughputN ?style ?fwidth ?fdigits ?repeat time f =
Bench (fun () ->
Benchmark.throughputN ?style ?fwidth ?fdigits ?repeat time f)
let (>::) n t =
if n = "" then invalid_arg ">::";
Multiple ([], SMap.singleton n t)
let (>:::) n l =
if n = "" then invalid_arg ">:::";
Multiple ([], SMap.singleton n (mk_list l))
let with_int f = function
| [] -> invalid_arg "with_int: empty list"
| l -> WithInt (List.map (fun n -> f, n) l)
let map_int l =
if l = [] then invalid_arg "map_int";
WithInt l
(* print the structure of the tree *)
let rec print fmt = function
| Multiple (l, m) ->
Format.fprintf fmt "@[<hv>%a%a@]"
print_map m
(print_list_ ~sep:"," print) l
| WithInt l ->
Format.fprintf fmt "@[<hv>[%a]@]"
(print_list_ print_pair)
(List.map (fun (f, n) -> n, f n) l)
| Bench _ -> Format.fprintf fmt "<>"
and print_pair fmt (n,t) =
Format.fprintf fmt "@[<h>%d: %a@]" n print t
and print_map fmt m =
let first = ref true in
Format.pp_open_vbox fmt 0;
SMap.iter (fun n t ->
if !first then first := false else Format.pp_print_cut fmt ();
Format.fprintf fmt "@[%s.%a@]" n print t) m;
Format.pp_close_box fmt ()
(** {2 Path} *)
type path = string list
let print_path fmt path =
Format.fprintf fmt "@[<h>%a@]"
(print_list_ ~sep:"." Format.pp_print_string) path
let str_split_ ~by s =
let len_by = String.length by in
assert (len_by > 0);
let l = ref [] in
let n = String.length s in
let rec search prev i =
if i >= n
then (
if i>prev then l := String.sub s prev (n-prev) :: !l ;
List.rev !l
)
else if is_prefix i 0
then begin
l := (String.sub s prev (i-prev)) :: !l; (* save substring *)
search (i+len_by) (i+len_by)
end
else search prev (i+1)
and is_prefix i j =
if j = len_by
then true
else if i = n
then false
else s.[i] = by.[j] && is_prefix (i+1) (j+1)
in search 0 0
let parse_path s = str_split_ ~by:"." s
let () =
assert (parse_path "foo.bar" = ["foo";"bar"]);
assert (parse_path "foo" = ["foo"]);
assert (parse_path "" = []);
()
let prefix path t = List.fold_right (fun s t -> s >:: t) path t
(** {2 Run} *)
(* run one atomic single_bench *)
let run_single_bench_ fmt path f =
print_line_ fmt ();
Format.fprintf fmt "run bench %a@." print_path (List.rev path);
let res = f () in
Benchmark.tabulate res
(* run all benchs *)
let rec run_all fmt path t = match t with
| Bench f -> run_single_bench_ fmt path f
| Multiple (l, m) ->
List.iter (run_all fmt path) l;
SMap.iter
(fun n t' ->
let path = n :: path in
run_all fmt path t'
) m
| WithInt l ->
List.iter (fun (f, n) -> run_all fmt (string_of_int n::path) (f n)) l
let run fmt t = run_all fmt [] t
let sprintf_ format =
let b = Buffer.create 32 in
let fmt = Format.formatter_of_buffer b in
Format.kfprintf
(fun fmt -> Format.pp_print_flush fmt (); Buffer.contents b) fmt format
(* run all within a path *)
let rec run_path_rec_ fmt path remaining t = match t, remaining with
| _, [] -> run_all fmt path t
| Multiple (_, m), s :: remaining' ->
begin try
let t' = SMap.find s m in
run_path_rec_ fmt (s::path) remaining' t'
with Not_found ->
let msg = sprintf_ "could not find %s under path %a"
s print_path (List.rev path) in
failwith msg
end
| WithInt l, _ ->
List.iter (fun (f, n) -> run_path_rec_ fmt (string_of_int n::path) remaining (f n)) l
| Bench _, _::_ -> ()
let run_path fmt t path = run_path_rec_ fmt [] path t
let run_main ?(argv=Sys.argv) ?(out=Format.std_formatter) t =
let path = ref [] in
let do_print_tree = ref false in
let set_path_ s = path := parse_path s in
let options =
[ "-p", Arg.String set_path_, "only apply to subpath"
; "-tree", Arg.Set do_print_tree, "print bench tree"
] in
try
Arg.parse_argv argv options (fun _ -> ()) "run benchmarks [options]";
if !do_print_tree
then Format.fprintf out "@[%a@]@." print t
else (
Format.printf "run on path %a@." print_path !path;
run_path out t !path (* regular path *)
)
with Arg.Help msg ->
Format.pp_print_string out msg
(** {2 Global Registration} *)
let tree_ = ref (Multiple ([], SMap.empty))
let global_bench () = !tree_
let register ?(path=[]) new_t =
tree_ := merge_ !tree_ (prefix path new_t)
let register' ~path new_t =
register ~path:(parse_path path) new_t
let run_main ?argv ?out () =
run_main ?argv ?out !tree_

118
benchs/run_benchs.ml
View file

@ -1,5 +1,13 @@
(** Generic benchs *) (** Generic benchs *)
module B = Benchmark
let (@>) = B.Tree.(@>)
let (@>>) = B.Tree.(@>>)
let (@>>>) = B.Tree.(@>>>)
let app_int f n = string_of_int n @> lazy (f n)
let app_ints f l = B.Tree.concat (List.map (app_int f) l)
(* composition *) (* composition *)
let (%%) f g x = f (g x) let (%%) f g x = f (g x)
@ -17,7 +25,7 @@ module L = struct
let l = lazy CCList.(1 -- n) in let l = lazy CCList.(1 -- n) in
let flatten_map_ l = List.flatten (CCList.map f_ l) let flatten_map_ l = List.flatten (CCList.map f_ l)
and flatten_ccmap_ l = List.flatten (List.map f_ l) in and flatten_ccmap_ l = List.flatten (List.map f_ l) in
CCBench.throughputN time B.throughputN time
[ "flat_map", CCList.flat_map f_ %% Lazy.force, l [ "flat_map", CCList.flat_map f_ %% Lazy.force, l
; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l ; "flatten o CCList.map", flatten_ccmap_ %% Lazy.force, l
; "flatten o map", flatten_map_ %% Lazy.force, l ; "flatten o map", flatten_map_ %% Lazy.force, l
@ -33,7 +41,7 @@ module L = struct
let l2 = lazy CCList.(n+1 -- 2*n) in let l2 = lazy CCList.(n+1 -- 2*n) in
let l3 = lazy CCList.(2*n+1 -- 3*n) in let l3 = lazy CCList.(2*n+1 -- 3*n) in
let arg = l1, l2, l3 in let arg = l1, l2, l3 in
CCBench.throughputN time B.throughputN time
[ "CCList.append", append_ CCList.append, arg [ "CCList.append", append_ CCList.append, arg
; "List.append", append_ List.append, arg ; "List.append", append_ List.append, arg
] ]
@ -51,7 +59,7 @@ module L = struct
(fun i x -> CCList.(x -- (x+ min i 100))) (fun i x -> CCList.(x -- (x+ min i 100)))
CCList.(1 -- n)) CCList.(1 -- n))
in in
CCBench.throughputN time B.throughputN time
[ "CCList.flatten", CCList.flatten %% Lazy.force, l [ "CCList.flatten", CCList.flatten %% Lazy.force, l
; "List.flatten", List.flatten %% Lazy.force, l ; "List.flatten", List.flatten %% Lazy.force, l
; "fold_right append", fold_right_append_ %% Lazy.force, l ; "fold_right append", fold_right_append_ %% Lazy.force, l
@ -60,23 +68,23 @@ module L = struct
(* MAIN *) (* MAIN *)
let () = CCBench.register CCBench.( let () = B.Tree.register (
"list" >::: "list" @>>>
[ "flat_map" >:: [ "flat_map" @>>
map_int B.Tree.concat
[ bench_flat_map ~time:2, 100 [ app_int (bench_flat_map ~time:2) 100
; bench_flat_map ~time:2, 10_000 ; app_int (bench_flat_map ~time:2) 10_000
; bench_flat_map ~time:4, 100_000] ; app_int (bench_flat_map ~time:4) 100_000]
; "flatten" >:: ; "flatten" @>>
map_int B.Tree.concat
[ bench_flatten ~time:2, 100 [ app_int (bench_flatten ~time:2) 100
; bench_flatten ~time:2, 10_000 ; app_int (bench_flatten ~time:2) 10_000
; bench_flatten ~time:4, 100_000] ; app_int (bench_flatten ~time:4) 100_000]
; "append" >:: ; "append" @>>
map_int B.Tree.concat
[ bench_append ~time:2, 100 [ app_int (bench_append ~time:2) 100
; bench_append ~time:2, 10_000 ; app_int (bench_append ~time:2) 10_000
; bench_append ~time:4, 100_000] ; app_int (bench_append ~time:4) 100_000]
] ]
) )
end end
@ -96,7 +104,7 @@ module Vec = struct
let bench_map n = let bench_map n =
let v = lazy (CCVector.init n (fun x->x)) in let v = lazy (CCVector.init n (fun x->x)) in
CCBench.throughputN 2 B.throughputN 2
[ "map", CCVector.map f %% Lazy.force, v [ "map", CCVector.map f %% Lazy.force, v
; "map_push", map_push_ f %% Lazy.force, v ; "map_push", map_push_ f %% Lazy.force, v
; "map_push_cap", map_push_size_ f %% Lazy.force, v ; "map_push_cap", map_push_size_ f %% Lazy.force, v
@ -113,15 +121,15 @@ module Vec = struct
let bench_append n = let bench_append n =
let v2 = lazy (CCVector.init n (fun x->n+x)) in let v2 = lazy (CCVector.init n (fun x->n+x)) in
CCBench.throughputN 2 B.throughputN 2
[ "append", try_append_ CCVector.append n v2, () [ "append", try_append_ CCVector.append n v2, ()
; "append_naive", try_append_ append_naive_ n v2, () ; "append_naive", try_append_ append_naive_ n v2, ()
] ]
let () = CCBench.register CCBench.( let () = B.Tree.register (
"vector" >::: "vector" @>>>
[ "map" >:: with_int bench_map [100; 10_000; 100_000] [ "map" @>> app_ints bench_map [100; 10_000; 100_000]
; "append" >:: with_int bench_append [100; 10_000; 50_000] ; "append" @>> app_ints bench_append [100; 10_000; 50_000]
] ]
) )
end end
@ -158,11 +166,11 @@ module Cache = struct
] @ l ] @ l
else l else l
in in
CCBench.throughputN 3 l B.throughputN 3 l
let () = CCBench.register CCBench.( let () = B.Tree.register (
"cache" >::: "cache" @>>>
[ "fib" >:: with_int bench_fib [10; 20; 100; 200; 1_000;] [ "fib" @>> app_ints bench_fib [10; 20; 100; 200; 1_000;]
] ]
) )
end end
@ -267,7 +275,7 @@ module Tbl = struct
h h
let bench_maps1 n = let bench_maps1 n =
CCBench.throughputN 3 B.throughputN 3
["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n;
"hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n;
"ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n;
@ -370,7 +378,7 @@ module Tbl = struct
h h
let bench_maps2 n = let bench_maps2 n =
CCBench.throughputN 3 B.throughputN 3
["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n;
"hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n; "hashtbl_replace", (fun n -> ignore (hashtbl_replace n)), n;
"ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n; "ihashtbl_replace", (fun n -> ignore (ihashtbl_replace n)), n;
@ -455,7 +463,7 @@ module Tbl = struct
let a = Array.init n (fun i -> string_of_int i) in let a = Array.init n (fun i -> string_of_int i) in
let m = imap_add n in let m = imap_add n in
let h'''''' = icchashtbl_add n in let h'''''' = icchashtbl_add n in
CCBench.throughputN 3 [ B.throughputN 3 [
"phashtbl_find", (fun () -> phashtbl_find h n), (); "phashtbl_find", (fun () -> phashtbl_find h n), ();
"hashtbl_find", (fun () -> hashtbl_find h' n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), ();
"ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); "ihashtbl_find", (fun () -> ihashtbl_find h'' n), ();
@ -468,11 +476,11 @@ module Tbl = struct
"cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); "cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), ();
] ]
let () = CCBench.register CCBench.( let () = B.Tree.register (
"tbl" >::: "tbl" @>>>
[ "add" >:: with_int bench_maps1 [10; 100; 1_000; 10_000;] [ "add" @>> app_ints bench_maps1 [10; 100; 1_000; 10_000;]
; "replace" >:: with_int bench_maps2 [10; 100; 1_000; 10_000] ; "replace" @>> app_ints bench_maps2 [10; 100; 1_000; 10_000]
; "find" >:: with_int bench_maps3 [10; 20; 100; 1_000; 10_000] ; "find" @>> app_ints bench_maps3 [10; 20; 100; 1_000; 10_000]
]) ])
end end
@ -483,7 +491,7 @@ module Iter = struct
let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in
let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let gen () = Gen.fold (+) 0 Gen.(0 -- n) in
let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in
CCBench.throughputN 3 B.throughputN 3
[ "sequence.fold", seq, (); [ "sequence.fold", seq, ();
"gen.fold", gen, (); "gen.fold", gen, ();
"klist.fold", klist, (); "klist.fold", klist, ();
@ -500,7 +508,7 @@ module Iter = struct
0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0
) )
in in
CCBench.throughputN 3 B.throughputN 3
[ "sequence.flat_map", seq, (); [ "sequence.flat_map", seq, ();
"gen.flat_map", gen, (); "gen.flat_map", gen, ();
"klist.flat_map", klist, (); "klist.flat_map", klist, ();
@ -523,17 +531,17 @@ module Iter = struct
1 -- n |> iter (fun x -> i := !i * x) 1 -- n |> iter (fun x -> i := !i * x)
) )
in in
CCBench.throughputN 3 B.throughputN 3
[ "sequence.iter", seq, (); [ "sequence.iter", seq, ();
"gen.iter", gen, (); "gen.iter", gen, ();
"klist.iter", klist, (); "klist.iter", klist, ();
] ]
let () = CCBench.register CCBench.( let () = B.Tree.register (
"iter" >::: "iter" @>>>
[ "fold" >:: with_int bench_fold [100; 1_000; 10_000; 1_000_000] [ "fold" @>> app_ints bench_fold [100; 1_000; 10_000; 1_000_000]
; "flat_map" >:: with_int bench_flat_map [1_000; 10_000] ; "flat_map" @>> app_ints bench_flat_map [1_000; 10_000]
; "iter" >:: with_int bench_iter [1_000; 10_000] ; "iter" @>> app_ints bench_iter [1_000; 10_000]
]) ])
end end
@ -586,16 +594,16 @@ module Batch = struct
CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a); CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a);
*) *)
assert (C.equal (batch a) (naive a)); assert (C.equal (batch a) (naive a));
CCBench.throughputN time B.throughputN time
[ C.name ^ "_naive", naive, a [ C.name ^ "_naive", naive, a
; C.name ^ "_batch", batch, a ; C.name ^ "_batch", batch, a
] ]
let bench = CCBench.( let bench = B.(
C.name >:: map_int C.name @>> B.Tree.concat
[ bench_for ~time:1, 100 [ app_int (bench_for ~time:1) 100
; bench_for ~time:4, 100_000 ; app_int (bench_for ~time:4) 100_000
; bench_for ~time:4, 1_000_000 ; app_int (bench_for ~time:4) 1_000_000
]) ])
end end
@ -622,8 +630,8 @@ module Batch = struct
let doubleton x y = CCKList.of_list [ x; y ] let doubleton x y = CCKList.of_list [ x; y ]
end) end)
let () = CCBench.register CCBench.( let () = B.Tree.register (
"batch" >:: mk_list "batch" @>> B.Tree.concat
[ BenchKList.bench [ BenchKList.bench
; BenchArray.bench ; BenchArray.bench
; BenchList.bench ; BenchList.bench
@ -631,4 +639,4 @@ module Batch = struct
end end
let () = let () =
CCBench.run_main () B.Tree.run_global ()