--- /dev/null
+freebsd_instance:
+ image_family: freebsd-12-1
+
+freebsd_task:
+ env:
+ matrix:
+ - OCAML_VERSION: 4.10.1
+ - OCAML_VERSION: 4.11.1
+ pkg_install_script: pkg install -y ocaml-opam gmp gmake pkgconf bash
+ ocaml_script: opam init -a --comp=$OCAML_VERSION
+ dependencies_script: eval `opam env` && opam install -y --deps-only .
+ build_script: eval `opam env` && dune build @install
+ test_script: eval `opam env` && opam install -y -t --deps-only . && dune build @runtest
--- /dev/null
+name: Eqaf
+
+on: [push, pull_request]
+
+jobs:
+ tests:
+ name: Tests
+
+ strategy:
+ fail-fast: false
+ matrix:
+ ocaml-version: ["4.10.0", "4.09.0", "4.08.1"]
+ 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: avsm/setup-ocaml@v2
+ with:
+ ocaml-version: ${{ 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
--- /dev/null
+_build
+setup.data
+setup.log
+doc/*.html
+*.native
+*.byte
+*.so
+lib/decompress_conf.ml
+*.tar.gz
+_tests
+lib_test/files
+zpipe
+c/dpipe
+*.install
+*~
+.merlin
\ No newline at end of file
--- /dev/null
+version=0.18.0
+disable=true
--- /dev/null
+### 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
--- /dev/null
+The 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.
--- /dev/null
+# 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
--- /dev/null
+open 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
--- /dev/null
+(library
+ (name microtime)
+ (modules microtime)
+ (foreign_stubs
+ (language c)
+ (names microtime)))
+
+(executable
+ (name attack)
+ (modules attack)
+ (libraries fmt unix microtime))
--- /dev/null
+/* Copyright (c) 2018 David Kaloper Meršinjak. All rights reserved.
+ See LICENSE.md */
+
+#include <caml/mlvalues.h>
+
+#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 <x86intrin.h>
+#endif
+
+#include <time.h>
+
+#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);
+}
--- /dev/null
+external microtime : unit -> int = "caml_microtime" [@@noalloc]
--- /dev/null
+# 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.
--- /dev/null
+type 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) |])
+
--- /dev/null
+let 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 () = 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 () = 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 _0 = _0 1 in
+ Fmt.pr "%d trial(s) for Eqaf.equal.\n%!" _0 ;
+ let _1 = _1 1 in
+ Fmt.pr "%d trial(s) for Eqaf.compare.\n%!" _1 ;
+ let _2 = _2 1 in
+ Fmt.pr "%d trial(s) for Eqaf.exists.\n%!" _2 ;
+ let _3 = _3 1 in
+ Fmt.pr "%d trial(s) for Eqaf.find_uint8.\n%!" _3 ;
+ let _4 = _4 1 in
+ Fmt.pr "%d trial(s) for Eqaf.divmod.\n%!" _3 ;
+
+ exit exit_success
--- /dev/null
+(executable
+ (name check)
+ (modules check linear_algebra benchmark fmt unsafe)
+ (libraries eqaf base64 clock))
+
+(rule
+ (copy %{read:../config/which-unsafe-file} unsafe.ml))
+
+(rule
+ (alias runbench)
+ (package eqaf)
+ (deps
+ (:check check.exe))
+ (action
+ (run %{check})))
--- /dev/null
+let 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
--- /dev/null
+(* Code under Apache License 2.0 - Jane Street Group, LLC <opensource@janestreet.com> *)
+
+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
+
--- /dev/null
+external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32"
--- /dev/null
+external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"
--- /dev/null
+let get_int32_ne b i = Bytes.get_int32_ne b i
--- /dev/null
+external clock_linux_get_time
+ : unit -> (int64[@unboxed])
+ = "clock_linux_get_time_byte" "clock_linux_get_time_native"
+[@@noalloc]
+
+let now () = clock_linux_get_time ()
--- /dev/null
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+#include <errno.h>
+#include <stdint.h>
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+#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 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);
+}
--- /dev/null
+external 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 ()
--- /dev/null
+#ifdef __MACH__
+#include <mach/mach.h>
+#include <mach/mach_time.h>
+#include <unistd.h>
+#endif
+
+#include <caml/mlvalues.h>
+#include <caml/memory.h>
+#include <caml/alloc.h>
+#include <caml/fail.h>
+
+// (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 copy_int64(now * s.numer / s.denom);
+}
--- /dev/null
+external 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 ()
--- /dev/null
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/misc.h>
+
+#include <windows.h>
+
+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 = copy_int64(now.QuadPart * frequency.QuadPart);
+
+ CAMLreturn(res);
+}
--- /dev/null
+(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))))
--- /dev/null
+let 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
+ | "windows" | "mingw64" | "mingw" | "cygwin" -> `Windows
+ | "freebsd" -> `FreeBSD
+ | "macosx" -> `MacOSX
+ | 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 <output>" Sys.argv.(0)
+ with _ -> invalid_arg "%s --system system -o <output>" 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
--- /dev/null
+let 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"
+
--- /dev/null
+(executable
+ (name config))
+
+(rule
+ (with-stdout-to
+ which-unsafe-file
+ (run ./config.exe)))
--- /dev/null
+(lang dune 2.0)
+(name eqaf)
+(version v0.8)
--- /dev/null
+version: "0.8"
+opam-version: "2.0"
+maintainer: [ "Romain Calascibetta <romain.calascibetta@gmail.com>" ]
+authors: [ "Romain Calascibetta <romain.calascibetta@gmail.com>" ]
+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"}
+ "cstruct" {>= "1.1.0"}
+ "base64" {with-test}
+ "alcotest" {with-test}
+ "crowbar" {with-test}
+]
\ No newline at end of file
--- /dev/null
+(executable
+ (name fuzz)
+ (libraries crowbar eqaf))
+
+(rule
+ (alias runtest)
+ (package eqaf)
+ (deps
+ (:fuzz fuzz.exe))
+ (action
+ (run %{fuzz})))
--- /dev/null
+open 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)
--- /dev/null
+(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_cstruct)
+ (public_name eqaf.cstruct)
+ (modules eqaf_cstruct)
+ (libraries cstruct eqaf.bigstring))
--- /dev/null
+let[@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
--- /dev/null
+(** 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}.
+*)
+
--- /dev/null
+type 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
--- /dev/null
+type 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
--- /dev/null
+let 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)
--- /dev/null
+val 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
--- /dev/null
+external 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
--- /dev/null
+external 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
--- /dev/null
+let 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
--- /dev/null
+(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})))
--- /dev/null
+type 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.strf "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.strf "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.strf "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.strf "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.strf
+ "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.strf
+ "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.strf
+ "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.strf
+ "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.strf
+ "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.strf
+ " %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.strf
+ " %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" "" ""]
+ ]
--- /dev/null
+let 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
+;;
projects / ocaml-eqaf.git / commitdiff