pax_global_header00006660000000000000000000000064146327737460014535gustar00rootroot0000000000000052 comment=7bec047f8bfa1a233d24fc4a4b77e8eb18988155 eqaf-0.10/000077500000000000000000000000001463277374600123715ustar00rootroot00000000000000eqaf-0.10/.cirrus.yml000066400000000000000000000010521463277374600144770ustar00rootroot00000000000000freebsd_instance: image_family: freebsd-14-1 freebsd_task: env: matrix: - OCAML_VERSION: 4.13.1 - OCAML_VERSION: 4.14.2 pkg_install_script: pkg install -y ocaml-opam gmake bash ocaml_script: opam init -a --comp=$OCAML_VERSION dependencies_script: eval `opam env` && opam pin add -yn eqaf.dev . && opam pin add -yn eqaf-cstruct.dev . && opam install -y --deps-only eqaf eqaf-cstruct build_script: eval `opam env` && dune build @install test_script: eval `opam env` && opam install -y -t --deps-only . && dune build @runtest eqaf-0.10/.github/000077500000000000000000000000001463277374600137315ustar00rootroot00000000000000eqaf-0.10/.github/workflows/000077500000000000000000000000001463277374600157665ustar00rootroot00000000000000eqaf-0.10/.github/workflows/test.yml000066400000000000000000000020071463277374600174670ustar00rootroot00000000000000name: Eqaf on: [push, pull_request] jobs: tests: name: Tests strategy: fail-fast: false matrix: ocaml-version: ["4.13.1", "4.14.2"] operating-system: [macos-latest, ubuntu-latest, windows-latest] runs-on: ${{ matrix.operating-system }} steps: - name: Checkout code uses: actions/checkout@v2 - name: Use OCaml ${{ matrix.ocaml-version }} uses: ocaml/setup-ocaml@v2 with: ocaml-compiler: ${{ matrix.ocaml-version }} - name: Install nasm uses: ilammy/setup-nasm@v1 - name: Install dependencies run: | opam pin add -n eqaf . opam depext -y eqaf opam install -t --deps-only . - name: Build run: opam exec -- dune build -p eqaf - name: Simple tests run: opam exec -- dune exec test/test.exe - name: Branch tests run: opam exec -- dune exec test/test_branch.exe - name: Fuzz tests run: opam exec -- dune exec fuzz/fuzz.exe eqaf-0.10/.gitignore000066400000000000000000000002241463277374600143570ustar00rootroot00000000000000_build setup.data setup.log doc/*.html *.native *.byte *.so lib/decompress_conf.ml *.tar.gz _tests lib_test/files zpipe c/dpipe *.install *~ .merlineqaf-0.10/.ocamlformat000066400000000000000000000000341463277374600146730ustar00rootroot00000000000000version=0.21.0 disable=true eqaf-0.10/CHANGES.md000066400000000000000000000072541463277374600137730ustar00rootroot00000000000000### v0.10 2024-06-14 Kyoto (Japon) - Implement functions provided by `eqaf` on bytes (@FantomeBeignet, #41) - Choose the right clock on MSVC systems (@dra27, #40) - Fix the lower bounds about base64 (@hannesm, #45) - Split `eqaf` and `eqaf-cstruct` (@dinosaure, @hannesm, #43) ### v0.9 2022-07-24 Paris (France) - Add support of OCaml 5.00 (@kit-ty-kate, #37) - Add support for current-bench and fix bad r² for unequal strings (@Zined-Ada, @art-w, #38) - Add benchmark with `bechamel` (@Zineb-Ada, @art-w, #38) ### v0.8 2021-08-06 Paris (France) - Fix the check tool on 4.11.0 (@dinosaure, @cfcs, @stedolan, #30) The compilation on 4.11 triggers a case where the locality of the expected value when we test `exists_uint8` must be the same. Otherwise, the access to this value can have a cost which faults our result. - Add several utility functions (@cfcs, @dinosaure, #26) * `bytes_of_hex` & `string_of_hex`, hex decoding * `hex_of_bytes` & `hex_of_string`, hex encoding * `divmod`, unsigned `int32` division with small divisors * `ascii_of_int32`, conversion from `int32` to decimal `string` representation * `lowercase_ascii` & `uppercase_ascii`, _constant-time_ implementation of `String.{lower,upper}case_ascii` * `select_a_if_in_range`, like `select_int` but only supporting positive ranges * `int_of_bool` & `bool_of_int`, _constant-time_ of `Bool.to_int` A documentation exists for each function. The _constant-time_ is checked only systematically for `divmod`. - Merge optional sub-packages (@kit-ty-kate, @hannesm, @dinosaure, #27) `cstruct` becomes a required dependency of `eqaf` - Fix FreeBSD support and remove support of < OCaml 4.07 and remove the dependency to `bigarray-compat` (@hannesm, @dinosaure, #32) - Add a CI on FreeBSD (@dinosaure, @hannesm, #33) - Remove the test `check/check.exe` (@dinosaure, #31) The test `check/check.exe` is really volatile and should be executed into a controlled environment (for instance, with `nice -n19` and a _bare-metal_ computer). We still require the test for any improvement of `eqaf` but it is executed separately from our CI. ### v0.7 2020-04-16 Paris (France) - Add `find_uint8` (@dinosaure, @cfcs, #20) - Add `exists_uint8` (@dinosaure, @cfcs, #20) ### v0.6 2020-03-11 Paris (France) - remove build dependency on dune (@CraigFe, #16) - add bigarray-compat and optional dependencies (@hannesm, #17) - add `select_int`, `one_if_not_zero`, `zero_if_not_zero` (@cfcs, @dinosaure, #19, #18) ### v0.5 2019-07-01 Paris (France) - Delete `min` and use `<>` operator to compare length on `equal` function - Implementation of `compare_{be,le}{,with_len}` function (@cfcs, @hannesm, @dinosaure) - Test on `compare` function (@dinosaure) - Unit test on `compare` (@dinosaure) - Fuzz test on `compare` (@dinosaure) - Documentation (@dinosaure, @cfcs) ### v0.4 2019-05-24 Paris (France) - Distribution integrate an attack example - Fuzzer to test `equal` function - Unroll internal loop over 16 bits integers instead 32 bits - Put x86 ASM output in implementation (and audit) - Do second check even if first on fails (bad r²) - Avoid indirection to `Pervasives` functions ### v0.3 2019-05-02 Paris (France) - Provide `Eqaf_bigstring` - Provide `Eqaf_cstruct` - New check tool and delete any dependencies on `eqaf` package (@dinosaure, @hannesm, @cfcs) NOTE: This version is buggy, you MUST use v0.2 or v0.4 ### v0.2 2018-10-15 Paris (France) * _Dunify_ project * Update OPAM file * Avoid `core_bench` dependency * Make benchmark to test constant-time on `eqml` * __Move `equal` function to the OCaml implementation__ (instead C implementation) * Port benchmark on Windows and Mac OSX ### v0.1 2018-08-31 Paris (France) * First release eqaf-0.10/LICENSE.md000066400000000000000000000020761463277374600140020ustar00rootroot00000000000000The MIT License (MIT) Copyright (c) 2018 Romain Calascibetta Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. eqaf-0.10/Makefile000066400000000000000000000001121463277374600140230ustar00rootroot00000000000000.PHONY: bench bench: dune exec check/check.exe dune exec check/bench.exeeqaf-0.10/README.md000066400000000000000000000224311463277374600136520ustar00rootroot00000000000000# Eq(af) - Constant time equal function This library implements various *constant time* algorithms, first and foremost the `Eqaf.equal` equality testing function for `string`. While the test suite has a number of external dependencies, the library itself does not have any dependencies besides the OCaml standard library. This should make `eqaf` small, self-contained, and easy to integrate in your code. The "constant time" provided by this library is *constant* in the sense that the time required to execute the functions does not depend on the *values* of the operands. The purpose is to help programmer shield their code from timing-based side-channel attacks where an adversary tries to measure execution time to learn about the contents of the operands. They are *not* necessarily "constant time" in the sense that each invocation takes exactly the same amount of microseconds. Constant time implementations are beneficial in many different applications; cryptographic libraries like [digestif](https://github.com/mirage/digestif), but also practial code that deal with sensitive information (like passwords) benefit from constant time execution in select situations. A practical example of where this matters is the [Lucky Thirteen attack](https://en.wikipedia.org/wiki/Lucky_Thirteen_attack) against the TLS protocol, where a short-circuiting comparison compromised the message encryption layer in many vulnerable implementations. You can generate and view the documentation in a browser with: ```shell dune build @doc xdg-open ./_build/default/_doc/_html/index.html ``` # Contents We found that we often had to duplicate the constant time `equal` function, and to avoid replication of code and ensure maintainability of the implementation, we decided to provide a little package which implements the `equal` function on `string`. Since then, we have added a number of other useful constant time implementations: - `compare_be` and `compare_le`: can be used to compare integers (or actual strings) of any size in either big-endian or little-endian representation. Regular string comparison (e.g. `String.compare`) is usually *short-circuiting*, which results in an adversary being able to learn the contents of compared strings by timing repeated executions. If the lengths do not match, the semantics for `compare_be` follow those of `String.compare`, and `compare_le` those of `String.compare (reverse str)`. - The `compare_be_with_len` and `compare_le_with_len` are similar, but does a constant time comparison of the lengths of the two strings and the `~len` parameter. If the lengths do not match, an exception is thrown (which leaks the fact that the lengths did not match, but not the lengths or the contents of the input operands). - `exists_uint8 : ?off -> f:(int -> bool) -> string -> bool`: implements the equivalent of `List.exists` on `string`, but executing in constant time with respect to the contents of the string and `?off`. The user provides a callback function that is given each byte as an integer, and is responsible for ensuring this function also operates in constant time. - `find_uint8`: similar to `exists_uint8`, but implementing the functionality of `List.find`: It returns the string index of the first match. - `divmod`: constant time division and modulo operations. The execution time of both operations in normal implementations are notoriously dependent on the operands. The `eqaf` implementation uses an algorithm ported from `SUPERCOP`. - `ascii_of_int32 : digits:int -> int32 -> string`: Turns the `int32` argument into a fixed-width (of length `= digits`) left-padded string containing the decimal representation, ex: `ascii_of_int32 ~digits:4 123l` is `"0123"`. Usually programming languages provide similar functionality (ex: `Int32.to_string`), but are vulnerable to timing attacks since they rely on division. This implementation is similar, but uses `Eqaf.divmod` to mitigate side channels. - `lowercase_ascii` and `uppercase_ascii` implement functionality equivalent to the identically named functions in `Stdlib.String` module, but without introducing a timing side channel. - `hex_of_string`: constant-time hex encoding. Normally hex encoding is implemented with either a table lookup or processor branches, both of which introduce side channels for an adversary to learn about the contents of the string being encoded. That can be a problem if an adversary can repeatedly trigger encoding of sensitive values in your application and measure the response time. - `string_of_hex`: constant-time hex decoding. Inverse of `hex_of_string`, but with support for decoding uppercase and lowercase letters alike. This package, if `cstruct` or `base-bigarray` is available, will make this `equal` function for them too (as `eqaf.cstruct` and `eqaf.bigarray`). A number of low-level primitives used by `Eqaf` are also exposed to enable you to construct your own constant time implementations: - `zero_if_not_zero : int -> int`: `(if n <> 0 then 0 else 1)`, or `!n` in the C programming language. - `one_if_not_zero : int -> int`: `(if n <> 0 then 1 else 0)`, or `!!n` in the C programming language. - `bool_of_int : int -> bool`, like `one_if_not_zero` but cast to `bool` - `int_of_bool : bool -> int`, inverse of `bool_of_int` - `select_int : int -> int -> int -> int`: `select_int choose_b a b` is a constant time utility for branching, but always executing all the branches (to ensure constant time operation): ```ocaml let select_int choose_b a b = if choose_b = 0 then a else b ``` - `select_a_if_in_range : ~low:int -> ~high:int -> n:int -> int -> int -> int` Similar to `select_int`, but checking for inclusion in a range rather than testing for zero - a CT version of: ```ocaml let select_a_if_in_range ~low ~high ~n a b = if low <= n && n <= high then a else b ``` ## Check tool To ensure correctness, `eqaf` ships with a test suite to measure the functions and comparing results both to the `Stdlib` implementations and to executions of the same function with similar length/size input. The goal is to try to spot implementation weaknesses that rely on the *values* of the function operands. The check tool will first attempt to calculate how many executions are required to get statistically sound numbers (sorting out random jitter from external factors like other programs executing on the computer). Then, using linear regression, we compare the results and verify that we did not spot differences: the regression coefficient should be close to `0.0`. You can test `eqaf` with this: ```sh $ dune exec check/check.exe ``` ### Q/A **Q** How to update `eqaf` implementation? **A** `eqaf` is fragile where the most important assumption is times needed to compute `equal`. So `eqaf` provides the `check` tool but results from it can be disturb by side-channel (like hypervisor). In a bare-metal environment, `check` strictly works and should return `0`. **Q** `eqaf` is slower than `String.compare`, it's possible to optimize it? **A** The final goal of `eqaf` is to provide a _safe_ equal function. Speed is clearly not what we want where we prefer to provide an implementation which does not leak informations like: where is the first byte which differs between `a` and `b`. **Q** Which attack `eqaf` prevents? **A** `eqaf` provide an equal function to avoid a timing attack. Most of equal or compare functions (like `String.compare`) leave at the first byte which differs. A possible attack is to see how long we need to compare two values, like an user input and a password. Logically, the longer this time is, the more user input is the password. So when we need to compare sensible values (like hashes), we should use something like `eqaf`. The distribution provides an example of this attack: ```sh $ dune exec attack/attack.exe Random: [|218;243;59;121;8;57;151;218;212;91;181;41;|]. 471cd8bc03992a31f8f0f0c55e9e477d 471cd8bc03992a31f8f0f0c55e9e477d ``` The first value is the hash, the second is what we found just by an introspection of time needed by our `equal` function. **Q** `eqaf` provides only equal function on `string`? **A** The first implementation use `string`, then, we copy/paste the code with `bigarray` and provide it only if `base-bigarray` is available. Finally, we provide an `equal` function for `cstruct` only if this package is available. So, it's not only about `string` but for some others data-structures. **Q** Why we need to do a linear regression to check assumptions on `eqaf`? **A** As we said, times are noisy by several side-computation (hypervisor, kernel, butterfly...). So, if we record two times how long we spend to compute `equal`, we will have 2 different values - close each others but different. So we need to have a bunch of samples and do an analyze on them to get an approximation. From that, we do 2 analyzes: - get the approximation where we compare 2 same values - get the approximation where we compare 2 different values From these results, we need to do an other analyze on these approximations to see if they are close each others or not. In the case of `eqaf`, it should be the case (and if it is, that means `eqaf` does not leak a time information according inputs). In the case of `String.compare`, we should have a big difference - and confirm expected behaviors. [digestif]: https://github.com/mirage/digestif.git eqaf-0.10/attack/000077500000000000000000000000001463277374600136405ustar00rootroot00000000000000eqaf-0.10/attack/attack.ml000066400000000000000000000042361463277374600154460ustar00rootroot00000000000000open Microtime let cycles = 1000 let length = 32 let range = [| "0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "a"; "b"; "c"; "d"; "e"; "f"; |] external random_seed : unit -> int array = "caml_sys_random_seed" let pp_int_array ppf arr = Fmt.pf ppf "[|" ; for i = 0 to pred (Array.length arr) do Fmt.pf ppf "%d;" arr.(i) done ; Fmt.pf ppf "|]" let () = let random_seed = random_seed () in Fmt.pr "Random: %a.\n%!" pp_int_array random_seed ; Random.full_init random_seed let random length = let get _ = range.(Random.int (Array.length range)).[0] in String.init length get exception Diff let equal a b = let ln = (min : int -> int -> int) (String.length a) (String.length b) in try for i = 0 to pred ln do if not (Char.equal a.[i] b.[i]) then raise_notrace Diff ; Unix.sleepf 0.0001 done ; String.length a = String.length b with Diff -> false let stabilize_garbage_collector () = let rec go limit last_heap_live_words = if limit <= 0 then failwith "Unable to stabilize the number of live words in the heap" ; Gc.compact () ; let stat = Gc.stat () in if stat.Gc.live_words <> last_heap_live_words then go (pred limit) stat.Gc.live_words in go 10 0 let compute a b = let t0 = microtime () in for _ = 0 to pred cycles do ignore (equal a b) done ; let t1 = microtime () in t1 - t0 let rec run hash prefix = let timers = Hashtbl.create cycles in for i = 0 to pred (Array.length range) do let m = prefix ^ range.(i) in stabilize_garbage_collector () ; Gc.compact () ; Gc.minor () ; let r = Sys.opaque_identity (compute m hash) in Hashtbl.add timers m r ; done ; let results = Hashtbl.fold (fun k v a -> (k, v) :: a) timers [] in let results = List.sort (fun (_, v0) (_, v1) -> (compare : int -> int -> int) v1 v0) results in match results with | [] -> assert false | (hit, _) :: _ -> if String.length hit = length then hit else run hash hit let exit_success = 0 let exit_failure = 1 let () = let hash = random length in print_endline hash ; let cracked = run hash "" in print_endline cracked ; if String.equal hash cracked then exit exit_success else exit exit_failure eqaf-0.10/attack/dune000066400000000000000000000002641463277374600145200ustar00rootroot00000000000000(library (name microtime) (modules microtime) (foreign_stubs (language c) (names microtime))) (executable (name attack) (modules attack) (libraries fmt unix microtime)) eqaf-0.10/attack/microtime.c000066400000000000000000000016531463277374600160010ustar00rootroot00000000000000/* Copyright (c) 2018 David Kaloper Meršinjak. All rights reserved. See LICENSE.md */ #include #if defined (__x86_64__) #define __x86__ #elif defined (__i686__) #warning Unmark uses unboxed native ints for low-level counters. Proceed with extreme caution. /* We can still do short benchmarks, tho. */ #define __x86__ #endif #if defined (__x86__) #include #endif #include #define __unit value unit __attribute__((unused)) #define nsec 1000000000 CAMLprim value caml_rdtsc (__unit) { #if defined (__x86__) return Val_long (__rdtsc ()); #else #warning Disabling RDTSC. return Val_long (0); #endif } /* This will break on some, or all, of: Windows, macOS, Mirage. * Please fill in the missing definitions. */ CAMLprim value caml_microtime (__unit) { struct timespec ts; clock_gettime (CLOCK_MONOTONIC, &ts); return Val_long ((intnat) ts.tv_sec * nsec + (intnat) ts.tv_nsec); } eqaf-0.10/attack/microtime.ml000066400000000000000000000001001463277374600161510ustar00rootroot00000000000000external microtime : unit -> int = "caml_microtime" [@@noalloc] eqaf-0.10/check/000077500000000000000000000000001463277374600134465ustar00rootroot00000000000000eqaf-0.10/check/README.md000066400000000000000000000127171463277374600147350ustar00rootroot00000000000000# Check tool - a small benchmark tool `eqaf` comes with a small benchmark tool to record time/tick spend by our functions: - `equal` - `compare` - `find_uint8` - `exists_uint8` This README.md wants to explain into details this tool. ## Some problems Try to record time spend is hard. Indeed, the operating system or, at least, the CPU can disturb this specific sample. Of course, into a virtualized operating-system, it's more difficult to rely on this sample. At least, `check.exe` should be executed into a bare-metal operating system. By this fact, when we try to record time/tick, we have some noise. It's easily understable by this simple code (assume a `Clock.now ()` function which gives you the current time). ```ocaml let bench f = let a = Clock.now () in f () ; let b = Clock.now () in Format.printf "%Ld ns.\n%!" (Int64.sub b a) ``` If you run `bench` two times, results are surely differents. The difference is small but enough to not be able to assert an equality. By this fact, try to check a predicate such as the _constant-time_ of our function is not so easy than that. **NOTE**: when we talk about _constant-time_, it's not an algorithmic _constant-time_ as we can believe. Currently, our equal function respects 2 predicates (and we will fold them into one term, _constant-time_): - for 2 strings where lengths differs, `equal` must spend `B` ns where `B` is a real constant - for 2 strings where lengths are equal but contents __can__ differs (or not), `equal` must spend `A * L + B` where `L` is a the length of input strings and `A` and `B` are real constants. Then, the first predicate should be a subset of the second where `L = 0`. ## Metrics Currently, `check` relies (when you compile it into a Linux operating-system) on ticks with the _Time Stamp Counter_ instead to use `clock_gettime`. For MacOS or Windows, we use `clock_gettime` or something equivalent. It's a special ASM instruction. So, we possibly not handle your architecture. In fact, `RDTSC` is more reliable than `clock_gettime`. ## Linear regresssion to infer `A * L + B` As we said, samples can be disturbed. So we are not able to just compare samples and see that they are equal or not. We must infer our equation `A * L + B` (eg. our _constant-time_ predicate). Our experience is done as follow: 1) we infer our equation `A1 * L + B1` when we compare 2 strictly equal strings 2) we infer our equation `A2 * L + B2` when we compare 2 strictly different strings Even if a computation of `Eqaf.equal` will return expected result (see _fuzzer_ and basic tests): 1) The function always returns `true` 2) The function always returns `false` We want to check that `A1 = A2` and `B1 = B2`, or, in other words, we infer the same equation independently than inputs (different or not) - if we check that time spent by `Eqaf.equal` does not depend on inputs. At the end, this check means that `Eqaf.equal` does not leak any information by the _time side channel_. To be able to infer our equation, we use a linear regression: 1) we follow a sequence to execute our function `R0 = 1`, `Rn = max (R(n-1) * 1.01, R(n-1) + 1)` when `R` is how many times we execute our function and `n` is our iteration Arbitrary, we do 750 iterations 2) For each iteration, we record our time metric as follow: `samples.(n).(0) <- tick` `samples.(n).(1) <- R` 3) At the end, from these samples, we can infer by a linear regression our equation. The resulted coefficient of determination should be higher than 0.95. It tells to us that the infered equation is good enough. ## A counter example However, we should show a counter example of our results and we can do that with `String.equal`. So we redo the experience with `String.equal` and we should have an inequality betwen our equations. **NOTE**: If 2 strings are physically equal, `String.equal` does not introspect contents and it returns directly `true`. So we ensure that strings can be equal (and they are) but they are not physically equal. ## Predictible results When we generate different strings, we do that randomly. The first diff character can be at the beginning of the string or at the end. Because of that, time spent by `String.equal` is not very predictable - it depends, as we want to solve, from contents. By this way, `check.exe` use a constant seed to generate strings to be more predictable about results. ## How to compare our equations Come back earlier, we want to check that our first equation when inputs are equal is the same than our equation when inputs are not equal. However, due to our problems (noise on our samples), we can not strictly assert that they are equal. However, we can infer the difference between them with 2 techniques: 1) CCEA technique 2) SPSS technique Both are explained into `check.ml` and they are not really formalized as we expect. However, they give to us a way to compare our results. From them, it comes a _coefficient_ which should be between `30.0` and `30.0`. Of course, this segment is arbitrary but it's far from what we can get when we do the same process with `String.equal`. So if we don't have a good _coefficient_ with the CCEA technique, we restart the process with the SPSS technique as the final result. ## Tries At the end, if we have a _good_ final coefficient, we can say that our function respects our predicate. If the coefficient of the determination is not good enough (`<= 0.95`), we restart the process. If we don't have a good final _coefficient_, we restart the process. At least, we give 20 chances to our process to check our predicate. eqaf-0.10/check/bench.ml000066400000000000000000000076101463277374600150630ustar00rootroot00000000000000let seed = "4EygbdYh+v35vvrmD9YYP4byT5E3H7lTeXJiIj+dQnc=" let seed = Base64.decode_exn seed let seed = let res = Array.make (String.length seed / 2) 0 in for i = 0 to (String.length seed / 2) - 1 do res.(i) <- (Char.code seed.[i * 2] lsl 8) lor Char.code seed.[(i * 2) + 1] done; res let () = let random_seed = seed in Random.full_init random_seed let random length = let get _ = match Random.int (10 + 26 + 26) with | n when n < 10 -> Char.(chr (code '0' + n)) | n when n < 10 + 26 -> Char.(chr (code 'a' + n - 10)) | n -> Char.(chr (code 'A' + n - 10 - 26)) in String.init length get open Bechamel open Toolkit let hash_eq_0 = random 4096 let hash_eq_1 = Bytes.to_string (Bytes.of_string hash_eq_0) let chr_into_hash_eq_0 = hash_eq_0.[Random.int 4096] let hash_neq_0 = random 4096 let hash_neq_1 = let rec go limit = if limit <= 0 then failwith "Impossible to generate different hashes."; let res = random 4096 in if res = hash_neq_0 then go (pred limit) else res in go 10 let random_chr = let rec go limit = if limit <= 0 then failwith "Impossible to generate a byte which does not appear into hash_neq_0."; let res = Char.chr (Random.int 256) in if not (String.contains hash_neq_0 res) then res else go (pred limit) in go 10 let test_equal0 = Test.make ~name:"equal" (Staged.stage @@ fun () -> Eqaf.equal hash_eq_0 hash_eq_1) let test_equal1 = Test.make ~name:"not equal" (Staged.stage @@ fun () -> Eqaf.equal hash_neq_0 hash_neq_1) let cfg = Benchmark.cfg ~start:100 let test_compare0 = Test.make ~name:"equal" (Staged.stage @@ fun () -> Eqaf.compare_be hash_eq_0 hash_eq_1) let test_compare1 = Test.make ~name:"not equal" (Staged.stage @@ fun () -> Eqaf.compare_be hash_neq_0 hash_neq_1) let f_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0 let f_neq_0 (v : int) = v = Char.code random_chr let test_exists0 = Test.make ~name:"equal" (Staged.stage @@ fun () -> Eqaf.exists_uint8 ~f:f_eq_0 hash_eq_0) let test_exists1 = Test.make ~name:"not equal" (Staged.stage @@ fun () -> Eqaf.exists_uint8 ~f:f_neq_0 hash_neq_0) let f_hash_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0 let f_random (v : int) = v = Char.code random_chr let test_find0 = Test.make ~name:"equal" (Staged.stage @@ fun () -> Eqaf.find_uint8 ~f:f_hash_eq_0 hash_eq_0) let test_find1 = Test.make ~name:"not equal" (Staged.stage @@ fun () -> Eqaf.find_uint8 ~f:f_random hash_neq_0) let benchmark () = let ols = Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |] in let instances = Instance.[ monotonic_clock ] in let cfg = Benchmark.cfg ~limit:2000 ~stabilize:true ~quota:(Time.second 1.) ~start:1000 ~kde:(Some 1000) () in let test_equal = Test.make_grouped ~name:"equal" ~fmt:"%s %s" [ test_equal0; test_equal1 ] in let test_compare = Test.make_grouped ~name:"compare" ~fmt:"%s %s" [ test_compare0; test_compare1 ] in let test_exists = Test.make_grouped ~name:"exists" ~fmt:"%s %s" [ test_exists0; test_exists1 ] in let test_find = Test.make_grouped ~name:"find" ~fmt:"%s %s" [ test_find0; test_find1 ] in let raw_results = Benchmark.all cfg instances (Test.make_grouped ~name:"benchmark" ~fmt:"%s %s" [ test_equal; test_compare; test_exists; test_find ]) in let results = List.map (fun instance -> Analyze.all ols instance raw_results) instances in let pr_bench name value = Format.printf {|{"results": [{"name": "eqaf", "metrics": [{"name": "%s", "value": %f, "units": "ns"}]}]}@.|} name value in let results = Analyze.merge ols instances results in let timings = Hashtbl.find results "monotonic-clock" in Hashtbl.iter (fun c v -> match Analyze.OLS.estimates v with | None -> () | Some ts -> List.iter (pr_bench c) ts) timings; () let () = benchmark ()eqaf-0.10/check/benchmark.ml000066400000000000000000000032701463277374600157340ustar00rootroot00000000000000type t = V : (unit -> 'a) -> t let stabilize_garbage_collector () = let rec go limit last_heap_live_words = if limit <= 0 then failwith "Unable to stabilize the number of live words in the heap" ; Gc.compact () ; let stat = Gc.stat () in if stat.Gc.live_words <> last_heap_live_words then go (pred limit) stat.Gc.live_words in go 10 0 let runnable f i = for _ = 1 to i do ignore @@ Sys.opaque_identity (f ()) done [@@inline] let tmp = Bytes.create 40 let reset () = Bytes.fill tmp 0 40 ' ' let print ppf (n, m) = let l = n * 40 / m in Bytes.fill tmp 0 l '#' ; Fmt.pf ppf "[%s] %d%%%!" (Bytes.unsafe_to_string tmp) (n * 100 / m) let samples = 750 let run t = let idx = ref 0 in let run = ref 0 in let (V fn) = t in let m = Array.create_float (samples * 2) in reset () ; Fmt.pr "%a" print (0, samples) ; while !idx < samples do let current_run = !run in let current_idx = !idx in (* XXX(dinosaure): GC and prints can put noise on our samples. - GC is not predictable - prints can add a latency on I/O *) (* Fmt.pr "\r%a" print (current_idx, samples) ; *) (* if current_run = 0 then stabilize_garbage_collector () ; *) let time_0 = Clock.now () in runnable fn current_run ; let time_1 = Clock.now () in m.((current_idx * 2) + 0) <- float_of_int current_run ; m.((current_idx * 2) + 1) <- Int64.to_float (Int64.sub time_1 time_0) ; let next = (max : int -> int -> int) (int_of_float (float_of_int current_run *. 1.01)) (succ current_run) in run := next ; incr idx done ; Fmt.pr "\r%a\n%!" print (samples, samples) ; Array.init samples (fun i -> [| m.((i * 2) + 0); m.((i * 2) + 1) |]) eqaf-0.10/check/check.ml000066400000000000000000000405221463277374600150600ustar00rootroot00000000000000let exit_success = 0 let exit_failure = 1 external random_seed : unit -> int array = "caml_sys_random_seed" let pp_int_array ppf arr = Fmt.pf ppf "[|" ; for i = 0 to pred (Array.length arr) do Fmt.pf ppf "%d;" arr.(i) done ; Fmt.pf ppf "|]" (* XXX(dinosaure): deterministic generation. It appears that some calls of [check/check.exe] does not get same results, mostly about [String.*] functions. As we understand implementation of them, it's an expected behavior but it puts some noises when we try to introspect results on different platforms. So all inputs are generated with this seed to be able to get as much as we can reproducible outputs. *) let seed = "4EygbdYh+v35vvrmD9YYP4byT5E3H7lTeXJiIj+dQnc=" let seed = Base64.decode_exn seed let seed = let res = Array.make (String.length seed / 2) 0 in for i = 0 to (String.length seed / 2) - 1 do res.(i) <- (Char.code seed.[i * 2] lsl 8) lor (Char.code seed.[i * 2 + 1]) done ; res let () = let random_seed = seed in Fmt.pr "Random: %a.\n%!" pp_int_array random_seed ; Random.full_init random_seed let random length = let get _ = match Random.int (10 + 26 + 26) with | n when n < 10 -> Char.(chr (code '0' + n)) | n when n < 10 + 26 -> Char.(chr (code 'a' + n - 10)) | n -> Char.(chr (code 'A' + n - 10 - 26)) in String.init length get let hash_eq_0 = random 4096 let hash_eq_1 = Bytes.to_string (Bytes.of_string hash_eq_0) let chr_into_hash_eq_0 = hash_eq_0.[Random.int 4096] let int32_into_hash_eq_0 = Unsafe.get_int32_ne (Bytes.of_string hash_eq_0) (Random.int (4096-4)) let int32_into_hash_eq_1 = Unsafe.get_int32_ne (Bytes.of_string hash_eq_1) (Random.int (4096-4)) let int14_into_hash_eq_0 = Unsafe.get_int32_ne (Bytes.of_string hash_eq_0) (Random.int (4096-4)) |> (Int32.logand 0xfffl) let int14_into_hash_eq_1 = Unsafe.get_int32_ne (Bytes.of_string hash_eq_1) (Random.int (4096-4)) |> (Int32.logand 0xfffl) let () = assert (hash_eq_0 != hash_eq_1) let () = assert (hash_eq_0 = hash_eq_1) let () = assert (String.contains hash_eq_0 chr_into_hash_eq_0) let hash_neq_0 = random 4096 let hash_neq_1 = let rec go limit = if limit <= 0 then failwith "Impossible to generate different hashes." ; let res = random 4096 in if res = hash_neq_0 then go (pred limit) else res in go 10 let random_chr = let rec go limit = if limit <= 0 then failwith "Impossible to generate a byte which does not appear into hash_neq_0." ; let res = Char.chr (Random.int 256) in if not (String.contains hash_neq_0 res) then res else go (pred limit) in go 10 let () = assert (hash_neq_0 <> hash_neq_1) let () = assert (not (String.contains hash_neq_0 random_chr)) let error_msgf fmt = Fmt.kstrf (fun err -> Error (`Msg err)) fmt let merge m0 m1 = let cons_0 r = [| 0.; r.(0); r.(1) |] in let cons_1 r = [| 1.; r.(0); r.(1) |] in Array.(append (map cons_0 m0) (map cons_1 m1)) let test_spss fn_0 fn_1 = Fmt.pr "> Start benchmarks on [fn⁰].\n%!" ; let m0 = Benchmark.run fn_0 in Fmt.pr "> Start benchmarks on [fn¹].\n%!" ; let m1 = Benchmark.run fn_1 in Fmt.pr "> Merge results.\n%!" ; let m = merge m0 m1 in let m = Array.map (fun r -> [| r.(0); r.(1); r.(2); r.(0) *. r.(1) |]) m in Fmt.pr "> Start linear regression.\n%!" ; match Linear_algebra.ols (fun m -> m.(2)) [|(fun m -> m.(0)); (fun m -> m.(1)); (fun m -> m.(3))|] m with | Ok (estimates, r_square) -> if r_square >= 0.95 then Ok estimates else error_msgf "r² (%f) is bad" r_square | Error (`Msg _) as err -> err let test_ccea fn_0 fn_1 = Fmt.pr "> Start benchmarks on [fn⁰].\n%!" ; let m0 = Benchmark.run fn_0 in Fmt.pr "> Start benchmarks on [fn¹].\n%!" ; let m1 = Benchmark.run fn_1 in match Linear_algebra.ols (fun m -> m.(1)) [|(fun m -> m.(0))|] m0, Linear_algebra.ols (fun m -> m.(1)) [|(fun m -> m.(0))|] m1 with | Ok (estimates_0, r_square_0), Ok (estimates_1, r_square_1) -> Fmt.epr "> Calculating Z.\n%!" ; let z = (estimates_0.(0) -. estimates_1.(0)) /. sqrt ((r_square_0 ** 2.) +. (r_square_1 ** 2.)) in Ok z | (Error (`Msg _) as err), Ok _ -> err | Ok _, (Error (`Msg _) as err) -> err | Error (`Msg err0), Error (`Msg err1) -> Fmt.epr "Got errors for while processing both.\n%!" ; Fmt.epr "B¹: %s.\n%!" err0 ; Fmt.epr "B²: %s.\n%!" err1 ; exit exit_failure let ccea ~reset ~switch ~name_of_fns_0 ~name_of_fns_1 fns_0 fns_1 = Fmt.pr "> Start to test %s (B¹).\n%!" name_of_fns_0 ; reset () ; let eqaf = test_ccea (fst fns_0) (snd fns_0) in switch () ; Fmt.pr "> Start to test %s (B²).\n%!" name_of_fns_1 ; let stdlib = test_ccea (fst fns_1) (snd fns_1) in match eqaf, stdlib with | Ok eqaf, Ok stdlib -> Ok (eqaf, stdlib) | Error (`Msg err), Ok _ -> Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_0 err ; Error () | Ok _, Error (`Msg err) -> Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_1 err ; Error () | Error (`Msg err0), Error (`Msg err1) -> Fmt.epr "Got errors while processing both:\n%!" ; Fmt.epr "B¹> %s.\n%!" err0 ; Fmt.epr "B²> %s.\n%!" err1 ; Error () let spss ~reset ~switch ~name_of_fns_0 ~name_of_fns_1 fns_0 fns_1 = Fmt.pr "> Start to test %s (B¹).\n%!" name_of_fns_0 ; reset () ; let eqaf = test_spss (fst fns_0) (snd fns_0) in switch () ; Fmt.pr "> Start to test %s (B²).\n%!" name_of_fns_1 ; let stdlib = test_spss (fst fns_1) (snd fns_1) in match eqaf, stdlib with | Ok eqaf, Ok stdlib -> Fmt.pr "%s: %f ns/run.\n%!" name_of_fns_0 eqaf.(1) ; Fmt.pr "%s: %f ns/run.\n%!" name_of_fns_1 stdlib.(1) ; Ok (eqaf.(2), stdlib.(2)) | Error (`Msg err), Ok _ -> Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_0 err ; Error () | Ok _, Error (`Msg err) -> Fmt.epr "Got an error while processing %s: %s\n%!" name_of_fns_1 err ; Error () | Error (`Msg err0), Error (`Msg err1) -> Fmt.epr "Got errors while processing both:\n%!" ; Fmt.epr "B¹> %s.\n%!" err0 ; Fmt.epr "B²> %s.\n%!" err1 ; Error () (* XXX(dinosaure): this program try to compute diff between 2 coefficient regressions: - 1: time needed to compute equal function on 2 same values ([_eq]) - 2: time needed to compute equal function on 2 different values ([_neq]) ### Samples We have 2 ways to compute it. The first is to compute a regression equation which includes group 1 and group 2. A initial regression equation can be done to know how long [equal] lasts: regression /dep time // m.(1) /method = enter run // m.(0) It's a basic linear regression where we run 1..N times the function with same inputs. Then, we have a matrix such as: m.(n).(0) <- time m.(n).(1) <- run Obviously, if our function is /constant-time/, you should have something like: y = m.(x).(0) = a * m.(x).(1) + b To infer the curve, we use the linear regression for each points. Then, we collect same samples but with [_neq] values. Now, the goal is to see that [_eq]: y = a * x + b and [_neq]: y = a * x + b are ~ equals. For that, we have 2 ways. ### SPSS The first way to compare group 1 ([_eq]) and group 2 ([_neq]): we need to insert a dummy variable [kind] where it is equal to [0.0] when it's owned by the group 1 and [1.1] is owned by the group 2 (see [cons_*] function). Finally, we had a new variable which is the product between [kind] ([m.(0)]) and [run] ([m.(1)]). Finally, we can start to compute a regression equation where [time] will be the responder and [kind], [run] and [kind * run] will be predictors: regression /dep time // m.(2) /method = enter kind run (kind * run) // m.(0) m.(1) m.(3) Time of [equal] will be available on [estimates.(1)] and diff will be available on [estimates.(2)]. [compare_spss] checks r² ([>= 0.95]) and main program checks if the diff is between [-30.0] and [30.0]. ### CCEA The second way to compare group 1 and group 2: it consists to compute basic regression equation to know how long [equal] lasts. Then, we will compute [Z] which is equal to: B¹-B² --------------- sqrt(r¹² + r²²) Where B¹ and B² are regression coefficients for [_eq] and [_neq] and r¹ and r² are standard error of B¹ and B². Then, main program, as the first way, checks if [Z] is between [-30.0] and [30.0]. NOTE about SPSS: This is the name of a software which explain how to compare results of linear regression. NOTE about CCEA: I don't remmember when I got this name but it seems close to Vuong test. NOTE about virtualization: Virtual context (VirtualBox, VMWare, Xen or qemu) can delayed CPU instructions and tricks on the time spended to execute them. By this fact, time counter lies about time needed to compute [equal] function. So, in a virtual context we can have some noises when we record measures (in [Benchmark]). NOTE about bare-metal: In a bare-metal context, results are more determinists (but they are not completely fixed). In fact, it depends on the system-scheduler which can prioritize an other process while [check/check.exe] is executed. For all of these reasons, [check/check.exe] is really fragile and can not work in your context - however, a CI with [eqaf] is provided is we surely are aware of it and results. *) module Make (Check : sig type ret val eqaf_name : string val stdlib_name : string val reset : unit -> unit val switch : unit -> unit val eqaf_true : unit -> ret val eqaf_false : unit -> ret val stdlib_true : unit -> ret val stdlib_false : unit -> ret end) = struct open Check let last_chance () = let open Benchmark in match ccea ~reset:Check.reset ~switch:Check.switch ~name_of_fns_0:eqaf_name ~name_of_fns_1:stdlib_name (V eqaf_true, V eqaf_false) (V stdlib_true, V stdlib_false) with | Error () -> exit_failure | Ok (eqaf, stdlib) -> if eqaf >= -30. && eqaf <= 30. then ( Fmt.pr "Z¹ = %f, Z² = %f.\n%!" eqaf stdlib ; exit_success ) else ( Fmt.pr "Z¹ = %f, Z² = %f.\n%!" eqaf stdlib ; exit_failure ) let test () = let open Benchmark in match spss ~reset:Check.reset ~switch:Check.switch ~name_of_fns_0:eqaf_name ~name_of_fns_1:stdlib_name (V eqaf_true, V eqaf_false) (V stdlib_true, V stdlib_false) with | Error () -> last_chance () | Ok (eqaf, stdlib) -> if eqaf >= -30. && eqaf <= 30. then ( Fmt.pr "B¹ = %f, B² = %f.\n%!" eqaf stdlib ; exit_success ) else ( Fmt.pr "Fail with B¹ = %f, B² = %f.\n%!" eqaf stdlib ; Fmt.pr "> Start to compute Z.\n%!" ; last_chance () ) end module Equal = Make(struct type ret = bool let eqaf_name = "Eqaf.equal" let stdlib_name = "String.equal" let reset = ignore and switch = ignore let stdlib_true () = String.equal hash_eq_0 hash_eq_1 let stdlib_false () = for _ = 1 to 100 do let _ = String.equal hash_neq_0 hash_neq_1 in () done ; String.equal hash_neq_0 hash_neq_1 let eqaf_true () = Eqaf.equal hash_eq_0 hash_eq_1 let eqaf_false () = Eqaf.equal hash_neq_0 hash_neq_1 end) module Compare = Make(struct type ret = int let eqaf_name = "Eqaf.compare" let stdlib_name = "String.compare" let reset = ignore and switch = ignore let stdlib_true () = String.compare hash_eq_0 hash_eq_1 let stdlib_false () = for _ = 1 to 100 do let _ = String.compare hash_neq_0 hash_neq_1 in () done ; String.compare hash_neq_0 hash_neq_1 let eqaf_true () = Eqaf.compare_be hash_eq_0 hash_eq_1 let eqaf_false () = Eqaf.compare_be hash_neq_0 hash_neq_1 end) module Exists = Make(struct type ret = bool let eqaf_name = "Eqaf.exists_uint8" let stdlib_name = "String.contains" let constant = ref (Char.code chr_into_hash_eq_0) let reset () = constant := Char.code chr_into_hash_eq_0 let switch () = constant := Char.code random_chr let stdlib_true () = String.contains hash_eq_0 chr_into_hash_eq_0 let stdlib_false () = String.contains hash_neq_0 random_chr let f (v : int) = v = !constant let eqaf_true () = Eqaf.exists_uint8 ~f hash_eq_0 let eqaf_false () = Eqaf.exists_uint8 ~f hash_neq_0 end) module Find = Make(struct type ret = int let eqaf_name = "Eqaf.find_uint8" let stdlib_name = "String.index" let switch () = () let reset () = () let stdlib_true () = String.index hash_eq_0 chr_into_hash_eq_0 let stdlib_false () = try String.index hash_neq_0 random_chr with Not_found -> (-1) let f_hash_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0 let f_random (v : int) = v = Char.code random_chr let eqaf_true () = Eqaf.find_uint8 ~f:f_hash_eq_0 hash_eq_0 let eqaf_false () = Eqaf.find_uint8 ~f:f_random hash_neq_0 end) module Divmod32 = Make(struct type ret = int32 * int32 let eqaf_name = "Eqaf.divmod" let stdlib_name = "Int32.unsigned_div,Int32.unsigned_rem" let switch () = () let reset () = () (* These are here for compat with OCaml <= 4.09 from >= they can be replaced by Int32.unsigned_div Int32.unsigned_rem *) let int32_div_unsigned n d = let sub,min_int = Int32.(sub,min_int)in let int32_unsigned_compare n m = Int32.compare (sub n min_int) (sub m min_int) in if d < 0_l then if int32_unsigned_compare n d < 0 then 0_l else 1_l else let q = let open Int32 in shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in let r = sub n (Int32.mul q d) in if int32_unsigned_compare r d >= 0 then Int32.succ q else q let int32_rem_unsigned n d = Int32.sub n (Int32.mul (int32_div_unsigned n d) d) (* TODO *) let stdlib_true () = let x, m = int32_into_hash_eq_0, int14_into_hash_eq_0 in int32_div_unsigned x m, int32_rem_unsigned x m let stdlib_false () = let x, m = int32_into_hash_eq_1, int14_into_hash_eq_1 in int32_div_unsigned x m, int32_rem_unsigned x m let eqaf_true () = Eqaf.divmod ~x:int32_into_hash_eq_0 ~m:int14_into_hash_eq_0 let eqaf_false () = Eqaf.divmod ~x:int32_into_hash_eq_1 ~m:int14_into_hash_eq_1 end) module Ascii_int32 = Make(struct type ret = string let eqaf_name = "Eqaf.ascii_of_int32" let stdlib_name = "Int32.to_string" let switch () = () let reset () = () (* TODO setting 0x8000 bit ensures five digits. We need a constant amount of digits to specify ~digits because we don't have a [Int32.to_string] that left-pads. Maybe we can use [Format.sprintf] ? *) let true_int = Int32.logand 0x8000l int14_into_hash_eq_0 let false_int = Int32.logand 0x8000l int14_into_hash_eq_1 let stdlib_true () = Int32.to_string true_int let stdlib_false () = Int32.to_string false_int let eqaf_true () = Eqaf.ascii_of_int32 ~digits:5 true_int let eqaf_false () = Eqaf.ascii_of_int32 ~digits:5 false_int end) let limit = 20 let () = let rec _0 tried = if tried > 20 then invalid_arg "Too many tried for Eqaf.equal" ; let res = Equal.test () in if res = exit_success then tried else _0 (succ tried) in let rec _1 tried = if tried > 20 then invalid_arg "Too many tried for Eqaf.compare" ; let res = Compare.test () in if res = exit_success then tried else _1 (succ tried) in let rec _2 tried = if tried > 20 then invalid_arg "Too many tried for Eqaf.exists" ; let res = Exists.test () in if res = exit_success then tried else _2 (succ tried) in let rec _3 tried = if tried > 20 then invalid_arg "Too many tried for Eqaf.find_uint8" ; let res = Find.test () in if res = exit_success then tried else _3 (succ tried) in let rec _4 tried = if tried > 20 then invalid_arg "Too many tried for Eqaf.divmod" ; let res = Divmod32.test () in if res = exit_success then tried else _4 (succ tried) in let pr_bench name value = Fmt.pr {|{"results": [{"name": "check", "metrics": [{"name": "%s", "value": %d}]}]}@.|} name value in let _0 = _0 1 in Fmt.pr "%d trial(s) for Eqaf.equal.\n%!" _0 ; pr_bench "equal" _0 ; let _1 = _1 1 in Fmt.pr "%d trial(s) for Eqaf.compare.\n%!" _1 ; pr_bench "compare" _1 ; let _2 = _2 1 in Fmt.pr "%d trial(s) for Eqaf.exists.\n%!" _2 ; pr_bench "exists" _2 ; let _3 = _3 1 in Fmt.pr "%d trial(s) for Eqaf.find_uint8.\n%!" _3 ; pr_bench "find_uint8" _3 ; let _4 = _4 1 in Fmt.pr "%d trial(s) for Eqaf.divmod.\n%!" _4 ; pr_bench "divmod" _4 ; exit exit_successeqaf-0.10/check/dune000066400000000000000000000005361463277374600143300ustar00rootroot00000000000000(executable (name check) (modules check linear_algebra benchmark fmt unsafe) (libraries eqaf base64 clock)) (executable (name bench) (modules bench) (libraries bechamel eqaf base64)) (rule (copy %{read:../config/which-unsafe-file} unsafe.ml)) (rule (alias runbench) (package eqaf) (deps (:check check.exe)) (action (run %{check}))) eqaf-0.10/check/fmt.ml000066400000000000000000000002211463277374600145610ustar00rootroot00000000000000let pr fmt = Format.printf fmt let epr fmt = Format.eprintf fmt let pf ppf fmt = Format.fprintf ppf fmt let kstrf k fmt = Format.kasprintf k fmt eqaf-0.10/check/linear_algebra.ml000066400000000000000000000072441463277374600167360ustar00rootroot00000000000000(* Code under Apache License 2.0 - Jane Street Group, LLC *) let col_norm a column = let acc = ref 0. in for i = 0 to Array.length a - 1 do let entry = a.(i).(column) in acc := !acc +. (entry *. entry) done ; sqrt !acc let col_inner_prod t j1 j2 = let acc = ref 0. in for i = 0 to Array.length t - 1 do acc := !acc +. (t.(i).(j1) *. t.(i).(j2)) done ; !acc let qr_in_place a = let m = Array.length a in if m = 0 then ([||], [||]) else let n = Array.length a.(0) in let r = Array.make_matrix n n 0. in for j = 0 to n - 1 do let alpha = col_norm a j in r.(j).(j) <- alpha ; let one_over_alpha = 1. /. alpha in for i = 0 to m - 1 do a.(i).(j) <- a.(i).(j) *. one_over_alpha done ; for j2 = j + 1 to n - 1 do let c = col_inner_prod a j j2 in r.(j).(j2) <- c ; for i = 0 to m - 1 do a.(i).(j2) <- a.(i).(j2) -. (c *. a.(i).(j)) done done done ; (a, r) let qr ?(in_place = false) a = let a = if in_place then a else Array.map Array.copy a in qr_in_place a let mul_mv ?(trans = false) a x = let rows = Array.length a in if rows = 0 then [||] else let cols = Array.length a.(0) in let m, n, get = if trans then let get i j = a.(j).(i) in (cols, rows, get) else let get i j = a.(i).(j) in (rows, cols, get) in if n <> Array.length x then failwith "Dimension mismatch" ; let result = Array.make m 0. in for i = 0 to m - 1 do let v, _ = Array.fold_left (fun (acc, j) x -> (acc +. (get i j *. x), succ j)) (0., 0) x in result.(i) <- v done ; result let is_nan v = match classify_float v with FP_nan -> true | _ -> false let error_msg msg = Error (`Msg msg) let triu_solve r b = let m = Array.length b in if m <> Array.length r then error_msg "triu_solve R b requires R to be square with same number of rows as b" else if m = 0 then Ok [||] else if m <> Array.length r.(0) then error_msg "triu_solve R b requires R to be a square" else let sol = Array.copy b in for i = m - 1 downto 0 do sol.(i) <- sol.(i) /. r.(i).(i) ; for j = 0 to i - 1 do sol.(j) <- sol.(j) -. (r.(j).(i) *. sol.(i)) done done ; if Array.exists is_nan sol then error_msg "triu_solve detected NaN result" else Ok sol let ols ?(in_place = false) a b = let q, r = qr ~in_place a in triu_solve r (mul_mv ~trans:true q b) let make_lr_inputs responder predictors m = Array.init (Array.length m) (fun i -> Array.map (fun a -> a m.(i)) predictors), Array.init (Array.length m) (fun i -> responder m.(i)) let r_square m responder predictors r = let predictors_matrix, responder_vector = make_lr_inputs responder predictors m in let sum_responder = Array.fold_left ( +. ) 0. responder_vector in let mean = sum_responder /. float (Array.length responder_vector) in let tot_ss = ref 0. in let res_ss = ref 0. in let predicted i = let x = ref 0. in for j = 0 to Array.length r - 1 do x := !x +. (predictors_matrix.(i).(j) *. r.(j)) done ; !x in for i = 0 to Array.length responder_vector - 1 do tot_ss := !tot_ss +. ((responder_vector.(i) -. mean) ** 2.) ; res_ss := !res_ss +. ((responder_vector.(i) -. predicted i) ** 2.) done ; 1. -. (!res_ss /. !tot_ss) let ols responder predictors m = let matrix, vector = make_lr_inputs responder predictors m in match ols ~in_place:true matrix vector with | Ok estimates -> let r_square = r_square m responder predictors estimates in Ok (estimates, r_square) | Error _ as err -> err eqaf-0.10/check/unsafe_pre407.ml000066400000000000000000000001051463277374600163560ustar00rootroot00000000000000external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32" eqaf-0.10/check/unsafe_pre408.ml000066400000000000000000000001041463277374600163560ustar00rootroot00000000000000external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32" eqaf-0.10/check/unsafe_stable.ml000066400000000000000000000000561463277374600166140ustar00rootroot00000000000000let get_int32_ne b i = Bytes.get_int32_ne b i eqaf-0.10/clock/000077500000000000000000000000001463277374600134645ustar00rootroot00000000000000eqaf-0.10/clock/clock_linux.ml000066400000000000000000000002541463277374600163310ustar00rootroot00000000000000external clock_linux_get_time : unit -> (int64[@unboxed]) = "clock_linux_get_time_byte" "clock_linux_get_time_native" [@@noalloc] let now () = clock_linux_get_time () eqaf-0.10/clock/clock_linux_stubs.c000066400000000000000000000024641463277374600173700ustar00rootroot00000000000000#define CAML_NAME_SPACE #include #include #include #include #include #include #include #include #include #ifndef __unused #define __unused(x) x __attribute((unused)) #endif #define __unit() value __unused(unit) CAMLprim value clock_linux_get_time_byte(__unit ()) { struct timespec ts; if (clock_gettime(CLOCK_MONOTONIC, &ts)) caml_invalid_argument("clock: unsupported clock"); return caml_copy_int64(ts.tv_sec * 1000000000LL + ts.tv_nsec); } // XXX(dinosaure): commented because to be able to compile the test into any // platform (ARM) // // uint64_t // clock_linux_get_tick(__unit ()) // { // // struct timespec ts; // unsigned hi, lo; // __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi)); // // // XXX(dinosaure): [clock_gettime] costs a lot and are // // not really precise. [rdtsc] (Read Time Stamp Counter) // // is more reliable. // // return (((unsigned long long) lo) | (((unsigned long long) hi) << 32)); // } uint64_t clock_linux_get_time_native(__unit ()) { struct timespec ts; (void) clock_gettime(CLOCK_MONOTONIC, &ts); // XXX(dinosaure): assume that it will never fail. // [caml_invalid_argument] allocs. return (ts.tv_sec * 1000000000LL + ts.tv_nsec); } eqaf-0.10/clock/clock_mach.ml000066400000000000000000000003021463277374600160740ustar00rootroot00000000000000external clock_mach_init : unit -> unit = "clock_mach_init" external clock_mach_get_time : unit -> int64 = "clock_mach_get_time" let () = clock_mach_init () let now () = clock_mach_get_time () eqaf-0.10/clock/clock_mach_stubs.c000066400000000000000000000013461463277374600171370ustar00rootroot00000000000000#ifdef __MACH__ #include #include #include #endif #include #include #include #include // (c) Daniel Bünzli static mach_timebase_info_data_t s = { 0 }; CAMLprim value clock_mach_init(value unit) { if (mach_timebase_info (&s) != KERN_SUCCESS) caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info () failed")); if (s.denom == 0) caml_raise_sys_error (caml_copy_string("clock_mach_init: mach_timebase_info_data.denom is 0")); return Val_unit; } CAMLprim value clock_mach_get_time(value unit) { uint64_t now; now = mach_absolute_time(); return caml_copy_int64(now * s.numer / s.denom); } eqaf-0.10/clock/clock_windows.ml000066400000000000000000000003241463277374600166620ustar00rootroot00000000000000external clock_windows_get_time : unit -> int64 = "clock_windows_get_time" external clock_windows_init : unit -> unit = "clock_windows_init" let () = clock_windows_init () let now () = clock_windows_get_time () eqaf-0.10/clock/clock_windows_stubs.c000066400000000000000000000010121463277374600177070ustar00rootroot00000000000000#include #include #include #include static LARGE_INTEGER frequency; CAMLprim value clock_windows_init(value unit) { QueryPerformanceFrequency(&frequency); frequency.QuadPart = 1000000000L / frequency.QuadPart; return Val_unit; } CAMLprim value clock_windows_get_time(value unit) { CAMLparam0(); CAMLlocal1(res); LARGE_INTEGER now; QueryPerformanceCounter(&now); res = caml_copy_int64(now.QuadPart * frequency.QuadPart); CAMLreturn(res); } eqaf-0.10/clock/dune000066400000000000000000000006411463277374600143430ustar00rootroot00000000000000(rule (targets clock.ml clock_stubs.c clock.sexp) (deps (:select select/select.ml) clock_linux.ml clock_linux_stubs.c clock_windows.ml clock_windows_stubs.c clock_mach.ml clock_mach_stubs.c) (action (run %{ocaml} %{select} --system %{ocaml-config:system} -o clock))) (library (name clock) (modules clock) (foreign_stubs (language c) (names clock_stubs) (flags (:include clock.sexp)))) eqaf-0.10/clock/select/000077500000000000000000000000001463277374600147435ustar00rootroot00000000000000eqaf-0.10/clock/select/select.ml000066400000000000000000000040101463277374600165470ustar00rootroot00000000000000let invalid_arg fmt = Format.ksprintf (fun s -> invalid_arg s) fmt let load_file filename = let ic = open_in_bin filename in let ln = in_channel_length ic in let rs = Bytes.create ln in let () = really_input ic rs 0 ln in Bytes.unsafe_to_string rs let sexp_linux = "(-lrt)" let sexp_freebsd = "()" let sexp_windows = "()" let sexp_mach = "()" let () = let system, output = try match Sys.argv with | [|_; "--system"; system; "-o"; output|] -> let system = match system with | "linux" | "elf" -> `Linux | "win32" | "win64" | "mingw64" | "mingw" | "cygwin" -> `Windows | "freebsd" -> `FreeBSD | "macosx" -> `MacOSX | "beos" | "dragonfly" | "bsd" | "openbsd" | "netbsd" | "gnu" | "solaris" | "unknown" -> invalid_arg "Unsupported system: %s" system | v -> if String.sub system 0 5 = "linux" then `Linux else invalid_arg "Invalid argument of system option: %s" v in (system, output) | _ -> invalid_arg "%s --system system -o " Sys.argv.(0) with _ -> invalid_arg "%s --system system -o " Sys.argv.(0) in let oc_ml, oc_c, oc_sexp = ( open_out (output ^ ".ml") , open_out (output ^ "_stubs.c") , open_out (output ^ ".sexp") ) in let ml, c, sexp = match system with | `Linux -> ( load_file "clock_linux.ml" , load_file "clock_linux_stubs.c" , sexp_linux ) | `FreeBSD -> ( load_file "clock_linux.ml" , load_file "clock_linux_stubs.c" , sexp_freebsd ) | `Windows -> ( load_file "clock_windows.ml" , load_file "clock_windows_stubs.c" , sexp_windows ) | `MacOSX -> (load_file "clock_mach.ml", load_file "clock_mach_stubs.c", sexp_mach) in Printf.fprintf oc_ml "%s%!" ml ; Printf.fprintf oc_c "%s%!" c ; Printf.fprintf oc_sexp "%s%!" sexp ; close_out oc_ml ; close_out oc_c ; close_out oc_sexp eqaf-0.10/config/000077500000000000000000000000001463277374600136365ustar00rootroot00000000000000eqaf-0.10/config/config.ml000066400000000000000000000004471463277374600154420ustar00rootroot00000000000000let parse s = Scanf.sscanf s "%d.%d" (fun major minor -> (major, minor)) let () = let version = parse Sys.ocaml_version in if version >= (4, 8) then print_string "unsafe_stable.ml" else if version >= (4, 7) then print_string "unsafe_pre408.ml" else print_string "unsafe_pre407.ml" eqaf-0.10/config/dune000066400000000000000000000001371463277374600145150ustar00rootroot00000000000000(executable (name config)) (rule (with-stdout-to which-unsafe-file (run ./config.exe))) eqaf-0.10/dune-project000066400000000000000000000000521463277374600147100ustar00rootroot00000000000000(lang dune 2.0) (name eqaf) (version dev) eqaf-0.10/eqaf-cstruct.opam000066400000000000000000000014301463277374600156460ustar00rootroot00000000000000opam-version: "2.0" maintainer: [ "Romain Calascibetta " ] authors: [ "Romain Calascibetta " ] homepage: "https://github.com/mirage/eqaf" bug-reports: "https://github.com/mirage/eqaf/issues" dev-repo: "git+https://github.com/mirage/eqaf.git" doc: "https://mirage.github.io/eqaf/" license: "MIT" synopsis: "Constant-time equal function on string" description: """ This package provides an equal function on string in constant-time to avoid timing-attack with crypto stuff. """ build: [ [ "dune" "subst" ] {dev} [ "dune" "build" "-p" name "-j" jobs ] ] depends: [ "ocaml" {>= "4.07.0"} "dune" {>= "2.0"} "cstruct" {>= "1.1.0"} "eqaf" {= version} ] eqaf-0.10/eqaf.opam000066400000000000000000000017361463277374600141720ustar00rootroot00000000000000opam-version: "2.0" maintainer: [ "Romain Calascibetta " ] authors: [ "Romain Calascibetta " ] homepage: "https://github.com/mirage/eqaf" bug-reports: "https://github.com/mirage/eqaf/issues" dev-repo: "git+https://github.com/mirage/eqaf.git" doc: "https://mirage.github.io/eqaf/" license: "MIT" synopsis: "Constant-time equal function on string" description: """ This package provides an equal function on string in constant-time to avoid timing-attack with crypto stuff. """ build: [ [ "dune" "subst" ] {dev} [ "dune" "build" "-p" name "-j" jobs ] [ "dune" "runtest" "-p" name "-j" "1" "--no-buffer" "--verbose" ] {with-test} ] depends: [ "ocaml" {>= "4.07.0"} "dune" {>= "2.0"} "base64" {with-test & >= "3.0.0"} "alcotest" {with-test} "crowbar" {with-test} "fmt" {with-test & >= "0.8.7"} "bechamel" {with-test} ] eqaf-0.10/fuzz/000077500000000000000000000000001463277374600133675ustar00rootroot00000000000000eqaf-0.10/fuzz/dune000066400000000000000000000002221463277374600142410ustar00rootroot00000000000000(executable (name fuzz) (libraries crowbar eqaf)) (rule (alias runtest) (package eqaf) (deps (:fuzz fuzz.exe)) (action (run %{fuzz}))) eqaf-0.10/fuzz/fuzz.ml000066400000000000000000000101051463277374600147140ustar00rootroot00000000000000open Crowbar let () = add_test ~name:"bool_of_int" [ int ] @@ fun n -> let result = Eqaf.bool_of_int n in check_eq ~eq:(=) (if n = 0 then false else true) result let () = add_test ~name:"select_a_if_in_range" [ range max_int ; range max_int ; int; range 10000; range 10000 ] @@ fun low high n a b -> let low, high = min low high, max low high in let choice = Eqaf.select_a_if_in_range ~low ~high ~n a b in check_eq ~eq:(=) (if low <= n && n <= high then a else b) choice let () = add_test ~name:"uppercase_ascii" [ bytes ] @@ fun raw_str -> check_eq ~eq:String.equal (String.uppercase_ascii raw_str) (Eqaf.uppercase_ascii raw_str) let () = add_test ~name:"lowercase_ascii" [ bytes ] @@ fun raw_str -> check_eq ~eq:String.equal (String.lowercase_ascii raw_str) (Eqaf.lowercase_ascii raw_str) let () = (* These are here for compat with OCaml <= 4.09 from >= they can be replaced by Int32.unsigned_div Int32.unsigned_rem *) let int32_div_unsigned n d = let sub,min_int = Int32.(sub,min_int)in let int32_unsigned_compare n m = Int32.compare (sub n min_int) (sub m min_int) in if d < 0_l then if int32_unsigned_compare n d < 0 then 0_l else 1_l else let q = let open Int32 in shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in let r = sub n (Int32.mul q d) in if int32_unsigned_compare r d >= 0 then Int32.succ q else q in let int32_rem_unsigned n d = Int32.sub n (Int32.mul (int32_div_unsigned n d) d) in add_test ~name:"divmod" [ int32 ; int32 ] @@ fun x m -> try let result = Eqaf.divmod ~x ~m in let expect = int32_div_unsigned x m, int32_rem_unsigned x m in check_eq ~eq:(=) expect result with | Invalid_argument desc -> (* we expect this for negative m: *) assert (desc = "m <= 0" || desc = "m >= 16348 not supported") let () = add_test ~name:"hex_of_string |> string_of_hex" [ bytes ] @@ fun raw -> let enc = Eqaf.hex_of_string raw in let dec = Eqaf.string_of_hex enc in check_eq ~pp:(fun fmt (s,err) -> Format.fprintf fmt "(%S,%d)" s err) ~eq:(=) (raw,0) dec ; String.iter (function (* check for invalid encoding: *) | '0'..'9' | 'a'..'z' | 'A'..'Z' -> () | _ -> assert false) enc let () = add_test ~name:"string_of_hex |> hex_of_string" [ bytes ] @@ fun hex -> begin match Eqaf.string_of_hex hex with | dec, 0 -> let enc = Eqaf.hex_of_string dec in check_eq ~pp:(fun fmt s -> Format.pp_print_string fmt @@ String.escaped s) ~eq:(=) (String.lowercase_ascii hex) enc ; | _ -> let invalid = ref false in begin if (String.length hex mod 2 = 1) then invalid := true else String.iter (function | 'a'..'f' | '0'..'9' | 'A'..'F' -> () | _ -> invalid := true ) hex end ; assert !invalid (* we expect it to be invalid since it raised *) end let () = add_test ~name:"equal" [ bytes; bytes; ] @@ fun a b -> let expect = String.equal a b in let result = Eqaf.equal a b in check_eq ~pp:Format.pp_print_bool ~eq:(=) expect result let rev str = let len = String.length str in let res = Bytes.create len in for i = 0 to len - 1 do Bytes.set res (len - 1 - i) str.[i] done ; Bytes.unsafe_to_string res type order = Zero | Neg | Pos let of_int = function 0 -> Zero | n -> if n < 0 then Neg else Pos let pf = Format.fprintf let pp_order ppf = function Zero -> pf ppf "Zero" | Neg -> pf ppf "Neg" | Pos -> pf ppf "Pos" let () = add_test ~name:"compare_le" [ bytes; bytes ] @@ fun a b -> if String.length a <> String.length b then bad_test () ; let expect = String.compare a b in let result = Eqaf.compare_be a b in check_eq ~pp:pp_order ~eq:(=) (of_int expect) (of_int result) let () = add_test ~name:"compare_be" [ bytes; bytes ] @@ fun a b -> if String.length a <> String.length b then bad_test () ; let expect = String.compare (rev a) (rev b) in let result = Eqaf.compare_le a b in check_eq ~pp:pp_order ~eq:(=) (of_int expect) (of_int result) eqaf-0.10/lib/000077500000000000000000000000001463277374600131375ustar00rootroot00000000000000eqaf-0.10/lib/dune000066400000000000000000000007041463277374600140160ustar00rootroot00000000000000(library (name eqaf) (public_name eqaf) (modules unsafe eqaf)) (rule (copy %{read:../config/which-unsafe-file} unsafe.ml)) (library (name eqaf_bigstring) (public_name eqaf.bigstring) (modules eqaf_bigstring) (libraries eqaf)) (library (name eqaf_bytes) (public_name eqaf.bytes) (modules eqaf_bytes) (libraries eqaf)) (library (name eqaf_cstruct) (public_name eqaf-cstruct) (modules eqaf_cstruct) (libraries cstruct eqaf.bigstring)) eqaf-0.10/lib/eqaf.ml000066400000000000000000000271221463277374600144110ustar00rootroot00000000000000let[@inline always] char_chr ch = (* Char.chr contains a branch on [ch] and a plt indirection, this * implementation ensures well-formedness by construction and avoids that: *) Char.unsafe_chr (ch land 0xff) let[@inline] get x i = String.unsafe_get x i |> Char.code (* XXX(dinosaure): we use [unsafe_get] to avoid jump to exception: sarq $1, %rbx movzbq (%rax,%rbx), %rax leaq 1(%rax,%rax), %rax ret *) external unsafe_get_int16 : string -> int -> int = "%caml_string_get16u" let[@inline] get16 x i = unsafe_get_int16 x i (* XXX(dinosaure): same as [unsafe_get] but for [int16]: sarq $1, %rbx movzwq (%rax,%rbx), %rax leaq 1(%rax,%rax), %rax ret *) let equal ~ln a b = let l1 = ln asr 1 in (* sarq $1, %rcx orq $1, %rcx *) let r = ref 0 in (* movq $1, %rdx *) for i = 0 to pred l1 do r := !r lor (get16 a (i * 2) lxor get16 b (i * 2)) done ; (* movq $1, %rsi addq $-2, %rcx cmpq %rcx, %rsi jg .L104 .L105: leaq -1(%rsi,%rsi), %r8 sarq $1, %r8 movzwq (%rdi,%r8), %r9 leaq 1(%r9,%r9), %r9 movzwq (%rbx,%r8), %r8 leaq 1(%r8,%r8), %r8 // [unsafe_get_int16 a i] and [unsafe_get_int6 b i] xorq %r9, %r8 orq $1, %r8 orq %r8, %rdx movq %rsi, %r8 addq $2, %rsi cmpq %rcx, %r8 jne .L105 .L104: *) for _ = 1 to ln land 1 do r := !r lor (get a (ln - 1) lxor get b (ln - 1)) done ; (* movq $3, %rsi movq %rax, %rcx andq $3, %rcx cmpq %rcx, %rsi jg .L102 .L103: movq %rax, %r8 addq $-2, %r8 sarq $1, %r8 movzbq (%rdi,%r8), %r9 leaq 1(%r9,%r9), %r9 movzbq (%rbx,%r8), %r8 leaq 1(%r8,%r8), %r8 // [unsafe_get a i] and [unsafe_get b i] xorq %r9, %r8 orq $1, %r8 orq %r8, %rdx movq %rsi, %r8 addq $2, %rsi cmpq %rcx, %r8 jne .L103 .L102: *) !r = 0 (* cmpq $1, %rdx sete %al movzbq %al, %rax leaq 1(%rax,%rax), %rax ret *) let equal a b = let al = String.length a in let bl = String.length b in if al <> bl then false else equal ~ln:al a b let[@inline always] compare (a:int) b = a - b let[@inline always] sixteen_if_minus_one_or_less n = (n asr Sys.int_size) land 16 let[@inline always] eight_if_one_or_more n = ((-n) asr Sys.int_size) land 8 let compare_le ~ln a b = let r = ref 0 in let i = ref (pred ln) in while !i >= 0 do let xa = get a !i and xb = get b !i in let c = compare xa xb in r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; decr i ; done ; (!r land 8) - (!r land 16) let compare_le_with_len ~len:ln a b = let al = String.length a in let bl = String.length b in if ln = 0 then 0 else if (al lxor ln) lor (bl lxor ln) <> 0 then invalid_arg "compare_le_with_len" else compare_le ~ln a b let compare_le a b = let al = String.length a in let bl = String.length b in if al < bl then 1 else if al > bl then (-1) else compare_le ~ln:al (* = bl *) a b let compare_be ~ln a b = let r = ref 0 in let i = ref 0 in while !i < ln do let xa = get a !i and xb = get b !i in let c = compare xa xb in r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; incr i ; done ; (!r land 8) - (!r land 16) let compare_be_with_len ~len:ln a b = let al = String.length a in let bl = String.length b in if ln = 0 then 0 else if (al lxor ln) lor (bl lxor ln) <> 0 then invalid_arg "compare_be_with_len" else compare_be ~ln a b let compare_be a b = let al = String.length a in let bl = String.length b in if al < bl then 1 else if al > bl then (-1) else compare_be ~ln:al (* = bl *) a b let[@inline always] minus_one_or_less n = n lsr (Sys.int_size - 1) let[@inline always] one_if_not_zero n = minus_one_or_less ((- n) lor n) let[@inline always] zero_if_not_zero n = (one_if_not_zero n) - 1 let[@inline always] select_int choose_b a b = let mask = ((- choose_b) lor choose_b) asr Sys.int_size in (a land (lnot mask)) lor (b land mask) external int_of_bool : bool -> int = "%identity" external unsafe_bool_of_int : int -> bool = "%identity" let[@inline] bool_of_int n = unsafe_bool_of_int (one_if_not_zero n) let[@inline always] find_uint8 ~off ~len ~f str = let i = ref (len - 1) in let a = ref (lnot 0) in while !i >= off do let byte = get str !i in let pred = int_of_bool (f byte) in (* XXX(dinosaure): a composition of [f] with [bool_of_int] such as [let f = bool_of_int <.> f in] implies an allocation (of a closure). To be GC-free, we must store result of [f] into a register, and apply [bool_of_int] then (introspection was done on OCaml 4.08.1). *) a := select_int (((!i - off) land min_int) lor pred) !a !i ; decr i ; done ; !a let find_uint8 ?(off= 0) ~f str = (* XXX(dinosaure): with this overload, OCaml is able to produce 2 [find_uint8]. One with [off= 0] and one other where [off] is an argument. I think it's about cross-module optimization where a call to [find_uint8 ~f v] will directly call the first one and a call to [find_uint8 ~off:x ~f v] will call the second one. *) let len = String.length str in find_uint8 ~off ~len ~f str let exists_uint8 ?off ~f str = let v = find_uint8 ?off ~f str in let r = select_int (v + 1) 0 1 in unsafe_bool_of_int r let divmod ~(x:int32) ~(m:int32) : int32 * int32 = (* Division and remainder being constant-time with respect to [x] * ( NOT [m] !). The OCaml variant would be: * [(x / m , x mod m)] where [x] is a secret and [m] is not secret. * Adapted from the NTRU Prime team's algorithm from * supercop/crypto_kem/sntrup761/ref/uint32.c * cite the round-2 ntru prime submission to nistpqc (march 2019) * Note that in practice this works for at least some much larger [x] and [m], * but it's unclear to me how to evaluate *which*, so leaving the original * restrictions in. *) let ( - ) , ( + ), ( * ) = Int32.(sub, add, mul) in let ( >> ) = Int32.shift_right_logical in if (m <= 0l) then raise (Invalid_argument "m <= 0") ; if (m >= 16348l) then raise (Invalid_argument "m >= 16348 not supported") ; let of_uint32 uint = (* apparently Int64.of_int32 sign-extends ... great... avoid that: *) let b = Bytes.make 8 '\x00' in Unsafe.set_int32_le b 0 uint ; Unsafe.get_int64_le b 0 in let x_0 = x in let x_2, q_1 = let int32_div_unsigned n d = (* can be replaced by Int32.unsigned_div * from OCaml >= 4.10 *) let sub,min_int = Int32.(sub,min_int)in let int32_unsigned_compare n m = Int32.compare (sub n min_int) (sub m min_int) in if d < 0_l then if int32_unsigned_compare n d < 0 then 0_l else 1_l else let q = let open Int32 in shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in let r = sub n (Int32.mul q d) in if int32_unsigned_compare r d >= 0 then Int32.succ q else q in let v = int32_div_unsigned Int32.min_int m |> of_uint32 in (*let v = 0x80_00_00_00 / m in*) (* floored div *) let x_1, q_0 = let qpart_0 = let open Int64 in shift_right_logical (mul (of_uint32 x_0) v) 31 |> to_int32 in x_0 - (qpart_0 * m), qpart_0 in let qpart_1 = let open Int64 in shift_right_logical (mul (of_uint32 x_1) v) 31 |> to_int32 in x_1 - (qpart_1 * m), (q_0 + qpart_1 + 1l) in let x_3 = x_2 - m in let mask = 0l - (x_3 >> 31) in q_1 + mask, x_3 + (Int32.logand mask m) let ascii_of_int32 ~digits (n:int32) : string = (* Recursively calls [divmod n 10]; the remainder is turned into ASCII and the quotient is used for the next division.*) if digits < 0 then raise (Invalid_argument "digits < 0"); let out = Bytes.make digits '0' in let rec loop x = function | -1 -> Bytes.unsafe_to_string out | idx -> let next, this = divmod ~x ~m:10l in Bytes.set out idx @@ char_chr (0x30 lor (Int32.to_int this)) ; loop next (pred idx) in loop n (pred digits) let[@inline always] to_hex_nibble f : char = let a = 86 + f in let c = 1 + ((a - 71 * ((a land 0x10) lsr 4)) lor 0x20) in char_chr c let hex_of_string rawbytes = String.init (2 * String.length rawbytes) (fun idx -> let byt = String.get rawbytes (idx lsr 1) |> Char.code in (* select which 4 bits to use, this can probably be done faster:*) let nib = 0xf land (byt lsr (((lnot idx) land 1) lsl 2)) in to_hex_nibble nib) let hex_of_bytes rawbytes = hex_of_string (Bytes.unsafe_to_string rawbytes) let[@inline always] select_a_if_in_range ~low ~high ~n a b = (* select [a] if [low <= n <= high] and [b] if [n] is out of range.*) (* NB: ONLY WORKS FOR [0 <= low <= high <= max_int]*) (* The idea being that: 1.a) if low <= n : (n - low) is positive + 1.b) if low > n : (n - low) is negative - 2.a) if n <= high: (high - n) is positive + 2.b) if n > high: (high - n) is negative - We OR the numbers together; we only really care about the sign bit which is set when negative. Thus both numbers are positive iff (low <= n && n <= high). We then select the sign bit with (land min_int) and use that to choose: *) let out_of_range = (* choose b if out of range *) ((n - low) lor (high - n) land min_int) in select_int out_of_range a b let lowercase_ascii src = (* ct version of String.lowercase_ascii *) String.map ( fun ch -> let n = Char.code ch in (* 0x41 is 'A'; 0x5a is 'Z'; 0x20 controls case for ASCII letters *) select_a_if_in_range ~low:0x41 ~high:0x5a ~n (n lor 0x20) (n) |> char_chr ) src let uppercase_ascii src = (* ct version of String.uppercase_ascii *) String.map ( fun ch -> let n = Char.code ch in (* 0x61 is 'a'; 0x7a is 'z'; 0x20 controls case for ASCII letters *) select_a_if_in_range ~low:0x61 ~high:0x7a ~n (n lxor 0x20) (n) |> char_chr ) src let bytes_of_hex rawhex = (* hex length must be multiple of 2: *) let error_bitmap = ref ((String.length rawhex land 1) lsl 4) in let decoded = Bytes.init (String.length rawhex lsr 1) (fun idx -> let idx = idx lsl 1 in let nib idx = String.get rawhex idx |> Char.code |> fun n -> (* uppercase -> lowercase: *) select_a_if_in_range ~low:0x41 ~high:0x5a ~n (n lor 0x20) (* set case bit *) n (* leave as-is *) |> fun n -> (* now either invalid; lowercase; numeric*) (select_a_if_in_range ~low:0x30 ~high:0x39 ~n (n - 0x30) (* numeric: subtract '0' to get [0..9] *) (select_a_if_in_range ~low:0x61 ~high:0x66 ~n (* a-f: subtract 'a' and add 10 to get [10..15]: *) (n - 0x61 + 10) (0xff) (* invalid, ensure we set upper bits of error_bitmap *) ) ) in let nibf0 = nib idx and nib0f = nib (succ idx) in error_bitmap := !error_bitmap lor nibf0 lor nib0f ; char_chr ((nibf0 lsl 4) lor nib0f) ) in (* if any non-nibble bits were set in !error_bitmap, decoding failed: *) decoded, !error_bitmap land (lnot 0xf) let string_of_hex rawhex = let byt, error = bytes_of_hex rawhex in Bytes.unsafe_to_string byt, error eqaf-0.10/lib/eqaf.mli000066400000000000000000000257431463277374600145710ustar00rootroot00000000000000(** Eqaf - constant time / timing side channel resistant functions *) (** {1 Basics} In cryptography, a timing-attack is a side-channel attack in which the attacker attempts to compromise a cryptosystem by analyzing the time taken to execute cryptographic algorithms. In some cases, a process needs to compare two values (input value and expected password). An attacker can analyze time needed by {!String.compare}/{!String.equal} to calculate expected password. This side-channel attack is due implementation of {!String.compare}/{!String.equal} which leaves as soon as possible when it reachs a difference between [a] and [b]. By this way, time taken to compare two values differs if they are equal or not. Distribution provides a little example of this kind of attack where we construct step by step (byte per byte) expected value from time spended to execute {!Stdlib.compare}. Distribution wants to provide some functions which protect user against this kind of attack: {ul {- [equal] like {!String.equal}} {- [compare_be] like {!String.compare}} {- [compare_le] which is a {!String.compare} with a reverse operation on inputs} {- {!divmod} like {!Int32.unsigned_div} and {!Int32.unsigned_rem}}} These functions are tested to see how long they took to compare two equal values and two different values. See {i check} tool for more informations. *) (** {1 Comparison functions} *) (** {2 Equal} *) val equal : string -> string -> bool (** [equal a b] returns [true] if [a] and [b] are equals. [String.equal a b = equal a b] for any [a] and [b]. The execution time of [equal] depends solely on the length of the strings, not the contents. *) (** {2 Big-endian comparison} *) val compare_be : string -> string -> int (** [compare_be a b] returns [0] if [a] is equal to [b], a negative integer if [a] if {i less} (lexicographically) than [b], and a positive integer if [a] is {i greater} (lexicographically) than [b]. [compare_be a b] returns the same {i order} than [String.compare a b] for any [a] and [b] (but not necessary the same integer!). Order is defined as: {ul {- [compare_be a b < 0] means [a < b]} {- [compare_be a b > 0] means [a > b]} {- [compare_be a b = 0] means [a = b]}} About time, if [String.length a <> String.length b], [compare_be] does not look into [a] or [b] and no comparison in bytes will be done. *) val compare_be_with_len : len:int -> string -> string -> int (** [compare_be_with_len ~len a b] does {!compare_be}[ a b] on [len] bytes. @raise Invalid_argument if [len] is upper than [String.length a] or [String.length b]. *) (** {2 Little-endian comparison} *) val compare_le : string -> string -> int (** [compare_le a b] is semantically [compare_be (rev a) (rev b)], where [rev] is a function that reverses a string bytewise ([a = rev (rev a)]). *) val compare_le_with_len : len:int -> string -> string -> int (** [compare_le_with_len a b] is semantically [compare_be_with_len ~len (rev a) (rev b)]. With [rev] reverse a string ([a = rev (rev a)]). @raise Invalid_argument if [len] is upper than [String.length a] or [String.length b]. *) (** {1 Arithmetic} *) (** {2 Division} *) val divmod : x:int32 -> m:int32 -> int32 * int32 (** 32-bit unsigned division with remainder, constant-time with respect to [x] ({b not} [m]). @param x Dividend (number to be divided). {b Can be secret}. @param m Divisor {b Must not be secret}. Must be [0 < m < 16384] This function is useful for implementation that need to produce e.g. pincodes from binary values in int32 format, example: {!ascii_of_int32}. @return [quotient, remainder] Example: {[ let ct = Eqaf.divmod ~x ~m in let not_ct = Int32.unsigned_div x m, Int32.unsigned_rem x m in assert ct = not_ct ; ]} That is, an attacker might be able to learn [m] by measuring execution time, but not the value of [x]. @raise Invalid_argument when [not (0 < m && m < 16384)]. @see "supercop/crypto_kem/sntrup761/ref/uint32.c" Adapted from the NTRU Prime team's algorithm from [supercop/sntrup761], see round-2 NTRU Prime submission to NISTPQC (March 2019). *) (** {1:stringutil String utilities} *) (** {2 String search}*) val find_uint8 : ?off:int -> f:(int -> bool) -> string -> int (** [find_uint8 ?off ~f v] returns the index of the first occurrence which respects the predicate [f] in string [v]. Otherwise, it returns [-1]. The caller is responsible for ensuring that [~f] operates in constant time. The {!bool_of_int} function can be relevant when writing [~f] functions. *) val exists_uint8 : ?off:int -> f:(int -> bool) -> string -> bool (** [exists_uint8 ?off ~f v] tests if an occurrence respects the predicate [f] in the string [v]. *) (** {2:ascii ASCII functions}*) val ascii_of_int32 : digits:int -> int32 -> string (** [ascii_of_int64 ~digits ~n] is a string consisting of the rightmost [digits] characters of the decimal representation of [n]. If [digits] is larger than the decimal representation, it is left-padded with ['0']. If [digits] is smaller, the output is truncated. Example: {[ let s1 = ascii_of_int64 ~digits:6 ~n:12345678L in assert (s = "345678") ; let s2 = ascii_of_int64 ~digits:6 ~n:1234L in assert (s = "001234") ; ]} @raise Invalid_argument when [digits < 0] *) val lowercase_ascii : string -> string (** [lowercase_ascii str] is [str] where [A-Z] is replaced with [a-z]. It is a constant time implementation of {!String.lowercase_ascii} *) val uppercase_ascii : string -> string (** [uppercase_ascii str] is [str] where [a-z] is replaced with [A-Z]. It is a constant time implementation of {!String.uppercase_ascii} *) (** {2:hex Hex encoding and decoding}*) val hex_of_bytes : bytes -> string (** [hex_of_bytes raw] is [raw] hex-encoded in constant time. Can be used to serialize sensitive values. The {b contents can be secret}, but an attacker can learn the {b length of} [raw] by timing this function. Hex has two valid forms, lowercase and uppercase. This function produces lowercase hex characters exclusively. Example: {[ let secret = "--Hi\x24" in let serialized = hex_of_string secret in (* serialized is now "2d2d486924" *) ]} @param raw is the source buffer. [raw] is not mutated by this function. *) val hex_of_string : string -> string (** [hex_of_string raw] is [hex_of_bytes raw] as a {!string} *) val bytes_of_hex : string -> bytes * int (** [bytes_of_hex hex] is [raw, error] decoded in constant time. Can be used to e.g. decode secrets from configuration files. The {b contents can be secret}, but an attacker can learn the {b length of} [hex] by timing this function. {b Error handling:} The second tuple element [error] is {b non-zero} when the length of [hex] is not a multiple of 2, or [hex] contains invalid characters. Implementations should ensure that `error = 0` before using [raw]. The function signals errors this way to allow implementations to handle invalid input errors in constant time. @param hex The hex-encoded octet string. Accepts characters [0-9 a-f A-F]. Note that [0x] prefixes or whitespace are not accepted. Example: {[ let serialized = "2d2d486924" in let secret, error = string_of_hex serialized in assert (error = 0); (* secret is now [--Hi$] *) ]} *) val string_of_hex : string -> string * int (** [string_of_hex hex] is {!bytes_of_hex} [hex], but returning a {!type:string} instead of {!type:bytes}. See {!bytes_of_hex} regarding handling of invalid input errors. *) (** {1 Low-level primitives} *) (** {2 Bithacks} *) val one_if_not_zero : int -> int (** [one_if_not_zero n] is a constant-time version of [if n <> 0 then 1 else 0]. This is functionally equivalent to [!!n] in the C programming language. *) val zero_if_not_zero : int -> int (** [zero_if_not_zero n] is a constant-time of [if n <> 0 then 0 else 1]. This is functionnaly equivalent to [!n] in the C programming language. *) val int_of_bool : bool -> int (** [int_of_bool b] is equivalent to [if b then 1 else 0]. Internally it cast with [%identity] instead of branching.*) val bool_of_int : int -> bool (** [bool_of_int n] is equivalent to [if n = 0 then false else true]. *) (** {2 Composition} *) val select_int : int -> int -> int -> int (** [select_int choose_b a b] is [a] if [choose_b = 0] and [b] otherwise. This comparison is constant-time and it should not be possible for a measuring adversary to determine anything about the values of [choose_b], [a], or [b]. *) val select_a_if_in_range : low:int -> high:int -> n:int -> int -> int -> int (** [select_a_if_in_range ~low ~high ~n a b] - is [a] if [low <= n <= high] (in range) - is [b] is [n < low || high < n] (out of range) This function {b only works for positive ranges}: @param low invariant: [0 <= low <= max_int] @param high invariant: [low <= high <= max_int] This function can be used like {!select_int} but using an integer range instead of zero/non-zero to select. It operates in constant time and is safe to use with secret parameters for [low, high, n, a, b]. Example: {[ let a = 123 and b = 456 in let x = select_a_if_in_range ~low:10 ~high:20 ~n:10 a b in (* x = 123 *) let x = select_a_if_in_range ~low:10 ~high:20 ~n:0 a b in (* x = 456 *) let x = select_a_if_in_range ~low:10 ~high:20 ~n:20 a b in (* x = 123 *) let x = select_a_if_in_range ~low:10 ~high:20 ~n:21 a b in (* x = 456 *) (* Constant-time subpatterns can be expressed by nesting, Below is a constant time version of: match 3 with | 1 | 2| 3 | 4 -> begin match 3 with | 2 | 3 -> 111 | _ -> 222 end | _ -> 333 *) let n = 3 select_a_if_in_range ~low:1 ~high:4 ~n (select_a_if_in_range ~low:2 ~high:3 ~n (111) (222) ) 333 (* evalutes to 111 because [1 <= n <= 4] selects the inner pattern and [2 <= n <= 3] selects the first branch ("a") of the inner pattern. *) (* The applications can also be composed in constant time, note that all the branches are always evaluated, so large expressions can get slow: *) 4 |> fun n -> select_a_if_in_range ~low:1 ~high:5 ~n (n * 10) (n - 100) |> fun n -> select_a_if_in_range ~low:20 ~high 30 ~n (n * 100) (n+3) (* evaluates to [4 *10 + 3] *) (* Below the normal, non-constant time version: *) 4 |> (function | n when 1 <= n && n <= 5 -> n * 10 | n -> n - 100) |> (function | n when 20 <= n && n <= 30 -> n * 100 | n -> n + 3) ]} Another example of how to use this can be found in the implementations of {!lowercase_ascii} and {!bytes_of_hex}. *) eqaf-0.10/lib/eqaf_bigstring.ml000066400000000000000000000055441463277374600164650ustar00rootroot00000000000000type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t let length x = Bigarray.Array1.dim x [@@inline] let get x i = Bigarray.Array1.unsafe_get x i |> Char.code [@@inline] external unsafe_get_int16 : bigstring -> int -> int = "%caml_bigstring_get16u" [@@noalloc] let get16 x i = unsafe_get_int16 x i [@@inline] let equal ~ln a b = let l1 = ln asr 1 in let r = ref 0 in for i = 0 to pred l1 do r := !r lor (get16 a (i * 2) lxor get16 b (i * 2)) done ; for _ = 1 to ln land 1 do r := !r lor (get a (ln - 1) lxor get b (ln - 1)) done ; !r = 0 let equal a b = let al = length a in let bl = length b in if al <> bl then false else equal ~ln:al a b let[@inline always] compare (a:int) b = a - b let[@inline always] sixteen_if_minus_one_or_less n = (n asr Sys.int_size) land 16 let[@inline always] eight_if_one_or_more n = ((-n) asr Sys.int_size) land 8 let compare_le ~ln a b = let r = ref 0 in let i = ref (pred ln) in while !i >= 0 do let xa = get a !i and xb = get b !i in let c = compare xa xb in r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; decr i ; done ; (!r land 8) - (!r land 16) let compare_le_with_len ~len:ln a b = let al = length a in let bl = length b in if ln = 0 then 0 else if (al lxor ln) lor (bl lxor ln) <> 0 then invalid_arg "compare_le_with_len" else compare_le ~ln a b let compare_le a b = let al = length a in let bl = length b in if al < bl then 1 else if al > bl then (-1) else compare_le ~ln:al (* = bl *) a b let compare_be ~ln a b = let r = ref 0 in let i = ref 0 in while !i < ln do let xa = get a !i and xb = get b !i in let c = compare xa xb in r := !r lor ((sixteen_if_minus_one_or_less c + eight_if_one_or_more c) lsr !r) ; incr i ; done ; (!r land 8) - (!r land 16) let compare_be_with_len ~len:ln a b = let al = length a in let bl = length b in if ln = 0 then 0 else if (al lxor ln) lor (bl lxor ln) <> 0 then invalid_arg "compare_be_with_len" else compare_be ~ln a b let compare_be a b = let al = length a in let bl = length b in if al < bl then 1 else if al > bl then (-1) else compare_be ~ln:al (* = bl *) a b (* XXX(dinosaure): see [eqaf.ml] for this part. *) external int_of_bool : bool -> int = "%identity" external unsafe_bool_of_int : int -> bool = "%identity" let[@inline always] find_uint8 ~off ~len ~f str = let i = ref (len - 1) in let a = ref (lnot 0) in while !i >= off do let byte = get str !i in let pred = int_of_bool (f byte) in a := Eqaf.select_int (((!i - off) land min_int) lor pred) !a !i ; decr i ; done ; !a let find_uint8 ?(off= 0) ~f str = let len = length str in find_uint8 ~off ~len ~f str let exists_uint8 ?off ~f str = let v = find_uint8 ?off ~f str in let r = Eqaf.select_int (v + 1) 0 1 in unsafe_bool_of_int r eqaf-0.10/lib/eqaf_bigstring.mli000066400000000000000000000007561463277374600166360ustar00rootroot00000000000000type bigstring = (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t val equal : bigstring -> bigstring -> bool val compare_be : bigstring -> bigstring -> int val compare_be_with_len : len:int -> bigstring -> bigstring -> int val compare_le : bigstring -> bigstring -> int val compare_le_with_len : len:int -> bigstring -> bigstring -> int val find_uint8 : ?off:int -> f:(int -> bool) -> bigstring -> int val exists_uint8 : ?off:int -> f:(int -> bool) -> bigstring -> bool eqaf-0.10/lib/eqaf_bytes.ml000066400000000000000000000015411463277374600156140ustar00rootroot00000000000000let equal a b = let a' = Bytes.unsafe_to_string a in let b' = Bytes.unsafe_to_string b in Eqaf.equal a' b' let compare_le_with_len ~len a b = let a' = Bytes.unsafe_to_string a in let b' = Bytes.unsafe_to_string b in Eqaf.compare_le_with_len ~len a' b' let compare_le a b = let a' = Bytes.unsafe_to_string a in let b' = Bytes.unsafe_to_string b in Eqaf.compare_le a' b' let compare_be_with_len ~len a b = let a' = Bytes.unsafe_to_string a in let b' = Bytes.unsafe_to_string b in Eqaf.compare_be_with_len ~len a' b' let compare_be a b = let a' = Bytes.unsafe_to_string a in let b' = Bytes.unsafe_to_string b in Eqaf.compare_be a' b' let find_uint8 ?off ~f b = let str = Bytes.unsafe_to_string b in Eqaf.find_uint8 ?off ~f str let exists_uint8 ?off ~f b = let str = Bytes.unsafe_to_string b in Eqaf.exists_uint8 ?off ~f str eqaf-0.10/lib/eqaf_bytes.mli000066400000000000000000000005441463277374600157670ustar00rootroot00000000000000val equal : bytes -> bytes -> bool val compare_be : bytes -> bytes -> int val compare_be_with_len : len:int -> bytes -> bytes -> int val compare_le : bytes -> bytes -> int val compare_le_with_len : len:int -> bytes -> bytes -> int val find_uint8 : ?off:int -> f:(int -> bool) -> bytes -> int val exists_uint8 : ?off:int -> f:(int -> bool) -> bytes -> bool eqaf-0.10/lib/eqaf_cstruct.ml000066400000000000000000000013431463277374600161550ustar00rootroot00000000000000let equal a b = Eqaf_bigstring.equal (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) let compare_be_with_len ~len a b = Eqaf_bigstring.compare_be_with_len ~len (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) let compare_le_with_len ~len a b = Eqaf_bigstring.compare_le_with_len ~len (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) let compare_le a b = Eqaf_bigstring.compare_le (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) let compare_be a b = Eqaf_bigstring.compare_be (Cstruct.to_bigarray a) (Cstruct.to_bigarray b) let find_uint8 ?off ~f v = Eqaf_bigstring.find_uint8 ?off ~f (Cstruct.to_bigarray v) let exists_uint8 ?off ~f v = Eqaf_bigstring.exists_uint8 ?off ~f (Cstruct.to_bigarray v) eqaf-0.10/lib/eqaf_cstruct.mli000066400000000000000000000006241463277374600163270ustar00rootroot00000000000000val equal : Cstruct.t -> Cstruct.t -> bool val compare_be : Cstruct.t -> Cstruct.t -> int val compare_be_with_len : len:int -> Cstruct.t -> Cstruct.t -> int val compare_le : Cstruct.t -> Cstruct.t -> int val compare_le_with_len : len:int -> Cstruct.t -> Cstruct.t -> int val find_uint8 : ?off:int -> f:(int -> bool) -> Cstruct.t -> int val exists_uint8 : ?off:int -> f:(int -> bool) -> Cstruct.t -> bool eqaf-0.10/lib/unsafe_pre407.ml000066400000000000000000000007031463277374600160530ustar00rootroot00000000000000external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_string_set32" external get_int64_ne : bytes -> int -> int64 = "%caml_string_get64" external swap32 : int32 -> int32 = "%bswap_int32" external swap64 : int64 -> int64 = "%bswap_int64" let set_int32_le b i x = if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x let get_int64_le b i = if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i eqaf-0.10/lib/unsafe_pre408.ml000066400000000000000000000007011463277374600160520ustar00rootroot00000000000000external set_int32_ne : bytes -> int -> int32 -> unit = "%caml_bytes_set32" external get_int64_ne : bytes -> int -> int64 = "%caml_bytes_get64" external swap32 : int32 -> int32 = "%bswap_int32" external swap64 : int64 -> int64 = "%bswap_int64" let set_int32_le b i x = if Sys.big_endian then set_int32_ne b i (swap32 x) else set_int32_ne b i x let get_int64_le b i = if Sys.big_endian then swap64 (get_int64_ne b i) else get_int64_ne b i eqaf-0.10/lib/unsafe_stable.ml000066400000000000000000000001401463277374600162770ustar00rootroot00000000000000let set_int32_le b i x = Bytes.set_int32_le b i x let get_int64_le b i = Bytes.get_int64_le b i eqaf-0.10/test/000077500000000000000000000000001463277374600133505ustar00rootroot00000000000000eqaf-0.10/test/dune000066400000000000000000000006231463277374600142270ustar00rootroot00000000000000(executable (name test) (modules test) (libraries alcotest eqaf)) (rule (alias runtest) (locks singleton) (package eqaf) (deps (:test test.exe)) (action (run %{test} --color=always))) (executable (name test_branch) (modules test_branch) (libraries clock unix eqaf)) (rule (alias runtest) (locks singleton) (package eqaf) (deps (:test test_branch.exe)) (action (run %{test}))) eqaf-0.10/test/test.ml000066400000000000000000000200041463277374600146550ustar00rootroot00000000000000type r = Neg | Pos | Zero let equal w a b = match w with | Zero -> a = 0 && b = 0 | Neg -> a < 0 && b < 0 | Pos -> a > 0 && b > 0 let of_expected = function | 0 -> Zero | n -> if n < 0 then Neg else Pos let value w = Alcotest.testable Fmt.int (equal w) let be a b expected = let title = Fmt.str "be %S %S = %d" a b expected in Alcotest.test_case title `Quick @@ fun () -> let expected' = String.compare a b in Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_be a b) expected ; Alcotest.(check (value (of_expected expected'))) "string.compare" (Eqaf.compare_be a b) expected' let le a b expected = let title = Fmt.str "le %S %S = %d" a b expected in Alcotest.test_case title `Quick @@ fun () -> Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_le a b) expected let exists str chr exists = Alcotest.test_case (Fmt.str "contains %S %c = %b" str chr exists) `Quick @@ fun () -> let res = Eqaf.exists_uint8 ~f:((=) (Char.code chr)) str in Alcotest.(check bool) "result" res exists let find str chr index = Alcotest.test_case (Fmt.str "index %S %c = %d" str chr index) `Quick @@ fun () -> let res = Eqaf.find_uint8 ~f:((=) (Char.code chr)) str in Alcotest.(check int) "result" res index let int_of_bool bool expect = Alcotest.test_case (Fmt.str "int_of_bool %B = %d" bool expect ) `Quick @@ fun ()-> Alcotest.(check int) "result" expect (Eqaf.int_of_bool bool) let bool_of_int desc n expect = Alcotest.test_case (Fmt.str "int_of_bool %s = %B" desc expect ) `Quick @@ fun ()-> Alcotest.(check bool) "result" expect (Eqaf.bool_of_int n) let select_a_if_in_range (low,high) n a b expect = Alcotest.test_case (Fmt.str "select_a_if_in_range (%d,%d) ~n:%d %d %d" low high n a b ) `Quick @@ fun ()-> let choice = Eqaf.select_a_if_in_range ~low ~high ~n a b in Alcotest.(check int) "selected" expect choice let a_uint32 = Alcotest.testable Fmt.uint32 (=) let divmod str x m q r = (* (x / m = q) and (x mod m = r) *) Alcotest.test_case (Fmt.str "divmod %s %lu / %lu = %lu, %lu mod %lu = %lu" str x m q x m r ) `Quick @@ fun ()-> let eq_quot, eq_rem = Eqaf.divmod ~x ~m in Alcotest.(check (pair a_uint32 a_uint32)) "q,r" (q,r) (eq_quot,eq_rem) let ascii_of_int32 str digits n expect = Alcotest.test_case (Fmt.str "ascii_of_string %s %d %lu %S" str digits n expect ) `Quick @@ fun ()-> try let ascii = Eqaf.ascii_of_int32 ~digits n in Alcotest.(check string) str expect ascii with Invalid_argument x when x = "digits < 0" -> () let string_of_hex str hex expect = Alcotest.test_case (Fmt.str " %s %S %S" str hex expect ) `Quick @@ fun ()-> let enc = Eqaf.string_of_hex hex in Alcotest.(check @@ pair string int) str (expect,0) enc let hex_of_string str raw expect = Alcotest.test_case (Fmt.str " %s %S %S" str raw expect ) `Quick @@ fun ()-> let enc = Eqaf.hex_of_string raw in Alcotest.(check string) str expect enc let () = Alcotest.run "eqaf" [ "be", [ be "a" "a" 0 ; be "a" "b" (-1) ; be "b" "a" 1 ; be "aa" "ab" (-1) ; be "aaa" "aba" (-1) ; be "bbb" "abc" 1 ; be "bbb" "bbc" (-1) ; be "bbb" "abb" 1 ; be "\x00\x34\x12" "\x00\x33\x12" 1 ; be "\x00\x34\x12" "\x00\x33\x99" 1 ] ; "le", [ le "a" "a" 0 ; le "a" "b" (-1) ; le "b" "a" 1 ; le "aa" "ab" (-1) ; le "aaa" "aba" (-1) ; le "bbb" "abc" (-1) ; le "bbb" "bbc" (-1) ; le "bbb" "abb" 1 ; le "\x00\x34\x12" "\x00\x33\x12" 1 ; le "\x00\x34\x12" "\x00\x33\x99" (-1) ] ; "exists", [ exists "a" 'a' true ; exists "a" 'b' false ; exists "abc" 'c' true ; exists "abc" 'a' true ; exists "abc" 'b' true ; exists "abc" 'd' false ] ; "find", [ find "a" 'a' 0 ; find "a" 'b' (-1) ; find "aaaa" 'a' 0 ; find "bbbb" 'a' (-1) ; find "aabb" 'b' 2 ; find "aabb" 'a' 0 ; find "aaab" 'b' 3 ] ; "int_of_bool", [ int_of_bool false 0 (* exhaustive :-) *) ; int_of_bool true 1] ; "bool_of_int", [ bool_of_int "0" 0 false ; bool_of_int "-1" ~-1 true ; bool_of_int "2" 2 true ; bool_of_int "max_int" max_int true ; bool_of_int "min_int" min_int true ; bool_of_int "1" 1 true ] ; "select_a_if_in_range", [ select_a_if_in_range (0,3) 0 22 30 22 ; select_a_if_in_range (0,3) 1 22 30 22 ; select_a_if_in_range (0,3) 2 22 30 22 ; select_a_if_in_range (0,3) 3 22 30 22 ; select_a_if_in_range (0,3) 4 22 30 30 ; select_a_if_in_range (0,3) ~-1 22 30 30 ; select_a_if_in_range (0,0) 0 1 2 1 ; select_a_if_in_range (1,1) 0 3 4 4 ; select_a_if_in_range (1,1) 1 5 6 5 ; select_a_if_in_range (1,1) 2 7 8 8 ; select_a_if_in_range (0,0) 0 7904 0 7904 ; select_a_if_in_range (0,3) min_int 22 30 30 ; select_a_if_in_range (0,3) max_int 22 30 30 ; select_a_if_in_range (1,max_int-1) max_int 1 2 2 ; select_a_if_in_range (1,max_int-1) min_int 1 2 2 ; select_a_if_in_range (1,max_int-1) ~-1 3 4 4 ; select_a_if_in_range (1,max_int-1) 0 5 6 6 ; select_a_if_in_range (1,max_int) max_int 1 2 1 ; select_a_if_in_range (1,max_int) min_int 1 2 2 ; select_a_if_in_range (1,max_int) ~-1 3 4 4 ; select_a_if_in_range (1,max_int) 0 5 6 6 ; select_a_if_in_range (1,max_int) 1 5 6 5 ; select_a_if_in_range (0,max_int) max_int 1 2 1 ; select_a_if_in_range (0,max_int) min_int 1 2 2 ; select_a_if_in_range (0,max_int) ~-1 3 4 4 ; select_a_if_in_range (0,max_int) 0 5 6 5 ] ; "divmod", [ divmod "" 1l 2l 0l 1l ; divmod "" 123l 1l 123l 0l ; divmod "" 1l 3l 0l 1l ; divmod "" 2l 3l 0l 2l ; divmod "" 3l 2l 1l 1l ; divmod "" 10l 6l 1l 4l ; divmod "" 10l 4l 2l 2l ; divmod "" 1l 2l 0l 1l ; divmod "" 30l 7l 4l 2l ; divmod "" 4l 2l 2l 0l ; divmod "" 1234567l 1l 1234567l 0l ; divmod "" 1234567l 10l 123456l 7l ; divmod "" 1234567l 100l 12345l 67l ; divmod "" 1234567l 1000l 1234l 567l ; divmod "" 1234567l 10000l 123l 4567l ; divmod "" 12345l 100l 123l 45l ; divmod "" 0xffff1234l 1_000_l 4294906l 420l ; divmod "" 1123456789l 10_000_l 112345l 6789l ] ; "ascii_of_int32", [ ascii_of_int32 "" 6 12345678l "345678" ; ascii_of_int32 "" ~-1 1234l "001234" ; ascii_of_int32 "" 1 9876l "6" ; ascii_of_int32 "" 4 0l "0000" ; ascii_of_int32 "" 6 1234l "001234" ; ascii_of_int32 "" 0 1234l ""] ; "string_of_hex", [ string_of_hex "" "2d2d486924" "--Hi$" ; string_of_hex "" "2D2d486924" "--Hi$" ; string_of_hex "" "1234" "\x12\x34" ; string_of_hex "" "ff80" "\xff\x80" ; string_of_hex "" "b7DDdd" "\xb7\xdd\xdd" ; string_of_hex "" "808888Fd" "\x80\x88\x88\xfd" ; string_of_hex "" "E0EE8eEEEE" "\xe0\xee\x8e\xee\xee" ; string_of_hex "empty" "" ""] ; "hex_of_string", [ hex_of_string "" "--Hi$" "2d2d486924" ; hex_of_string "" "\x12\x34" "1234" ; hex_of_string "" "\xff\x80" "ff80" ; hex_of_string "" "\xb7\xff\x20" "b7ff20" ; hex_of_string "" "\x00\x01\x00" "000100" ; hex_of_string "empty" "" ""] ] eqaf-0.10/test/test_branch.ml000066400000000000000000000115221463277374600161770ustar00rootroot00000000000000let exit_success = 0 let exit_failure = 1 (* First computation wants to count operations needed by - one_if_not_zero - zero_if_not_zero - select_int For each /assembly instructions/, we update a counter. This way is not totally true. Even if we check by hands that bitwise operations don't emit branches, this is our only assumption! *) let operation = ref 0 let logical_shift_right a b = incr operation ; a lsr b let logical_or a b = incr operation ; a lor b let shift_right a b = incr operation ; a asr b let logical_and a b = incr operation ; a land b let logical_not a = incr operation ; lnot a let minus a = incr operation ; (- a) let sub a b = incr operation ; a - b let[@inline always] minus_one_or_less n = logical_shift_right n (sub Sys.int_size 1) let[@inline always] one_if_not_zero n = minus_one_or_less (logical_or (minus n) n) let[@inline always] zero_if_not_zero n = sub (one_if_not_zero n) 1 let[@inline always] select_int choose_b a b = let mask = shift_right (logical_or (minus choose_b) choose_b) Sys.int_size in logical_or (logical_and a (logical_not mask)) (logical_and b mask) let one_if_not_zero_ops = let _ = one_if_not_zero 0x7eadbeef in Format.printf "[one_if_not_zero]: %d operation(s).\n%!" !operation ; !operation let () = operation := 0 let zero_if_not_zero_ops = let _ = zero_if_not_zero 0x7eadbeef in Format.printf "[zero_if_not_zero]: %d operation(s).\n%!" !operation ; !operation let () = operation := 0 let select_int_ops = let _ = select_int 0 1 2 in Format.printf "[select_int]: %d operation(s).\n%!" !operation ; !operation let eqaf_sleep () = Unix.sleep 1 let logical_shift_right a b = eqaf_sleep () ; a lsr b let logical_or a b = eqaf_sleep () ; a lor b let shift_right a b = eqaf_sleep () ; a asr b let logical_and a b = eqaf_sleep () ; a land b let logical_not a = eqaf_sleep () ; lnot a let minus a = eqaf_sleep () ; (- a) let sub a b = eqaf_sleep () ; a - b let[@inline always] minus_one_or_less n = logical_shift_right n (sub Sys.int_size 1) let[@inline always] one_if_not_zero n = minus_one_or_less (logical_or (minus n) n) let[@inline always] zero_if_not_zero n = sub (one_if_not_zero n) 1 let[@inline always] select_int choose_b a b = let mask = shift_right (logical_or (minus choose_b) choose_b) Sys.int_size in logical_or (logical_and a (logical_not mask)) (logical_and b mask) (* Finally, we count how many time we spend when we call our functions. [eqaf_sleep] spends 1 second, so our bitwise operators should spend 1 second + some nanosecond. At the end, execution of them should be closely equal to our operation counter where: 1 operation ~= 1 second To be able to count time, we use [caml_time] which is available only on Linux and for a native compilation (see [@unboxed]). Because bitwise operation spend at least 1 second, we finally [floor] our results to delete noise. NOTE: [check/check] does a linear regression to delete noise and really get how long is our functions. We think that for our functions: - zero_if_not_zero - one_if_not_zero - select_int [check/check] is too huge. *) let time () = Clock.now () let fdiv a b = a /. b let () = let t0 = time () in let _ = one_if_not_zero 0x7eadbeef in let t1 = time () in let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[one_if_not_zero 0x7eadbeef]: %fs.\n%!" v0 ; let t0 = time () in let _ = one_if_not_zero 0x0 in let t1 = time () in let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[one_if_not_zero 0x0]: %fs.\n%!" v0 ; if v0 = v1 && int_of_float v0 = one_if_not_zero_ops && int_of_float v1 = one_if_not_zero_ops then () else exit exit_failure let () = let t0 = time () in let _ = zero_if_not_zero 0x7eadbeef in let t1 = time () in let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[zero_if_not_zero 0x7eadbeef]: %fs.\n%!" v0 ; let t0 = time () in let _ = zero_if_not_zero 0x0 in let t1 = time () in let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[zero_if_not_zero 0x0]: %fs.\n%!" v0 ; if v0 = v1 && int_of_float v0 = zero_if_not_zero_ops && int_of_float v1 = zero_if_not_zero_ops then () else exit exit_failure let () = let t0 = time () in let _ = select_int 0 1 2 in let t1 = time () in let v0 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[select_int 0 1 2]: %fs.\n%!" v0 ; let t0 = time () in let _ = select_int 2 1 0 in let t1 = time () in let v1 = Int64.(floor (fdiv (to_float (sub t1 t0)) 1000000000.)) in Format.printf "[select_int 2 1 0]: %fs.\n%!" v1 ; if v0 = v1 && int_of_float v0 = select_int_ops && int_of_float v1 = select_int_ops then () else exit exit_failure ;;