From 9e290d3ff643da27fb4e0fec5f4dfd26f320cd3c Mon Sep 17 00:00:00 2001 From: Simon Cruanes Date: Thu, 15 Jan 2015 18:21:29 +0100 Subject: [PATCH] use benchmark 1.4, with the upstreamed tree system --- benchs/CCBench.ml | 252 ------------------------------------------- benchs/run_benchs.ml | 118 ++++++++++---------- 2 files changed, 63 insertions(+), 307 deletions(-) delete mode 100644 benchs/CCBench.ml diff --git a/benchs/CCBench.ml b/benchs/CCBench.ml deleted file mode 100644 index 73145714..00000000 --- a/benchs/CCBench.ml +++ /dev/null @@ -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 "@[%a%a@]" - print_map m - (print_list_ ~sep:"," print) l - | WithInt l -> - Format.fprintf fmt "@[[%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 "@[%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 "@[%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_ diff --git a/benchs/run_benchs.ml b/benchs/run_benchs.ml index 3bde113e..01753b76 100644 --- a/benchs/run_benchs.ml +++ b/benchs/run_benchs.ml @@ -1,5 +1,13 @@ (** 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 *) let (%%) f g x = f (g x) @@ -17,7 +25,7 @@ module L = struct let l = lazy CCList.(1 -- n) in let flatten_map_ l = List.flatten (CCList.map f_ l) 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 ; "flatten o CCList.map", flatten_ccmap_ %% 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 l3 = lazy CCList.(2*n+1 -- 3*n) in let arg = l1, l2, l3 in - CCBench.throughputN time + B.throughputN time [ "CCList.append", append_ CCList.append, arg ; "List.append", append_ List.append, arg ] @@ -51,7 +59,7 @@ module L = struct (fun i x -> CCList.(x -- (x+ min i 100))) CCList.(1 -- n)) in - CCBench.throughputN time + B.throughputN time [ "CCList.flatten", CCList.flatten %% Lazy.force, l ; "List.flatten", List.flatten %% Lazy.force, l ; "fold_right append", fold_right_append_ %% Lazy.force, l @@ -60,23 +68,23 @@ module L = struct (* MAIN *) - let () = CCBench.register CCBench.( - "list" >::: - [ "flat_map" >:: - map_int - [ bench_flat_map ~time:2, 100 - ; bench_flat_map ~time:2, 10_000 - ; bench_flat_map ~time:4, 100_000] - ; "flatten" >:: - map_int - [ bench_flatten ~time:2, 100 - ; bench_flatten ~time:2, 10_000 - ; bench_flatten ~time:4, 100_000] - ; "append" >:: - map_int - [ bench_append ~time:2, 100 - ; bench_append ~time:2, 10_000 - ; bench_append ~time:4, 100_000] + let () = B.Tree.register ( + "list" @>>> + [ "flat_map" @>> + B.Tree.concat + [ app_int (bench_flat_map ~time:2) 100 + ; app_int (bench_flat_map ~time:2) 10_000 + ; app_int (bench_flat_map ~time:4) 100_000] + ; "flatten" @>> + B.Tree.concat + [ app_int (bench_flatten ~time:2) 100 + ; app_int (bench_flatten ~time:2) 10_000 + ; app_int (bench_flatten ~time:4) 100_000] + ; "append" @>> + B.Tree.concat + [ app_int (bench_append ~time:2) 100 + ; app_int (bench_append ~time:2) 10_000 + ; app_int (bench_append ~time:4) 100_000] ] ) end @@ -96,7 +104,7 @@ module Vec = struct let bench_map n = let v = lazy (CCVector.init n (fun x->x)) in - CCBench.throughputN 2 + B.throughputN 2 [ "map", CCVector.map f %% Lazy.force, v ; "map_push", map_push_ 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 v2 = lazy (CCVector.init n (fun x->n+x)) in - CCBench.throughputN 2 + B.throughputN 2 [ "append", try_append_ CCVector.append n v2, () ; "append_naive", try_append_ append_naive_ n v2, () ] - let () = CCBench.register CCBench.( - "vector" >::: - [ "map" >:: with_int bench_map [100; 10_000; 100_000] - ; "append" >:: with_int bench_append [100; 10_000; 50_000] + let () = B.Tree.register ( + "vector" @>>> + [ "map" @>> app_ints bench_map [100; 10_000; 100_000] + ; "append" @>> app_ints bench_append [100; 10_000; 50_000] ] ) end @@ -158,11 +166,11 @@ module Cache = struct ] @ l else l in - CCBench.throughputN 3 l + B.throughputN 3 l - let () = CCBench.register CCBench.( - "cache" >::: - [ "fib" >:: with_int bench_fib [10; 20; 100; 200; 1_000;] + let () = B.Tree.register ( + "cache" @>>> + [ "fib" @>> app_ints bench_fib [10; 20; 100; 200; 1_000;] ] ) end @@ -267,7 +275,7 @@ module Tbl = struct h let bench_maps1 n = - CCBench.throughputN 3 + B.throughputN 3 ["phashtbl_add", (fun n -> ignore (phashtbl_add n)), n; "hashtbl_add", (fun n -> ignore (hashtbl_add n)), n; "ihashtbl_add", (fun n -> ignore (ihashtbl_add n)), n; @@ -370,7 +378,7 @@ module Tbl = struct h let bench_maps2 n = - CCBench.throughputN 3 + B.throughputN 3 ["phashtbl_replace", (fun n -> ignore (phashtbl_replace n)), n; "hashtbl_replace", (fun n -> ignore (hashtbl_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 m = imap_add n in let h'''''' = icchashtbl_add n in - CCBench.throughputN 3 [ + B.throughputN 3 [ "phashtbl_find", (fun () -> phashtbl_find h n), (); "hashtbl_find", (fun () -> hashtbl_find h' n), (); "ihashtbl_find", (fun () -> ihashtbl_find h'' n), (); @@ -468,11 +476,11 @@ module Tbl = struct "cchashtbl_find", (fun () -> icchashtbl_find h'''''' n), (); ] - let () = CCBench.register CCBench.( - "tbl" >::: - [ "add" >:: with_int bench_maps1 [10; 100; 1_000; 10_000;] - ; "replace" >:: with_int bench_maps2 [10; 100; 1_000; 10_000] - ; "find" >:: with_int bench_maps3 [10; 20; 100; 1_000; 10_000] + let () = B.Tree.register ( + "tbl" @>>> + [ "add" @>> app_ints bench_maps1 [10; 100; 1_000; 10_000;] + ; "replace" @>> app_ints bench_maps2 [10; 100; 1_000; 10_000] + ; "find" @>> app_ints bench_maps3 [10; 20; 100; 1_000; 10_000] ]) end @@ -483,7 +491,7 @@ module Iter = struct let seq () = Sequence.fold (+) 0 Sequence.(0 --n) in let gen () = Gen.fold (+) 0 Gen.(0 -- n) in let klist () = CCKList.fold (+) 0 CCKList.(0 -- n) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.fold", seq, (); "gen.fold", gen, (); "klist.fold", klist, (); @@ -500,7 +508,7 @@ module Iter = struct 0 -- n |> flat_map (fun x -> x-- (x+10)) |> fold (+) 0 ) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.flat_map", seq, (); "gen.flat_map", gen, (); "klist.flat_map", klist, (); @@ -523,17 +531,17 @@ module Iter = struct 1 -- n |> iter (fun x -> i := !i * x) ) in - CCBench.throughputN 3 + B.throughputN 3 [ "sequence.iter", seq, (); "gen.iter", gen, (); "klist.iter", klist, (); ] - let () = CCBench.register CCBench.( - "iter" >::: - [ "fold" >:: with_int bench_fold [100; 1_000; 10_000; 1_000_000] - ; "flat_map" >:: with_int bench_flat_map [1_000; 10_000] - ; "iter" >:: with_int bench_iter [1_000; 10_000] + let () = B.Tree.register ( + "iter" @>>> + [ "fold" @>> app_ints bench_fold [100; 1_000; 10_000; 1_000_000] + ; "flat_map" @>> app_ints bench_flat_map [1_000; 10_000] + ; "iter" @>> app_ints bench_iter [1_000; 10_000] ]) end @@ -586,16 +594,16 @@ module Batch = struct CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a); *) assert (C.equal (batch a) (naive a)); - CCBench.throughputN time + B.throughputN time [ C.name ^ "_naive", naive, a ; C.name ^ "_batch", batch, a ] - let bench = CCBench.( - C.name >:: map_int - [ bench_for ~time:1, 100 - ; bench_for ~time:4, 100_000 - ; bench_for ~time:4, 1_000_000 + let bench = B.( + C.name @>> B.Tree.concat + [ app_int (bench_for ~time:1) 100 + ; app_int (bench_for ~time:4) 100_000 + ; app_int (bench_for ~time:4) 1_000_000 ]) end @@ -622,8 +630,8 @@ module Batch = struct let doubleton x y = CCKList.of_list [ x; y ] end) - let () = CCBench.register CCBench.( - "batch" >:: mk_list + let () = B.Tree.register ( + "batch" @>> B.Tree.concat [ BenchKList.bench ; BenchArray.bench ; BenchList.bench @@ -631,4 +639,4 @@ module Batch = struct end let () = - CCBench.run_main () + B.Tree.run_global ()