diff --git a/bechamel.opam b/bechamel.opam index 83b96dc..f5f079a 100644 --- a/bechamel.opam +++ b/bechamel.opam @@ -21,4 +21,5 @@ depends: [ "ocaml" {>= "4.08.0"} "dune" {>= "2.0.0"} "fmt" {>= "0.9.0"} + "alcotest" {with-test} ] diff --git a/test/allocate/dune b/test/allocate/dune new file mode 100644 index 0000000..43a9557 --- /dev/null +++ b/test/allocate/dune @@ -0,0 +1,5 @@ +(test + (name test) + (package bechamel) + (modules test) + (libraries bechamel alcotest)) diff --git a/test/allocate/test.ml b/test/allocate/test.ml new file mode 100644 index 0000000..f07855b --- /dev/null +++ b/test/allocate/test.ml @@ -0,0 +1,83 @@ +open Bechamel +open Bechamel.Toolkit + +let all_released = + Alcotest.test_case "all released" `Quick @@ fun () -> + let global = ref 0 in + let called = ref 0 in + let test = + Test.make_with_resource ~name:"test" Test.uniq + ~allocate:(fun () -> + incr called; + incr global) + ~free:(fun () -> decr global) + (Staged.stage (Fun.const ())) + in + let[@warning "-8"] [ test ] = Test.elements test in + let cfg = Benchmark.cfg ~limit:10 ~kde:None () in + let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in + Alcotest.(check int) "all released" !global 0; + if !called = 0 then Alcotest.failf "Benchmark does not allocate" + +let with_kde = + Alcotest.test_case "with kde" `Quick @@ fun () -> + let global = ref 0 in + let called = ref 0 in + let test = + Test.make_with_resource ~name:"test" Test.uniq + ~allocate:(fun () -> + incr called; + incr global) + ~free:(fun () -> decr global) + (Staged.stage (Fun.const ())) + in + let[@warning "-8"] [ test ] = Test.elements test in + let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in + let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in + Alcotest.(check int) "with kde" !global 0; + if !called = 0 then Alcotest.failf "Benchmark does not allocate" + +let uniq_resources = + Alcotest.test_case "uniq resources" `Quick @@ fun () -> + let tbl = Hashtbl.create 0x100 in + let idx = ref 0 in + let test = + Test.make_with_resource ~name:"test" Test.uniq + ~allocate:(fun () -> + let value = !idx in + incr idx; + Hashtbl.add tbl value (); + value) + ~free:(Hashtbl.remove tbl) + (Staged.stage (Fun.const ())) + in + let[@warning "-8"] [ test ] = Test.elements test in + let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in + let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in + Alcotest.(check int) "uniq resources" (Hashtbl.length tbl) 0 + +let double_free = + Alcotest.test_case "double free" `Quick @@ fun () -> + let tbl = Hashtbl.create 0x100 in + let idx = ref 0 in + let test = + Test.make_with_resource ~name:"test" Test.uniq + ~allocate:(fun () -> + let value = !idx in + incr idx; + Hashtbl.add tbl value (); + value) + ~free:(fun value -> + match Hashtbl.find_opt tbl value with + | None -> Alcotest.failf "Double free" + | Some () -> Hashtbl.remove tbl value) + (Staged.stage (Fun.const ())) + in + let[@warning "-8"] [ test ] = Test.elements test in + let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in + let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in + Alcotest.(check int) "double free" (Hashtbl.length tbl) 0 + +let () = + Alcotest.run "allocate" + [ ("uniq", [ all_released; with_kde; uniq_resources; double_free ]) ]