├── .github └── workflows │ └── wintest.yml ├── .gitignore ├── .ocamlformat ├── .travis.yml ├── CHANGES.md ├── LICENSE.md ├── README.md ├── bechamel-js.opam ├── bechamel-notty.opam ├── bechamel-perf.opam ├── bechamel.opam ├── bin └── bechamel-html │ ├── bechamel_html.ml │ └── dune ├── dune-project ├── examples ├── dune ├── fact.html ├── fact.ml ├── list.ml └── sqrt.ml ├── html ├── index.html ├── style.css └── without_data.js ├── img └── output0.png ├── lib ├── analyze.ml ├── analyze.mli ├── bechamel.ml ├── bechamel.mli ├── benchmark.ml ├── benchmark.mli ├── dune ├── ext.ml ├── ext.mli ├── js │ ├── bechamel_js.ml │ ├── dataset.ml │ ├── desc.ml │ ├── dune │ ├── kDE.ml │ ├── oLS.ml │ └── point.ml ├── linear_algebra.ml ├── measure.ml ├── measure.mli ├── measurement_raw.ml ├── measurement_raw.mli ├── monotonic_clock │ ├── clock_linux.ml │ ├── clock_linux_stubs.c │ ├── clock_mach.ml │ ├── clock_mach_stubs.c │ ├── clock_windows.ml │ ├── clock_windows_stubs.c │ ├── dune │ └── select │ │ └── select.ml ├── notty │ ├── bechamel_notty.ml │ └── dune ├── perf │ ├── .ocamlformat │ ├── bechamel_perf.ml │ ├── bechamel_perf.mli │ └── dune ├── ransac.ml ├── s.ml ├── s.mli ├── staged.ml ├── staged.mli ├── test.ml ├── test.mli ├── time.ml ├── time.mli ├── toolkit.ml ├── toolkit.mli └── unsafe.ml ├── mperf.opam ├── mperf └── lib │ ├── dune │ ├── mperf.ml │ ├── mperf.mli │ └── mperf_stubs.c └── test ├── allocate ├── dune └── test.ml └── bechamel-html ├── dune ├── input.json └── output.html.expected /.github/workflows/wintest.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | jobs: 6 | winbuild: 7 | runs-on: windows-latest 8 | 9 | steps: 10 | - name: Checkout code 11 | uses: actions/checkout@v4 12 | 13 | - name: Set-up OCaml 14 | uses: ocaml/setup-ocaml@v2 15 | with: 16 | ocaml-compiler: ocaml.5.0.0,ocaml-option-mingw 17 | opam-local-packages: bechamel.opam 18 | opam-repositories: | 19 | dra27: https://github.com/dra27/opam-repository.git#windows-5.0 20 | opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 21 | default: https://github.com/ocaml/opam-repository.git 22 | 23 | - run: opam pin add . -n 24 | - run: opam install bechamel --with-test -v 25 | 26 | winbuild4: 27 | runs-on: windows-latest 28 | 29 | steps: 30 | - name: Checkout code 31 | uses: actions/checkout@v4 32 | 33 | - name: Set-up OCaml 34 | uses: ocaml/setup-ocaml@v2 35 | with: 36 | ocaml-compiler: 4.14.1 37 | opam-local-packages: bechamel.opam 38 | opam-repositories: | 39 | opam-repository-mingw: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 40 | default: https://github.com/ocaml/opam-repository.git 41 | 42 | - run: opam pin add . -n 43 | - run: opam install bechamel --with-test -v 44 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | setup.data 3 | setup.log 4 | doc/*.html 5 | *.native 6 | *.byte 7 | *.so 8 | lib/decompress_conf.ml 9 | *.tar.gz 10 | _tests 11 | lib_test/files 12 | zpipe 13 | c/dpipe 14 | *.merlin 15 | *.install -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.25.1 2 | dock-collection-brackets=false 3 | break-separators=before 4 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | install: 3 | - wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh 4 | script: bash -ex .travis-opam.sh 5 | sudo: true 6 | env: 7 | global: 8 | - PINS="bechamel.dev:. bechamel-notty.dev:. bechamel-perf.dev:. bechamel-js.dev:. mperf.dev:." 9 | matrix: 10 | - PACKAGE="bechamel-js" OCAML_VERSION=4.08 TESTS=true 11 | - PACKAGE="bechamel-js" OCAML_VERSION=4.09 TESTS=true 12 | - PACKAGE="bechamel-js" OCAML_VERSION=4.10 TESTS=true 13 | - PACKAGE="bechamel-notty" OCAML_VERSION=4.10 14 | - PACKAGE="bechamel-perf" OCAML_VERSION=4.10 15 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ### v0.5.0 2023-10-31 Paris (France) 2 | 3 | - Fix unsafe access causing SIGSEGV (@edwintorok, #43) 4 | - Fix compulation of the confidence indicator (@edwintorok, @lindig, @dinosaure, #45) 5 | - Upgrade monotonic clock detection (@dra27, #44) 6 | - Fix double-free when we use resources (@edwintorok, @dinosaure, #47) 7 | 8 | ### v0.4.0 2023-03-30 Paris (France) 9 | 10 | - Fix the support of OCaml 5.0 (@avsm, #38) 11 | - Add a CI on Windows (@avsm, #38) 12 | - Add a documentation about `Bechamel_perf` (@dinosaure, @OliverNicole, #39) 13 | 14 | ### v0.3.0 2022-06-24 Paris (France) 15 | 16 | - Improve the entry point documentation (@yomimono, #28) 17 | - Fix deprecated `Obj` function (@OlivierNicole, #29) 18 | - Use json-data-encoding instead of ocplib-json-typed (@samoht, #34) 19 | - Improve the documentation (@edwintorok, #32) 20 | - Add hardware perf measures (@OlivierNicole, #30) 21 | 22 | ### v0.2.0 2022-01-17 Paris (France) 23 | 24 | - Add missing dependencies (@kit-ty-kate, #20) 25 | - Upgrade the codebase (@dinosaure, #24) 26 | - Add a finalizer function to allow the user to allocate 27 | resource (@dinosaure, @CraigFe, #22, #25) 28 | - Update the documentation (@dinosaure, #26) 29 | 30 | ### v0.1.0 2020-08-10 Paris (France) 31 | 32 | - First release 33 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2018 Romain Calascibetta 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Bechamel - Agnostic benchmark tool in OCaml 2 | 3 | Bechamel is a toolkit to do a _micro_-benchmarking on your functions. The user 4 | is able to extend metrics (depending on your machine). Intially, Bechamel can 5 | record monotonic clock & garbage collector. `bechamel-perf` can help you 6 | for `perf` metrics if you are a Linux user. 7 | 8 | Bechamel can show results: 9 | - in your terminal with `bechamel-notty` 10 | - _via_ a HTML + JavaScript page with `bechamel-js` 11 | 12 | You can see an example of the produced HTML page [here][html-example]. Some 13 | examples exist which take the opportunity of the output and metrics: 14 | - [fact.ml][fact.ml] which produces an HTML + JavaScript report 15 | - [list.ml][list.ml] which shows results into your terminal 16 | - [sqrt.ml][sqrt.ml] which uses `perf` metrics 17 | 18 | The documentation is available [here][documentation]. 19 | 20 | [html-example]: https://mirage.github.io/bechamel/fact.html 21 | [fact.ml]: examples/fact.ml 22 | [list.ml]: examples/list.ml 23 | [sqrt.ml]: examples/sqrt.ml 24 | [documentation]: https://mirage.github.io/bechamel 25 | -------------------------------------------------------------------------------- /bechamel-js.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bechamel-js" 3 | maintainer: "Romain Calascibetta " 4 | authors: "Romain Calascibetta " 5 | homepage: "https://github.com/mirage/bechamel" 6 | bug-reports: "https://github.com/mirage/bechamel/issues" 7 | dev-repo: "git+https://github.com/mirage/bechamel.git" 8 | doc: "https://mirage.github.io/bechamel/" 9 | license: "MIT" 10 | synopsis: "HTML generator for bechamel's output" 11 | description: """A simple tool to generate a standalone HTML 12 | page which shows results from bechamel's benchmarks.""" 13 | 14 | build: [ 15 | [ "dune" "build" "-p" name "-j" jobs ] 16 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 17 | ] 18 | 19 | depends: [ 20 | "ocaml" {>= "4.08.0"} 21 | "dune" {>= "2.0.0"} 22 | "bechamel" {= version} 23 | "rresult" 24 | "json-data-encoding" 25 | "jsonm" 26 | "fmt" {>= "0.9.0"} 27 | "result" 28 | ] 29 | -------------------------------------------------------------------------------- /bechamel-notty.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bechamel-notty" 3 | maintainer: "Romain Calascibetta " 4 | authors: "Romain Calascibetta " 5 | homepage: "https://github.com/mirage/bechamel" 6 | bug-reports: "https://github.com/mirage/bechamel/issues" 7 | dev-repo: "git+https://github.com/mirage/bechamel.git" 8 | doc: "https://mirage.github.io/bechamel/" 9 | license: "MIT" 10 | synopsis: "CLI generator for bechamel's output" 11 | description: """A simple tool to generate a CLI output with notty 12 | which shows results from bechamel's benchmarks (as core_bench).""" 13 | 14 | build: [ 15 | [ "dune" "build" "-p" name "-j" jobs ] 16 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 17 | ] 18 | 19 | depends: [ 20 | "ocaml" {>= "4.08.0"} 21 | "dune" {>= "2.0.0"} 22 | "bechamel" {= version} 23 | "notty" 24 | "fmt" {>= "0.9.0"} 25 | ] 26 | -------------------------------------------------------------------------------- /bechamel-perf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bechamel-perf" 3 | maintainer: "Romain Calascibetta " 4 | authors: "Romain Calascibetta " 5 | homepage: "https://github.com/mirage/bechamel" 6 | bug-reports: "https://github.com/mirage/bechamel/issues" 7 | dev-repo: "git+https://github.com/mirage/bechamel.git" 8 | doc: "https://mirage.github.io/bechamel/" 9 | license: "MIT" 10 | synopsis: "Linux perf's metrics for bechamel" 11 | description: """A simple layer on Linux perf's metrics for 12 | bechamel to record and analyze them.""" 13 | 14 | build: [ 15 | [ "dune" "build" "-p" name "-j" jobs ] 16 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 17 | ] 18 | 19 | depends: [ 20 | "ocaml" {>= "4.08.0"} 21 | "dune" {>= "2.0.0"} 22 | "mperf" 23 | "bechamel" {= version} 24 | "fmt" {>= "0.9.0"} 25 | "base-unix" 26 | ] 27 | -------------------------------------------------------------------------------- /bechamel.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bechamel" 3 | maintainer: "Romain Calascibetta " 4 | authors: "Romain Calascibetta " 5 | homepage: "https://github.com/mirage/bechamel" 6 | bug-reports: "https://github.com/mirage/bechamel/issues" 7 | dev-repo: "git+https://github.com/mirage/bechamel.git" 8 | doc: "https://mirage.github.io/bechamel/" 9 | license: "MIT" 10 | synopsis: "Yet Another Benchmark in OCaml" 11 | description: """BEnchmark for a CHAMEL/camel/caml which 12 | is agnostic to the system. It's a micro-benchmark tool 13 | which lets the user to re-analyzes and prints samples.""" 14 | 15 | build: [ 16 | [ "dune" "build" "-p" name "-j" jobs ] 17 | [ "dune" "runtest" "-p" name "-j" jobs ] {with-test} 18 | ] 19 | 20 | depends: [ 21 | "ocaml" {>= "4.08.0"} 22 | "dune" {>= "2.0.0"} 23 | "fmt" {>= "0.9.0"} 24 | "alcotest" {with-test} 25 | ] 26 | -------------------------------------------------------------------------------- /bin/bechamel-html/bechamel_html.ml: -------------------------------------------------------------------------------- 1 | (* [string_find str target] returns [None] if the string [target] cannot be 2 | find in [str] and [Some i] if the first occurence of [target] begins at 3 | position [i]. *) 4 | let string_find str target = 5 | let exception Not_equal in 6 | let substring_equal a a_i b = 7 | String.iteri (fun i c -> if c <> a.[a_i + i] then raise Not_equal) b 8 | in 9 | let rec loop i = 10 | match String.index_from_opt str i target.[0] with 11 | | None -> None 12 | | Some i when String.length str - i < String.length target -> None 13 | | Some i -> ( 14 | match substring_equal str i target with 15 | | exception Not_equal -> loop (i + 1) 16 | | () -> Some i) 17 | in 18 | if String.length target = 0 then None else loop 0 19 | 20 | let stdin_to_stdout () = 21 | try 22 | while true do 23 | print_endline (read_line ()) 24 | done 25 | with End_of_file -> () 26 | 27 | (* [cut ~error_msg str sep] cuts the string [str] into the two parts before and 28 | after [sep]. If [sep] not appears in [str] an error is raised with the text 29 | [error_msg]. *) 30 | let cut ~error_msg str separator = 31 | match string_find str separator with 32 | | None -> failwith error_msg 33 | | Some i -> 34 | let ends = i + String.length separator in 35 | (String.sub str 0 i, String.sub str ends (String.length str - ends)) 36 | 37 | (* [cut_html html] cuts in 3 parts: the part before "/*style*/", the part 38 | between "/*style*/" and "//js_script" and the rest of the text *) 39 | let cut_html html = 40 | let sep1 = "/*style*/" in 41 | let sep2 = "//js_script" in 42 | let part1, rest = 43 | cut ~error_msg:("Separator " ^ sep1 ^ " not found in html file.") html sep1 44 | in 45 | let part2, part3 = 46 | cut ~error_msg:("Separator " ^ sep2 ^ " not found in html file.") rest sep2 47 | in 48 | (part1, part2, part3) 49 | 50 | (* Print the java script file, including the json data passed as stdin. *) 51 | let print_js_script () = 52 | (* Read first line so we don't show [head] if user forgot to redirect its json 53 | file and if it's already end of input, it will be an explicit uncaught 54 | exception instead of generating an invalid HTML file *) 55 | let first_line = read_line () in 56 | let js = Js_file.data in 57 | let separator = "//BECHAMEL_CONTENTS//" in 58 | let head, tail = 59 | cut ~error_msg:"Separator not found in js file" js separator 60 | in 61 | print_string head; 62 | print_string "contents = "; 63 | print_endline first_line; 64 | stdin_to_stdout (); 65 | print_string tail 66 | 67 | let () = 68 | let html = Html_file.data in 69 | let css = Css_file.data in 70 | let html1, html2, html3 = cut_html html in 71 | print_string html1; 72 | print_string css; 73 | print_string html2; 74 | print_js_script (); 75 | print_string html3 76 | -------------------------------------------------------------------------------- /bin/bechamel-html/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name bechamel_html) 3 | (modules bechamel_html js_file html_file css_file) 4 | (package bechamel) 5 | (public_name bechamel-html)) 6 | 7 | (rule 8 | (with-stdout-to 9 | js_file.ml 10 | (progn 11 | (echo "let data = {js_file|") 12 | (cat ../../html/without_data.js) 13 | (echo "|js_file}")))) 14 | 15 | (rule 16 | (with-stdout-to 17 | html_file.ml 18 | (progn 19 | (echo "let data = {html_file|") 20 | (cat ../../html/index.html) 21 | (echo "|html_file}")))) 22 | 23 | (rule 24 | (with-stdout-to 25 | css_file.ml 26 | (progn 27 | (echo "let data = {css_file|") 28 | (cat ../../html/style.css) 29 | (echo "|css_file}")))) 30 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name bechamel) 3 | (version dev) 4 | (implicit_transitive_deps false) 5 | -------------------------------------------------------------------------------- /examples/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name list) 3 | (modules list) 4 | (public_name bechamel-notty.examples.list) 5 | (package bechamel-notty) 6 | (libraries bechamel notty.unix unix bechamel-notty)) 7 | 8 | (executable 9 | (name sqrt) 10 | (modules sqrt) 11 | (public_name bechamel-perf.examples.sqrt) 12 | (package bechamel-perf) 13 | (libraries bechamel fmt bechamel-perf)) 14 | 15 | (executable 16 | (name fact) 17 | (modules fact) 18 | (public_name bechamel-js.examples.fact) 19 | (package bechamel-js) 20 | (libraries bechamel bechamel-js)) 21 | 22 | (rule 23 | (targets fact.json) 24 | (action 25 | (with-stdout-to 26 | %{targets} 27 | (run ./fact.exe)))) 28 | 29 | (rule 30 | (targets fact.html) 31 | (mode promote) 32 | (action 33 | (system "%{bin:bechamel-html} < %{dep:fact.json} > %{targets}"))) 34 | -------------------------------------------------------------------------------- /examples/fact.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | open Toolkit 3 | 4 | let () = Random.self_init () 5 | 6 | let imp_fact x = 7 | let y = ref 0 in 8 | let r = ref 1 in 9 | while !y < x do 10 | y := !y + 1; 11 | r := !r * !y 12 | done; 13 | !r 14 | 15 | let rec fun_fact x = if x = 0 then 1 else x * fun_fact (x - 1) 16 | let random_max = 32767. 17 | let ( <.> ) f g x = f (g x) 18 | 19 | let normal n = 20 | let m = n + (n mod 2) in 21 | let values = Array.create_float m in 22 | for i = 0 to (m / 2) - 1 do 23 | let x = ref 0. and y = ref 0. and rsq = ref 0. in 24 | while 25 | x := (Random.float random_max /. random_max *. 2.0) -. 1.; 26 | y := (Random.float random_max /. random_max *. 2.0) -. 1.; 27 | rsq := (!x *. !x) +. (!y *. !y); 28 | !rsq >= 1. || !rsq = 0. 29 | do 30 | () 31 | done; 32 | let f = sqrt (-2.0 *. log !rsq /. !rsq) in 33 | values.(i * 2) <- !x *. f; 34 | values.((i * 2) + 1) <- !y *. f 35 | done; 36 | Array.map (Float.to_int <.> ( *. ) random_max) values 37 | 38 | let imp_fact n = 39 | let vs = normal n in 40 | Staged.stage @@ fun () -> Array.iter (ignore <.> imp_fact <.> abs) vs 41 | 42 | let fun_fact n = 43 | let vs = normal n in 44 | Staged.stage @@ fun () -> Array.iter (ignore <.> fun_fact <.> abs) vs 45 | 46 | let test0 = 47 | Test.make_indexed ~name:"functional" ~fmt:"%s %d" ~args:[ 10; 50; 100 ] 48 | fun_fact 49 | 50 | let test1 = 51 | Test.make_indexed ~name:"imperative" ~fmt:"%s %d" ~args:[ 10; 50; 100 ] 52 | imp_fact 53 | 54 | let benchmark () = 55 | let ols = 56 | Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] 57 | in 58 | let instances = 59 | Instance.[ minor_allocated; major_allocated; monotonic_clock ] 60 | in 61 | let cfg = 62 | Benchmark.cfg ~limit:2000 ~stabilize:true ~quota:(Time.second 0.5) 63 | ~kde:(Some 1000) () 64 | in 65 | let raw_results = 66 | Benchmark.all cfg instances 67 | (Test.make_grouped ~name:"factorial" ~fmt:"%s %s" [ test0; test1 ]) 68 | in 69 | let results = 70 | List.map (fun instance -> Analyze.all ols instance raw_results) instances 71 | in 72 | let results = Analyze.merge ols instances results in 73 | (results, raw_results) 74 | 75 | let compare k0 k1 = 76 | let a = ref 0 and b = ref 0 in 77 | Scanf.sscanf k0 "%s %s %d" (fun _ _ a' -> a := a'); 78 | Scanf.sscanf k1 "%s %s %d" (fun _ _ b' -> b := b'); 79 | !a - !b 80 | 81 | let nothing _ = Ok () 82 | 83 | let () = 84 | let results = benchmark () in 85 | let results = 86 | let open Bechamel_js in 87 | emit ~dst:(Channel stdout) nothing ~compare ~x_label:Measure.run 88 | ~y_label:(Measure.label Instance.monotonic_clock) 89 | results 90 | in 91 | match results with Ok () -> () | Error (`Msg err) -> invalid_arg err 92 | -------------------------------------------------------------------------------- /examples/list.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | open Toolkit 3 | 4 | (* This is our /protected/ function which take an argument and return a simple 5 | function: [unit -> 'a]. The function must be wrapped into a [Staged.t]. 6 | 7 | NOTE: [words] is __outside__ our [(unit -> 'a) Staged.t]*) 8 | 9 | let make_list words = 10 | Staged.stage @@ fun () -> 11 | let rec go n acc = if n = 0 then acc else go (n - 1) (n :: acc) in 12 | ignore (go ((words / 3) + 1) []) 13 | 14 | (* From our function [make_list], we make an indexed (by [args]) test. It's a list 15 | of tests which are applied with [args] such as: 16 | 17 | {[ 18 | let test = 19 | [ make_list 0 20 | ; make_list 10 21 | ; make_list 100 22 | ; make_list 400 23 | ; make_list 1000 ] 24 | ]} *) 25 | let test = 26 | Test.make_indexed ~name:"list" ~fmt:"%s %d" ~args:[ 0; 10; 100; 400; 1000 ] 27 | make_list 28 | 29 | (* From our test, we can start to benchmark it! 30 | 31 | A benchmark is a /run/ of your test multiple times. From results given by 32 | [Benchmark.all], an analyse is needed to infer measures of one call of your 33 | test. 34 | 35 | [Bechamel] asks 3 things: 36 | - what you want to record (see [instances]) 37 | - how you want to analyse (see [ols]) 38 | - how you want to benchmark your test (see [cfg]) 39 | 40 | The core of [Bechamel] (see [Bechamel.Toolkit]) has some possible measures 41 | such as the [monotonic-clock] to see time performances. 42 | 43 | The analyse can be OLS (Ordinary Least Square) or RANSAC. In this example, we 44 | use only one. 45 | 46 | Finally, to launch the benchmark, we need some others details such as: 47 | - should we stabilise the GC? 48 | - how many /run/ you want 49 | - the maximum of time allowed by the benchmark 50 | - etc. 51 | 52 | [raw_results] is what the benchmark produced. [results] is what the analyse 53 | can infer. The first one is used to show graphs or to let the user (with 54 | [Measurement_raw]) to infer something else than what [ols] did. The second is 55 | mostly what you want: a synthesis of /samples/. *) 56 | 57 | let benchmark () = 58 | let ols = 59 | Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] 60 | in 61 | let instances = 62 | Instance.[ minor_allocated; major_allocated; monotonic_clock ] 63 | in 64 | let cfg = 65 | Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) () 66 | in 67 | let raw_results = Benchmark.all cfg instances test in 68 | let results = 69 | List.map (fun instance -> Analyze.all ols instance raw_results) instances 70 | in 71 | let results = Analyze.merge ols instances results in 72 | (results, raw_results) 73 | 74 | let () = 75 | List.iter 76 | (fun v -> Bechamel_notty.Unit.add v (Measure.unit v)) 77 | Instance.[ minor_allocated; major_allocated; monotonic_clock ] 78 | 79 | let img (window, results) = 80 | Bechamel_notty.Multiple.image_of_ols_results ~rect:window 81 | ~predictor:Measure.run results 82 | 83 | open Notty_unix 84 | 85 | let () = 86 | let window = 87 | match winsize Unix.stdout with 88 | | Some (w, h) -> { Bechamel_notty.w; h } 89 | | None -> { Bechamel_notty.w = 80; h = 1 } 90 | in 91 | let results, _ = benchmark () in 92 | img (window, results) |> eol |> output_image 93 | -------------------------------------------------------------------------------- /examples/sqrt.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | let () = Random.self_init () 4 | let random_max = 32767. 5 | let ( <.> ) f g x = f (g x) 6 | 7 | let normal n = 8 | let m = n + (n mod 2) in 9 | let values = Array.create_float m in 10 | for i = 0 to (m / 2) - 1 do 11 | let x = ref 0. and y = ref 0. and rsq = ref 0. in 12 | while 13 | x := (Random.float random_max /. random_max *. 2.0) -. 1.; 14 | y := (Random.float random_max /. random_max *. 2.0) -. 1.; 15 | rsq := (!x *. !x) +. (!y *. !y); 16 | !rsq >= 1. || !rsq = 0. 17 | do 18 | () 19 | done; 20 | let f = sqrt (-2.0 *. log !rsq /. !rsq) in 21 | values.(i * 2) <- !x *. f; 22 | values.((i * 2) + 1) <- !y *. f 23 | done; 24 | Array.map (( *. ) random_max) values 25 | 26 | let sqrt n = 27 | let vs = normal n in 28 | Staged.stage @@ fun () -> 29 | for i = 0 to Array.length vs - 1 do 30 | ignore (sqrt vs.(i)) 31 | done 32 | 33 | let test = Test.make_indexed ~name:"sqrt" ~fmt:"%s %d" ~args:[ 10; 50 ] sqrt 34 | 35 | let benchmark () = 36 | let ols = 37 | Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] 38 | in 39 | let instances = Bechamel_perf.Instance.[ cpu_clock ] in 40 | let cfg = 41 | Benchmark.cfg ~limit:2000 ~quota:(Time.second 0.5) ~kde:(Some 1000) () 42 | in 43 | let raw_results = Benchmark.all cfg instances test in 44 | let results = 45 | List.map (fun instance -> Analyze.all ols instance raw_results) instances 46 | in 47 | let results = Analyze.merge ols instances results in 48 | (results, raw_results) 49 | 50 | let () = 51 | let results, _ = benchmark () in 52 | match 53 | Hashtbl.fold 54 | (fun _ v a -> Hashtbl.fold (fun k v a -> (k, v) :: a) v [] :: a) 55 | results [] 56 | with 57 | | [ results ] -> 58 | let print (k, ols) = Fmt.pr "%s: %a\n%!" k Analyze.OLS.pp ols in 59 | List.iter print results 60 | | _ -> assert false 61 | -------------------------------------------------------------------------------- /html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 13 | 14 | 15 | 16 | 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /html/style.css: -------------------------------------------------------------------------------- 1 | *{ 2 | margin: 0; 3 | padding: 0; 4 | box-sizing: border-box; 5 | } 6 | 7 | body{ 8 | width: 100%; 9 | height: 100%; 10 | font-family:Helvetica Neue,metric,sans-serif; 11 | text-rendering: optimizeLegibility; 12 | } 13 | 14 | .center{ 15 | width: 500px; 16 | margin:auto 17 | } 18 | 19 | text{ 20 | font-family: metric,sans-serif; 21 | } 22 | 23 | .ml { 24 | text-align: left 25 | } 26 | 27 | svg { 28 | overflow: hidden; 29 | margin: auto 30 | } 31 | 32 | .axis line, .axis path{ 33 | stroke: #2E3532; 34 | stroke-width:1px; 35 | } 36 | 37 | .axisTitle, .axis text{ 38 | fill: #2E3532; 39 | font-size:12px; 40 | } 41 | 42 | .background { 43 | fill: #FBFBFB; 44 | stroke: #2E3532; 45 | } 46 | 47 | .axisTitle, .chartTitle{ 48 | text-anchor: middle 49 | } 50 | 51 | 52 | .ytitle { 53 | text-anchor: middle; 54 | transform: rotate(90deg) 55 | } 56 | 57 | .warningtext{ 58 | text-anchor: center; 59 | fill: #F06449; 60 | } 61 | 62 | .regLine { 63 | stroke: #F06449; 64 | stroke-width:2px; 65 | opacity:0.7 66 | } 67 | 68 | .circle { 69 | fill: #4ECDC4; 70 | stroke: #292f36; 71 | stroke-width:0.3px 72 | } 73 | 74 | table { 75 | margin:auto; 76 | text-align:left; 77 | border-spacing: 15px 5px; 78 | border: 1px solid #2E3532 79 | } 80 | 81 | th { 82 | text-align: center; 83 | color:#F06449 84 | } 85 | 86 | 87 | tr { 88 | fill: #2E3532; 89 | font-size:10px 90 | } 91 | 92 | .tooltip .tooltiptext { 93 | visibility: hidden; 94 | width: auto; 95 | background-color: #F06449; 96 | color: #FFFFFF; 97 | text-align: center; 98 | border-radius: 10px; 99 | padding: 0 5px 0 5px; 100 | /* Position the tooltip */ 101 | position: absolute; 102 | z-index: 1; 103 | } 104 | 105 | .tooltip:hover .tooltiptext { 106 | visibility: visible; 107 | } 108 | .bar { 109 | fill: #4ECDC4; 110 | stroke:#292f36; 111 | } 112 | .bar:hover { 113 | fill: #F06449; 114 | stroke:#292f36; 115 | stroke-width:1px; 116 | } 117 | 118 | .radio { 119 | margin: auto; 120 | width : 200px; 121 | } 122 | 123 | .wrapper { 124 | display: grid; 125 | margin: 50px 50px 50px 50px; 126 | gap: 10px 20px; 127 | grid-auto-rows: minmax(20px, auto); 128 | text-align: center; 129 | place-items: center; 130 | } 131 | 132 | .mainTitle, .summarizeTitle { 133 | height:30px; 134 | width: auto; 135 | border-radius: 2px; 136 | padding: 0 45px 0 45px; 137 | border-style: solid; 138 | border-width:1px; 139 | box-shadow: 2px 2px 1px rgba(0,0,0,0.1); 140 | color: #2E3532; 141 | background: #FBFBFB; 142 | display: flex; 143 | align-items: center; 144 | justify-content: center; 145 | font-weight: bold; 146 | } 147 | 148 | .slidecontainer{ 149 | width: 50%; 150 | } 151 | -------------------------------------------------------------------------------- /html/without_data.js: -------------------------------------------------------------------------------- 1 | // structure of JSON 2 | // { xLabel: string, 3 | // yLabel: string, 4 | // series: [ tests ] } 5 | // 6 | // tests := { name: string, 7 | // description: { start : int, sampling: float, stabilize: bool, 8 | // quota: float, limit: int, instances: [string], 9 | // samples: int, time : float} 10 | // dataset: [ point ], 11 | // kde : [ v: float ] (optional) 12 | // result: { estimate: float, r_square: float (optional) } } 13 | // 14 | // point := { x : double, 15 | // y : double } 16 | // 17 | // xLabel and yLabel are the same for any tests 18 | window.onload = function () { 19 | 20 | const wsvg = 600; 21 | const hsvg = 400; 22 | const wslider = 200; 23 | const hslider = 50; 24 | const margin = {left:50,right:50,top:20,bottom:50}; 25 | const dotSize = 1.5; 26 | const innerW = wsvg-(margin.left+margin.right); 27 | const innerH = hsvg-(margin.top+margin.bottom); 28 | 29 | const marginbar = {left:150,right:150,top:50,bottom:50}; 30 | const wbar = 900; 31 | const innerWbar = wbar-(marginbar.left+marginbar.right); 32 | 33 | const SQRT_2PI = Math.sqrt(2 * Math.PI); 34 | 35 | // Main function : place containers and call plot functions. 36 | function render(inputs) { 37 | inputs.series.forEach( 38 | function(serie) { 39 | serie.dataset.forEach( 40 | function(d) { 41 | d.x = +d.x; 42 | d.y = +d.y; 43 | });} 44 | ); 45 | 46 | // First step : check if there is no kde/histogram data at all in 47 | // the benchmarks, in which case, we want to reduce our layout to 48 | // one column. 49 | let nonempty_kde = false; 50 | inputs.series.forEach(function (serie) { 51 | if ('kde' in serie) { 52 | nonempty_kde = nonempty_kde || true;} }); 53 | const nb_col = nonempty_kde ? 2 : 1; 54 | 55 | // ************************************************ // 56 | // Layout of the page // 57 | // ************************************************ // 58 | // + a summarize bar graph on top 59 | // + one section for each benchmark which includes 60 | // * 1 title 61 | // * 1 linear regression graph and its title and information table 62 | // * if kde data are available a histogram/kde graph with its control panel. 63 | // 64 | // If none of the benchmarks has kde data, the layout is the same 65 | // but with only one column (no hist/kde graphs). 66 | // 67 | // 68 | // c1: c2: 69 | // 70 | // r1: *title* 71 | // ___________________ 72 | // r2: | summarize bar | 73 | // |___________________| 74 | // 75 | // r3: *title-1* 76 | // 77 | // r4: *title* *radio* 78 | // _______ _______ 79 | // r5: | lr-1 | | kde-1 | 80 | // |_______| |_______| 81 | // 82 | // r6: *infos-1* *slider-1* 83 | // .. 84 | // r(4i+3): *title-i* 85 | // 86 | // r(4i+4): *title* *radio* 87 | // _______ _______ 88 | // r(4i+5): | lr-i | | kde-i | 89 | // |_______| |_______| 90 | // 91 | // r(4i+6): *infos-i* *slider-i* 92 | // 93 | // etc .. 94 | 95 | const main = d3.select("body") 96 | .append("div") 97 | .attr("class", "wrapper") 98 | .style("grid-template-columns", (nonempty_kde ? "repeat(2,"+wsvg+"px)" : "900px")) 99 | .attr("id", "main"); 100 | 101 | // ************************************************ // 102 | // Summarize bar graph // 103 | // ************************************************ // 104 | 105 | // Title 106 | main.append("div") 107 | .style("grid-row", "1") 108 | .style("grid-column", "1 / "+(nb_col+1)) 109 | .attr("class", "summarizeTitle") 110 | .text("Benchmarks summary"); 111 | 112 | // Bar graph 113 | let bar_container = main 114 | .append("div") 115 | .style("grid-row", "2") 116 | .style("grid-column", "1 / "+(nb_col+1)) 117 | .attr("id", "bar"); 118 | plot_summarize_bar_graph(bar_container, inputs); 119 | 120 | 121 | // ************************************************ // 122 | // Layout for lr/kde graphs // 123 | // ************************************************ // 124 | 125 | // Benchmark titles 126 | const titles = main 127 | .selectAll(".mainTitle") 128 | .data(inputs.series) 129 | .enter() 130 | .append("div") 131 | .attr("id", (data, i) => "title-"+i) 132 | .style("grid-row", (data,i) =>""+(4*i+3)) 133 | .style("grid-column", "1 / "+(nb_col+1)) 134 | .attr("class","mainTitle") 135 | .append("text") 136 | .attr("x", wsvg) 137 | .attr("y", margin.top-10) 138 | .text((data, i) => "#"+data.name); 139 | 140 | // Linear regression graph titles 141 | const titles_lr = main 142 | .selectAll("#title_lr") 143 | .data(inputs.series) 144 | .enter() 145 | .append("div") 146 | .attr("id", "title_lr") 147 | .style("grid-row", (data,i) =>""+(4*i+4)) 148 | .style("grid-column", "1") 149 | .append("text") 150 | .attr("class","chartTitle") 151 | .text("Linear regression"); 152 | 153 | // Containers for linear regression graphs 154 | const lr_graphs = main 155 | .selectAll(".lr") 156 | .data(inputs.series) 157 | .enter() 158 | .append("div") 159 | .attr("class", "lr") 160 | .attr("id", (data, i) => "linearRegression-"+i) 161 | .style("grid-row", (data,i) =>""+(4*i+5)) 162 | .style("grid-column", "1"); 163 | 164 | // Containers for linear regression info tables 165 | const lr_info = main 166 | .selectAll(".lr-info") 167 | .data(inputs.series) 168 | .enter() 169 | .append("div") 170 | .attr("class", "lr-info") 171 | .attr("id", (data, i) => "lr-info-"+i) 172 | .style("grid-row", (data,i) =>""+(4*i+6)) 173 | .style("grid-column", "1"); 174 | 175 | let radio_div, kde_graphs, kde_controler; 176 | if (nonempty_kde) { 177 | // Containers for radio buttons to choose between histogram/kde plots 178 | radio_div = main 179 | .selectAll(".radio_div") 180 | .data(inputs.series) 181 | .enter() 182 | .append("div") 183 | .attr("class", "radio") 184 | .attr("id", (d, i) => "radio_div"+i) 185 | .style("grid-row", (data,i) =>""+(4*i+4)) 186 | .style("grid-column", "2"); 187 | 188 | // Containers for kde/hist graph 189 | kde_graphs = main 190 | .selectAll(".kde") 191 | .data(inputs.series) 192 | .enter() 193 | .append("div") 194 | .attr("class", "kde") 195 | .attr("id", (data, i) => "histKde-"+i) 196 | .style("grid-row", (data,i) =>""+(4*i+5)) 197 | .style("grid-column", "2"); 198 | 199 | // Containers for kde/hist controlers 200 | kde_controler = main 201 | .selectAll(".kde-controler") 202 | .data(inputs.series) 203 | .enter() 204 | .append("div") 205 | .attr("class", "kde-controler") 206 | .attr("id", (data, i) => "kde-controler-"+i) 207 | .style("grid-row", (data,i) =>""+(4*i+6)) 208 | .style("grid-column", "2"); 209 | } 210 | 211 | // ************************************************ // 212 | // Linear regression graph // 213 | // ************************************************ // 214 | lr_graphs.each( function(serie, i) { 215 | //Curves for each input 216 | const xMin = 0; 217 | const xMax = d3.max(serie.dataset, d => d.x); 218 | const yMin = 0; 219 | const yMax = d3.max(serie.dataset, d => d.y); 220 | 221 | // Define x axis 222 | const xScale = d3.scaleLinear() 223 | .domain([xMin,xMax]) 224 | .range([0,innerW]) 225 | .nice(); 226 | const xAxis = d3.axisBottom() 227 | .scale(xScale) 228 | .ticks(8, "s"); 229 | // "s" = number format such as 1000 -> 1k 230 | 231 | // Define y axis 232 | const yScale = d3.scaleLinear() 233 | .domain([yMin,yMax]) 234 | .range([innerH,0]) 235 | .nice(); 236 | const yAxis = d3.axisLeft() 237 | .scale(yScale) 238 | .ticks(8, "s"); 239 | 240 | // Svg 241 | const plot = d3.select(this) 242 | .append("svg") 243 | .attr("width",wsvg) 244 | .attr("height",hsvg); 245 | // Color background 246 | plot.append("rect") 247 | .attr("x",margin.left) 248 | .attr("y",margin.top) 249 | .attr("width",innerW) 250 | .attr("height",innerH) 251 | .attr("class","background axis"); 252 | // Plot axis 253 | plot.append("g") 254 | .attr("transform", 255 | "translate("+margin.left+"," 256 | +(hsvg-margin.bottom)+")") 257 | .attr("class", "axis") 258 | .call(xAxis); 259 | plot.append("g") 260 | .attr("transform", 261 | "translate("+margin.left+"," 262 | +margin.top+")") 263 | .attr("class", "axis") 264 | .call(yAxis); 265 | // Print axis titles 266 | plot.append("text") 267 | .attr("class", "axisTitle") 268 | .attr("x", wsvg/2) 269 | .attr("y", hsvg-10) 270 | .text(inputs.xLabel); 271 | plot.append("text") 272 | .attr("class", "axisTitle ytitle") 273 | .attr("transform-origin", 0, hsvg/2) 274 | .attr("x", 0) 275 | .attr("y", hsvg/2) 276 | .text(inputs.yLabel); 277 | 278 | // Plot data 279 | plot.append("g") 280 | .attr("transform", 281 | "translate("+margin.left+"," 282 | +margin.top+")") 283 | .selectAll("circle") 284 | .data(serie.dataset) 285 | .enter() 286 | .append("circle") 287 | .attr("class", "circle") 288 | .attr("r", dotSize) 289 | .attr("cx", d => xScale(d.x)) 290 | .attr("cy", d => yScale(d.y)); 291 | 292 | // Plot linear regression line 293 | 294 | const xVals = serie.dataset.map((e,j) => e.x); 295 | const yVals = serie.dataset.map((e,j) => e.y); 296 | const pairs = []; 297 | xVals.forEach((d,i) => pairs.push([xVals[i],yVals[i]])); 298 | const linReg = ss.linearRegression(pairs); 299 | const linRegLine = ss.linearRegressionLine(linReg); 300 | let line = plot 301 | .append("line") 302 | .attr("transform","translate("+margin.left+","+margin.top+")") 303 | .attr("class","regLine") 304 | .attr("x1",xScale(xMin)) 305 | .attr("x2",xScale(xMin)) 306 | .attr("y1",yScale(linRegLine(xMin))) 307 | .attr("y2",yScale(linRegLine(xMin))); 308 | line.transition().duration(1000).delay(2000) 309 | .attr("x2",xScale(xMax)) 310 | .attr("y2",yScale(linRegLine(xMax))); 311 | 312 | // Add text boxes 313 | //const meanX = ss.mean(xVals).toFixed(0); 314 | //const meanY = ss.mean(yVals).toFixed(2); 315 | //const varX = ss.sampleVariance(xVals).toFixed(0); 316 | //const varY = ss.sampleVariance(yVals).toFixed(1); 317 | //const corCoeff = ss.sampleCorrelation(xVals,yVals).toFixed(3); 318 | 319 | const lr_results = [ 320 | ["Linear regression line", "y = "+linReg.b.toFixed(2)+" + "+linReg.m.toFixed(3)+"x"], 321 | ["Coefficient", serie.result.estimate], 322 | ["R²", serie.result.r_square] 323 | ]; 324 | 325 | const sampling_to_string = sampling => 326 | (Number.isInteger(sampling) ? "`Linear "+sampling+"" : "`Geometric "+sampling+""); 327 | 328 | const format = v => d3.format("s")(v); 329 | 330 | const param_benchmarks = [ 331 | ["LR sampling (sampling)", sampling_to_string(serie.description.sampling)], 332 | ["Start (start)", serie.description.start], 333 | ["Benchmark runtime (time / quota)", 334 | format(serie.description.time) + " / " + format(serie.description.quota)], 335 | ["Number of runs (samples)", serie.description.samples + " / " + serie.description.limit], 336 | ["Stabilized GC (stabilize)", serie.description.stabilize] 337 | ]; 338 | 339 | const table = d3.select("#lr-info-"+i) 340 | .append("table"); 341 | 342 | table.append("thead") 343 | .append("tr") 344 | .append("th") 345 | .attr("colspan", 2) 346 | .attr("scope", "col") 347 | .text("Linear regression results"); 348 | 349 | table.append("tbody") 350 | .selectAll("tr") 351 | .data(lr_results) 352 | .enter() 353 | .append("tr") 354 | .selectAll("td") 355 | .data(d => d) 356 | .enter() 357 | .append("td") 358 | .text(d=>d); 359 | 360 | table.append("thead") 361 | .append("tr") 362 | .append("th") 363 | .attr("class", "tooltip") 364 | .attr("colspan", 2) 365 | .attr("scope", "col") 366 | .text("Benchmarks parameters") 367 | .append("span") 368 | .attr("class","tooltiptext") 369 | .text("See [Benchmarks.stats]"); 370 | 371 | table.append("tbody") 372 | .selectAll("tr") 373 | .data(param_benchmarks) 374 | .enter() 375 | .append("tr") 376 | .selectAll("td") 377 | .data(d => d) 378 | .enter() 379 | .append("td") 380 | .text(d=>d); 381 | 382 | }); 383 | 384 | // ************************************************ // 385 | // Histogram and kde graphs // 386 | // ************************************************ // 387 | if (nonempty_kde) { 388 | kde_graphs.each(function (serie, i) { 389 | 390 | // Svg for histogram and kde graphs 391 | let pdfgraph = d3.select(this) 392 | .append("svg") 393 | .attr("id", "pdfgraph") 394 | .attr("width", wsvg) 395 | .attr("height", hsvg) 396 | .append("g") 397 | .attr("transform", "translate("+margin.left+","+margin.top+")"); 398 | 399 | // If there is no kde field in the data [serie], some note 400 | // is written in the svg window. 401 | if (!('kde' in serie)) { 402 | pdfgraph.append("text") 403 | .attr("x", (margin.left+margin.right+wsvg)/2) 404 | .attr("y", (margin.top+margin.bottom+hsvg)/2) 405 | .attr("class", "warning") 406 | .text("No available data"); 407 | } else if (d3.max(serie.kde) == d3.min(serie.kde)) { 408 | pdfgraph.append("text") 409 | .attr("x", wsvg/2) 410 | .attr("y", hsvg/2) 411 | .attr("class", "warningtext") 412 | .text("All data have same value."); 413 | } else { 414 | const data = serie.kde; 415 | //Some default values 416 | const min_slider = (d3.max(data)-d3.min(data))/data.length; 417 | const max_slider = (d3.max(data)-d3.min(data))/30; 418 | let vslider = min_slider; 419 | 420 | //Radio buttons 421 | const form = d3.select("#radio_div"+i) 422 | .append("form"); 423 | 424 | form.append("input") 425 | .attr("type", "radio") 426 | .attr("name", "graph") 427 | .attr("value", "hist"+i) 428 | .attr("name", "graph") 429 | .attr("checked", "checked") 430 | .on("change", () => plot_chosen_graph(d3.select(this), "hist")); 431 | form.append("label") 432 | .attr("for", "hist"+i) 433 | .text("Histogram"); 434 | form.append("input") 435 | .attr("type", "radio") 436 | .attr("value", "kde"+i) 437 | .attr("name", "graph") 438 | .on("change", () => plot_chosen_graph(d3.select(this), "kde")); 439 | form.append("label") 440 | .attr("for", "kde"+i) 441 | .text("KDE"); 442 | 443 | //axis 444 | const min = d3.min(data), 445 | max = d3.max(data); 446 | const minX = d3.max([0, min-max_slider]), 447 | maxX = max+max_slider; 448 | 449 | //X axis is the same for both graphs (histogram and kde) 450 | const xscale = d3.scaleLinear() 451 | .range([0, innerW]) 452 | .domain([minX, maxX]) 453 | .nice(); 454 | const xAxis = d3.axisBottom() 455 | .scale(xscale) 456 | .ticks(8, "s"); 457 | 458 | //Y axis has a different domain value between both graphs. 459 | //So yscale.domain() is defined individually for each plot. 460 | const yscale = d3.scaleLinear() 461 | .range([0, innerH]) 462 | .nice(); 463 | const yAxis = d3.axisLeft() 464 | .scale(yscale) 465 | .ticks(8, "s"); 466 | 467 | //x value for kde graph 468 | const n = 1000; 469 | const x = Array(n); 470 | const xmin = d3.min(xscale.domain()), 471 | xmax = d3.max(xscale.domain()); 472 | for (let i=0; i { 574 | if (value > 0) { 575 | vslider=value; 576 | update_hist(vslider);}})); 577 | } else { 578 | //Defined yAxis 579 | yscale.domain([maxYkde, 0]).nice(); 580 | yAxis.scale(yscale); 581 | gyAxis.call(yAxis); 582 | 583 | // y Axis title 584 | pdfgraph.append("text") 585 | .attr("transform-origin", "10 "+(innerH/2)) 586 | .attr("class", "axisTitle ytitle") 587 | .attr("x", +10) 588 | .attr("y", innerH/2) 589 | .text("Density"); 590 | 591 | const bandwidth = vslider; 592 | const update_kde = plot_kde(pdfgraph, data, bandwidth, xscale, yscale, x); 593 | 594 | //slider 595 | control_container.insert("p") 596 | .attr("align", "center") 597 | .attr("id", "slidertitle-"+i) 598 | .text("Bandwidth"); 599 | 600 | control_container.insert("svg") 601 | .attr("width", wsvg) 602 | .attr("height", hslider) 603 | .attr("id", "slider-"+i) 604 | .append("g") 605 | .attr("transform", "translate("+(wsvg-wslider)/2+",10)") 606 | .call(d3 607 | .sliderBottom() 608 | .min(min_slider) 609 | .max(max_slider) 610 | .width(wslider) 611 | .ticks(5, "s") 612 | .default(vslider) 613 | .fill("red") 614 | .on("onchange", (value) => 615 | {if (value > 0) { vslider=value; update_kde(vslider);}})); 616 | }; // end else 617 | }; // end function 618 | }; //end else (available kde data) 619 | }); //end function // end each 620 | }; //end if 621 | 622 | 623 | 624 | function plot_summarize_bar_graph(container, inputs) { 625 | 626 | const hbar = d3.min([60*inputs.series.length, hsvg]); 627 | const innerHbar = hbar - marginbar.top - marginbar.bottom; 628 | 629 | const xb = d3.scaleLinear() 630 | .range([0, innerWbar]) 631 | .domain([0, d3.max(inputs.series, serie => serie.result.estimate)]) 632 | .nice(); 633 | const yb = d3.scaleBand() 634 | .range([0, innerHbar]) 635 | .padding(0.2) 636 | .domain(inputs.series.map(serie => serie.name)); 637 | const xbAxis = d3.axisBottom() 638 | .scale(xb) 639 | .ticks(8, "s"); 640 | const ybAxis = d3.axisLeft() 641 | .scale(yb); 642 | 643 | const bargraph = 644 | container.append("svg") 645 | .attr("width", wbar) 646 | .attr("height", hbar); 647 | 648 | // background 649 | bargraph.append("rect") 650 | .attr("x", marginbar.left) 651 | .attr("y", marginbar.top) 652 | .attr("width", innerWbar) 653 | .attr("height", innerHbar) 654 | .attr("class", "background axis"); 655 | // x Axis 656 | bargraph.append("g") 657 | .attr("transform","translate("+marginbar.left+","+(hbar-marginbar.bottom)+")") 658 | .attr("class", "axis") 659 | .call(xbAxis); 660 | // x axis title 661 | bargraph.append("text") 662 | .attr("class", "axisTitle") 663 | .attr("x", wbar/2) 664 | .attr("y", hbar-10) 665 | .text("Estimated "+inputs.yLabel); 666 | // y Axis 667 | bargraph.append("g") 668 | .attr("transform","translate("+marginbar.left+","+marginbar.bottom+")") 669 | .attr("class", "axis") 670 | .call(ybAxis); 671 | 672 | // Bargraph 673 | bargraph.append("g") 674 | .attr("transform","translate("+marginbar.left+","+marginbar.top+")") 675 | .selectAll(".bar") 676 | .data(inputs.series) 677 | .enter() 678 | .append("rect") 679 | .attr("class", "bar") 680 | .attr("y", serie => yb(serie.name)) 681 | .attr("height", yb.bandwidth) 682 | .attr("x", serie => 0) 683 | .attr("width", serie => xb(serie.result.estimate)) 684 | .attr("fill", "#4ECDC4") 685 | .on("mouseover", function (serie) { 686 | // Specify where to put label of text 687 | bargraph.append("text") 688 | .attr("class", "axisTitle") 689 | .attr("id", "tt") 690 | .attr("x", wbar-200) 691 | .attr("y", marginbar.top-10) 692 | .text("Value: "+d3.format(".4s")(serie.result.estimate)); 693 | }) 694 | .on("mouseout", function (serie) { 695 | // Select text by id and then remove 696 | d3.selectAll("#tt").transition().duration("50").remove(); 697 | }); 698 | 699 | }; 700 | 701 | // [histrogram (data, barwidth, min, max)] computes histogram 702 | // values as follows: 703 | // - a value [v] of [data] contributes to the bar between [u] and 704 | // [u+barwidth] if u <= v < u+barwidth 705 | // - the [i]th bar is between [min+i*barwidth] and [min+(i+1)*barwidth] 706 | // - [max] is used only to determine the number of bars. It MUST be greater 707 | // than [d3.max(data)] 708 | function histogram(data, barwidth, min, max) { 709 | const nbar = Math.floor((max-min)/barwidth)+1; 710 | let hist = new Array(nbar); 711 | for (let i=0; i xscale(i*barwidth+min)) 759 | .attr("width", (v, i) => xscale(barwidth)-xscale(0)) 760 | .attr("y", (v, i) => yscale(v)) 761 | .attr("height", (v, i) => innerH-yscale(v)) 762 | .on("mouseover", print_value) 763 | .on("mouseout", () => d3.selectAll("#tt2").transition().duration("50").remove()); 764 | 765 | function update_hist(nbarwidth) { 766 | //compute new histograph values 767 | const nhist = histogram(data, nbarwidth, min, max); 768 | 769 | const rects = container 770 | .selectAll(".bar") 771 | .data(nhist); 772 | 773 | rects.exit().remove(); 774 | 775 | rects.enter().append("rect").attr("class", "bar") 776 | .merge(rects) 777 | .attr("x", (v, i) => xscale(i*nbarwidth+min)) 778 | .attr("width", (v, i) => xscale(nbarwidth)-xscale(0)) 779 | .attr("y", (v, i) => yscale(v)) 780 | .attr("height", (v, i) => innerH-yscale(v)) 781 | .on("mouseover", print_value) 782 | .on("mouseout", () => d3.selectAll("#tt2").transition().duration("50").remove()); 783 | } 784 | return update_hist; 785 | }; 786 | 787 | // [kernelDensityEstimation(data, bandwith] returns the function x -> kde(x) 788 | // for [data]. The kernel function used is a gaussian. 789 | function kernelDensityEstimation(X, bandwidth) { 790 | //gaussian constante 791 | const a = 1/(2*bandwidth*bandwidth); 792 | const b = bandwidth * SQRT_2PI; 793 | const gaussianKernel = 794 | function (x) { 795 | return Math.exp(-a * x * x) / b; 796 | }; 797 | 798 | return function (x) { 799 | let i = 0; 800 | let sum = 0; 801 | for (i = 0; i < X.length; i++) { 802 | sum += gaussianKernel(x - X[i])/X.length; 803 | } 804 | return sum ; 805 | }; 806 | } 807 | 808 | // [plot_kde(container, data, bandwidth, xscale, yscale, x)] draws 809 | // the kde function computes with [kde(data, bandwidth)] 810 | // for the abscisse values defined by [x], in the html element 811 | // [container]. 812 | // 813 | // Axis are already defined on [container], using [xscale] and 814 | // [yscale]. 815 | // 816 | // In addition, this function returns the update function that 817 | // redraw the curve if called with a new bandwidth. 818 | function plot_kde(container, data, bandwidth, xscale, yscale, x) { 819 | const n = x.length; 820 | const kde = kernelDensityEstimation(data, bandwidth); 821 | const density = new Array(n); 822 | 823 | for (let i=0; i xscale(d[0])) 842 | .y(d => yscale(d[1]))); 843 | 844 | function update_kde(nbandwidth) { 845 | let kde = kernelDensityEstimation(data, nbandwidth); 846 | 847 | for (let i=0; i xscale(d[0])) 858 | .y(d => yscale(d[1]))); 859 | }; 860 | 861 | return update_kde; 862 | }; 863 | 864 | }; 865 | 866 | 867 | var contents = null; 868 | //BECHAMEL_CONTENTS// 869 | 870 | if (contents == null) 871 | d3.json("outputs.json", render); 872 | else 873 | render(contents); 874 | } 875 | -------------------------------------------------------------------------------- /img/output0.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mirage/bechamel/bf27a9edfa89918948227ce25fe0545c57d7ef01/img/output0.png -------------------------------------------------------------------------------- /lib/analyze.ml: -------------------------------------------------------------------------------- 1 | module OLS = struct 2 | module Ci95 = struct 3 | (* 95% confidence interval *) 4 | type t = { r : float; l : float } 5 | 6 | let pp ppf x = Fmt.pf ppf "@[%f to %f@]" x.r x.l 7 | let bad = { r = neg_infinity; l = neg_infinity } 8 | end 9 | 10 | (* Linear regression inputs *) 11 | let make_lr_inputs ?indices ~responder ~predictors m = 12 | let responder_accessor = Measurement_raw.get ~label:responder in 13 | let predictors_accessor = 14 | Array.map (fun label -> Measurement_raw.get ~label) predictors 15 | in 16 | match indices with 17 | | Some indices -> 18 | ( Array.map 19 | (fun i -> Array.map (fun a -> a m.(i)) predictors_accessor) 20 | indices 21 | , Array.map (fun i -> responder_accessor m.(i)) indices ) 22 | | None -> 23 | ( Array.init (Array.length m) (fun i -> 24 | Array.map (fun a -> a m.(i)) predictors_accessor) 25 | , Array.init (Array.length m) (fun i -> responder_accessor m.(i)) ) 26 | 27 | type t = 28 | { predictors : string array 29 | ; responder : string 30 | ; value : (v, [ `Msg of string ]) result 31 | } 32 | 33 | and v = 34 | { estimates : float array 35 | ; ci95 : Ci95.t array option 36 | ; r_square : float option 37 | } 38 | 39 | let r_square m ~responder ~predictors r = 40 | let predictors_matrix, responder_vector = 41 | make_lr_inputs ~responder ~predictors m 42 | in 43 | let sum_responder = Array.fold_left ( +. ) 0. responder_vector in 44 | let mean = sum_responder /. float (Array.length responder_vector) in 45 | let tot_ss = ref 0. in 46 | let res_ss = ref 0. in 47 | let predicted i = 48 | let x = ref 0. in 49 | for j = 0 to Array.length r - 1 do 50 | x := !x +. (predictors_matrix.(i).(j) *. r.(j)) 51 | done; 52 | !x 53 | in 54 | for i = 0 to Array.length responder_vector - 1 do 55 | tot_ss := !tot_ss +. ((responder_vector.(i) -. mean) ** 2.); 56 | res_ss := !res_ss +. ((responder_vector.(i) -. predicted i) ** 2.) 57 | done; 58 | 1. -. (!res_ss /. !tot_ss) 59 | 60 | (* XXX(dinosaure): see core_bench and [(1/e)^bootstrap_threshold < 61 | 0.05/predictors] which describe area on top of logarithm curve (where 62 | maximum seems close to 6~7). *) 63 | let bootstrap_threshold = 10 64 | 65 | let can_bootstrap ~responder ~predictors m = 66 | let matrix, _ = make_lr_inputs ~responder ~predictors m in 67 | let non_zero = Array.make (Array.length predictors) 0 in 68 | let non_zero_cols = ref 0 in 69 | Array.iter 70 | (fun row -> 71 | for i = 0 to Array.length non_zero - 1 do 72 | if row.(i) <> 0.0 then ( 73 | non_zero.(i) <- non_zero.(i) + 1; 74 | if non_zero.(i) = bootstrap_threshold then incr non_zero_cols) 75 | done) 76 | matrix; 77 | if !non_zero_cols = Array.length non_zero then true else false 78 | 79 | let () = Random.self_init () 80 | 81 | let random_indices_in_place ~max arr = 82 | let len = Array.length arr in 83 | for i = 0 to len - 1 do 84 | arr.(i) <- Random.int max 85 | done 86 | 87 | let quantile_of_array ?(failures = 0) ~len ~low ~high arr = 88 | Array.sort (compare : float -> float -> int) arr; 89 | let index q = int_of_float ((float len *. q) +. (0.5 *. float failures)) in 90 | let extended_get i = if i >= len then infinity else arr.(i) in 91 | let l = extended_get ((min : int -> int -> int) (index low) (len - 1)) in 92 | let r = extended_get ((max : int -> int -> int) (index high) failures) in 93 | Ci95.{ l; r } 94 | 95 | let bootstrap ~trials m ~responder ~predictors = 96 | let p = Array.length predictors in 97 | match can_bootstrap ~responder ~predictors m with 98 | | false -> assert false 99 | | true -> 100 | let bootstrap_fails = ref 0 in 101 | let indices = Array.make (Array.length m) 0 in 102 | let bootstrap_coeffs = Array.init p (fun _ -> Array.make trials 0.0) in 103 | for i = 0 to trials - 1 do 104 | random_indices_in_place indices ~max:(Array.length m); 105 | let matrix, vector = 106 | make_lr_inputs ~indices ~responder ~predictors m 107 | in 108 | match Linear_algebra.ols ~in_place:true matrix vector with 109 | | Ok bt_ols_result -> 110 | for p = 0 to p - 1 do 111 | bootstrap_coeffs.(p).(i) <- bt_ols_result.(p) 112 | done 113 | | _ -> 114 | incr bootstrap_fails; 115 | for p = 0 to p - 1 do 116 | bootstrap_coeffs.(p).(i) <- neg_infinity 117 | done 118 | done; 119 | Array.init p (fun i -> 120 | if trials = 0 then Ci95.bad 121 | else 122 | quantile_of_array bootstrap_coeffs.(i) ~failures:!bootstrap_fails 123 | ~len:trials ~low:0.025 ~high:0.975) 124 | 125 | (* Ordinary Least Square *) 126 | let ols ?bootstrap:(trials = 0) ?r_square:(do_r_square = false) ~responder 127 | ~predictors m = 128 | let matrix, vector = make_lr_inputs ~responder ~predictors m in 129 | match Linear_algebra.ols ~in_place:true matrix vector with 130 | | Ok estimates -> 131 | let r_square = 132 | if do_r_square then Some (r_square m ~responder ~predictors estimates) 133 | else None 134 | in 135 | let ci95 = 136 | match trials with 137 | | 0 -> None 138 | | trials -> Some (bootstrap ~trials ~responder ~predictors m) 139 | in 140 | { predictors; responder; value = Ok { estimates; ci95; r_square } } 141 | | Error _ as err -> { predictors; responder; value = err } 142 | 143 | let pp ~predictors ~responder ppf v = 144 | Fmt.pf ppf "{ @["; 145 | for i = 0 to Array.length predictors - 1 do 146 | Fmt.pf ppf "%s per %s = %f" responder predictors.(i) v.estimates.(i); 147 | (match v.ci95 with 148 | | Some ci95 -> Fmt.pf ppf " (confidence: %a)" Ci95.pp ci95.(i) 149 | | None -> ()); 150 | Fmt.pf ppf ";@ " 151 | done; 152 | Fmt.pf ppf "r² = %a@] }" Fmt.(Dump.option float) v.r_square 153 | 154 | let pp ppf x = 155 | match x.value with 156 | | Ok v -> pp ~predictors:x.predictors ~responder:x.responder ppf v 157 | | Error (`Msg err) -> Format.fprintf ppf "%s" err 158 | 159 | let predictors { predictors; _ } = Array.to_list predictors 160 | let responder { responder; _ } = responder 161 | 162 | let estimates { value; _ } = 163 | match value with 164 | | Ok { estimates; _ } -> Some (Array.to_list estimates) 165 | | Error _ -> None 166 | 167 | let r_square { value; _ } = 168 | match value with Ok { r_square; _ } -> r_square | Error _ -> None 169 | end 170 | 171 | module RANSAC = struct 172 | (* returns [a, b] such that [f(x) = a*x + b] minimize the distance between 173 | [sum(fun (x -> (f(x) - v(x))^2)] *) 174 | let affine_adjustment (r : (float * float) array) = 175 | let len = float (Array.length r) in 176 | let mean_x = 177 | let sum_x = Array.fold_right (fun (x, _) acc -> x +. acc) r 0. in 178 | sum_x /. len 179 | in 180 | let mean_y = 181 | let sum_y = Array.fold_right (fun (_, y) acc -> y +. acc) r 0. in 182 | sum_y /. len 183 | in 184 | let variance_x = 185 | let sumvar = 186 | Array.fold_right 187 | (fun (x, _) acc -> 188 | let v = x -. mean_x in 189 | (v *. v) +. acc) 190 | r 0. 191 | in 192 | sumvar /. len 193 | in 194 | let covariance_x_y = 195 | let sumcovar = 196 | Array.fold_right 197 | (fun (x, y) acc -> 198 | let v = (x -. mean_x) *. (y -. mean_y) in 199 | v +. acc) 200 | r 0. 201 | in 202 | sumcovar /. len 203 | in 204 | let a = covariance_x_y /. variance_x in 205 | let b = mean_y -. (a *. mean_x) in 206 | (a, b) 207 | 208 | let quality data (a, b) = 209 | let acc = ref 0. in 210 | for i = 0 to Array.length data - 1 do 211 | let x, y = data.(i) in 212 | let diff = 213 | let d = (a *. x) +. b -. y in 214 | d *. d 215 | in 216 | acc := !acc +. diff 217 | done; 218 | !acc /. float (Array.length data) 219 | 220 | let ransac_filter_distance (x, y) (a, b) = 221 | let level = max x (max y (max a b)) in 222 | abs_float ((a *. x) +. b -. y) /. level 223 | 224 | let ransac_param data = 225 | { Ransac.model = affine_adjustment 226 | ; data 227 | ; subset_size = 10 228 | ; rounds = 100 229 | ; distance = ransac_filter_distance 230 | ; filter_distance = 0.05 231 | ; minimum_valid = Array.length data / 3 232 | ; error = quality 233 | } 234 | 235 | let sum a = Array.fold_left ( +. ) 0. a 236 | 237 | let standard_error ~a ~b (r : (float * float) array) = 238 | let estimate x = (a *. x) +. b in 239 | let dy (x, y) = 240 | let d = y -. estimate x in 241 | d *. d 242 | in 243 | let sum_dy = sum (Array.map dy r) in 244 | let mean_x = 245 | sum (Array.map (fun (x, _) -> x) r) /. float (Array.length r) 246 | in 247 | let dx (x, _) = 248 | let d = x -. mean_x in 249 | d *. d 250 | in 251 | sqrt (sum_dy /. float (Array.length r - 2)) /. sqrt (sum (Array.map dx r)) 252 | 253 | type t = 254 | { predictor : string 255 | ; responder : string 256 | ; mean_value : float 257 | ; constant : float 258 | ; max_value : float * float 259 | ; min_value : float * float 260 | ; standard_error : float 261 | } 262 | 263 | let pp ppf t = 264 | Fmt.pf ppf "{ @[%s per %s = %f;@ standard-error = %f;@] }" t.responder 265 | t.predictor t.mean_value t.standard_error 266 | 267 | let result_column ~predictor ~responder m = 268 | ( Measurement_raw.get ~label:predictor m 269 | , Measurement_raw.get ~label:responder m ) 270 | 271 | let ransac ?(filter_outliers = true) ~predictor ~responder ml = 272 | let a = Array.map (result_column ~predictor ~responder) ml in 273 | let mean_value, constant = 274 | if filter_outliers then 275 | match Ransac.ransac (ransac_param a) with 276 | | None -> 277 | (* Couldn't extract a model, just return crude affine adjustment *) 278 | affine_adjustment a 279 | | Some { Ransac.model; _ } -> model 280 | else affine_adjustment a 281 | in 282 | let min_value = 283 | Array.fold_left 284 | (fun (row_min, val_min) (row, value) -> 285 | let value = (value -. constant) /. row in 286 | if val_min < value || value <= 0. then (row_min, val_min) 287 | else (row, value)) 288 | (0., max_float) a 289 | in 290 | let correct_float f = classify_float f = FP_normal in 291 | let max_value = 292 | Array.fold_left 293 | (fun (row_max, val_max) (row, value) -> 294 | let value = (value -. constant) /. row in 295 | if val_max > value || not (correct_float value) then (row_max, val_max) 296 | else (row, value)) 297 | (0., min_float) a 298 | in 299 | let standard_error = standard_error ~a:mean_value ~b:constant a in 300 | { predictor 301 | ; responder 302 | ; mean_value 303 | ; constant 304 | ; min_value 305 | ; max_value 306 | ; standard_error 307 | } 308 | 309 | let responder { responder; _ } = responder 310 | let predictor { predictor; _ } = predictor 311 | let mean { mean_value; _ } = mean_value 312 | let constant { constant; _ } = constant 313 | let min { min_value; _ } = min_value 314 | let max { max_value; _ } = max_value 315 | let error { standard_error; _ } = standard_error 316 | end 317 | 318 | type 'a t = 319 | | OLS : 320 | { predictors : string array; r_square : bool; bootstrap : int } 321 | -> OLS.t t 322 | | RANSAC : { filter_outliers : bool; predictor : string } -> RANSAC.t t 323 | 324 | let ols ~r_square ~bootstrap ~predictors = 325 | OLS { predictors; r_square; bootstrap } 326 | 327 | let ransac ~filter_outliers ~predictor = RANSAC { filter_outliers; predictor } 328 | 329 | let one : type a. a t -> Measure.witness -> Benchmark.t -> a = 330 | fun kind e { lr = m; _ } -> 331 | let label = Measure.label e in 332 | match kind with 333 | | OLS { predictors; r_square; bootstrap } -> 334 | OLS.ols ~bootstrap ~r_square ~predictors ~responder:label m 335 | | RANSAC { filter_outliers; predictor } -> 336 | RANSAC.ransac ~filter_outliers ~predictor ~responder:label m 337 | 338 | let all : 339 | type a. 340 | a t 341 | -> Measure.witness 342 | -> (string, Benchmark.t) Hashtbl.t 343 | -> (string, a) Hashtbl.t = 344 | fun kind e ms -> 345 | let ret = Hashtbl.create (Hashtbl.length ms) in 346 | Hashtbl.iter (fun name m -> Hashtbl.add ret name (one kind e m)) ms; 347 | ret 348 | 349 | let merge : 350 | type a. 351 | a t 352 | -> Measure.witness list 353 | -> (string, a) Hashtbl.t list 354 | -> (string, (string, a) Hashtbl.t) Hashtbl.t = 355 | fun _ instances results -> 356 | let ret = Hashtbl.create (List.length instances) in 357 | List.iter2 358 | (fun instance result -> Hashtbl.add ret (Measure.label instance) result) 359 | instances results; 360 | ret 361 | -------------------------------------------------------------------------------- /lib/analyze.mli: -------------------------------------------------------------------------------- 1 | (** Analyze module. 2 | 3 | Micro-benchmark usually uses a {i linear-regression} to estimates the 4 | execution time of a code segments. For example, the following table might 5 | represent [{!Measurement_raw.t} array] collected by {!Benchmark.run}: 6 | 7 | {v 8 | +-----+------+ 9 | | run | time | 10 | +-----+------+ 11 | | 1 | 19 | 12 | | 2 | 25 | 13 | | 3 | 37 | 14 | | 4 | 47 | 15 | | 5 | 56 | 16 | +-----+------+ 17 | v} 18 | 19 | Bechamel records 3000 samples and the number of iterations can grows 20 | geometrically (see {!Benchmark.run}). Then, Bechamel can use 2 algorithms: 21 | 22 | - Ordinary Least Square 23 | - RANdom SAmple Consensus 24 | 25 | The user can choose one of it. Currently, {!OLS} is the best to use. These 26 | algorithms will estimate the actual execution time of the code segment. 27 | Using {!OLS} with the above data would yield an estimated execution time of 28 | [9.6] nanoseconds with a goodness of fit ([r²]) of [0.992]. 29 | 30 | More generally, Bechamel lets the user choose the {i predictors} and 31 | {i responder}. Indeed, the user can use others metrics (such as [perf]) and 32 | the API allows to analyze such metrics together. *) 33 | 34 | module OLS : sig 35 | type t 36 | 37 | val ols : 38 | ?bootstrap:int 39 | -> ?r_square:bool 40 | -> responder:string 41 | -> predictors:string array 42 | -> Measurement_raw.t array 43 | -> t 44 | 45 | val pp : t Fmt.t 46 | val predictors : t -> string list 47 | val responder : t -> string 48 | val estimates : t -> float list option 49 | val r_square : t -> float option 50 | end 51 | 52 | module RANSAC : sig 53 | type t 54 | 55 | val ransac : 56 | ?filter_outliers:bool 57 | -> predictor:string 58 | -> responder:string 59 | -> Measurement_raw.t array 60 | -> t 61 | 62 | val pp : t Fmt.t 63 | val responder : t -> string 64 | val predictor : t -> string 65 | val mean : t -> float 66 | val constant : t -> float 67 | val max : t -> float * float 68 | val min : t -> float * float 69 | val error : t -> float 70 | end 71 | 72 | type 'a t 73 | (** Type of analysis. *) 74 | 75 | val ols : r_square:bool -> bootstrap:int -> predictors:string array -> OLS.t t 76 | (** [ols ~r_square ~bootstrap ~predictors] is an Ordinary Least Square analysis 77 | on [predictors]. It calculates [r²] if [r_square = true]. [bootstrap] defines 78 | how many times Bechamel tries to {i resample} measurements. *) 79 | 80 | val ransac : filter_outliers:bool -> predictor:string -> RANSAC.t t 81 | 82 | val one : 'a t -> Measure.witness -> Benchmark.t -> 'a 83 | (** [one analysis measure { Benchmark.stat; lr; kde; }] estimates the actual 84 | given [measure] for one [predictor]. So, 85 | [one analysis time { Benchmark.stat; lr; kde; }] 86 | wants to estimate actual {i run}-[time] (or execution time) value, 87 | where [analysis] is initialized with [run] {i predictor}. *) 88 | 89 | val all : 90 | 'a t 91 | -> Measure.witness 92 | -> (string, Benchmark.t) Hashtbl.t 93 | -> (string, 'a) Hashtbl.t 94 | (** [all analysis measure tbl] is an application of {!val:one} for all results 95 | from the given [tbl]. *) 96 | 97 | val merge : 98 | 'a t 99 | -> Measure.witness list 100 | -> (string, 'a) Hashtbl.t list 101 | -> (string, (string, 'a) Hashtbl.t) Hashtbl.t 102 | (** [merge witnesses tbls] returns a dictionary where the key is the {i label} 103 | of a measure (from the given [witnesses]) and the value is the result of 104 | this specific measure. *) 105 | -------------------------------------------------------------------------------- /lib/bechamel.ml: -------------------------------------------------------------------------------- 1 | module S = S 2 | module Measure = Measure 3 | module Benchmark = Benchmark 4 | module Test = Test 5 | module Staged = Staged 6 | module Measurement_raw = Measurement_raw 7 | module Linear_algebra = Linear_algebra 8 | module Analyze = Analyze 9 | module Toolkit = Toolkit 10 | module Time = Time 11 | -------------------------------------------------------------------------------- /lib/bechamel.mli: -------------------------------------------------------------------------------- 1 | (** {1 Bechamel, a simple and agnostic micro-benchmarking framework.} 2 | 3 | Bechamel is a simple and {i agnostic} micro-benchmarking framework to help 4 | the developer prove and compare metrics for a given {b small} function. 5 | It's measuring the performance of something "small", like a 6 | system call. Bechamel does not do, as we say, a macro-benchmark which can 7 | show a performance regression or I/O congestion for instance. 8 | 9 | It just permits to assert that a simple call of a small function [fn1] 10 | can be faster than a call of another small function [fn2] 11 | (if you use a {i time} metric). 12 | In this way, it asserts that [fn1] should be more efficient than [fn2] and 13 | it lets the developer {b deduce} the best choice according to the 14 | runtime context. 15 | 16 | Bechamel should {b not} lead to premature optimization. It gives only 17 | clues/metrics about what you use, but you {b must} recontextualize results 18 | according to your case to lead to {i certain} optimizations. 19 | 20 | {2 How to use Bechamel?} 21 | 22 | Bechamel is split into 3 parts: 23 | - A user interface to define {i tests} (your small function) 24 | - A {i runner} which will record required metrics 25 | - An {i analyzer} which will analyze {i raw} metrics and give you a 26 | stated result 27 | 28 | This is the core of Bechamel where the user is able to: 29 | - define its own tests 30 | - use its own metrics 31 | - have a choice between 2 analyses (for instance, Ordinary Least Square 32 | analysis or RANdom SAmple Consensus analysis) 33 | 34 | {3 Make a test.} 35 | 36 | The {!module:Test} gives an API which permits defining your tests. Let's 37 | take the example of the recursive factorial and the "imperative" factorial: 38 | {[ 39 | let rec fact0 n = 40 | if n = 0 then 1 41 | else n * fact0 (n - 1) 42 | 43 | let fact1 n = 44 | let m = ref 0 in 45 | let v = ref 1 in 46 | while !m < n do 47 | m := !m + 1 ; 48 | v := !v * !m ; 49 | done ; !v 50 | ]} 51 | 52 | From these small functions, we are able to make a test for each function 53 | and group them into one test: 54 | {[ 55 | let test0 = Test.make ~name:"recursive" 56 | (Staged.stage @@ fun () -> fact0 120) 57 | let test1 = Test.make ~name:"imperative" 58 | (Staged.stage @@ fun () -> fact1 120) 59 | let test = Test.make_grouped ~name:"factorial" ~fmt:"%s %s" 60 | [ test0; test1; ] 61 | ]} 62 | 63 | The user is able to make multiple kinds of tests: 64 | - A simple one as we did above 65 | - An indexed one which can take an [int] as an argument. For instance, 66 | we can execute our [fact] function with a set of [int]s. 67 | - A test which requires a "resource" which must be allocated before the 68 | {i benchmark} and released after. For instance, we can allocate a 69 | {i socket}, run {!val:Unix.write} and record metrics and release 70 | ({!val:Unix.close}) the resource then. 71 | - Finally, we can define an {i indexed} test with a required resource 72 | 73 | {3 Run the benchmark.} 74 | 75 | Then, you need to run the benchmark and record metrics. Bechamel is 76 | {i agnostic} to the system: it permits recording a few metrics like the 77 | {!val:Toolkit.Instance.monotonic_clock} or how many words were allocated 78 | into the minor heap {!val:Toolkit.Instance.minor_allocated}. 79 | 80 | Depending on the execution context, the user is able to add some new 81 | metrics. For instance, on Linux, you can record the 82 | {!val:Bechamel_perf.Instance.cpu_clock} - but it's not a part of the core 83 | distribution. More abstractly, Bechamel is able to record any metrics as 84 | far as the user is able to provide a {!modtype:Bechamel.S.MEASURE}. 85 | 86 | For instance, we will try to record the monotonic clock: it represents the 87 | absolute elapsed {i wall-clock} time since an arbitrary, fixed point in 88 | the past (usually, the time since the program began running). 89 | 90 | {[ 91 | let benchmark () = 92 | let instances = Instance.[ monotonic_clock ] in 93 | let cfg = Benchmark.cfg ~limit:2000 ~stabilize:true 94 | ~quota:(Time.second 0.5) () in 95 | Benchmark.all cfg instances tests 96 | ]} 97 | 98 | The benchmark has many options and you should take a look at 99 | {!val:Benchmark.cfg}. They permit to refine the context of the execution. 100 | For instance, you can {i stabilize} the garbage-collector. 101 | 102 | The function gives you {i raw} results (see {!module:Measurement_raw}). You 103 | can manipulate it as is or analyze it to extract useful information. 104 | 105 | {3 Analyze results.} 106 | 107 | Finally, you probably want to know the time spent by our factorial 108 | functions! This result requires to analyze our metrics. Indeed, if you run 109 | one time [fact0] and record the monotonic clock, you will 110 | probably get a {i partial} result which fluctuated a lot per run: 111 | {[ 112 | $ cat >main.ml < let rec fact0 x = 114 | > if x = 0 then 1 115 | > else x * fact0 (x - 1) 116 | > 117 | > let () = 118 | > let t0 = Unix.gettimeofday () in 119 | > let _ = fact0 200 in 120 | > let t1 = Unix.gettimeofday () in 121 | > Format.printf "%f\n%!" (t1 -. t0) 122 | > EOF 123 | $ ocamlfind opt -package unix -linkpkg main.ml 124 | $ ./a.out 125 | 0.000001 126 | $ ./a.out 127 | 0.000003 128 | ]} 129 | 130 | This is why Bechamel exists. From metrics, it can estimate the time spent 131 | by our test. There are 2 methods to do that: 132 | - calculate the Ordinary Least Square from metrics 133 | - calculate the RANdom Sample Consensus from metrics 134 | 135 | In our cases, we will use {!val:Analyze.ols}: 136 | {[ 137 | let analyze results = 138 | let ols = Analyze.ols ~bootstrap:0 ~r_square:true 139 | ~predictors:[| Measure.run |] in 140 | let results = Analyze.all ols Instance.monotonic_clock results in 141 | Analyze.merge ols [ Instance.monotonic_clock ] [ results ] 142 | ]} 143 | 144 | The main question behind this function is: I would like to compare what 145 | with what? By default, the benchmark iterates a {i certain} time on your 146 | function. For each iteration, it will execute {i run} time(s) your function 147 | and this number increases for each iteration: 148 | 149 | {v 150 | +-----+------+------------+ 151 | | run | time |call of [fn]| 152 | +-----+------+------------+ 153 | | 1 | 19 | 1 | 154 | | 2 | 25 | 2 | 155 | | 3 | 37 | 3 | 156 | | 4 | 47 | 4 | 157 | | 5 | 56 | 5 | 158 | +-----+------+------------+ 159 | v} 160 | 161 | From these metrics, we can fit a curve: [a * x + b = y] where, from our 162 | code, [x = Measure.run] and [y = Instance.monotonic_clock]. OLS and 163 | RANSAC are algorithms which try to fit this curve. Then, [a] will become 164 | the time spent by our function for [x = 1] and this is what we want: 165 | 166 | > How much time do I spend if I call my function {b one time}? 167 | 168 | Some details differ between OLS and RANSAC but the documentation can help 169 | you to determine which one you should take. 170 | 171 | {3 Show results.} 172 | 173 | Bechamel has many ways to show results, but the core still is agnostic 174 | to the system and does not need anything (like {!module:Unix}) to show 175 | results. However, the distribution comes with many possibilities: 176 | - A [notty] which shows your results in a terminal 177 | - An HTML + JavaScript which produces an [index.html] 178 | 179 | We will try to show the results {i via} our terminal, but the HTML + 180 | JavaScript support has the ability to show you more information (such as 181 | the curve for instance): 182 | {[ 183 | let () = Bechamel_notty.Unit.add 184 | Instance.monotonic_clock 185 | (Measure.unit Instance.monotonic_clock) 186 | 187 | let img (window, results) = 188 | Bechamel_notty.Multiple.image_of_ols_results ~rect:window 189 | ~predictor:Measure.run results 190 | 191 | open Notty_unix 192 | 193 | let () = 194 | let window = 195 | match winsize Unix.stdout with 196 | | Some (w, h) -> { Bechamel_notty.w; h } 197 | | None -> { Bechamel_notty.w= 80; h= 1; } in 198 | let results = benchmark () in 199 | let results = analyze results in 200 | img (window, results) |> eol |> output_image 201 | ]} 202 | 203 | You can compile (with [dune]) the program with: 204 | {[ 205 | $ cat >dune < (executable 207 | > (name example) 208 | > (modules example) 209 | > (libraries bechamel notty.unix bechamel-notty)) 210 | > EOF 211 | $ dune build ./example.exe 212 | $ dune exec ./example.exe 213 | ╭────────────────────────┬───────────────────────────╮ 214 | │name │ monotonic-clock │ 215 | ├────────────────────────┼───────────────────────────┤ 216 | │ factorial functional │ 643.0477 ns/run│ 217 | │ factorial imperative │ 129.1994 ns/run│ 218 | ╰────────────────────────┴───────────────────────────╯ 219 | ]} 220 | *) 221 | 222 | module S = S 223 | module Measure = Measure 224 | module Benchmark = Benchmark 225 | module Test = Test 226 | module Staged = Staged 227 | module Measurement_raw = Measurement_raw 228 | module Linear_algebra = Linear_algebra 229 | module Analyze = Analyze 230 | module Toolkit = Toolkit 231 | module Time = Time 232 | -------------------------------------------------------------------------------- /lib/benchmark.ml: -------------------------------------------------------------------------------- 1 | open Unsafe 2 | 3 | let always x _ = x 4 | 5 | let runnable_with_resources f vs i = 6 | for _ = 1 to i do 7 | ignore (Sys.opaque_identity (f (unsafe_array_get vs (i - 1)))) 8 | done 9 | [@@inline] 10 | 11 | let runnable_with_resource f v i = 12 | for _ = 1 to i do 13 | ignore (Sys.opaque_identity (f v)) 14 | done 15 | [@@inline] 16 | 17 | let runnable : 18 | type a v t. (a, v, t) Test.kind -> (a -> 'b) -> a -> a array -> int -> unit 19 | = 20 | fun k f v vs i -> 21 | match k with 22 | | Test.Uniq -> runnable_with_resource f v i 23 | | Test.Multiple -> runnable_with_resources f vs i 24 | [@@inline] 25 | 26 | let record measure = 27 | let (Measure.V (m, (module M))) = Measure.prj measure in 28 | fun () -> M.get m 29 | 30 | let stabilize_garbage_collector () = 31 | let rec go fail last_heap_live_words = 32 | if fail <= 0 then 33 | failwith "Unable to stabilize the number of live words in the major heap"; 34 | Gc.compact (); 35 | let stat = Gc.stat () in 36 | if stat.Gc.live_words <> last_heap_live_words then 37 | go (fail - 1) stat.Gc.live_words 38 | in 39 | go 10 0 40 | 41 | let exceeded_allowed_time allowed_time_span t = 42 | let t' = Monotonic_clock.now () in 43 | let t' = Time.of_uint64_ns t' in 44 | Time.span_compare (Time.span t t') allowed_time_span > 0 45 | 46 | type sampling = [ `Linear of int | `Geometric of float ] 47 | 48 | type stats = 49 | { start : int 50 | ; sampling : sampling 51 | ; stabilize : bool 52 | ; quota : Time.span 53 | ; limit : int 54 | ; instances : string list 55 | ; samples : int 56 | ; time : Time.span 57 | } 58 | 59 | type configuration = 60 | { start : int 61 | ; sampling : sampling 62 | ; stabilize : bool 63 | ; compaction : bool 64 | ; quota : Time.span 65 | ; kde : int option 66 | ; limit : int 67 | } 68 | 69 | type t = 70 | { stats : stats 71 | ; lr : Measurement_raw.t array 72 | ; kde : Measurement_raw.t array option 73 | } 74 | 75 | let cfg ?(limit = 3000) ?(quota = Time.second 1.) ?(kde = None) 76 | ?(sampling = `Geometric 1.01) ?(stabilize = true) ?(compaction = true) 77 | ?(start = 1) () : configuration = 78 | { limit; start; quota; sampling; kde; stabilize; compaction } 79 | 80 | let run cfg measures test : t = 81 | let idx = ref 0 in 82 | let run = ref cfg.start in 83 | let (Test.V { fn; kind; allocate; free }) = Test.Elt.fn test in 84 | let fn = fn `Init in 85 | (* allocate0 always defined, allocate1 may not be *) 86 | let (allocate0 : unit -> _), free0, (allocate1 : int -> _), free1 = 87 | match kind with 88 | | Test.Uniq -> 89 | ( (fun () -> Test.Uniq.prj (allocate ())) 90 | , (fun v -> free (Test.Uniq.inj v)) 91 | , always [||] 92 | , ignore ) 93 | | Test.Multiple -> 94 | ( (fun () -> unsafe_array_get (Test.Multiple.prj (allocate 1)) 0) 95 | , (fun v -> free (Test.Multiple.inj [| v |])) 96 | , (fun n -> Test.Multiple.prj (allocate n)) 97 | , fun v -> free (Test.Multiple.inj v) ) 98 | in 99 | let resource = allocate0 () in 100 | 101 | let measures = Array.of_list measures in 102 | let length = Array.length measures in 103 | let m = Array.create_float (cfg.limit * (length + 1)) in 104 | let m0 = Array.create_float length in 105 | let m1 = Array.create_float length in 106 | 107 | Array.iter Measure.load measures; 108 | let records = Array.init length (fun i -> record measures.(i)) in 109 | 110 | stabilize_garbage_collector (); 111 | 112 | let init_time = Time.of_uint64_ns (Monotonic_clock.now ()) in 113 | 114 | let total_run = ref 0 in 115 | 116 | while (not (exceeded_allowed_time cfg.quota init_time)) && !idx < cfg.limit do 117 | let current_run = !run in 118 | let current_idx = !idx in 119 | let resources = allocate1 !run in 120 | 121 | if cfg.stabilize then stabilize_garbage_collector (); 122 | 123 | if not cfg.compaction then 124 | Gc.set { (Gc.get ()) with Gc.max_overhead = 1_000_000 }; 125 | 126 | (* The returned measurements are a difference betwen a measurement [m0] 127 | taken before running the tested function [fn] and a measurement taken 128 | after [m1]. *) 129 | for i = 0 to length - 1 do 130 | m0.(i) <- records.(i) () 131 | done; 132 | 133 | runnable kind fn resource resources current_run; 134 | 135 | for i = 0 to length - 1 do 136 | m1.(i) <- records.(i) () 137 | done; 138 | 139 | free1 resources; 140 | 141 | m.(current_idx * (length + 1)) <- float_of_int current_run; 142 | for i = 1 to length do 143 | m.((current_idx * (length + 1)) + i) <- m1.(i - 1) -. m0.(i - 1) 144 | done; 145 | 146 | let next = 147 | match cfg.sampling with 148 | | `Linear k -> current_run + k 149 | | `Geometric scale -> 150 | let next_geometric = 151 | int_of_float (float_of_int current_run *. scale) 152 | in 153 | if next_geometric >= current_run + 1 then next_geometric 154 | else current_run + 1 155 | in 156 | 157 | total_run := !total_run + !run; 158 | run := next; 159 | incr idx 160 | done; 161 | 162 | let samples = !idx in 163 | let labels = Array.map Measure.label measures in 164 | 165 | let measurement_raw idx = 166 | let run = m.(idx * (length + 1)) in 167 | let measures = Array.sub m ((idx * (length + 1)) + 1) length in 168 | Measurement_raw.make ~measures ~labels run 169 | in 170 | let lr_raw = Array.init samples measurement_raw in 171 | 172 | (* Additional measurement for kde, if requested. Note that if these 173 | measurements go through, the time limit is twice the one without it.*) 174 | let kde_raw = 175 | match cfg.kde with 176 | | None -> None 177 | | Some kde_limit -> 178 | let mkde = Array.create_float (kde_limit * length) in 179 | let init_time' = Time.of_uint64_ns (Monotonic_clock.now ()) in 180 | let current_idx = ref 0 in 181 | while 182 | (not (exceeded_allowed_time cfg.quota init_time')) 183 | && !current_idx < kde_limit 184 | do 185 | let resource = allocate0 () in 186 | 187 | for i = 0 to length - 1 do 188 | m0.(i) <- records.(i) () 189 | done; 190 | 191 | ignore (Sys.opaque_identity (fn resource)); 192 | 193 | for i = 0 to length - 1 do 194 | m1.(i) <- records.(i) () 195 | done; 196 | 197 | free0 resource; 198 | 199 | for i = 0 to length - 1 do 200 | mkde.((!current_idx * length) + i) <- m1.(i) -. m0.(i) 201 | done; 202 | 203 | incr current_idx 204 | done; 205 | let kde_raw idx = 206 | let measures = Array.sub mkde (idx * length) length in 207 | Measurement_raw.make ~measures ~labels 1. 208 | in 209 | 210 | Some (Array.init !current_idx kde_raw) 211 | in 212 | 213 | let final_time = Time.of_uint64_ns (Monotonic_clock.now ()) in 214 | free0 resource; 215 | Array.iter Measure.unload measures; 216 | 217 | let stats = 218 | { start = cfg.start 219 | ; sampling = cfg.sampling 220 | ; stabilize = cfg.stabilize 221 | ; quota = cfg.quota 222 | ; limit = cfg.limit 223 | ; instances = Array.to_list labels 224 | ; samples 225 | ; time = Time.span init_time final_time 226 | } 227 | in 228 | 229 | { stats; lr = lr_raw; kde = kde_raw } 230 | 231 | let all cfg measures test = 232 | let tests = Array.of_list (Test.elements test) in 233 | let tbl = Hashtbl.create (Array.length tests) in 234 | 235 | for i = 0 to Array.length tests - 1 do 236 | let results = run cfg measures tests.(i) in 237 | Hashtbl.add tbl (Test.Elt.name tests.(i)) results 238 | done; 239 | tbl 240 | -------------------------------------------------------------------------------- /lib/benchmark.mli: -------------------------------------------------------------------------------- 1 | type sampling = [ `Linear of int | `Geometric of float ] 2 | 3 | type configuration 4 | (** Type of configuration. *) 5 | 6 | val cfg : 7 | ?limit:int 8 | -> ?quota:Time.span 9 | -> ?kde:int option 10 | -> ?sampling:sampling 11 | -> ?stabilize:bool 12 | -> ?compaction:bool 13 | -> ?start:int 14 | -> unit 15 | -> configuration 16 | (** [cfg ()] returns a configuration needed to run a {i benchmark}. It accepts 17 | several optional arguments: 18 | 19 | - [limit] is the maximum of [samples] allowed (default to [3000]). 20 | - [quota] is the maximum of time allowed (default to 1 second). 21 | - [kde] : optional number of additional measurements taken to enable kde and 22 | histogram js display (default None). If [kde] = Some _, the same time 23 | limit [quota] is applied, meaning the actual time limit for all the 24 | benchmarks is actually 2x[quota]. 25 | - [sampling] is the way to grow the [run] metric (default to 26 | [`Geometric 1.0.1]). 27 | - [stabilize] allows the benchmark to {i stabilize} the garbage collector 28 | before each run (default to [true]). 29 | - [start] is the first value of the [run] metric (default to [1]). *) 30 | 31 | type stats = 32 | { start : int 33 | ; sampling : sampling 34 | ; stabilize : bool 35 | ; quota : Time.span 36 | ; limit : int 37 | ; instances : string list 38 | ; samples : int 39 | ; time : Time.span 40 | } 41 | (** Type of statistics of one benchmark. It contains which {!configuration} the 42 | benchmark used and: 43 | 44 | - How long was the benchmark, see [time]. 45 | - How many runs the benchmark did, see [samples]. 46 | 47 | It's useful to introspect which limit was reached (the time or the limit of 48 | runs). *) 49 | 50 | type t = 51 | { stats : stats 52 | ; lr : Measurement_raw.t array 53 | ; kde : Measurement_raw.t array option 54 | } 55 | (** Results of one benchmark: 56 | 57 | - [stats] contains all the information about the benchmarks as described 58 | above 59 | - [lr] contains the measurements necessary for oLS and ransac analysis. 60 | - [kde] optionally contains more measurements to enable the display of 61 | density function (KDE or histogram) with the js display. *) 62 | 63 | val run : configuration -> Measure.witness list -> Test.Elt.t -> t 64 | (** [run cfg measures test] returns samples of [measures] according to the given 65 | configuration [cfg]. It returns statistics of the benchmark too. *) 66 | 67 | val all : 68 | configuration -> Measure.witness list -> Test.t -> (string, t) Hashtbl.t 69 | (** [all cfg measures tests] calls {!run} for each element of [tests] (see 70 | {!Test.elements}). *) 71 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bechamel) 3 | (public_name bechamel) 4 | (libraries fmt monotonic_clock)) 5 | -------------------------------------------------------------------------------- /lib/ext.ml: -------------------------------------------------------------------------------- 1 | (* (c) Frédéric Bour *) 2 | 3 | module Make (Functor : S.FUNCTOR) = struct 4 | type t = .. 5 | 6 | module type Extension = sig 7 | type x 8 | type t += T of x 9 | end 10 | 11 | type 'a extension = (module Extension with type x = 'a) 12 | type instance = V : 'a * 'a Functor.t -> instance 13 | 14 | let handlers = Hashtbl.create 16 15 | 16 | module Injection (X : sig 17 | type t 18 | 19 | val instance : t Functor.t 20 | end) : Extension with type x = X.t = struct 21 | type x = X.t 22 | type t += T of x 23 | 24 | let () = 25 | let instance = X.instance in 26 | Hashtbl.add handlers 27 | (Stdlib.Obj.Extension_constructor.id [%extension_constructor T] 28 | [@warning "-3"]) 29 | (function T x -> V (x, instance) | _ -> raise Not_found) 30 | end 31 | 32 | let inj (type a) (f : a Functor.t) : a extension = 33 | (module Injection (struct 34 | type t = a 35 | 36 | let instance = f 37 | end)) 38 | 39 | let rec iter t lst = 40 | let[@warning "-8"] (f :: r) = lst in 41 | try f t with _ -> (iter [@tailcall]) t r 42 | 43 | let prj (t : t) = 44 | let uid = 45 | Stdlib.Obj.Extension_constructor.((id (of_val t) [@warning "-3"])) 46 | in 47 | iter t (Hashtbl.find_all handlers uid) 48 | end 49 | -------------------------------------------------------------------------------- /lib/ext.mli: -------------------------------------------------------------------------------- 1 | module Make (Functor : S.FUNCTOR) : sig 2 | (* XXX(dinosaure): only on [>= 4.06.0] *) 3 | type t = private .. 4 | 5 | module type Extension = sig 6 | type x 7 | type t += T of x 8 | end 9 | 10 | type 'a extension = (module Extension with type x = 'a) 11 | type instance = V : 'a * 'a Functor.t -> instance 12 | 13 | module Injection (X : sig 14 | type t 15 | 16 | val instance : t Functor.t 17 | end) : Extension with type x = X.t 18 | 19 | val inj : 'a Functor.t -> 'a extension 20 | val prj : t -> instance 21 | end 22 | -------------------------------------------------------------------------------- /lib/js/bechamel_js.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | type t = 4 | { x_label : string 5 | ; y_label : string 6 | ; series : (string, Desc.t * Dataset.t * KDE.t option * OLS.t) Hashtbl.t 7 | } 8 | 9 | let label_witness : string Json_encoding.encoding = Json_encoding.string 10 | 11 | let witness ~compare : t Json_encoding.encoding = 12 | let open Json_encoding in 13 | let x_label = req "xLabel" label_witness in 14 | let y_label = req "yLabel" label_witness in 15 | let serie = 16 | let name = req "name" string in 17 | let dataset = req "dataset" Dataset.witness in 18 | let kde = opt "kde" KDE.witness in 19 | let ols = req "result" OLS.witness in 20 | let desc = req "description" Desc.witness in 21 | obj5 name desc dataset kde ols 22 | in 23 | let series = req "series" (list serie) in 24 | conv 25 | (fun t -> 26 | let l = 27 | Hashtbl.fold 28 | (fun k (desc, dataset, kde, ols) a -> 29 | (k, desc, dataset, kde, ols) :: a) 30 | t.series [] 31 | in 32 | ( t.x_label 33 | , t.y_label 34 | , List.sort (fun (k0, _, _, _, _) (k1, _, _, _, _) -> compare k0 k1) l )) 35 | (fun (x_label, y_label, l) -> 36 | let series = Hashtbl.create (List.length l) in 37 | List.iter 38 | (fun (k, desc, dataset, kde, ols) -> 39 | Hashtbl.add series k (desc, dataset, kde, ols)) 40 | l; 41 | { x_label; y_label; series }) 42 | (obj3 x_label y_label series) 43 | 44 | let of_ols_results ~x_label ~y_label ols_results raws = 45 | if not (Hashtbl.mem ols_results y_label) then 46 | Rresult.R.error_msgf "y:%s does not exist in OLS results" y_label 47 | else 48 | let results = Hashtbl.find ols_results y_label in 49 | let series = Hashtbl.create (Hashtbl.length results) in 50 | 51 | try 52 | Hashtbl.iter 53 | (fun serie ols -> 54 | let open Rresult.R in 55 | let Benchmark.{ stats; lr = raws; kde = raws_kde } = 56 | Hashtbl.find raws serie 57 | in 58 | let res = 59 | Dataset.of_measurement_raws ~x_label ~y_label raws >>= fun raws -> 60 | KDE.of_kde_raws ~label:y_label raws_kde >>= fun raws_kde -> 61 | OLS.of_ols_result ~x_label ~y_label ols >>| fun ols -> 62 | (stats, raws, raws_kde, ols) 63 | in 64 | match res with 65 | | Ok (stats, raws, raws_kde, ols) -> 66 | Hashtbl.add series serie (stats, raws, raws_kde, ols) 67 | | Error _ as err -> Rresult.R.error_msg_to_invalid_arg err) 68 | results; 69 | Ok { x_label; y_label; series } 70 | with Invalid_argument err -> Rresult.R.error_msg err 71 | 72 | type value = [ `Null | `Bool of bool | `String of string | `Float of float ] 73 | 74 | let flat json : Jsonm.lexeme list = 75 | let rec arr acc k = function 76 | | [] -> k (List.rev (`Ae :: acc)) 77 | | (#value as x) :: r -> arr (x :: acc) k r 78 | | `A l :: r -> arr [ `As ] (fun l -> arr (List.rev_append l acc) k r) l 79 | | `O l :: r -> obj [ `Os ] (fun l -> arr (List.rev_append l acc) k r) l 80 | and obj acc k = function 81 | | [] -> k (List.rev (`Oe :: acc)) 82 | | (n, x) :: r -> 83 | base (fun v -> obj (List.rev_append v (`Name n :: acc)) k r) x 84 | and base k = function 85 | | `A l -> arr [ `As ] k l 86 | | `O l -> obj [ `Os ] k l 87 | | #value as x -> k [ x ] 88 | in 89 | 90 | base (fun l -> l) json 91 | 92 | type buffer = bytes * int * int 93 | type transmit = buffer -> buffer 94 | type 'a or_error = ('a, [ `Msg of string ]) result 95 | 96 | type 'a dst = 97 | | Manual : transmit -> buffer dst 98 | | Buffer : Buffer.t -> (Buffer.t -> unit or_error) dst 99 | | Channel : out_channel -> (out_channel -> unit or_error) dst 100 | 101 | let manual transmit = Manual transmit 102 | 103 | let buffer ~chunk = 104 | let buffer = Buffer.create chunk in 105 | Buffer buffer 106 | 107 | let channel filename = 108 | let oc = open_out filename in 109 | Channel oc 110 | 111 | type raws = (string, Benchmark.t) Hashtbl.t 112 | type ols_results = (string, (string, Analyze.OLS.t) Hashtbl.t) Hashtbl.t 113 | 114 | let emit : 115 | type a. 116 | dst:a dst 117 | -> a 118 | -> ?compare:(string -> string -> int) 119 | -> x_label:string 120 | -> y_label:string 121 | -> ols_results * raws 122 | -> unit or_error = 123 | fun ~dst a ?compare:(compare_label = String.compare) ~x_label ~y_label 124 | (ols_results, raw_results) -> 125 | let to_dst : type a. a dst -> Jsonm.dst = function 126 | | Manual _ -> `Manual 127 | | Buffer buffer -> `Buffer buffer 128 | | Channel oc -> `Channel oc 129 | in 130 | let encoder = Jsonm.encoder ~minify:true (to_dst dst) in 131 | let buf, off, len = 132 | match dst with 133 | | Manual _ -> 134 | let buf, off, len = a in 135 | (ref buf, ref off, ref len) 136 | | Buffer _ -> (ref Bytes.empty, ref 0, ref 0) 137 | | Channel _ -> (ref Bytes.empty, ref 0, ref 0) 138 | in 139 | let go json = 140 | let flat = flat json in 141 | 142 | List.iter 143 | (fun lexeme -> 144 | match Jsonm.encode encoder (`Lexeme lexeme) with 145 | | `Ok -> () 146 | | `Partial -> ( 147 | match dst with 148 | | Manual transmit -> 149 | let buf', off', len' = 150 | transmit (!buf, !off, !len - Jsonm.Manual.dst_rem encoder) 151 | in 152 | buf := buf'; 153 | off := off'; 154 | len := len'; 155 | Jsonm.Manual.dst encoder buf' off' len' 156 | | Buffer _ -> () 157 | | Channel _ -> ())) 158 | flat; 159 | 160 | let rec go : type a. a dst -> a -> unit or_error = 161 | fun dst a -> 162 | match (Jsonm.encode encoder `End, dst) with 163 | | `Ok, Buffer buf -> a buf 164 | | `Ok, Channel oc -> a oc 165 | | `Ok, Manual _ -> Ok () 166 | | `Partial, Manual transmit -> 167 | let buf', off', len' = 168 | transmit (!buf, !off, !len - Jsonm.Manual.dst_rem encoder) 169 | in 170 | buf := buf'; 171 | off := off'; 172 | len := len'; 173 | Jsonm.Manual.dst encoder buf' off' len'; 174 | go dst a 175 | (* XXX(dinosaure): [Jsonm] explains that these cases never occur. *) 176 | | `Partial, Buffer _ -> assert false 177 | | `Partial, Channel _ -> assert false 178 | in 179 | 180 | go dst a 181 | in 182 | 183 | let open Rresult.R in 184 | of_ols_results ~x_label ~y_label ols_results raw_results 185 | >>| Json_encoding.construct (witness ~compare:compare_label) 186 | >>= go 187 | -------------------------------------------------------------------------------- /lib/js/dataset.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | type t = Point.t list 4 | 5 | let witness : t Json_encoding.encoding = 6 | let open Json_encoding in 7 | list Point.witness 8 | 9 | let of_measurement_raws ~x_label ~y_label raws = 10 | if not (Array.for_all (Measurement_raw.exists ~label:x_label) raws) then 11 | Fmt.invalid_arg "x-label:%s does not exist in measurement raws" x_label; 12 | if not (Array.for_all (Measurement_raw.exists ~label:y_label) raws) then 13 | Fmt.invalid_arg "y-label:%s does not exist in measurement raws" y_label; 14 | 15 | let has_x_label = 16 | Array.for_all (Measurement_raw.exists ~label:x_label) raws 17 | in 18 | let has_y_label = 19 | Array.for_all (Measurement_raw.exists ~label:y_label) raws 20 | in 21 | 22 | if (not has_x_label) || not has_y_label then 23 | Rresult.R.error_msgf "x:%s or y:%s does not exist in dataset." x_label 24 | y_label 25 | else 26 | let to_point t = 27 | let x = Measurement_raw.get ~label:x_label t in 28 | let y = Measurement_raw.get ~label:y_label t in 29 | Point.make ~x ~y 30 | in 31 | let data = Array.map to_point raws in 32 | Ok (Array.to_list data) 33 | -------------------------------------------------------------------------------- /lib/js/desc.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | type t = Benchmark.stats 4 | 5 | let sampling_witness : Benchmark.sampling Json_encoding.encoding = 6 | let open Json_encoding in 7 | let a = 8 | case float 9 | (function `Geometric x -> Some x | _ -> None) 10 | (fun x -> `Geometric x) 11 | in 12 | let b = 13 | case int (function `Linear x -> Some x | _ -> None) (fun x -> `Linear x) 14 | in 15 | union [ a; b ] 16 | 17 | let mtime_witness : Time.span Json_encoding.encoding = 18 | let open Json_encoding in 19 | conv Time.span_to_uint64_ns Time.span_of_uint64_ns int53 20 | 21 | (* XXX(dinosaure): fix [int53]. *) 22 | 23 | let label_witness : string Json_encoding.encoding = Json_encoding.string 24 | 25 | let witness : t Json_encoding.encoding = 26 | let open Json_encoding in 27 | let start = req "start" int in 28 | let sampling = req "sampling" sampling_witness in 29 | let stabilize = req "stabilize" bool in 30 | let quota = req "quota" mtime_witness in 31 | let limit = req "limit" int in 32 | let instances = req "instances" (list label_witness) in 33 | let samples = req "samples" int in 34 | let time = req "time" mtime_witness in 35 | conv 36 | (fun (t : t) -> 37 | let open Benchmark in 38 | ( t.start 39 | , t.sampling 40 | , t.stabilize 41 | , t.quota 42 | , t.limit 43 | , t.instances 44 | , t.samples 45 | , t.time )) 46 | (fun (start, sampling, stabilize, quota, limit, instances, samples, time) -> 47 | let open Benchmark in 48 | { start; sampling; stabilize; quota; limit; instances; samples; time }) 49 | (obj8 start sampling stabilize quota limit instances samples time) 50 | -------------------------------------------------------------------------------- /lib/js/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bechamel_js) 3 | (public_name bechamel-js) 4 | (libraries bechamel fmt rresult result json-data-encoding jsonm)) 5 | -------------------------------------------------------------------------------- /lib/js/kDE.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | type t = float list 4 | 5 | let witness : t Json_encoding.encoding = 6 | let open Json_encoding in 7 | list float 8 | 9 | let of_kde_raws ~label kde_raws = 10 | match kde_raws with 11 | | None -> Ok None 12 | | Some kde_raws -> 13 | let has_label = Array.for_all (Measurement_raw.exists ~label) kde_raws in 14 | 15 | if not has_label then 16 | Rresult.R.error_msgf "%s does not exist in kde data." label 17 | else 18 | let to_float t = Measurement_raw.get ~label t in 19 | let data = Array.map to_float kde_raws in 20 | Ok (Some (Array.to_list data)) 21 | -------------------------------------------------------------------------------- /lib/js/oLS.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | 3 | type t = { estimate : float; r_square : float option; ci95 : ci95 option } 4 | and ci95 = { r : float; l : float } 5 | 6 | let ci95_witness : ci95 Json_encoding.encoding = 7 | let open Json_encoding in 8 | let l = req "low" float in 9 | let r = req "high" float in 10 | conv (fun t -> (t.l, t.r)) (fun (l, r) -> { l; r }) (obj2 l r) 11 | 12 | let witness : t Json_encoding.encoding = 13 | let open Json_encoding in 14 | let estimate = req "estimate" float in 15 | let r_square = opt "r_square" float in 16 | let ci95 = opt "ci95" ci95_witness in 17 | conv 18 | (fun t -> (t.estimate, t.r_square, t.ci95)) 19 | (fun (estimate, r_square, ci95) -> { estimate; r_square; ci95 }) 20 | (obj3 estimate r_square ci95) 21 | 22 | let of_ols_result ~x_label ~y_label ols = 23 | let has_y_label = String.equal (Analyze.OLS.responder ols) y_label in 24 | let has_x_label = 25 | List.exists (String.equal x_label) (Analyze.OLS.predictors ols) 26 | in 27 | 28 | if (not has_y_label) || not has_x_label then 29 | Rresult.R.error_msgf "x:%s or y:%s does not exist in result: @[%a@]" 30 | x_label y_label Analyze.OLS.pp ols 31 | else 32 | match Analyze.OLS.estimates ols with 33 | | None -> 34 | Rresult.R.error_msgf "Result is errored: @[%a@]" Analyze.OLS.pp ols 35 | | Some estimates -> 36 | let predictors = Analyze.OLS.predictors ols in 37 | let estimate = 38 | let exception Found in 39 | let estimate = ref None in 40 | try 41 | List.iter2 42 | (fun predictor e -> 43 | if String.equal x_label predictor then ( 44 | estimate := Some e; 45 | raise Found)) 46 | predictors estimates; 47 | assert false 48 | with Found -> ( 49 | match !estimate with 50 | | Some estimate -> estimate 51 | | None -> assert false) 52 | in 53 | Ok { estimate; r_square = Analyze.OLS.r_square ols; ci95 = None } 54 | -------------------------------------------------------------------------------- /lib/js/point.ml: -------------------------------------------------------------------------------- 1 | type t = { x : float; y : float } 2 | 3 | let make ~x ~y = { x; y } 4 | 5 | let witness = 6 | let open Json_encoding in 7 | let x = req "x" float in 8 | let y = req "y" float in 9 | conv (fun { x; y } -> (x, y)) (fun (x, y) -> { x; y }) (obj2 x y) 10 | -------------------------------------------------------------------------------- /lib/linear_algebra.ml: -------------------------------------------------------------------------------- 1 | (* Code under Apache License 2.0 but without owner. 2 | * I believe owner is Jane Street Group, LLC 3 | *) 4 | 5 | let error_msgf fmt = Format.kasprintf (fun err -> Error (`Msg err)) fmt 6 | 7 | let col_norm a column = 8 | let acc = ref 0. in 9 | for i = 0 to Array.length a - 1 do 10 | let entry = a.(i).(column) in 11 | acc := !acc +. (entry *. entry) 12 | done; 13 | sqrt !acc 14 | 15 | let col_inner_prod t j1 j2 = 16 | let acc = ref 0. in 17 | for i = 0 to Array.length t - 1 do 18 | acc := !acc +. (t.(i).(j1) *. t.(i).(j2)) 19 | done; 20 | !acc 21 | 22 | let qr_in_place a = 23 | let m = Array.length a in 24 | if m = 0 then ([||], [||]) 25 | else 26 | let n = Array.length a.(0) in 27 | let r = Array.make_matrix n n 0. in 28 | for j = 0 to n - 1 do 29 | let alpha = col_norm a j in 30 | r.(j).(j) <- alpha; 31 | let one_over_alpha = 1. /. alpha in 32 | for i = 0 to m - 1 do 33 | a.(i).(j) <- a.(i).(j) *. one_over_alpha 34 | done; 35 | for j2 = j + 1 to n - 1 do 36 | let c = col_inner_prod a j j2 in 37 | r.(j).(j2) <- c; 38 | for i = 0 to m - 1 do 39 | a.(i).(j2) <- a.(i).(j2) -. (c *. a.(i).(j)) 40 | done 41 | done 42 | done; 43 | (a, r) 44 | 45 | let qr ?(in_place = false) a = 46 | let a = if in_place then a else Array.map Array.copy a in 47 | qr_in_place a 48 | 49 | let mul_mv ?(trans = false) a x = 50 | let rows = Array.length a in 51 | if rows = 0 then [||] 52 | else 53 | let cols = Array.length a.(0) in 54 | let m, n, get = 55 | if trans then 56 | let get i j = a.(j).(i) in 57 | (cols, rows, get) 58 | else 59 | let get i j = a.(i).(j) in 60 | (rows, cols, get) 61 | in 62 | if n <> Array.length x then failwith "Dimension mismatch"; 63 | let result = Array.make m 0. in 64 | for i = 0 to m - 1 do 65 | let v, _ = 66 | Array.fold_left 67 | (fun (acc, j) x -> (acc +. (get i j *. x), succ j)) 68 | (0., 0) x 69 | in 70 | result.(i) <- v 71 | done; 72 | result 73 | 74 | let is_nan v = match classify_float v with FP_nan -> true | _ -> false 75 | 76 | let triu_solve r b = 77 | let m = Array.length b in 78 | if m <> Array.length r then 79 | error_msgf 80 | "triu_solve R b requires R to be square with same number of rows as b" 81 | else if m = 0 then Ok [||] 82 | else if m <> Array.length r.(0) then 83 | error_msgf "triu_solve R b requires R to be a square" 84 | else 85 | let sol = Array.copy b in 86 | for i = m - 1 downto 0 do 87 | sol.(i) <- sol.(i) /. r.(i).(i); 88 | for j = 0 to i - 1 do 89 | sol.(j) <- sol.(j) -. (r.(j).(i) *. sol.(i)) 90 | done 91 | done; 92 | if Array.exists is_nan sol then error_msgf "triu_solve detected NaN result" 93 | else Ok sol 94 | 95 | let ols ?(in_place = false) a b = 96 | let q, r = qr ~in_place a in 97 | triu_solve r (mul_mv ~trans:true q b) 98 | -------------------------------------------------------------------------------- /lib/measure.ml: -------------------------------------------------------------------------------- 1 | type 'a impl = (module S.MEASURE with type witness = 'a) 2 | 3 | module Ext = Ext.Make (struct 4 | type 'a t = 'a impl 5 | end) 6 | 7 | type 'a measure = 'a Ext.extension 8 | type witness = Ext.t 9 | 10 | let register : type w. w impl -> w measure = 11 | fun (module M) -> 12 | (* if Hashtbl.mem labels (M.label ()) then Fmt.invalid_arg "Label %s already 13 | exist, find a new one." (M.label ()) ; *) 14 | Ext.inj (module M) 15 | 16 | let instance : type w. w impl -> w measure -> witness = 17 | fun (module M) x -> 18 | let module Ext = (val x) in 19 | Ext.T (M.make ()) 20 | 21 | let load : witness -> unit = 22 | fun v -> 23 | let (Ext.V (m, (module M))) = Ext.prj v in 24 | M.load m 25 | 26 | let unload : witness -> unit = 27 | fun v -> 28 | let (Ext.V (m, (module M))) = Ext.prj v in 29 | M.unload m 30 | 31 | let label : witness -> string = 32 | fun v -> 33 | let (Ext.V (m, (module M))) = Ext.prj v in 34 | M.label m 35 | 36 | let unit : witness -> string = 37 | fun v -> 38 | let (Ext.V (m, (module M))) = Ext.prj v in 39 | M.unit m 40 | 41 | type value = Ext.instance = V : 'w * 'w impl -> value 42 | 43 | let prj w = Ext.prj w 44 | let run = "run" 45 | -------------------------------------------------------------------------------- /lib/measure.mli: -------------------------------------------------------------------------------- 1 | type 'a impl = (module S.MEASURE with type witness = 'a) 2 | (** Type of module implementation to record a measure. *) 3 | 4 | type 'a measure 5 | (** Type of measure. ['a] represents the {i witness} to record the measure. *) 6 | 7 | type witness 8 | (** Abstract type of a {i witness} to be able to record a {!measure}. *) 9 | 10 | val register : 'w impl -> 'w measure 11 | (** [register (module Measure)] registers a implementation to record a specific 12 | measure. The implementation will be globally accessible. *) 13 | 14 | val instance : 'w impl -> 'w measure -> witness 15 | (** [instance (module Measure) measure] returns a value which is able to 16 | introspect a measure [measure]. *) 17 | 18 | val load : witness -> unit 19 | (** [load w] signals to the operating-system to allocate resources needed to 20 | record the underlying measure. *) 21 | 22 | val unload : witness -> unit 23 | (** [unload w] releases the operating-system's resources used record the underlying 24 | measure. *) 25 | 26 | val label : witness -> string 27 | (** [label w] is the name of the underlying measure represented by [w]. *) 28 | 29 | val unit : witness -> string 30 | 31 | type value = V : 'w * 'w impl -> value 32 | 33 | val prj : witness -> value 34 | val run : string 35 | -------------------------------------------------------------------------------- /lib/measurement_raw.ml: -------------------------------------------------------------------------------- 1 | type t = { run : float; measures : float array; labels : string array } 2 | 3 | let make ~measures ~labels run = 4 | if Array.length measures <> Array.length labels then 5 | invalid_arg "Measures and labels differ" 6 | else { run; measures; labels } 7 | 8 | exception Find 9 | 10 | let get_index ~label m = 11 | let i0 = ref 0 in 12 | try 13 | while !i0 < Array.length m.labels do 14 | if String.equal m.labels.(!i0) label then raise Find; 15 | incr i0 16 | done; 17 | raise Not_found 18 | with Find -> !i0 19 | 20 | let exists ~label m = 21 | if String.equal label Measure.run then true 22 | else 23 | let yes = ref false in 24 | for i = 0 to Array.length m.labels - 1 do 25 | if String.equal m.labels.(i) label then yes := true 26 | done; 27 | !yes 28 | 29 | let run t = t.run 30 | 31 | let get ~label m = 32 | if label = Measure.run then m.run 33 | else 34 | let i = get_index ~label m in 35 | m.measures.(i) 36 | 37 | let pp ppf x = 38 | Fmt.pf ppf "{ @[run = %f;@ " x.run; 39 | for i = 0 to Array.length x.labels - 1 do 40 | Fmt.pf ppf "%s = %f;@ " x.labels.(i) x.measures.(i) 41 | done; 42 | Fmt.pf ppf "@] }" 43 | -------------------------------------------------------------------------------- /lib/measurement_raw.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** Type of samples. *) 3 | 4 | val make : measures:float array -> labels:string array -> float -> t 5 | (** [make ~measures ~labels run] is samples of one record of [run] runs. 6 | [labels.(i)] is associated to [measures.(i)]. *) 7 | 8 | val run : t -> float 9 | (** [run t] is the number of runs of [t]. *) 10 | 11 | val get_index : label:string -> t -> int 12 | (** [get_index ~label t] is the index of the measure identified by [label]. *) 13 | 14 | val get : label:string -> t -> float 15 | (** [get ~label t] is the recorded measure [label] into [t]. *) 16 | 17 | val pp : t Fmt.t 18 | (** Pretty-printer of {!t}. *) 19 | 20 | val exists : label:string -> t -> bool 21 | (** [exists ~label t] returns [true] if the measure [label] exists into [t]. 22 | Otherwise, it returns [false]. *) 23 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_linux.ml: -------------------------------------------------------------------------------- 1 | external clock_linux_get_time : unit -> (int64[@unboxed]) 2 | = "clock_linux_get_time_bytecode" "clock_linux_get_time_native" 3 | [@@noalloc] 4 | 5 | let now () = clock_linux_get_time () 6 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_linux_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | 11 | #ifndef __unused 12 | #define __unused(x) x __attribute((unused)) 13 | #endif 14 | #define __unit() value __unused(unit) 15 | 16 | uint64_t 17 | clock_linux_get_time_native(__unit ()) 18 | { 19 | struct timespec ts; 20 | 21 | clock_gettime(CLOCK_MONOTONIC, &ts); 22 | 23 | return ((uint64_t) ts.tv_sec 24 | * (uint64_t) 1000000000LL 25 | + (uint64_t) ts.tv_nsec); 26 | } 27 | 28 | CAMLprim value 29 | clock_linux_get_time_bytecode(__unit ()) 30 | { 31 | struct timespec ts; 32 | 33 | clock_gettime(CLOCK_MONOTONIC, &ts); 34 | 35 | return caml_copy_int64((uint64_t) ts.tv_sec 36 | * (uint64_t) 1000000000LL 37 | + (uint64_t) ts.tv_nsec); 38 | } 39 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_mach.ml: -------------------------------------------------------------------------------- 1 | external clock_mach_get_time : unit -> int64 = "clock_mach_get_time" 2 | external clock_mach_init : unit -> unit = "clock_mach_init" 3 | 4 | let () = clock_mach_init () 5 | let now () = clock_mach_get_time () 6 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_mach_stubs.c: -------------------------------------------------------------------------------- 1 | #ifdef __MACH__ 2 | #include 3 | #include 4 | #include 5 | #endif 6 | 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | // (c) Daniel Bünzli 13 | 14 | static mach_timebase_info_data_t s = { 0 }; 15 | 16 | CAMLprim value 17 | clock_mach_init(value vunit) 18 | { 19 | if (mach_timebase_info (&s) != KERN_SUCCESS) 20 | caml_raise_sys_error (caml_copy_string("bechamel.clock: mach_timebase_info () failed")); 21 | if (s.denom == 0) 22 | caml_raise_sys_error (caml_copy_string("bechamel.clock: mach_timebase_info_data.denom is 0")); 23 | 24 | return Val_unit; 25 | } 26 | 27 | CAMLprim value 28 | clock_mach_get_time(value vunit) 29 | { 30 | uint64_t now; 31 | 32 | now = mach_absolute_time(); 33 | 34 | return caml_copy_int64(now * s.numer / s.denom); 35 | } 36 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_windows.ml: -------------------------------------------------------------------------------- 1 | external clock_windows_get_time : unit -> int64 = "clock_windows_get_time" 2 | external clock_windows_init : unit -> unit = "clock_windows_init" 3 | 4 | let () = clock_windows_init () 5 | let now () = clock_windows_get_time () 6 | -------------------------------------------------------------------------------- /lib/monotonic_clock/clock_windows_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | 13 | #include 14 | #include 15 | #include 16 | #include 17 | #include 18 | #include 19 | #include 20 | #include 21 | #include 22 | #include 23 | #include 24 | #include 25 | #include 26 | 27 | static LARGE_INTEGER frequency; 28 | 29 | CAMLprim value 30 | clock_windows_init(value unit) 31 | { 32 | QueryPerformanceFrequency(&frequency); 33 | frequency.QuadPart = 1000000000L / frequency.QuadPart; 34 | 35 | return Val_unit; 36 | } 37 | 38 | CAMLprim value 39 | clock_windows_get_time(value unit) 40 | { 41 | CAMLparam0(); 42 | CAMLlocal1(res); 43 | LARGE_INTEGER now; 44 | 45 | QueryPerformanceCounter(&now); 46 | 47 | res = caml_copy_int64(now.QuadPart * frequency.QuadPart); 48 | 49 | CAMLreturn(res); 50 | } 51 | -------------------------------------------------------------------------------- /lib/monotonic_clock/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets monotonic_clock.ml monotonic_clock_stubs.c monotonic_clock.sexp) 3 | (deps 4 | (:select select/select.ml) 5 | clock_linux.ml 6 | clock_linux_stubs.c 7 | clock_windows.ml 8 | clock_windows_stubs.c 9 | clock_mach.ml 10 | clock_mach_stubs.c) 11 | (action 12 | (run %{ocaml} %{select} --system %{ocaml-config:system} -o monotonic_clock))) 13 | 14 | (library 15 | (name monotonic_clock) 16 | (modules monotonic_clock) 17 | (public_name bechamel.monotonic_clock) 18 | (foreign_stubs 19 | (language c) 20 | (flags 21 | (:include monotonic_clock.sexp)) 22 | (names monotonic_clock_stubs))) 23 | -------------------------------------------------------------------------------- /lib/monotonic_clock/select/select.ml: -------------------------------------------------------------------------------- 1 | let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt 2 | 3 | let load_file filename = 4 | try 5 | let ic = open_in_bin filename in 6 | let ln = in_channel_length ic in 7 | let rs = Bytes.create ln in 8 | let () = really_input ic rs 0 ln in 9 | Bytes.unsafe_to_string rs 10 | with End_of_file -> invalid_arg "EOF reading: %S" filename 11 | 12 | let sexp_linux = "(-lrt)" 13 | let sexp_empty = "()" 14 | 15 | let () = 16 | let system, output = 17 | match Sys.argv with 18 | | [| _; "--system"; system; "-o"; output |] -> 19 | let system = 20 | match system with 21 | | "linux" | "elf" -> `Linux 22 | | "win32" | "win64" | "mingw64" | "mingw" | "cygwin" -> `Windows 23 | | "freebsd" -> `FreeBSD 24 | | "macosx" -> `MacOSX 25 | | "beos" | "dragonfly" | "bsd" | "openbsd" | "netbsd" | "gnu" 26 | | "solaris" | "unknown" -> 27 | invalid_arg "Unsupported system: %s" system 28 | | v -> 29 | if String.sub system 0 5 = "linux" then `Linux 30 | else invalid_arg "Invalid argument of system option: %s" v 31 | in 32 | (system, output) 33 | | _ -> 34 | invalid_arg "Expected `%s --system -o ' got `%s'" 35 | Sys.argv.(0) 36 | (String.concat " " (Array.to_list Sys.argv)) 37 | in 38 | let oc_ml, oc_c, oc_sexp = 39 | ( open_out (output ^ ".ml") 40 | , open_out (output ^ "_stubs.c") 41 | , open_out (output ^ ".sexp") ) 42 | in 43 | let ml, c = 44 | match system with 45 | | `Linux | `FreeBSD -> 46 | (load_file "clock_linux.ml", load_file "clock_linux_stubs.c") 47 | | `Windows -> 48 | (load_file "clock_windows.ml", load_file "clock_windows_stubs.c") 49 | | `MacOSX -> (load_file "clock_mach.ml", load_file "clock_mach_stubs.c") 50 | in 51 | let sexp = if system = `Linux then sexp_linux else sexp_empty in 52 | Printf.fprintf oc_ml "%s%!" ml; 53 | Printf.fprintf oc_c "%s%!" c; 54 | Printf.fprintf oc_sexp "%s%!" sexp; 55 | close_out oc_ml; 56 | close_out oc_c; 57 | close_out oc_sexp 58 | -------------------------------------------------------------------------------- /lib/notty/bechamel_notty.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | open Notty 3 | 4 | type 'a result = (string, 'a) Hashtbl.t 5 | type 'a results = (string, 'a result) Hashtbl.t 6 | 7 | let ( <.> ) f g x = f (g x) 8 | 9 | module Unit = struct 10 | let units = Hashtbl.create 16 11 | 12 | let add instance unit = 13 | if String.length unit > 5 then 14 | Fmt.invalid_arg "A unit shoud be smaller than 5 bytes: %s" unit; 15 | Hashtbl.add units (Measure.label instance) unit 16 | 17 | let label label = I.string A.empty label 18 | 19 | let unit_of_label label = 20 | try Hashtbl.find units label with Not_found -> label 21 | end 22 | 23 | module Order = struct 24 | type t = Increasing | Decreasing 25 | 26 | let increasing = Increasing 27 | let decreasing = Decreasing 28 | let orders = Hashtbl.create 16 29 | let add instance order = Hashtbl.add orders (Measure.label instance) order 30 | 31 | let order_of_label label = 32 | try Hashtbl.find orders label with Not_found -> Increasing 33 | 34 | let compare_of_order order a b = 35 | match order with 36 | | Increasing -> (compare : float option -> float option -> int) a b 37 | | Decreasing -> (compare : float option -> float option -> int) b a 38 | 39 | let compare_of_label = compare_of_order <.> order_of_label 40 | end 41 | 42 | let fmt_value : _ format6 = "%6.04f %s/%s" 43 | let max_length_of_values = 23 44 | 45 | let ols_value : predictor:string -> Analyze.OLS.t -> image = 46 | fun ~predictor v -> 47 | if not (List.mem predictor (Analyze.OLS.predictors v)) then 48 | Fmt.invalid_arg "Predictor %s was not computed in %a." predictor 49 | Analyze.OLS.pp v; 50 | 51 | let attrs = 52 | match Analyze.OLS.r_square v with 53 | | Some r_square -> 54 | if r_square <= 0.5 then A.(bg red ++ st bold) 55 | else if r_square <= 0.75 then A.(fg red) 56 | else if r_square <= 0.90 then A.(fg yellow) 57 | else if r_square <= 0.98 then A.(fg green) 58 | else A.(bg green ++ st bold) 59 | | None -> A.(fg white) 60 | in 61 | let responder = Analyze.OLS.responder v in 62 | let unit_responder = Unit.unit_of_label responder in 63 | let unit_predictor = Unit.unit_of_label predictor in 64 | match Analyze.OLS.estimates v with 65 | | None -> I.string A.(bg red ++ st bold) "#none" 66 | | Some values -> ( 67 | match 68 | List.fold_left2 69 | (fun a v p -> if String.equal p predictor then Some v else a) 70 | None values (Analyze.OLS.predictors v) 71 | with 72 | | Some value -> 73 | let s = Fmt.str fmt_value value unit_responder unit_predictor in 74 | I.string attrs s 75 | | None -> assert false) 76 | 77 | (* XXX(dinosaure): should never occur. *) 78 | 79 | let ransac_value : Analyze.RANSAC.t -> image = 80 | fun v -> 81 | let attrs = 82 | let error = Analyze.RANSAC.error v in 83 | if error <= 0.5 then A.(bg red ++ st bold) 84 | else if error <= 0.75 then A.(fg red) 85 | else if error <= 0.90 then A.(fg yellow) 86 | else if error <= 0.98 then A.(fg green) 87 | else A.(bg green ++ st bold) 88 | in 89 | let responder = Analyze.RANSAC.responder v in 90 | let predictor = Analyze.RANSAC.predictor v in 91 | let unit_responder = Unit.unit_of_label responder in 92 | let unit_predictor = Unit.unit_of_label predictor in 93 | let s = 94 | Fmt.str fmt_value (Analyze.RANSAC.mean v) unit_responder unit_predictor 95 | in 96 | I.string attrs s 97 | 98 | let corner_tl ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x256D) 99 | let corner_tr ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x256E) 100 | let corner_bl ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x2570) 101 | let corner_br ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x256F) 102 | let break_t ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x252C) 103 | let break_b ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x2534) 104 | let break_l ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x251C) 105 | let break_r ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x2524) 106 | let cross ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x253C) 107 | let line ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x2500) 108 | let sideline ?(attr = A.empty) = I.uchar attr (Uchar.of_int 0x2502) 109 | let grid xxs = xxs |> List.map I.hcat |> I.vcat 110 | 111 | type rect = { w : int; h : int } 112 | 113 | exception Break 114 | 115 | let hashtbl_choose hashtbl = 116 | let k = ref None in 117 | let v = ref None in 118 | 119 | if Hashtbl.length hashtbl = 0 then 120 | Fmt.invalid_arg "hashtbl_choose: empty hashtbl"; 121 | 122 | try 123 | Hashtbl.iter 124 | (fun k' v' -> 125 | k := Some k'; 126 | v := Some v'; 127 | raise Break) 128 | hashtbl; 129 | assert false 130 | with Break -> ( 131 | match (!k, !v) with Some k, Some v -> (k, v) | _, _ -> assert false) 132 | 133 | module One = struct 134 | let image_of_header ~rect result = 135 | let _, v = hashtbl_choose result in 136 | let responder = Analyze.OLS.responder v in 137 | let max_length_of_names = 138 | Hashtbl.fold (fun name _ -> max (String.length name)) result 0 139 | in 140 | 141 | grid 142 | [ [ corner_tl 1 1 143 | ; line (max_length_of_names + 4) 1 144 | ; break_t 1 1 145 | ; line (rect.w - 2 - 1 - (max_length_of_names + 4)) 1 146 | ; corner_tr 1 1 147 | ] 148 | ; [ sideline 1 1 149 | ; I.(string A.(st italic) "name") 150 | ; I.void max_length_of_names 1 151 | ; sideline 1 1 152 | ; I.(string A.empty responder |> hpad 2 0) 153 | ; I.void 154 | (rect.w 155 | - (max_length_of_names + 4 + 2 + 2 + 1 + String.length responder)) 156 | 1 157 | ; sideline 1 1 158 | ] 159 | ; [ break_l 1 1 160 | ; line (max_length_of_names + 4) 1 161 | ; cross 1 1 162 | ; line (rect.w - 2 - 1 - (max_length_of_names + 4)) 1 163 | ; break_r 1 1 164 | ] 165 | ] 166 | 167 | let image_of_field ~max_length_of_names ~rect ~predictor img (name, v) = 168 | let open Notty.Infix in 169 | let value = ols_value ~predictor v in 170 | 171 | let field = 172 | grid 173 | [ [ sideline 1 1 174 | ; I.(string A.empty name |> hpad 2 0) 175 | ; I.void (max_length_of_names + 4 - 2 - String.length name) 1 176 | ; sideline 1 1 177 | ; I.( 178 | hsnap ~align:`Right 179 | (rect.w - 2 - 1 - (max_length_of_names + 4)) 180 | value) 181 | ; sideline 1 1 182 | ] 183 | ] 184 | in 185 | img <-> field 186 | 187 | let best_and_worst_case (result : Analyze.OLS.t result) ~sort ~predictor ~rect 188 | = 189 | let tests = Hashtbl.fold (fun name v a -> (name, v) :: a) result [] in 190 | 191 | let values = 192 | List.map 193 | (fun (name, v) -> 194 | match Analyze.OLS.estimates v with 195 | | Some values -> 196 | List.fold_left2 197 | (fun a v p -> 198 | if String.equal p predictor then (name, Some v) else a) 199 | (name, None) values (Analyze.OLS.predictors v) 200 | | None -> (name, None)) 201 | tests 202 | in 203 | let tests = List.sort (fun (_, a) (_, b) -> sort a b) values in 204 | let (best, _), (worst, _) = (List.hd tests, List.hd (List.rev tests)) in 205 | let max_length_of_names = 206 | Hashtbl.fold (fun name _ -> max (String.length name)) result 0 207 | in 208 | 209 | grid 210 | [ [ break_l 1 1 211 | ; line (max_length_of_names + 4) 1 212 | ; cross 1 1 213 | ; line (rect.w - 2 - 1 - (max_length_of_names + 4)) 1 214 | ; break_r 1 1 215 | ] 216 | ; [ sideline 1 1 217 | ; I.(string A.(st italic) "best") 218 | ; I.void max_length_of_names 1 219 | ; sideline 1 1 220 | ; I.(string A.empty best |> hpad 2 0) 221 | ; I.void 222 | (rect.w - (max_length_of_names + 4 + 2 + 2 + 1 + String.length best)) 223 | 1 224 | ; sideline 1 1 225 | ] 226 | ; [ sideline 1 1 227 | ; I.(string A.(st italic) "worst") 228 | ; I.void (max_length_of_names - 1) 1 229 | ; sideline 1 1 230 | ; I.(string A.empty worst |> hpad 2 0) 231 | ; I.void 232 | (rect.w 233 | - (max_length_of_names + 4 + 2 + 2 + 1 + String.length worst)) 234 | 1 235 | ; sideline 1 1 236 | ] 237 | ; [ corner_bl 1 1 238 | ; line (max_length_of_names + 4) 1 239 | ; break_b 1 1 240 | ; line (rect.w - 2 - 1 - (max_length_of_names + 4)) 1 241 | ; corner_br 1 1 242 | ] 243 | ] 244 | 245 | let image_of_ols_result : 246 | ?sort:(string -> string -> int) 247 | -> rect:rect 248 | -> predictor:string 249 | -> Analyze.OLS.t result 250 | -> image = 251 | fun ?(sort = String.compare) ~rect ~predictor result -> 252 | let tests = Hashtbl.fold (fun name v a -> (name, v) :: a) result [] in 253 | let tests = List.sort (fun (a, _) (b, _) -> sort a b) tests in 254 | 255 | let header = image_of_header ~rect result in 256 | let max_length_of_names = 257 | Hashtbl.fold (fun name _ -> max (String.length name)) result 0 258 | in 259 | 260 | let header_and_body = 261 | List.fold_left 262 | (image_of_field ~max_length_of_names ~rect ~predictor) 263 | header tests 264 | in 265 | 266 | let open Notty.Infix in 267 | header_and_body 268 | <-> best_and_worst_case result 269 | ~sort:(Order.compare_of_label predictor) 270 | ~rect ~predictor 271 | end 272 | 273 | module Multiple = struct 274 | [@@@warning "-26-27"] 275 | 276 | let image_of_header ~rect (results : 'a results) = 277 | let instances = Hashtbl.fold (fun k _ a -> k :: a) results [] in 278 | let _, result = hashtbl_choose results in 279 | let max_length_of_names = 280 | Hashtbl.fold (fun name _ -> max (String.length name)) result 0 281 | in 282 | let max_length_of_instances = 283 | List.fold_right 284 | (fun label -> max (String.length label)) 285 | instances max_length_of_values 286 | in 287 | let max_length_of_fields = 288 | max max_length_of_values max_length_of_instances 289 | in 290 | 291 | let tt = 292 | List.map 293 | (fun _ -> [ break_t 1 1; line (max_length_of_fields + 4) 1 ]) 294 | instances 295 | |> List.concat 296 | in 297 | let tt = corner_tl 1 1 :: line (max_length_of_names + 4) 1 :: tt in 298 | let tt = tt @ [ corner_tr 1 1 ] in 299 | 300 | let cc = 301 | List.map 302 | (fun instance -> 303 | let rest = max_length_of_instances - String.length instance + 2 in 304 | [ sideline 1 1 305 | ; I.(string A.empty instance |> I.hpad 2 0) 306 | ; I.void rest 0 307 | ]) 308 | instances 309 | |> List.concat 310 | in 311 | let cc = 312 | sideline 1 1 313 | :: I.(string A.(st italic) "name") 314 | :: I.void max_length_of_names 1 315 | :: cc 316 | in 317 | let cc = cc @ [ sideline 1 1 ] in 318 | 319 | let bb = 320 | List.map 321 | (fun _ -> [ cross 1 1; line (max_length_of_fields + 4) 1 ]) 322 | instances 323 | |> List.concat 324 | in 325 | let bb = break_l 1 1 :: line (max_length_of_names + 4) 1 :: bb in 326 | let bb = bb @ [ break_r 1 1 ] in 327 | 328 | let open Notty in 329 | I.vcat [ I.hcat tt; I.hcat cc; I.hcat bb ] 330 | 331 | let image_of_ols_fields ~max_length_of_names ~max_length_of_instances ~rect 332 | ~predictor img (name, vs) = 333 | let values = List.map (ols_value ~predictor) vs in 334 | let max_length_of_fields = 335 | max max_length_of_values max_length_of_instances 336 | in 337 | 338 | let ll = 339 | [ sideline 1 1 340 | ; I.(string A.empty name |> hpad 2 0) 341 | ; I.void (max_length_of_names + 4 - 2 - String.length name) 1 342 | ] 343 | in 344 | let cc = 345 | List.map 346 | (fun value -> 347 | [ sideline 1 1 348 | ; I.(hsnap ~align:`Right (max_length_of_fields + 4)) value 349 | ]) 350 | values 351 | |> List.concat 352 | in 353 | let rr = [ sideline 1 1 ] in 354 | 355 | let open Notty.Infix in 356 | img <-> I.hcat (ll @ cc @ rr) 357 | 358 | let image_of_ols_results : 359 | ?sort:(string -> string -> int) 360 | -> rect:rect 361 | -> predictor:string 362 | -> Analyze.OLS.t results 363 | -> image = 364 | fun ?(sort = String.compare) ~rect ~predictor results -> 365 | let header = image_of_header ~rect results in 366 | let instances = Hashtbl.fold (fun k _ a -> k :: a) results [] in 367 | let _, result = hashtbl_choose results in 368 | let max_length_of_names = 369 | Hashtbl.fold (fun name _ -> max (String.length name)) result 0 370 | in 371 | let max_length_of_instances = 372 | List.fold_right 373 | (fun label -> max (String.length label)) 374 | instances max_length_of_values 375 | in 376 | 377 | let tests = Hashtbl.fold (fun name _ a -> name :: a) result [] in 378 | let tests = List.sort sort tests in 379 | 380 | let header_and_body = 381 | List.fold_left 382 | (fun img name -> 383 | let vs = 384 | Hashtbl.fold 385 | (fun label result a -> Hashtbl.find result name :: a) 386 | results [] 387 | in 388 | image_of_ols_fields ~max_length_of_names ~max_length_of_instances 389 | ~rect ~predictor img (name, vs)) 390 | header tests 391 | in 392 | 393 | let max_length_of_fields = 394 | max max_length_of_values max_length_of_instances 395 | in 396 | 397 | let bottom = 398 | List.map 399 | (fun _ -> [ break_b 1 1; line (max_length_of_fields + 4) 1 ]) 400 | instances 401 | |> List.concat 402 | in 403 | let bottom = corner_bl 1 1 :: line (max_length_of_names + 4) 1 :: bottom in 404 | let bottom = bottom @ [ corner_br 1 1 ] in 405 | 406 | let open Notty.Infix in 407 | header_and_body <-> I.hcat bottom 408 | end 409 | -------------------------------------------------------------------------------- /lib/notty/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bechamel_notty) 3 | (public_name bechamel-notty) 4 | (libraries fmt notty bechamel)) 5 | -------------------------------------------------------------------------------- /lib/perf/.ocamlformat: -------------------------------------------------------------------------------- 1 | module-item-spacing=compact 2 | break-struct=force 3 | break-infix=fit-or-vertical 4 | parens-tuple=always 5 | wrap-comments=true 6 | break-collection-expressions=wrap -------------------------------------------------------------------------------- /lib/perf/bechamel_perf.ml: -------------------------------------------------------------------------------- 1 | module Perf = Mperf 2 | 3 | module Make (X : sig 4 | val kind : Perf.Attr.Kind.t 5 | end) = 6 | struct 7 | type witness = Perf.t 8 | 9 | let load witness = Perf.enable witness 10 | let unload witness = Perf.disable witness 11 | 12 | let make () = 13 | try Perf.make (Perf.Attr.make X.kind) 14 | with Unix.Unix_error (Unix.EACCES, _, _) -> 15 | (* kernel.perf_event_paranoid doesn't allow measuring the kernel *) 16 | Perf.make (Perf.Attr.make ~flags:[ Perf.Attr.Exclude_kernel ] X.kind) 17 | 18 | let label witness = 19 | let kind = Perf.kind witness in 20 | Perf.Attr.Kind.to_string kind 21 | 22 | let unit witness = 23 | match Perf.kind witness with 24 | | Cycles -> "cyc" 25 | | Instructions -> "inst" 26 | | Cache_references -> "cref" 27 | | Cache_misses -> "cmiss" 28 | | Branch_misses -> "bmiss" 29 | | Branch_instructions -> "binst" 30 | | Bus_cycles -> "bcyc" 31 | | Stalled_cycles_frontend -> "stcyc" 32 | | Stalled_cycles_backend -> "stcyc" 33 | | Ref_cpu_cycles -> "cyc" 34 | | Cpu_clock -> "ns" 35 | | Task_clock -> "ns" 36 | | Page_faults -> "pft" 37 | | Context_switches -> "cxsw" 38 | | Cpu_migrations -> "migr" 39 | | Page_faults_min -> "mnpft" 40 | | Page_faults_maj -> "mjpft" 41 | | Alignment_faults -> "alft" 42 | | Emulation_faults -> "emuft" 43 | | Dummy -> "dummy" 44 | 45 | let get witness = Int64.to_float (Perf.read witness) 46 | end 47 | 48 | module Cycles = Make (struct 49 | let kind = Perf.Attr.Kind.Cycles 50 | end) 51 | 52 | module Instructions = Make (struct 53 | let kind = Perf.Attr.Kind.Instructions 54 | end) 55 | 56 | module Cache_references = Make (struct 57 | let kind = Perf.Attr.Kind.Cache_references 58 | end) 59 | 60 | module Cache_misses = Make (struct 61 | let kind = Perf.Attr.Kind.Cache_misses 62 | end) 63 | 64 | module Branch_instructions = Make (struct 65 | let kind = Perf.Attr.Kind.Branch_instructions 66 | end) 67 | 68 | module Branch_misses = Make (struct 69 | let kind = Perf.Attr.Kind.Branch_misses 70 | end) 71 | 72 | module Bus_cycles = Make (struct 73 | let kind = Perf.Attr.Kind.Bus_cycles 74 | end) 75 | 76 | module Stalled_cycles_frontend = Make (struct 77 | let kind = Perf.Attr.Kind.Stalled_cycles_frontend 78 | end) 79 | 80 | module Stalled_cycles_backend = Make (struct 81 | let kind = Perf.Attr.Kind.Stalled_cycles_backend 82 | end) 83 | 84 | module Ref_cpu_cycles = Make (struct 85 | let kind = Perf.Attr.Kind.Ref_cpu_cycles 86 | end) 87 | 88 | module Cpu_clock = Make (struct 89 | let kind = Perf.Attr.Kind.Cpu_clock 90 | end) 91 | 92 | module Task_clock = Make (struct 93 | let kind = Perf.Attr.Kind.Task_clock 94 | end) 95 | 96 | module Page_faults = Make (struct 97 | let kind = Perf.Attr.Kind.Page_faults 98 | end) 99 | 100 | module Context_switches = Make (struct 101 | let kind = Perf.Attr.Kind.Context_switches 102 | end) 103 | 104 | module Cpu_migrations = Make (struct 105 | let kind = Perf.Attr.Kind.Cpu_migrations 106 | end) 107 | 108 | module Page_faults_min = Make (struct 109 | let kind = Perf.Attr.Kind.Page_faults_min 110 | end) 111 | 112 | module Page_faults_maj = Make (struct 113 | let kind = Perf.Attr.Kind.Page_faults_maj 114 | end) 115 | 116 | module Alignment_faults = Make (struct 117 | let kind = Perf.Attr.Kind.Alignment_faults 118 | end) 119 | 120 | module Emulation_faults = Make (struct 121 | let kind = Perf.Attr.Kind.Emulation_faults 122 | end) 123 | 124 | module Dummy = Make (struct 125 | let kind = Perf.Attr.Kind.Dummy 126 | end) 127 | 128 | open Bechamel 129 | 130 | module Extension = struct 131 | include Toolkit.Extension 132 | 133 | let cycles = Measure.register (module Cycles) 134 | let instructions = Measure.register (module Instructions) 135 | let cache_references = Measure.register (module Cache_references) 136 | let cache_misses = Measure.register (module Cache_misses) 137 | let branch_instructions = Measure.register (module Branch_instructions) 138 | let branch_misses = Measure.register (module Branch_misses) 139 | let cpu_clock = Measure.register (module Cpu_clock) 140 | let task_clock = Measure.register (module Task_clock) 141 | let page_faults = Measure.register (module Page_faults) 142 | let context_switches = Measure.register (module Context_switches) 143 | let cpu_migrations = Measure.register (module Cpu_migrations) 144 | let page_faults_min = Measure.register (module Page_faults_min) 145 | let page_faults_maj = Measure.register (module Page_faults_maj) 146 | let alignment_faults = Measure.register (module Alignment_faults) 147 | let emulation_faults = Measure.register (module Emulation_faults) 148 | let dummy = Measure.register (module Dummy) 149 | end 150 | 151 | module Instance = struct 152 | include Toolkit.Instance 153 | 154 | (* Some measures are not implemented here because they are not available on 155 | some machines, and thus implementing them here would prevent bechamel-perf 156 | from loading. These measures are: Bus_cycles, Ref_cpu_cycles, 157 | Stalled_cycles_frontend, Stalled_cycles_backend. *) 158 | 159 | let cycles = Measure.instance (module Cycles) Extension.cycles 160 | 161 | let instructions = 162 | Measure.instance (module Instructions) Extension.instructions 163 | 164 | let cache_references = 165 | Measure.instance (module Cache_references) Extension.cache_references 166 | 167 | let cache_misses = 168 | Measure.instance (module Cache_misses) Extension.cache_misses 169 | 170 | let branch_instructions = 171 | Measure.instance (module Branch_instructions) Extension.branch_instructions 172 | 173 | let branch_misses = 174 | Measure.instance (module Branch_misses) Extension.branch_misses 175 | 176 | let cpu_clock = Measure.instance (module Cpu_clock) Extension.cpu_clock 177 | let task_clock = Measure.instance (module Task_clock) Extension.task_clock 178 | let page_faults = Measure.instance (module Page_faults) Extension.page_faults 179 | 180 | let context_switches = 181 | Measure.instance (module Context_switches) Extension.context_switches 182 | 183 | let cpu_migrations = 184 | Measure.instance (module Cpu_migrations) Extension.cpu_migrations 185 | 186 | let page_faults_min = 187 | Measure.instance (module Page_faults_min) Extension.page_faults_min 188 | 189 | let page_faults_maj = 190 | Measure.instance (module Page_faults_maj) Extension.page_faults_maj 191 | 192 | let alignment_faults = 193 | Measure.instance (module Alignment_faults) Extension.alignment_faults 194 | 195 | let emulation_faults = 196 | Measure.instance (module Emulation_faults) Extension.emulation_faults 197 | 198 | let dummy = Measure.instance (module Dummy) Extension.dummy 199 | end 200 | -------------------------------------------------------------------------------- /lib/perf/bechamel_perf.mli: -------------------------------------------------------------------------------- 1 | (** This module provides several event counters from the [perf] API provided by 2 | Linux (2.6+) - and they are {b not} compatible with other systems. These 3 | counters are basically what the [perf] command provides. 4 | 5 | For some events, it is necessary {b to be root}. If you try to use these 6 | counters with insufficient privileges, [Bechamel_perf] will report you an 7 | permission error. 8 | 9 | If you want to use [Bechamel_perf] as a normal user, you should take a look 10 | on {{:https://www.kernel.org/doc/Documentation/sysctl/kernel.txt}the 11 | documentation about [perf_paranoid]}. 12 | 13 | If the user wants to measuring the kernel, the program must be run as root. 14 | We cannot measure in a virtualized environment ([ENOENT] is returned). *) 15 | 16 | open Bechamel 17 | 18 | module Extension : sig 19 | val cycles : Mperf.t Measure.measure 20 | val instructions : Mperf.t Measure.measure 21 | val cache_references : Mperf.t Measure.measure 22 | val cache_misses : Mperf.t Measure.measure 23 | val branch_instructions : Mperf.t Measure.measure 24 | val branch_misses : Mperf.t Measure.measure 25 | val cpu_clock : Mperf.t Measure.measure 26 | val task_clock : Mperf.t Measure.measure 27 | val page_faults : Mperf.t Measure.measure 28 | val context_switches : Mperf.t Measure.measure 29 | val cpu_migrations : Mperf.t Measure.measure 30 | val page_faults_min : Mperf.t Measure.measure 31 | val page_faults_maj : Mperf.t Measure.measure 32 | val alignment_faults : Mperf.t Measure.measure 33 | val emulation_faults : Mperf.t Measure.measure 34 | val dummy : Mperf.t Measure.measure 35 | end 36 | 37 | module Instance : sig 38 | val cycles : Measure.witness 39 | val instructions : Measure.witness 40 | val cache_references : Measure.witness 41 | val cache_misses : Measure.witness 42 | val branch_instructions : Measure.witness 43 | val branch_misses : Measure.witness 44 | val cpu_clock : Measure.witness 45 | val task_clock : Measure.witness 46 | val page_faults : Measure.witness 47 | val context_switches : Measure.witness 48 | val cpu_migrations : Measure.witness 49 | val page_faults_min : Measure.witness 50 | val page_faults_maj : Measure.witness 51 | val alignment_faults : Measure.witness 52 | val emulation_faults : Measure.witness 53 | val dummy : Measure.witness 54 | end 55 | -------------------------------------------------------------------------------- /lib/perf/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bechamel_perf) 3 | (public_name bechamel-perf) 4 | (libraries mperf bechamel unix)) 5 | -------------------------------------------------------------------------------- /lib/ransac.ml: -------------------------------------------------------------------------------- 1 | (* (c) OCamlPro - under MIT license *) 2 | 3 | let random_permutation a = 4 | let len = Array.length a in 5 | for i = 0 to Array.length a - 1 do 6 | let n = Random.int (len - i) + i in 7 | let v1 = a.(i) in 8 | let v2 = a.(n) in 9 | a.(i) <- v2; 10 | a.(n) <- v1 11 | done; 12 | a 13 | 14 | let random_indices n = 15 | let a = Array.init n (fun i -> i) in 16 | random_permutation a 17 | 18 | let random_partition n a = 19 | let indices = random_indices (Array.length a) in 20 | ( Array.init n (fun i -> a.(indices.(i))) 21 | , Array.init (Array.length a - n) (fun i -> a.(indices.(i + n))) ) 22 | 23 | let array_filter f a = 24 | let in_size = ref 0 in 25 | for i = 0 to Array.length a - 1 do 26 | let v = a.(i) in 27 | if f v then ( 28 | let after_in = !in_size in 29 | let v' = a.(after_in) in 30 | a.(i) <- v'; 31 | a.(after_in) <- v; 32 | incr in_size) 33 | done; 34 | Array.sub a 0 !in_size 35 | 36 | type ('a, 'b) input = 37 | { model : 'a array -> 'b 38 | ; data : 'a array 39 | ; subset_size : int 40 | ; rounds : int 41 | ; distance : 'a -> 'b -> float 42 | ; filter_distance : float 43 | ; minimum_valid : int 44 | ; error : 'a array -> 'b -> float 45 | } 46 | 47 | type ('a, 'b) result = { model : 'b; input : 'a array; error : float } 48 | 49 | let one_round (r : ('a, 'b) input) : ('a, 'b) result option = 50 | let in_subset, _out_of_subset = 51 | random_partition (min (Array.length r.data / 2) r.subset_size) r.data 52 | in 53 | let model = r.model in_subset in 54 | let fiting = 55 | array_filter (fun p -> r.distance p model < r.filter_distance) r.data 56 | in 57 | if Array.length fiting > r.minimum_valid then 58 | let input = Array.append in_subset fiting in 59 | let model = r.model input in 60 | Some { model; input; error = r.error input model } 61 | else None 62 | 63 | let ransac r : (_, _) result option = 64 | let rec loop n (best : (_, _) result option) = 65 | if n >= r.rounds then best 66 | else 67 | let best = 68 | match (one_round r, best) with 69 | | res, None | None, res -> res 70 | | (Some { error; _ } as new_best), Some { error = best_error; _ } 71 | when error < best_error -> 72 | new_best 73 | | Some _, Some _ -> best 74 | in 75 | loop (n + 1) best 76 | in 77 | loop 0 None 78 | -------------------------------------------------------------------------------- /lib/s.ml: -------------------------------------------------------------------------------- 1 | module type FUNCTOR = sig 2 | type 'a t 3 | end 4 | 5 | module type MEASURE = sig 6 | type witness 7 | 8 | val label : witness -> string 9 | val unit : witness -> string 10 | val make : unit -> witness 11 | val load : witness -> unit 12 | val unload : witness -> unit 13 | val get : witness -> float 14 | end 15 | -------------------------------------------------------------------------------- /lib/s.mli: -------------------------------------------------------------------------------- 1 | module type FUNCTOR = sig 2 | type 'a t 3 | end 4 | 5 | module type MEASURE = sig 6 | type witness 7 | 8 | val label : witness -> string 9 | val unit : witness -> string 10 | val make : unit -> witness 11 | val load : witness -> unit 12 | val unload : witness -> unit 13 | val get : witness -> float 14 | end 15 | -------------------------------------------------------------------------------- /lib/staged.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a 2 | 3 | let stage = Sys.opaque_identity 4 | let unstage = Sys.opaque_identity 5 | -------------------------------------------------------------------------------- /lib/staged.mli: -------------------------------------------------------------------------------- 1 | (** Staged value. 2 | 3 | Staged value is used by the module {!Test} to protect the underlying value 4 | about optimization (specially cross-module optimization). *) 5 | 6 | type 'a t 7 | 8 | val stage : 'a -> 'a t 9 | val unstage : 'a t -> 'a 10 | -------------------------------------------------------------------------------- /lib/test.ml: -------------------------------------------------------------------------------- 1 | type ('a, 't) app 2 | 3 | module Uniq : sig 4 | type t 5 | 6 | external inj : 'a -> ('a, t) app = "%identity" 7 | external prj : ('a, t) app -> 'a = "%identity" 8 | val unit : (unit, t) app 9 | end = struct 10 | type t 11 | 12 | external inj : 'a -> ('a, t) app = "%identity" 13 | external prj : ('a, t) app -> 'a = "%identity" 14 | 15 | let unit = inj () 16 | end 17 | 18 | module Multiple : sig 19 | type t 20 | 21 | external inj : 'a array -> ('a, t) app = "%identity" 22 | external prj : ('a, t) app -> 'a array = "%identity" 23 | end = struct 24 | type t 25 | 26 | external inj : 'a array -> ('a, t) app = "%identity" 27 | external prj : ('a, t) app -> 'a array = "%identity" 28 | end 29 | 30 | type packed = 31 | | V : 32 | { fn : [ `Init ] -> 'a -> 'b 33 | ; kind : ('a, 'v, 't) kind 34 | ; allocate : 'v -> ('a, 't) app 35 | ; free : ('a, 't) app -> unit 36 | } 37 | -> packed 38 | 39 | and ('a, 'v, 'k) kind = 40 | | Uniq : ('a, unit, Uniq.t) kind 41 | | Multiple : ('a, int, Multiple.t) kind 42 | 43 | let uniq = Uniq 44 | let multiple = Multiple 45 | let always v _ = v 46 | let ( <.> ) f g x = f (g x) 47 | 48 | module Elt = struct 49 | type t = { key : int; name : string; fn : packed } 50 | 51 | let unsafe_make ~name fn = 52 | { key = 0 53 | ; name 54 | ; fn = 55 | V 56 | { fn = (fun `Init -> Staged.unstage fn) 57 | ; kind = Uniq 58 | ; allocate = always Uniq.unit 59 | ; free = always () 60 | } 61 | } 62 | 63 | let key { key; _ } = key 64 | let name { name; _ } = name 65 | let fn { fn; _ } = fn 66 | end 67 | 68 | type fmt_indexed = 69 | (string -> int -> string, Format.formatter, unit, string) format4 70 | 71 | type fmt_grouped = 72 | (string -> string -> string, Format.formatter, unit, string) format4 73 | 74 | type t = { name : string; set : Elt.t list } 75 | 76 | let make ~name fn = 77 | { name 78 | ; set = 79 | [ { Elt.key = 0 80 | ; Elt.name 81 | ; Elt.fn = 82 | V 83 | { fn = (fun `Init -> Staged.unstage fn) 84 | ; kind = Uniq 85 | ; allocate = always Uniq.unit 86 | ; free = always () 87 | } 88 | } 89 | ] 90 | } 91 | 92 | open Unsafe 93 | 94 | let make_multiple_allocate f = function 95 | | 0 -> [||] 96 | | len -> 97 | let vs = unsafe_array_make len (f ()) in 98 | for i = 1 to len - 1 do 99 | unsafe_array_set vs i (f ()) 100 | done; 101 | vs 102 | 103 | let make_multiple_free f arr = 104 | for i = 0 to Array.length arr - 1 do 105 | f (unsafe_array_get arr i) 106 | done 107 | 108 | let make_with_resource : 109 | type a v k. 110 | name:string 111 | -> (a, v, k) kind 112 | -> allocate:(unit -> a) 113 | -> free:(a -> unit) 114 | -> (a -> 'b) Staged.t 115 | -> t = 116 | fun ~name kind ~allocate ~free fn -> 117 | match kind with 118 | | Uniq -> 119 | { name 120 | ; set = 121 | [ { Elt.key = 0 122 | ; Elt.name 123 | ; Elt.fn = 124 | V 125 | { fn = (fun `Init -> Staged.unstage fn) 126 | ; allocate = Uniq.inj <.> allocate 127 | ; free = free <.> Uniq.prj 128 | ; kind = Uniq 129 | } 130 | } 131 | ] 132 | } 133 | | Multiple -> 134 | { name 135 | ; set = 136 | [ { Elt.key = 0 137 | ; Elt.name 138 | ; Elt.fn = 139 | V 140 | { fn = (fun `Init -> Staged.unstage fn) 141 | ; allocate = Multiple.inj <.> make_multiple_allocate allocate 142 | ; free = make_multiple_free free <.> Multiple.prj 143 | ; kind = Multiple 144 | } 145 | } 146 | ] 147 | } 148 | 149 | let make_indexed ~name ?(fmt : fmt_indexed = "%s:%d") ~args fn = 150 | { name 151 | ; set = 152 | List.map 153 | (fun key -> 154 | { Elt.key 155 | ; Elt.name = Fmt.str fmt name key 156 | ; Elt.fn = 157 | V 158 | { fn = (fun `Init -> Staged.unstage (fn key)) 159 | ; kind = Uniq 160 | ; allocate = always Uniq.unit 161 | ; free = always () 162 | } 163 | }) 164 | args 165 | } 166 | 167 | let make_indexed_with_resource : 168 | type a f g. 169 | name:string 170 | -> ?fmt:fmt_indexed 171 | -> args:int list 172 | -> (a, f, g) kind 173 | -> allocate:(int -> a) 174 | -> free:(a -> unit) 175 | -> (int -> (a -> 'b) Staged.t) 176 | -> t = 177 | fun ~name ?(fmt : fmt_indexed = "%s:%d") ~args kind ~allocate ~free fn -> 178 | match kind with 179 | | Uniq -> 180 | { name 181 | ; set = 182 | List.map 183 | (fun key -> 184 | { Elt.key 185 | ; Elt.name = Fmt.str fmt name key 186 | ; Elt.fn = 187 | V 188 | { fn = (fun `Init -> Staged.unstage (fn key)) 189 | ; kind = Uniq 190 | ; allocate = (fun () -> Uniq.inj (allocate key)) 191 | ; free = free <.> Uniq.prj 192 | } 193 | }) 194 | args 195 | } 196 | | Multiple -> 197 | { name 198 | ; set = 199 | List.map 200 | (fun key -> 201 | { Elt.key 202 | ; Elt.name = Fmt.str fmt name key 203 | ; Elt.fn = 204 | V 205 | { fn = (fun `Init -> Staged.unstage (fn key)) 206 | ; kind = Multiple 207 | ; allocate = 208 | Multiple.inj 209 | <.> make_multiple_allocate (fun () -> allocate key) 210 | ; free = make_multiple_free free <.> Multiple.prj 211 | } 212 | }) 213 | args 214 | } 215 | 216 | let name { name; _ } = name 217 | let names { set; _ } = List.map Elt.name set 218 | let elements { set; _ } = set 219 | let expand ts = List.concat (List.map (fun t -> t.set) ts) 220 | 221 | let make_grouped ~name ?(fmt : fmt_grouped = "%s/%s") ts = 222 | let ts = expand ts in 223 | { name 224 | ; set = 225 | List.map (fun t -> { t with Elt.name = Fmt.str fmt name t.Elt.name }) ts 226 | } 227 | -------------------------------------------------------------------------------- /lib/test.mli: -------------------------------------------------------------------------------- 1 | type ('a, 't) app 2 | 3 | module Uniq : sig 4 | type t 5 | 6 | external inj : 'a -> ('a, t) app = "%identity" 7 | external prj : ('a, t) app -> 'a = "%identity" 8 | val unit : (unit, t) app 9 | end 10 | 11 | module Multiple : sig 12 | type t 13 | 14 | external inj : 'a array -> ('a, t) app = "%identity" 15 | external prj : ('a, t) app -> 'a array = "%identity" 16 | end 17 | 18 | type packed = private 19 | | V : 20 | { fn : [ `Init ] -> 'a -> 'b 21 | ; kind : ('a, 'v, 't) kind 22 | ; allocate : 'v -> ('a, 't) app 23 | ; free : ('a, 't) app -> unit 24 | } 25 | -> packed 26 | 27 | and ('a, 'v, 'k) kind = private 28 | | Uniq : ('a, unit, Uniq.t) kind 29 | | Multiple : ('a, int, Multiple.t) kind 30 | 31 | val uniq : ('a, unit, Uniq.t) kind 32 | val multiple : ('a, int, Multiple.t) kind 33 | 34 | module Elt : sig 35 | type t 36 | 37 | val unsafe_make : name:string -> (unit -> 'a) Staged.t -> t 38 | val key : t -> int 39 | val name : t -> string 40 | val fn : t -> packed 41 | end 42 | 43 | type t 44 | 45 | type fmt_indexed = 46 | (string -> int -> string, Format.formatter, unit, string) format4 47 | 48 | type fmt_grouped = 49 | (string -> string -> string, Format.formatter, unit, string) format4 50 | 51 | val make : name:string -> (unit -> 'a) Staged.t -> t 52 | (** [make ~name fn] is a naming benchmark measuring [fn]. [fn] can be 53 | constructed with {!Staged.stage}: 54 | 55 | {[ 56 | let write = 57 | Test.make ~name:"unix-write" 58 | (Staged.stage @@ fun () -> Unix.write Unix.stdout "Hello World!") 59 | ]} *) 60 | 61 | val make_with_resource : 62 | name:string 63 | -> ('a, 'f, 'g) kind 64 | -> allocate:(unit -> 'a) 65 | -> free:('a -> unit) 66 | -> ('a -> 'b) Staged.t 67 | -> t 68 | (** [make_with_resource ~name k ~allocate ~free fn] is a naming benchmark 69 | measuring [fn] with a pre-allocated resource ['v] (given by [allocate]). 70 | It permits to measure [fn] which requires a resource allocated {b before} 71 | the benchmark. Then, this resource can be free-ed {i via} the given [free] 72 | function. 73 | 74 | Depending on the [k] given, the resource can be allocated only one time or 75 | per [run]: 76 | - {!val:uniq}, the resource is allocated one ime before the benchmark and 77 | used by [fn] for all runs. Then, it is free-ed at the end of the 78 | benchmark. 79 | - {!val:multiple}, the resource is allocated multiple times (depending on 80 | how many times we want to {i run} [fn]) at the beginning of the benchmark 81 | and [fn] is executed with a structurally different resource per [run]. 82 | Then, these resources are free-ed at the end of the benchmark. 83 | 84 | {b NOTE}: the {!val:multiple} case can ask a huge allocation (for instance, 85 | it can call 3000 times [allocate]). Be aware that such usage, depending on 86 | what you allocate, can lead an [Out_of_memory] exception. *) 87 | 88 | val make_indexed : 89 | name:string 90 | -> ?fmt:fmt_indexed 91 | -> args:int list 92 | -> (int -> (unit -> 'a) Staged.t) 93 | -> t 94 | (** [make_indexed ~name ~fmt ~args fn] is naming benchmarks indexed by an 95 | argument (by [args]). Name of each benchmark is [Fmt.strf fmt name arg] 96 | (default to ["%s:%d"]). 97 | 98 | {[ 99 | let make_list words = 100 | Staged.stage @@ fun () -> 101 | let rec go n acc = if n = 0 then acc else go (n - 1) (n :: acc) in 102 | go ((words / 3) + 1) [] 103 | 104 | let test = 105 | make_indexed ~name:"make_list" ~args:[ 0; 10; 100; 100 ] make_list 106 | ]} 107 | 108 | This kind of test is helpful to see results of the {b same} implementation 109 | with differents arguments (indexed by the given [int]). *) 110 | 111 | val make_indexed_with_resource : 112 | name:string 113 | -> ?fmt:fmt_indexed 114 | -> args:int list 115 | -> ('a, 'f, 'g) kind 116 | -> allocate:(int -> 'a) 117 | -> free:('a -> unit) 118 | -> (int -> ('a -> 'b) Staged.t) 119 | -> t 120 | 121 | val make_grouped : name:string -> ?fmt:fmt_grouped -> t list -> t 122 | (** [make_grouped ~name ~fmt tests] is naming benchmarks. Name of each benchmark 123 | is [Fmt.strf fmt name arg] (default to [%s/%s]). 124 | 125 | {[ 126 | let f0 = Test.make ~name:"fib1" ... ;; let f1 = Test.make ~name:"fib0" 127 | ... ;; 128 | 129 | let test = Test.make_grouped ~name:"fibonacci" [ f0; f1; ] ;; 130 | ]} 131 | 132 | This kind of test is helpful to compare results between many implementations. *) 133 | 134 | val name : t -> string 135 | (** [name t] returns the name of the test. *) 136 | 137 | val names : t -> string list 138 | (** [names t] returns names of sub-tests of [t] (such as {i indexed} tests or 139 | {i grouped} tests). *) 140 | 141 | val elements : t -> Elt.t list 142 | (** [elements t] returns all measuring functions of [t]. *) 143 | 144 | val expand : t list -> Elt.t list 145 | -------------------------------------------------------------------------------- /lib/time.ml: -------------------------------------------------------------------------------- 1 | open Stdlib 2 | 3 | type t = int64 4 | type span = int64 5 | 6 | let of_uint64_ns x = x 7 | let to_uint64_ns x = x 8 | 9 | let span t0 t1 = 10 | if Int64.unsigned_compare t0 t1 < 0 then Int64.sub t1 t0 else Int64.sub t0 t1 11 | 12 | let s_to_ns = 1e9 13 | let to_span o x = span (Int64.of_float (s_to_ns *. (x *. o))) 0L 14 | let second n = to_span 1. n 15 | let millisecond n = to_span 1e-3 n 16 | let microsecond n = to_span 1e-6 n 17 | let nanosecond n = to_span 1e-9 n 18 | let span_compare = Int64.unsigned_compare 19 | let span_of_uint64_ns x = x 20 | let span_to_uint64_ns x = x 21 | -------------------------------------------------------------------------------- /lib/time.mli: -------------------------------------------------------------------------------- 1 | type t 2 | type span 3 | 4 | val of_uint64_ns : int64 -> t 5 | val to_uint64_ns : t -> int64 6 | val span : t -> t -> span 7 | val second : float -> span 8 | val millisecond : float -> span 9 | val microsecond : float -> span 10 | val nanosecond : float -> span 11 | val span_of_uint64_ns : int64 -> span 12 | val span_to_uint64_ns : span -> int64 13 | val span_compare : span -> span -> int 14 | -------------------------------------------------------------------------------- /lib/toolkit.ml: -------------------------------------------------------------------------------- 1 | module One = struct 2 | type witness = unit 3 | 4 | let load () = () 5 | let unload () = () 6 | let make () = () 7 | let get () = 1. 8 | let label () = "one" 9 | let unit () = "one" 10 | end 11 | 12 | module Minor_allocated = struct 13 | type witness = unit 14 | 15 | let load () = () 16 | let unload () = () 17 | let make () = () 18 | let get () = (Gc.quick_stat ()).minor_words 19 | let label () = "minor-allocated" 20 | let unit () = "mnw" 21 | end 22 | 23 | module Major_allocated = struct 24 | type witness = unit 25 | 26 | let load () = () 27 | let unload () = () 28 | let make () = () 29 | let get () = (Gc.quick_stat ()).major_words 30 | let label () = "major-allocated" 31 | let unit () = "mjw" 32 | end 33 | 34 | module Promoted = struct 35 | type witness = unit 36 | 37 | let load () = () 38 | let unload () = () 39 | let make () = () 40 | let get () = (Gc.quick_stat ()).promoted_words 41 | let label () = "promoted" 42 | let unit () = "p" 43 | end 44 | 45 | module Compaction = struct 46 | type witness = unit 47 | 48 | let load () = () 49 | let unload () = () 50 | let make () = () 51 | let get () = float_of_int (Gc.quick_stat ()).compactions 52 | let label () = "compaction" 53 | let unit () = "compact" 54 | end 55 | 56 | module Minor_collection = struct 57 | type witness = unit 58 | 59 | let load () = () 60 | let unload () = () 61 | let make () = () 62 | let get () = float_of_int (Gc.quick_stat ()).minor_collections 63 | let label () = "minor-collection" 64 | let unit () = "mn-collect" 65 | end 66 | 67 | module Major_collection = struct 68 | type witness = unit 69 | 70 | let load () = () 71 | let unload () = () 72 | let make () = () 73 | let get () = float_of_int (Gc.quick_stat ()).major_collections 74 | let label () = "major-collection" 75 | let unit () = "mj-collect" 76 | end 77 | 78 | module Monotonic_clock = struct 79 | type witness = unit 80 | 81 | let load () = () 82 | let unload () = () 83 | let make () = () 84 | let get () = Int64.to_float (Monotonic_clock.now ()) 85 | let label () = "monotonic-clock" 86 | let unit () = "ns" 87 | end 88 | 89 | module Extension = struct 90 | type 'w t = 'w Measure.measure 91 | 92 | let one = Measure.register (module One) 93 | let minor_allocated = Measure.register (module Minor_allocated) 94 | let major_allocated = Measure.register (module Major_allocated) 95 | let promoted = Measure.register (module Promoted) 96 | let compaction = Measure.register (module Compaction) 97 | let minor_collection = Measure.register (module Minor_collection) 98 | let major_collection = Measure.register (module Major_collection) 99 | let monotonic_clock = Measure.register (module Monotonic_clock) 100 | end 101 | 102 | module Instance = struct 103 | let one = Measure.instance (module One) Extension.one 104 | 105 | let minor_allocated = 106 | Measure.instance (module Minor_allocated) Extension.minor_allocated 107 | 108 | let major_allocated = 109 | Measure.instance (module Major_allocated) Extension.major_allocated 110 | 111 | let promoted = Measure.instance (module Promoted) Extension.promoted 112 | let compaction = Measure.instance (module Compaction) Extension.compaction 113 | 114 | let major_collection = 115 | Measure.instance (module Major_collection) Extension.major_collection 116 | 117 | let minor_collection = 118 | Measure.instance (module Minor_collection) Extension.minor_collection 119 | 120 | let monotonic_clock = 121 | Measure.instance (module Monotonic_clock) Extension.monotonic_clock 122 | end 123 | -------------------------------------------------------------------------------- /lib/toolkit.mli: -------------------------------------------------------------------------------- 1 | module One : S.MEASURE with type witness = unit 2 | module Minor_allocated : S.MEASURE with type witness = unit 3 | module Major_allocated : S.MEASURE with type witness = unit 4 | module Promoted : S.MEASURE with type witness = unit 5 | module Compaction : S.MEASURE with type witness = unit 6 | module Minor_collection : S.MEASURE with type witness = unit 7 | module Major_collection : S.MEASURE with type witness = unit 8 | module Monotonic_clock : S.MEASURE with type witness = unit 9 | 10 | module Extension : sig 11 | type 'w t = 'w Measure.measure 12 | 13 | val one : One.witness t 14 | val minor_allocated : Minor_allocated.witness t 15 | val major_allocated : Major_allocated.witness t 16 | val promoted : Promoted.witness t 17 | val compaction : Compaction.witness t 18 | val minor_collection : Minor_collection.witness t 19 | val major_collection : Major_collection.witness t 20 | val monotonic_clock : Monotonic_clock.witness t 21 | end 22 | 23 | module Instance : sig 24 | val one : Measure.witness 25 | val minor_allocated : Measure.witness 26 | val major_allocated : Measure.witness 27 | val promoted : Measure.witness 28 | val compaction : Measure.witness 29 | val minor_collection : Measure.witness 30 | val major_collection : Measure.witness 31 | val monotonic_clock : Measure.witness 32 | end 33 | -------------------------------------------------------------------------------- /lib/unsafe.ml: -------------------------------------------------------------------------------- 1 | let unsafe_array_make = Array.make 2 | let unsafe_array_get = Array.unsafe_get 3 | let unsafe_array_set = Array.unsafe_set 4 | -------------------------------------------------------------------------------- /mperf.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "mperf" 3 | version: "0.5" 4 | maintainer: [ "Romain Calascibetta " ] 5 | authors: [ "Vincent Bernardoff " "Pierre Chambart " ] 6 | homepage: "http://github.com/dinosaure/bechamel" 7 | dev-repo: "git://github.com/dinosaure/bechamel" 8 | bug-reports: "http://github.com/dinosaure/bechamel/issues" 9 | license: "GPL-2.0-only" 10 | synopsis: "Bindings to Linux perf's metrics" 11 | description: """Simple binding to Linux perf's metrics""" 12 | 13 | build: [ 14 | [ "dune" "subst" ] {dev} 15 | [ "dune" "build" "-p" name "-j" jobs ] 16 | ] 17 | 18 | depends: [ 19 | "ocaml" {>= "4.07"} 20 | "dune" {>= "2.0.0"} 21 | "base-unix" 22 | "conf-linux-libc-dev" {build} 23 | ] 24 | 25 | available: [ os = "linux" ] 26 | -------------------------------------------------------------------------------- /mperf/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mperf) 3 | (public_name mperf) 4 | (foreign_stubs 5 | (language c) 6 | (names mperf_stubs)) 7 | (libraries unix)) 8 | -------------------------------------------------------------------------------- /mperf/lib/mperf.ml: -------------------------------------------------------------------------------- 1 | module Attr = struct 2 | type flag = 3 | | Disabled (** off by default *) 4 | | Inherit (** children inherit it *) 5 | | Exclude_user (** don't count user *) 6 | | Exclude_kernel (** don't count kernel *) 7 | | Exclude_hv (** don't count hypervisor *) 8 | | Exclude_idle (** don't count when idle *) 9 | | Enable_on_exec (** next exec enables *) 10 | 11 | let flag_to_enum = function 12 | | Disabled -> 1 13 | | Inherit -> 2 14 | | Exclude_user -> 4 15 | | Exclude_kernel -> 8 16 | | Exclude_hv -> 16 17 | | Exclude_idle -> 32 18 | | Enable_on_exec -> 64 19 | 20 | module FSet = Set.Make (struct 21 | type t = flag 22 | 23 | let compare = compare 24 | end) 25 | 26 | module Kind = struct 27 | type t = 28 | (* Hardware *) 29 | | Cycles 30 | | Instructions 31 | | Cache_references 32 | | Cache_misses 33 | | Branch_instructions 34 | | Branch_misses 35 | | Bus_cycles 36 | | Stalled_cycles_frontend 37 | | Stalled_cycles_backend 38 | | Ref_cpu_cycles 39 | (* Software *) 40 | | Cpu_clock 41 | | Task_clock 42 | | Page_faults 43 | | Context_switches 44 | | Cpu_migrations 45 | | Page_faults_min 46 | | Page_faults_maj 47 | | Alignment_faults 48 | | Emulation_faults 49 | | Dummy 50 | 51 | let to_enum = function 52 | | Cycles -> 0 53 | | Instructions -> 1 54 | | Cache_references -> 2 55 | | Cache_misses -> 3 56 | | Branch_instructions -> 4 57 | | Branch_misses -> 5 58 | | Bus_cycles -> 6 59 | | Stalled_cycles_frontend -> 7 60 | | Stalled_cycles_backend -> 8 61 | | Ref_cpu_cycles -> 9 62 | | Cpu_clock -> 10 63 | | Task_clock -> 11 64 | | Page_faults -> 12 65 | | Context_switches -> 13 66 | | Cpu_migrations -> 14 67 | | Page_faults_min -> 15 68 | | Page_faults_maj -> 16 69 | | Alignment_faults -> 17 70 | | Emulation_faults -> 18 71 | | Dummy -> 19 72 | 73 | let string_of_t k = 74 | match k with 75 | | Cycles -> "Cycles" 76 | | Instructions -> "Instructions" 77 | | Cache_references -> "Cache_references" 78 | | Cache_misses -> "Cache_misses" 79 | | Branch_instructions -> "Branch_instructions" 80 | | Branch_misses -> "Branch_misses" 81 | | Bus_cycles -> "Bus_cycles" 82 | | Stalled_cycles_frontend -> "Stalled_cycles_frontend" 83 | | Stalled_cycles_backend -> "Stalled_cycles_backend" 84 | | Ref_cpu_cycles -> "Ref_cpu_cycles" 85 | (* Software *) 86 | | Cpu_clock -> "Cpu_clock" 87 | | Task_clock -> "Task_clock" 88 | | Page_faults -> "Page_faults" 89 | | Context_switches -> "Context_switches" 90 | | Cpu_migrations -> "Cpu_migrations" 91 | | Page_faults_min -> "Page_faults_min" 92 | | Page_faults_maj -> "Page_faults_maj" 93 | | Alignment_faults -> "Alignment_faults" 94 | | Emulation_faults -> "Emulation_faults" 95 | | Dummy -> "Dummy" 96 | 97 | let t_of_string s = 98 | match s with 99 | | "Cycles" -> Cycles 100 | | "Instructions" -> Instructions 101 | | "Cache_references" -> Cache_references 102 | | "Cache_misses" -> Cache_misses 103 | | "Branch_instructions" -> Branch_instructions 104 | | "Branch_misses" -> Branch_misses 105 | | "Bus_cycles" -> Bus_cycles 106 | | "Stalled_cycles_frontend" -> Stalled_cycles_frontend 107 | | "Stalled_cycles_backend" -> Stalled_cycles_backend 108 | | "Ref_cpu_cycles" -> Ref_cpu_cycles 109 | (* Software *) 110 | | "Cpu_clock" -> Cpu_clock 111 | | "Task_clock" -> Task_clock 112 | | "Page_faults" -> Page_faults 113 | | "Context_switches" -> Context_switches 114 | | "Cpu_migrations" -> Cpu_migrations 115 | | "Page_faults_min" -> Page_faults_min 116 | | "Page_faults_maj" -> Page_faults_maj 117 | | "Alignment_faults" -> Alignment_faults 118 | | "Emulation_faults" -> Emulation_faults 119 | | "Dummy" -> Dummy 120 | | _ -> invalid_arg "kind_of_string" 121 | 122 | let to_string t = string_of_t t |> String.uncapitalize_ascii 123 | let of_string s = String.capitalize_ascii s |> t_of_string 124 | let compare = compare 125 | end 126 | 127 | type t = { flags : FSet.t; kind : Kind.t } 128 | 129 | (** [make ?flags kind] is a perf event attribute of type [kind], with flags 130 | [flags]. *) 131 | let make ?(flags = []) kind = { flags = FSet.of_list flags; kind } 132 | 133 | let compare t1 t2 = compare t1.kind t2.kind 134 | end 135 | 136 | module KindMap = Map.Make (Attr.Kind) 137 | 138 | type flag = Fd_cloexec | Fd_no_group | Fd_output | Pid_cgroup 139 | 140 | let flag_to_enum = function 141 | | Fd_cloexec -> 1 142 | | Fd_no_group -> 2 143 | | Fd_output -> 4 144 | | Pid_cgroup -> 8 145 | 146 | type t = { fd : Unix.file_descr; kind : Attr.Kind.t } 147 | 148 | external perf_event_open : 149 | kind:int 150 | -> attr_flags:int 151 | -> pid:int 152 | -> cpu:int 153 | -> group_fd:int 154 | -> flags:int 155 | -> Unix.file_descr = "mperf_event_open_byte" "mperf_event_open_native" 156 | 157 | external perf_event_ioc_enable : Unix.file_descr -> unit 158 | = "mperf_event_ioc_enable" 159 | 160 | external perf_event_ioc_disable : Unix.file_descr -> unit 161 | = "mperf_event_ioc_disable" 162 | 163 | external perf_event_ioc_reset : Unix.file_descr -> unit 164 | = "mperf_event_ioc_reset" 165 | 166 | external enable_all : unit -> unit = "mperf_events_enable_all" 167 | external disable_all : unit -> unit = "mperf_events_disable_all" 168 | 169 | module FSet = Set.Make (struct 170 | type t = flag 171 | 172 | let compare = compare 173 | end) 174 | 175 | let make ?(pid = 0) ?(cpu = -1) ?group ?(flags = []) attr = 176 | let flags = FSet.of_list flags in 177 | let flags = FSet.fold (fun f acc -> acc + flag_to_enum f) flags 0 in 178 | 179 | let attr_flags = 180 | let open Attr in 181 | FSet.fold (fun f acc -> acc + Attr.(flag_to_enum f)) attr.flags 0 182 | in 183 | 184 | let group = 185 | match group with None -> -1 | Some { fd; _ } -> (Obj.magic fd : int) 186 | in 187 | let kind_enum = Attr.(Kind.(to_enum attr.kind)) in 188 | Attr. 189 | { fd = 190 | perf_event_open ~kind:kind_enum ~attr_flags ~pid ~cpu ~group_fd:group 191 | ~flags 192 | ; kind = attr.kind 193 | } 194 | 195 | let kind c = c.kind 196 | 197 | external get_int64 : bytes -> int -> int64 = "%caml_bytes_get64" 198 | external swap64 : int64 -> int64 = "caml_int64_bswap" 199 | 200 | let get_int64 buf off = 201 | if Sys.big_endian then swap64 (get_int64 buf off) else get_int64 buf off 202 | 203 | let read c = 204 | let buf = Bytes.create 8 in 205 | let nb_read = Unix.read c.fd buf 0 8 in 206 | assert (nb_read = 8); 207 | get_int64 buf 0 208 | 209 | let reset c = perf_event_ioc_reset c.fd 210 | let enable c = perf_event_ioc_enable c.fd 211 | let disable c = perf_event_ioc_disable c.fd 212 | let close c = Unix.close c.fd 213 | 214 | type execution = 215 | { process_status : Unix.process_status 216 | ; stdout : string 217 | ; stderr : string 218 | ; data : Int64.t KindMap.t 219 | } 220 | 221 | let string_of_ic ic = really_input_string ic @@ in_channel_length ic 222 | 223 | let string_of_file filename = 224 | let ic = open_in filename in 225 | try 226 | let res = string_of_ic ic in 227 | close_in ic; 228 | res 229 | with exn -> 230 | close_in ic; 231 | raise exn 232 | 233 | let with_process_exn ?env ?timeout ?stdout ?stderr cmd attrs = 234 | let attrs = 235 | List.map 236 | Attr.( 237 | fun a -> 238 | { flags = 239 | List.fold_left 240 | (fun a f -> Attr.FSet.add f a) 241 | a.flags 242 | [ Disabled; Inherit; Enable_on_exec ] 243 | ; kind = a.kind 244 | }) 245 | attrs 246 | in 247 | let counters = List.map make attrs in 248 | let tmp_stdout_name = 249 | match stdout with 250 | | None -> Filename.temp_file "ocaml-perf" "stdout" 251 | | Some s -> s 252 | in 253 | let tmp_stderr_name = 254 | match stderr with 255 | | None -> Filename.temp_file "ocaml-perf" "stderr" 256 | | Some s -> s 257 | in 258 | let tmp_stdout = 259 | Unix.(openfile tmp_stdout_name [ O_WRONLY; O_CREAT; O_TRUNC ] 0o600) 260 | in 261 | let tmp_stderr = 262 | Unix.(openfile tmp_stderr_name [ O_WRONLY; O_CREAT; O_TRUNC ] 0o600) 263 | in 264 | match Unix.fork () with 265 | | 0 -> 266 | (* child *) 267 | Unix.( 268 | handle_unix_error 269 | (fun () -> 270 | dup2 tmp_stdout stdout; 271 | close tmp_stdout; 272 | dup2 tmp_stderr stderr; 273 | close tmp_stderr; 274 | match env with 275 | | None -> execvp (List.hd cmd) (Array.of_list cmd) 276 | | Some env -> 277 | execvpe (List.hd cmd) (Array.of_list cmd) (Array.of_list env)) 278 | ()) 279 | | n -> 280 | (* parent *) 281 | (* Setup an alarm if timeout is specified. The alarm signal 282 | handles do nothing, but this will make waitpid fail with 283 | EINTR, unblocking the program. *) 284 | let (_ : int) = match timeout with None -> 0 | Some t -> Unix.alarm t in 285 | Sys.(set_signal sigalrm (Signal_handle (fun _ -> ()))); 286 | let _, process_status = Unix.waitpid [] n in 287 | List.iter disable counters; 288 | Unix.( 289 | close tmp_stdout; 290 | close tmp_stderr); 291 | let res = 292 | { process_status 293 | ; stdout = string_of_file tmp_stdout_name 294 | ; stderr = string_of_file tmp_stderr_name 295 | ; data = 296 | List.fold_left 297 | (fun a c -> KindMap.add c.kind (read c) a) 298 | KindMap.empty counters 299 | } 300 | in 301 | List.iter close counters; 302 | (* Remove stdout/stderr files iff they were left unspecified. *) 303 | (match stdout with None -> Unix.unlink tmp_stdout_name | _ -> ()); 304 | (match stderr with None -> Unix.unlink tmp_stderr_name | _ -> ()); 305 | res 306 | 307 | let with_process ?env ?timeout ?stdout ?stderr cmd attrs = 308 | try `Ok (with_process_exn ?env ?timeout ?stdout ?stderr cmd attrs) with 309 | | Unix.Unix_error (Unix.EINTR, _, _) -> `Timeout 310 | | exn -> `Exn exn 311 | -------------------------------------------------------------------------------- /mperf/lib/mperf.mli: -------------------------------------------------------------------------------- 1 | module Attr : sig 2 | type flag = 3 | | Disabled (** off by default *) 4 | | Inherit (** children inherit it *) 5 | | Exclude_user (** don't count user *) 6 | | Exclude_kernel (** don't count kernel *) 7 | | Exclude_hv (** don't count hypervisor *) 8 | | Exclude_idle (** don't count when idle *) 9 | | Enable_on_exec (** next exec enables *) 10 | 11 | module Kind : sig 12 | type t = 13 | | Cycles 14 | | Instructions 15 | | Cache_references 16 | | Cache_misses 17 | | Branch_instructions 18 | | Branch_misses 19 | | Bus_cycles 20 | | Stalled_cycles_frontend 21 | | Stalled_cycles_backend 22 | | Ref_cpu_cycles 23 | | Cpu_clock 24 | | Task_clock 25 | | Page_faults 26 | | Context_switches 27 | | Cpu_migrations 28 | | Page_faults_min 29 | | Page_faults_maj 30 | | Alignment_faults 31 | | Emulation_faults 32 | | Dummy 33 | 34 | val to_string : t -> string 35 | val of_string : string -> t 36 | end 37 | 38 | type t 39 | (** Opaque type of a perf event attribute. *) 40 | 41 | val make : ?flags:flag list -> Kind.t -> t 42 | (** [make ?flags kind] is a perf event attribute of type [kind], with flags 43 | [flags]. *) 44 | 45 | val compare : t -> t -> int 46 | (** comparison function on {!t}. *) 47 | end 48 | 49 | module KindMap : Map.S with type key = Attr.Kind.t 50 | 51 | type flag = 52 | | Fd_cloexec 53 | (** (since Linux 3.14). This flag enables the close-on-exec flag for the 54 | created event file descriptor, so that the file descriptor is 55 | automatically closed on execve(2). Setting the close-on-exec flags at 56 | creation time, rather than later with fcntl(2), avoids potential race 57 | conditions where the calling thread invokes perf_event_open() and 58 | fcntl(2) at the same time as another thread calls fork(2) then 59 | execve(2). *) 60 | | Fd_no_group 61 | (** This flag allows creating an event as part of an event group but 62 | having no group leader. It is unclear why this is useful.*) 63 | | Fd_output 64 | (** This flag reroutes the output from an event to the group leader. *) 65 | | Pid_cgroup 66 | (** This flag activates per-container system-wide monitoring. A container 67 | is an abstraction that isolates a set of resources for finer-grained 68 | control (CPUs, memory, etc.). In this mode, the event is measured only 69 | if the thread running on the monitored CPU belongs to the designated 70 | container (cgroup). The cgroup is identified by passing a file 71 | descriptor opened on its directory in the cgroupfs filesystem. For 72 | instance, if the cgroup to monitor is called test, then a file 73 | descriptor opened on /dev/cgroup/test (assuming cgroupfs is mounted on 74 | /dev/cgroup) must be passed as the pid parameter. cgroup monitoring is 75 | available only for system-wide events and may therefore require extra 76 | permissions. *) 77 | 78 | type t 79 | (** Opaque type of an event counter (internally [t] is a file descriptor). Each 80 | file descriptor corresponds to one event that is measured; these can be 81 | grouped together to measure multiple events simultaneously. *) 82 | 83 | val make : ?pid:int -> ?cpu:int -> ?group:t -> ?flags:flag list -> Attr.t -> t 84 | (** [make ~pid ~cpu ?group ?flags attr] is a perf event counter. Refer to 85 | perf_event_open(2) for the description of the arguments. One counter only 86 | counts one kind of attribute at a time. If you want to simultanously count 87 | different metrics (like the perf stat tool does), you have to setup several 88 | counters. *) 89 | 90 | val kind : t -> Attr.Kind.t 91 | (** [kind c] is the kind of events that this counter counts. *) 92 | 93 | val read : t -> int64 94 | (** [read c] is the value of the counter [c]. *) 95 | 96 | val reset : t -> unit 97 | (** [reset c] sets [c] to zero. *) 98 | 99 | val enable : t -> unit 100 | (** Start measuring. *) 101 | 102 | val disable : t -> unit 103 | (** Disabling an event. When an event is disabled it does not count or generate 104 | overflows but does continue to exist and maintain its count value. *) 105 | 106 | val close : t -> unit 107 | (** Free resources associated with a counter. *) 108 | 109 | type execution = private 110 | { process_status : Unix.process_status 111 | ; stdout : string 112 | ; stderr : string 113 | ; data : Int64.t KindMap.t 114 | } 115 | (** Type returned by [with_process] *) 116 | 117 | val with_process : 118 | ?env:string list 119 | -> ?timeout:int 120 | -> ?stdout:string 121 | -> ?stderr:string 122 | -> string list 123 | -> Attr.t list 124 | -> [ `Ok of execution | `Timeout | `Exn of exn ] 125 | (** [with_process ?env ?timeout ?stdout ?stderr cmd attrs] is the result of the 126 | execution of the program described by [cmd]. This can either be a successful 127 | execution, or an error. *) 128 | 129 | val enable_all : unit -> unit 130 | (** A process can enable or disable all the event groups that are attached to it 131 | using the prctl(2) PR_TASK_PERF_EVENTS_ENABLE and 132 | PR_TASK_PERF_EVENTS_DISABLE operations. This applies to all counters on the 133 | calling process, whether created by this process or by another, and does not 134 | affect any counters that this process has created on other processes. It 135 | enables or disables only the group leaders, not any other members in the 136 | groups. *) 137 | 138 | val disable_all : unit -> unit 139 | -------------------------------------------------------------------------------- /mperf/lib/mperf_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #include 9 | #include 10 | 11 | #include 12 | #include 13 | #include 14 | #include 15 | 16 | static long 17 | perf_event_open(struct perf_event_attr *hw_event, pid_t pid, 18 | int cpu, int group_fd, unsigned long flags) 19 | { 20 | int ret; 21 | ret = syscall(__NR_perf_event_open, hw_event, pid, cpu, 22 | group_fd, flags); 23 | return ret; 24 | } 25 | 26 | CAMLprim value mperf_events_enable_all (value unit) 27 | { 28 | CAMLparam1(unit); 29 | int ret; 30 | ret = prctl(PR_TASK_PERF_EVENTS_ENABLE, 0, 0, 0, 0); 31 | 32 | if(ret == -1) 33 | uerror(__func__, Nothing); 34 | 35 | CAMLreturn(Val_unit); 36 | } 37 | 38 | CAMLprim value mperf_events_disable_all (value unit) 39 | { 40 | CAMLparam1(unit); 41 | int ret; 42 | ret = prctl(PR_TASK_PERF_EVENTS_DISABLE, 0, 0, 0, 0); 43 | 44 | if(ret == -1) 45 | uerror(__func__, Nothing); 46 | 47 | CAMLreturn(Val_unit); 48 | } 49 | 50 | CAMLprim value mperf_event_ioc_enable (value fd) 51 | { 52 | CAMLparam1(fd); 53 | int ret; 54 | ret = ioctl(Int_val(fd), PERF_EVENT_IOC_ENABLE); 55 | 56 | if(ret == -1) 57 | uerror(__func__, Nothing); 58 | 59 | CAMLreturn(Val_unit); 60 | } 61 | 62 | CAMLprim value mperf_event_ioc_disable (value fd) 63 | { 64 | CAMLparam1(fd); 65 | int ret; 66 | ret = ioctl(Int_val(fd), PERF_EVENT_IOC_DISABLE); 67 | 68 | if(ret == -1) 69 | uerror(__func__, Nothing); 70 | 71 | CAMLreturn(Val_unit); 72 | } 73 | 74 | CAMLprim value mperf_event_ioc_reset (value fd) 75 | { 76 | CAMLparam1(fd); 77 | int ret; 78 | ret = ioctl(Int_val(fd), PERF_EVENT_IOC_RESET); 79 | 80 | if(ret == -1) 81 | uerror(__func__, Nothing); 82 | 83 | CAMLreturn(Val_unit); 84 | } 85 | 86 | CAMLprim value mperf_event_open_native (value kind, value attr_flags, 87 | value pid, value cpu, value group_fd, value flags) 88 | { 89 | CAMLparam5(kind, attr_flags, pid, cpu, group_fd); 90 | CAMLxparam1(flags); 91 | 92 | int ret; 93 | int c_flags = 0; 94 | 95 | struct perf_event_attr attr; 96 | memset(&attr, 0, sizeof(struct perf_event_attr)); 97 | attr.size = sizeof(struct perf_event_attr); 98 | #ifdef PERF_FLAG_FD_CLOEXEC 99 | if (Int_val(flags) & 1) c_flags += PERF_FLAG_FD_CLOEXEC; 100 | #endif 101 | if (Int_val(flags) & 2) c_flags += PERF_FLAG_FD_NO_GROUP; 102 | if (Int_val(flags) & 4) c_flags += PERF_FLAG_FD_OUTPUT; 103 | if (Int_val(flags) & 8) c_flags += PERF_FLAG_PID_CGROUP; 104 | 105 | if (Int_val(kind) < 10) attr.type = PERF_TYPE_HARDWARE; 106 | else attr.type = PERF_TYPE_SOFTWARE; 107 | 108 | switch (Int_val(kind)) 109 | { 110 | case 0: attr.config = PERF_COUNT_HW_CPU_CYCLES; break; 111 | case 1: attr.config = PERF_COUNT_HW_INSTRUCTIONS; break; 112 | case 2: attr.config = PERF_COUNT_HW_CACHE_REFERENCES; break; 113 | case 3: attr.config = PERF_COUNT_HW_CACHE_MISSES; break; 114 | case 4: attr.config = PERF_COUNT_HW_BRANCH_INSTRUCTIONS; break; 115 | case 5: attr.config = PERF_COUNT_HW_BRANCH_MISSES; break; 116 | case 6: attr.config = PERF_COUNT_HW_BUS_CYCLES; break; 117 | case 7: attr.config = PERF_COUNT_HW_STALLED_CYCLES_FRONTEND; break; 118 | case 8: attr.config = PERF_COUNT_HW_STALLED_CYCLES_BACKEND; break; 119 | case 9: attr.config = PERF_COUNT_HW_REF_CPU_CYCLES; break; 120 | case 10: attr.config = PERF_COUNT_SW_CPU_CLOCK; break; 121 | case 11: attr.config = PERF_COUNT_SW_TASK_CLOCK; break; 122 | case 12: attr.config = PERF_COUNT_SW_PAGE_FAULTS; break; 123 | case 13: attr.config = PERF_COUNT_SW_CONTEXT_SWITCHES; break; 124 | case 14: attr.config = PERF_COUNT_SW_CPU_MIGRATIONS; break; 125 | case 15: attr.config = PERF_COUNT_SW_PAGE_FAULTS_MIN; break; 126 | case 16: attr.config = PERF_COUNT_SW_PAGE_FAULTS_MAJ; break; 127 | case 17: attr.config = PERF_COUNT_SW_ALIGNMENT_FAULTS; break; 128 | case 18: attr.config = PERF_COUNT_SW_EMULATION_FAULTS; break; 129 | case 19: attr.config = PERF_COUNT_SW_DUMMY; break; 130 | } 131 | 132 | if(Int_val(attr_flags) & 1) attr.disabled = 1; 133 | if(Int_val(attr_flags) & 2) attr.inherit = 1; 134 | if(Int_val(attr_flags) & 4) attr.exclude_user = 1; 135 | if(Int_val(attr_flags) & 8) attr.exclude_kernel = 1; 136 | if(Int_val(attr_flags) & 16) attr.exclude_hv = 1; 137 | if(Int_val(attr_flags) & 32) attr.exclude_idle = 1; 138 | if(Int_val(attr_flags) & 64) attr.enable_on_exec = 1; 139 | 140 | ret = perf_event_open(&attr, Int_val(pid), Int_val(cpu), Int_val(group_fd), c_flags); 141 | 142 | if(ret == -1) 143 | uerror(__func__, Nothing); 144 | 145 | CAMLreturn(Val_int(ret)); 146 | } 147 | 148 | CAMLprim value mperf_event_open_byte (value *argv, int argn) 149 | { 150 | return mperf_event_open_native(argv[0], argv[1], argv[2], 151 | argv[3], argv[4], argv[5]); 152 | } 153 | 154 | -------------------------------------------------------------------------------- /test/allocate/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (package bechamel) 4 | (modules test) 5 | (libraries bechamel alcotest)) 6 | -------------------------------------------------------------------------------- /test/allocate/test.ml: -------------------------------------------------------------------------------- 1 | open Bechamel 2 | open Bechamel.Toolkit 3 | 4 | let all_released kind = 5 | Alcotest.test_case "all released" `Quick @@ fun () -> 6 | let global = ref 0 in 7 | let called = ref 0 in 8 | let test = 9 | Test.make_with_resource ~name:"test" kind 10 | ~allocate:(fun () -> 11 | incr called; 12 | incr global) 13 | ~free:(fun () -> decr global) 14 | (Staged.stage (Fun.const ())) 15 | in 16 | let[@warning "-8"] [ test ] = Test.elements test in 17 | let cfg = Benchmark.cfg ~limit:10 ~kde:None () in 18 | let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in 19 | Alcotest.(check int) "all released" !global 0; 20 | if !called = 0 then Alcotest.failf "Benchmark does not allocate" 21 | 22 | let with_kde kind = 23 | Alcotest.test_case "with kde" `Quick @@ fun () -> 24 | let global = ref 0 in 25 | let called = ref 0 in 26 | let test = 27 | Test.make_with_resource ~name:"test" kind 28 | ~allocate:(fun () -> 29 | incr called; 30 | incr global) 31 | ~free:(fun () -> decr global) 32 | (Staged.stage (Fun.const ())) 33 | in 34 | let[@warning "-8"] [ test ] = Test.elements test in 35 | let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in 36 | let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in 37 | Alcotest.(check int) "with kde" !global 0; 38 | if !called = 0 then Alcotest.failf "Benchmark does not allocate" 39 | 40 | let uniq_resources kind = 41 | Alcotest.test_case "uniq resources" `Quick @@ fun () -> 42 | let tbl = Hashtbl.create 0x100 in 43 | let idx = ref 0 in 44 | let test = 45 | Test.make_with_resource ~name:"test" kind 46 | ~allocate:(fun () -> 47 | let value = !idx in 48 | incr idx; 49 | Hashtbl.add tbl value (); 50 | value) 51 | ~free:(Hashtbl.remove tbl) 52 | (Staged.stage (Fun.const ())) 53 | in 54 | let[@warning "-8"] [ test ] = Test.elements test in 55 | let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in 56 | let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in 57 | Alcotest.(check int) "uniq resources" (Hashtbl.length tbl) 0 58 | 59 | let double_free kind = 60 | Alcotest.test_case "double free" `Quick @@ fun () -> 61 | let tbl = Hashtbl.create 0x100 in 62 | let idx = ref 0 in 63 | let test = 64 | Test.make_with_resource ~name:"test" kind 65 | ~allocate:(fun () -> 66 | let value = !idx in 67 | incr idx; 68 | Hashtbl.add tbl value (); 69 | value) 70 | ~free:(fun value -> 71 | match Hashtbl.find_opt tbl value with 72 | | None -> Alcotest.failf "Double free" 73 | | Some () -> Hashtbl.remove tbl value) 74 | (Staged.stage (Fun.const ())) 75 | in 76 | let[@warning "-8"] [ test ] = Test.elements test in 77 | let cfg = Benchmark.cfg ~limit:10 ~kde:(Some 1000) () in 78 | let _ = Benchmark.run cfg Instance.[ monotonic_clock ] test in 79 | Alcotest.(check int) "double free" (Hashtbl.length tbl) 0 80 | 81 | let () = 82 | Alcotest.run "allocate" 83 | [ ( "uniq" 84 | , [ all_released Test.uniq 85 | ; with_kde Test.uniq 86 | ; uniq_resources Test.uniq 87 | ; double_free Test.uniq 88 | ] ) 89 | ; ( "multiple" 90 | , [ all_released Test.multiple 91 | ; with_kde Test.multiple 92 | ; uniq_resources Test.multiple 93 | ; double_free Test.multiple 94 | ] ) 95 | ] 96 | -------------------------------------------------------------------------------- /test/bechamel-html/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (targets output.html) 3 | (action 4 | (with-stdout-to 5 | %{targets} 6 | (system "%{bin:bechamel-html} < %{dep:input.json}")))) 7 | 8 | (rule 9 | (alias runtest) 10 | (package bechamel-js) 11 | (action 12 | (diff output.html.expected output.html))) 13 | -------------------------------------------------------------------------------- /test/bechamel-html/input.json: -------------------------------------------------------------------------------- 1 | {"a": "b"} 2 | -------------------------------------------------------------------------------- /test/bechamel-html/output.html.expected: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 163 | 164 | 165 | 166 | 1044 | 1045 | 1046 | 1047 | --------------------------------------------------------------------------------