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

update benchmarks

Browse source
This commit is contained in:
Simon Cruanes 2016-11-04 21:10:54 +01:00
parent 92f86da650
commit 6dd0894c1f
3 changed files with 12 additions and 300 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
benchs/mem_measure.ml
View file

@ -102,8 +102,8 @@ let tests_ =
let run_test ~n name = List.assoc name tests_ n
let print_list () =
Format.printf "@[<v2>tests:@ %a@]@."
(CCList.print CCString.print) (List.map fst tests_)
Format.printf "@[<v2>tests:@ [@[%a@]]@]@."
CCFormat.(list string) (List.map fst tests_)
let () =
let to_test = ref [] in

16
benchs/run_bench_hash.ml
View file

@ -26,9 +26,9 @@ let rec eq t1 t2 = match t1, t2 with
| _, Node _ -> false
let rec hash_tree t h = match t with
| Empty -> CCHash.string_ "empty" h
| Empty -> CCHash.string "empty" h
| Node (i, l) ->
CCHash.list_ hash_tree l (CCHash.int_ i (CCHash.string_ "node" h))
CCHash.list hash_tree l (CCHash.int i (CCHash.string "node" h))
module H = Hashtbl.Make(struct
type t = tree
@ -38,25 +38,25 @@ end)
let print_hashcons_stats st =
let open Hashtbl in
CCPrint.printf
"tbl stats: %d elements, num buckets: %d, max bucket: %d\n"
Format.printf
"tbl stats: %d elements, num buckets: %d, max bucket: %d@."
st.num_bindings st.num_buckets st.max_bucket_length;
Array.iteri
(fun i n -> CCPrint.printf " %d\t buckets have length %d\n" n i)
(fun i n -> Format.printf " %d\t buckets have length %d@." n i)
st.bucket_histogram
let () =
let st = Random.State.make_self_init () in
let n = 50_000 in
CCPrint.printf "generate %d elements...\n" n;
Format.printf "generate %d elements...\n" n;
let l = CCRandom.run ~st (CCList.random_len n random_tree) in
(* with custom hashtable *)
CCPrint.printf "### custom hashtable\n";
Format.printf "### custom hashtable\n";
let tbl = H.create 256 in
List.iter (fun t -> H.replace tbl t ()) l;
print_hashcons_stats (H.stats tbl);
(* with default hashtable *)
CCPrint.printf "### default hashtable\n";
Format.printf "### default hashtable\n";
let tbl' = Hashtbl.create 256 in
List.iter (fun t -> Hashtbl.replace tbl' t ()) l;
print_hashcons_stats (Hashtbl.stats tbl');

292
benchs/run_benchs.ml
View file

@ -86,7 +86,7 @@ module L = struct
CCList.fold_right CCList.append l []
in
let l =
CCList.Idx.mapi
CCList.mapi
(fun i x -> CCList.(x -- (x+ min i 100)))
CCList.(1 -- n)
in
@ -688,97 +688,6 @@ module Iter = struct
])
end
module Batch = struct
(** benchmark CCBatch *)
module type COLL = sig
val name : string
include CCBatch.COLLECTION
val doubleton : 'a -> 'a -> 'a t
val (--) : int -> int -> int t
val equal : int t -> int t -> bool
end
module Make(C : COLL) = struct
let f1 x = x mod 2 = 0
let f2 x = -x
let f3 x = C.doubleton x (x+1)
let f4 x = -x
let collect a = C.fold (+) 0 a
let naive a =
let a = C.filter f1 a in
let a = C.flat_map f3 a in
let a = C.filter f1 a in
let a = C.map f2 a in
let a = C.flat_map f3 a in
let a = C.map f4 a in
ignore (collect a);
a
module BA = CCBatch.Make(C)
let ops =
BA.(filter f1 >>> flat_map f3 >>> filter f1 >>>
map f2 >>> flat_map f3 >>> map f4)
let batch a =
let a = BA.apply ops a in
ignore (collect a);
a
let bench_for ~time n =
let a = C.(0 -- n) in
(* debug
CCPrint.printf "naive: %a\n" (CCArray.pp CCInt.pp) (naive a);
CCPrint.printf "simple: %a\n" (CCArray.pp CCInt.pp) (batch_simple a);
CCPrint.printf "batch: %a\n" (CCArray.pp CCInt.pp) (batch a);
*)
assert (C.equal (batch a) (naive a));
B.throughputN time ~repeat
[ C.name ^ "_naive", naive, a
; C.name ^ "_batch", batch, a
]
let bench =
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
module BenchArray = Make(struct
include CCArray
let name = "array"
let equal a b = a=b
let doubleton x y = [| x; y |]
let fold = Array.fold_left
end)
module BenchList = Make(struct
include CCList
let name = "list"
let equal a b = a=b
let doubleton x y = [ x; y ]
let fold = List.fold_left
end)
module BenchKList = Make(struct
include CCKList
let name = "klist"
let equal a b = equal (=) a b
let doubleton x y = CCKList.of_list [ x; y ]
end)
let () = B.Tree.register (
"batch" @>> B.Tree.concat
[ BenchKList.bench
; BenchArray.bench
; BenchList.bench
])
end
module Deque = struct
module type DEQUE = sig
type 'a t
@ -983,133 +892,6 @@ module Deque = struct
)
end
module Thread = struct
module Q = CCBlockingQueue
module type TAKE_PUSH = sig
val take : 'a Q.t -> 'a
val push : 'a Q.t -> 'a -> unit
val take_list: 'a Q.t -> int -> 'a list
val push_list : 'a Q.t -> 'a list -> unit
end
let cur = (module Q : TAKE_PUSH)
let naive =
let module Q = struct
let take = Q.take
let push = Q.push
let push_list q l = List.iter (push q) l
let rec take_list q n =
if n=0 then []
else
let x = take q in
x :: take_list q (n-1)
end in
(module Q : TAKE_PUSH)
(* n senders, n receivers *)
let bench_queue ~size ~senders ~receivers n =
let make (module TP : TAKE_PUSH) =
let l = CCList.(1 -- n) in
fun () ->
let q = Q.create size in
let res = CCLock.create 0 in
let expected_res = 2 * senders * Sequence.(1 -- n |> fold (+) 0) in
let a_senders = CCThread.Arr.spawn senders
(fun _ ->
TP.push_list q l;
TP.push_list q l
)
and a_receivers = CCThread.Arr.spawn receivers
(fun _ ->
let l1 = TP.take_list q n in
let l2 = TP.take_list q n in
let n = List.fold_left (+) 0 l1 + List.fold_left (+) 0 l2 in
CCLock.update res ((+) n);
()
)
in
CCThread.Arr.join a_senders;
CCThread.Arr.join a_receivers;
assert (expected_res = CCLock.get res);
()
in
B.throughputN 3 ~repeat
[ "cur", make cur, ()
; "naive", make naive, ()
]
let fib_pool_ ~size n =
let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in
let open P.Fut.Infix in
let rec fib n =
if n<=1 then P.Fut.return 1
else
let f1 = fib (n-1)
and f2 = fib (n-2) in
P.Fut.return (+) <*> f1 <*> f2
in
P.Fut.get (fib n)
let fib_manual n =
let rec fib n =
if n<= 1 then 1
else fib (n-1) + fib (n-2)
in
fib n
(* pool of size [size] *)
let bench_pool ~size n =
assert (fib_manual n = fib_pool_ ~size n);
B.throughputN 3 ~repeat
[ "sequential", fib_manual, n
; "pool", fib_pool_ ~size, n
]
let bench_sequence ~size n =
let module P = CCPool.Make(struct let min_size = 0 let max_size = size end) in
let id_ x = Thread.delay 0.0001; x in
let mk_list() = CCList.init n (P.Fut.make1 id_) in
let mk_sequence () =
let l = mk_list() in
P.Fut.sequence_l l |> P.Fut.get
(* reserves a thread for the computation *)
and mk_blocking () =
let l = mk_list() in
P.Fut.make (fun () -> List.map P.Fut.get l) |> P.Fut.get
in
B.throughputN 3 ~repeat
[ "sequence", mk_sequence, ()
; "blocking", mk_blocking, ()
]
let () = B.Tree.register (
let take_push = CCList.map
(fun (size,senders,receivers) ->
Printf.sprintf "queue.take/push (size=%d,senders=%d,receivers=%d)"
size senders receivers
@>>
app_ints (bench_queue ~size ~senders ~receivers)
[100; 1_000]
) [ 2, 3, 3
; 5, 3, 3
; 1, 5, 5
; 2, 10, 10
; 5, 10, 10
; 20, 10, 10
]
in
"thread" @>>>
( take_push @
[ "fib_size5" @>> app_ints (bench_pool ~size:5) [10; 15; 30; 35]
; "fib_size15" @>> app_ints (bench_pool ~size:15) [10; 15; 30; 35]
; "sequence" @>> app_ints (bench_sequence ~size:15) [100; 500; 10_000; 100_000]
]
)
)
end
module Graph = struct
(* divisors graph *)
let div_children_ i =
@ -1123,11 +905,7 @@ module Graph = struct
in
aux 1 i
let div_graph_ = {CCGraph.
origin=fst;
dest=snd;
children=div_children_
}
let div_graph_ = CCGraph.divisors_graph
module H = Hashtbl.Make(CCInt)
@ -1318,72 +1096,6 @@ module Str = struct
end
module Alloc = struct
module type ALLOC_ARR = sig
type 'a t
val name : string
val create : int -> 'a t
val make : 'a t -> int -> 'a -> 'a array
val free : 'a t -> 'a array -> unit
end
let dummy =
let module A = struct
type _ t = unit
let name = "dummy"
let create _ = ()
let make _ i x = Array.make i x
let free _ _ = ()
end in
(module A : ALLOC_ARR)
let alloc_cache ~buck_size =
let module A = struct
type 'a t = 'a CCAllocCache.Arr.t
let name = Printf.sprintf "alloc_cache(%d)" buck_size
let create n = CCAllocCache.Arr.create ~buck_size n
let make = CCAllocCache.Arr.make
let free = CCAllocCache.Arr.free
end in
(module A : ALLOC_ARR)
(* repeat [n] times:
- repeat [batch] times:
- allocate [batch] arrays of size from 1 to batch+1
- free those arrays
*)
let bench1 ~batch n =
let make (module C : ALLOC_ARR) () =
let c = C.create (batch*2) in
let tmp = Array.make (batch * batch) [||] in (* temporary storage *)
for _ = 1 to n do
for j = 0 to batch-1 do
for k = 0 to batch-1 do
tmp.(j*batch + k) <- C.make c (k+1) '_';
done;
done;
Array.iter (C.free c) tmp (* free the whole array *)
done
in
B.throughputN 3 ~repeat
[ "dummy", make dummy, ()
; "cache(5)", make (alloc_cache ~buck_size:5), ()
; "cache(20)", make (alloc_cache ~buck_size:20), ()
; "cache(50)", make (alloc_cache ~buck_size:50), ()
]
let () = B.Tree.register (
"alloc" @>>>
[ "bench1(batch=5)" @>>
app_ints (bench1 ~batch:5) [100; 1_000]
; "bench1(batch=15)" @>>
app_ints (bench1 ~batch:15) [100; 1_000]
; "bench1(batch=50)" @>>
app_ints (bench1 ~batch:50) [100; 1_000]
]
)
end
let () =
try B.Tree.run_global ()
with Arg.Help msg -> print_endline msg