swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Browse source
This commit is contained in:
swrup 2025-11-11 02:07:51 +01:00
parent aa2ff7b2f0
commit 2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

13
unikernel/duniverse/eqaf/.cirrus.yml Normal file
View file

@ -0,0 +1,13 @@
freebsd_instance:
image_family: freebsd-14-1
freebsd_task:
env:
matrix:
- OCAML_VERSION: 4.13.1
- OCAML_VERSION: 4.14.2
pkg_install_script: pkg install -y ocaml-opam gmake bash
ocaml_script: opam init -a --comp=$OCAML_VERSION
dependencies_script: eval `opam env` && opam pin add -yn eqaf.dev . && opam pin add -yn eqaf-cstruct.dev . && opam install -y --deps-only eqaf eqaf-cstruct
build_script: eval `opam env` && dune build @install
test_script: eval `opam env` && opam install -y -t --deps-only . && dune build @runtest

42
unikernel/duniverse/eqaf/.github/workflows/test.yml vendored Normal file
View file

@ -0,0 +1,42 @@
name: Eqaf
on: [push, pull_request]
jobs:
tests:
name: Tests
strategy:
fail-fast: false
matrix:
ocaml-version: ["4.13.1", "4.14.2"]
operating-system: [macos-latest, ubuntu-latest, windows-latest]
runs-on: ${{ matrix.operating-system }}
steps:
- name: Checkout code
uses: actions/checkout@v2
- name: Use OCaml ${{ matrix.ocaml-version }}
uses: ocaml/setup-ocaml@v2
with:
ocaml-compiler: ${{ matrix.ocaml-version }}
- name: Install nasm
uses: ilammy/setup-nasm@v1
- name: Install dependencies
run: |
opam pin add -n eqaf .
opam depext -y eqaf
opam install -t --deps-only .
- name: Build
run: opam exec -- dune build -p eqaf
- name: Simple tests
run: opam exec -- dune exec test/test.exe
- name: Branch tests
run: opam exec -- dune exec test/test_branch.exe
- name: Fuzz tests
run: opam exec -- dune exec fuzz/fuzz.exe

16
unikernel/duniverse/eqaf/.gitignore vendored Normal file
View file

@ -0,0 +1,16 @@
_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

2
unikernel/duniverse/eqaf/.ocamlformat Normal file
View file

@ -0,0 +1,2 @@
version=0.21.0
disable=true

93
unikernel/duniverse/eqaf/CHANGES.md Normal file
View file

@ -0,0 +1,93 @@
### v0.10 2024-06-14 Kyoto (Japon)
- Implement functions provided by `eqaf` on bytes (@FantomeBeignet, #41)
- Choose the right clock on MSVC systems (@dra27, #40)
- Fix the lower bounds about base64 (@hannesm, #45)
- Split `eqaf` and `eqaf-cstruct` (@dinosaure, @hannesm, #43)
### v0.9 2022-07-24 Paris (France)
- Add support of OCaml 5.00 (@kit-ty-kate, #37)
- Add support for current-bench and fix bad r² for unequal strings (@Zined-Ada, @art-w, #38)
- Add benchmark with `bechamel` (@Zineb-Ada, @art-w, #38)
### v0.8 2021-08-06 Paris (France)
- Fix the check tool on 4.11.0 (@dinosaure, @cfcs, @stedolan, #30)
The compilation on 4.11 triggers a case where the locality of the expected
value when we test `exists_uint8` must be the same. Otherwise, the access to
this value can have a cost which faults our result.
- Add several utility functions (@cfcs, @dinosaure, #26)
* `bytes_of_hex` & `string_of_hex`, hex decoding
* `hex_of_bytes` & `hex_of_string`, hex encoding
* `divmod`, unsigned `int32` division with small divisors
* `ascii_of_int32`, conversion from `int32` to decimal `string`
representation
* `lowercase_ascii` & `uppercase_ascii`, _constant-time_ implementation of
`String.{lower,upper}case_ascii`
* `select_a_if_in_range`, like `select_int` but only supporting positive
ranges
* `int_of_bool` & `bool_of_int`, _constant-time_ of `Bool.to_int`
A documentation exists for each function. The _constant-time_ is checked only
systematically for `divmod`.
- Merge optional sub-packages (@kit-ty-kate, @hannesm, @dinosaure, #27)
`cstruct` becomes a required dependency of `eqaf`
- Fix FreeBSD support and remove support of < OCaml 4.07 and remove the
dependency to `bigarray-compat` (@hannesm, @dinosaure, #32)
- Add a CI on FreeBSD (@dinosaure, @hannesm, #33)
- Remove the test `check/check.exe` (@dinosaure, #31)
The test `check/check.exe` is really volatile and should be executed into a
controlled environment (for instance, with `nice -n19` and a _bare-metal_
computer). We still require the test for any improvement of `eqaf` but it is
executed separately from our CI.
### v0.7 2020-04-16 Paris (France)
- Add `find_uint8` (@dinosaure, @cfcs, #20)
- Add `exists_uint8` (@dinosaure, @cfcs, #20)
### v0.6 2020-03-11 Paris (France)
- remove build dependency on dune (@CraigFe, #16)
- add bigarray-compat and optional dependencies (@hannesm, #17)
- add `select_int`, `one_if_not_zero`, `zero_if_not_zero` (@cfcs, @dinosaure, #19, #18)
### v0.5 2019-07-01 Paris (France)
- Delete `min` and use `<>` operator to compare length on `equal` function
- Implementation of `compare_{be,le}{,with_len}` function (@cfcs, @hannesm, @dinosaure)
- Test on `compare` function (@dinosaure)
- Unit test on `compare` (@dinosaure)
- Fuzz test on `compare` (@dinosaure)
- Documentation (@dinosaure, @cfcs)
### v0.4 2019-05-24 Paris (France)
- Distribution integrate an attack example
- Fuzzer to test `equal` function
- Unroll internal loop over 16 bits integers instead 32 bits
- Put x86 ASM output in implementation (and audit)
- Do second check even if first on fails (bad r²)
- Avoid indirection to `Pervasives` functions
### v0.3 2019-05-02 Paris (France)
- Provide `Eqaf_bigstring`
- Provide `Eqaf_cstruct`
- New check tool and delete any dependencies on `eqaf` package (@dinosaure, @hannesm, @cfcs)
NOTE: This version is buggy, you MUST use v0.2 or v0.4
### v0.2 2018-10-15 Paris (France)
* _Dunify_ project
* Update OPAM file
* Avoid `core_bench` dependency
* Make benchmark to test constant-time on `eqml`
* __Move `equal` function to the OCaml implementation__ (instead C implementation)
* Port benchmark on Windows and Mac OSX
### v0.1 2018-08-31 Paris (France)
* First release

20
unikernel/duniverse/eqaf/LICENSE.md Normal file
View file

@ -0,0 +1,20 @@
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.

4
unikernel/duniverse/eqaf/Makefile Normal file
View file

@ -0,0 +1,4 @@
.PHONY: bench
bench:
dune exec check/check.exe
dune exec check/bench.exe

204
unikernel/duniverse/eqaf/README.md Normal file
View file

@ -0,0 +1,204 @@
# 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

79
unikernel/duniverse/eqaf/attack/attack.ml Normal file
View file

@ -0,0 +1,79 @@
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

11
unikernel/duniverse/eqaf/attack/dune Normal file
View file

@ -0,0 +1,11 @@
(library
(name microtime)
(modules microtime)
(foreign_stubs
(language c)
(names microtime)))
(executable
(name attack)
(modules attack)
(libraries fmt unix microtime))

41
unikernel/duniverse/eqaf/attack/microtime.c Normal file
View file

@ -0,0 +1,41 @@
/* 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);
}

1
unikernel/duniverse/eqaf/attack/microtime.ml Normal file
View file

@ -0,0 +1 @@
external microtime : unit -> int = "caml_microtime" [@@noalloc]

127
unikernel/duniverse/eqaf/check/README.md Normal file
View file

@ -0,0 +1,127 @@
# 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.

137
unikernel/duniverse/eqaf/check/bench.ml Normal file
View file

@ -0,0 +1,137 @@
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
Random.full_init random_seed
let random length =
let get _ =
match Random.int (10 + 26 + 26) with
| n when n < 10 -> Char.(chr (code '0' + n))
| n when n < 10 + 26 -> Char.(chr (code 'a' + n - 10))
| n -> Char.(chr (code 'A' + n - 10 - 26))
in
String.init length get
open Bechamel
open Toolkit
let hash_eq_0 = random 4096
let hash_eq_1 = Bytes.to_string (Bytes.of_string hash_eq_0)
let chr_into_hash_eq_0 = hash_eq_0.[Random.int 4096]
let hash_neq_0 = random 4096
let hash_neq_1 =
let rec go limit =
if limit <= 0 then failwith "Impossible to generate different hashes.";
let res = random 4096 in
if res = hash_neq_0 then go (pred limit) else res
in
go 10
let random_chr =
let rec go limit =
if limit <= 0 then
failwith
"Impossible to generate a byte which does not appear into hash_neq_0.";
let res = Char.chr (Random.int 256) in
if not (String.contains hash_neq_0 res) then res else go (pred limit)
in
go 10
let test_equal0 =
Test.make ~name:"equal"
(Staged.stage @@ fun () -> Eqaf.equal hash_eq_0 hash_eq_1)
let test_equal1 =
Test.make ~name:"not equal"
(Staged.stage @@ fun () -> Eqaf.equal hash_neq_0 hash_neq_1)
let cfg = Benchmark.cfg ~start:100
let test_compare0 =
Test.make ~name:"equal"
(Staged.stage @@ fun () -> Eqaf.compare_be hash_eq_0 hash_eq_1)
let test_compare1 =
Test.make ~name:"not equal"
(Staged.stage @@ fun () -> Eqaf.compare_be hash_neq_0 hash_neq_1)
let f_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0
let f_neq_0 (v : int) = v = Char.code random_chr
let test_exists0 =
Test.make ~name:"equal"
(Staged.stage @@ fun () -> Eqaf.exists_uint8 ~f:f_eq_0 hash_eq_0)
let test_exists1 =
Test.make ~name:"not equal"
(Staged.stage @@ fun () -> Eqaf.exists_uint8 ~f:f_neq_0 hash_neq_0)
let f_hash_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0
let f_random (v : int) = v = Char.code random_chr
let test_find0 =
Test.make ~name:"equal"
(Staged.stage @@ fun () -> Eqaf.find_uint8 ~f:f_hash_eq_0 hash_eq_0)
let test_find1 =
Test.make ~name:"not equal"
(Staged.stage @@ fun () -> Eqaf.find_uint8 ~f:f_random hash_neq_0)
let benchmark () =
let ols =
Analyze.ols ~bootstrap:0 ~r_square:true ~predictors:Measure.[| run |]
in
let instances =
Instance.[ monotonic_clock ]
in
let cfg =
Benchmark.cfg ~limit:2000 ~stabilize:true ~quota:(Time.second 1.)
~start:1000 ~kde:(Some 1000) ()
in
let test_equal =
Test.make_grouped ~name:"equal" ~fmt:"%s %s"
[ test_equal0; test_equal1 ]
in
let test_compare =
Test.make_grouped ~name:"compare" ~fmt:"%s %s"
[ test_compare0; test_compare1 ]
in
let test_exists =
Test.make_grouped ~name:"exists" ~fmt:"%s %s"
[ test_exists0; test_exists1 ]
in
let test_find =
Test.make_grouped ~name:"find" ~fmt:"%s %s"
[ test_find0; test_find1 ]
in
let raw_results =
Benchmark.all cfg instances
(Test.make_grouped ~name:"benchmark" ~fmt:"%s %s"
[ test_equal; test_compare; test_exists; test_find ])
in
let results =
List.map (fun instance -> Analyze.all ols instance raw_results) instances
in
let pr_bench name value =
Format.printf
{|{"results": [{"name": "eqaf", "metrics": [{"name": "%s", "value": %f, "units": "ns"}]}]}@.|}
name value
in
let results = Analyze.merge ols instances results in
let timings = Hashtbl.find results "monotonic-clock" in
Hashtbl.iter
(fun c v ->
match Analyze.OLS.estimates v with
| None -> ()
| Some ts -> List.iter (pr_bench c) ts)
timings;
()
let () = benchmark ()

63
unikernel/duniverse/eqaf/check/benchmark.ml Normal file
View file

@ -0,0 +1,63 @@
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) |])

490
unikernel/duniverse/eqaf/check/check.ml Normal file
View file

@ -0,0 +1,490 @@
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 () =
for _ = 1 to 100
do let _ = String.equal hash_neq_0 hash_neq_1 in () done ;
String.equal hash_neq_0 hash_neq_1
let eqaf_true () = Eqaf.equal hash_eq_0 hash_eq_1
let eqaf_false () = Eqaf.equal hash_neq_0 hash_neq_1
end)
module Compare = Make(struct
type ret = int
let eqaf_name = "Eqaf.compare"
let stdlib_name = "String.compare"
let reset = ignore and switch = ignore
let stdlib_true () = String.compare hash_eq_0 hash_eq_1
let stdlib_false () =
for _ = 1 to 100
do let _ = String.compare hash_neq_0 hash_neq_1 in () done ;
String.compare hash_neq_0 hash_neq_1
let eqaf_true () = Eqaf.compare_be hash_eq_0 hash_eq_1
let eqaf_false () = Eqaf.compare_be hash_neq_0 hash_neq_1
end)
module Exists = Make(struct
type ret = bool
let eqaf_name = "Eqaf.exists_uint8"
let stdlib_name = "String.contains"
let constant = ref (Char.code chr_into_hash_eq_0)
let reset () = constant := Char.code chr_into_hash_eq_0
let switch () = constant := Char.code random_chr
let stdlib_true () = String.contains hash_eq_0 chr_into_hash_eq_0
let stdlib_false () = String.contains hash_neq_0 random_chr
let f (v : int) = v = !constant
let eqaf_true () = Eqaf.exists_uint8 ~f hash_eq_0
let eqaf_false () = Eqaf.exists_uint8 ~f hash_neq_0
end)
module Find = Make(struct
type ret = int
let eqaf_name = "Eqaf.find_uint8"
let stdlib_name = "String.index"
let switch () = ()
let reset () = ()
let stdlib_true () = String.index hash_eq_0 chr_into_hash_eq_0
let stdlib_false () = try String.index hash_neq_0 random_chr with Not_found -> (-1)
let f_hash_eq_0 (v : int) = v = Char.code chr_into_hash_eq_0
let f_random (v : int) = v = Char.code random_chr
let eqaf_true () = Eqaf.find_uint8 ~f:f_hash_eq_0 hash_eq_0
let eqaf_false () = Eqaf.find_uint8 ~f:f_random hash_neq_0
end)
module Divmod32 = Make(struct
type ret = int32 * int32
let eqaf_name = "Eqaf.divmod"
let stdlib_name = "Int32.unsigned_div,Int32.unsigned_rem"
let switch () = ()
let reset () = ()
(* These are here for compat with OCaml <= 4.09
from >= they can be replaced by
Int32.unsigned_div
Int32.unsigned_rem
*)
let int32_div_unsigned n d =
let sub,min_int = Int32.(sub,min_int)in
let int32_unsigned_compare n m =
Int32.compare (sub n min_int) (sub m min_int)
in
if d < 0_l then
if int32_unsigned_compare n d < 0 then 0_l else 1_l
else
let q =
let open Int32 in
shift_left (Int32.div (Int32.shift_right_logical n 1) d) 1 in
let r = sub n (Int32.mul q d) in
if int32_unsigned_compare r d >= 0 then Int32.succ q else q
let int32_rem_unsigned n d =
Int32.sub n (Int32.mul (int32_div_unsigned n d) d)
(* TODO *)
let stdlib_true () =
let x, m = int32_into_hash_eq_0, int14_into_hash_eq_0 in
int32_div_unsigned x m,
int32_rem_unsigned x m
let stdlib_false () =
let x, m = int32_into_hash_eq_1, int14_into_hash_eq_1 in
int32_div_unsigned x m,
int32_rem_unsigned x m
let eqaf_true () =
Eqaf.divmod ~x:int32_into_hash_eq_0 ~m:int14_into_hash_eq_0
let eqaf_false () =
Eqaf.divmod ~x:int32_into_hash_eq_1 ~m:int14_into_hash_eq_1
end)
module Ascii_int32 = Make(struct
type ret = string
let eqaf_name = "Eqaf.ascii_of_int32"
let stdlib_name = "Int32.to_string"
let switch () = ()
let reset () = ()
(* TODO setting 0x8000 bit ensures five digits.
We need a constant amount of digits to specify ~digits because
we don't have a [Int32.to_string] that left-pads.
Maybe we can use [Format.sprintf] ?
*)
let true_int = Int32.logand 0x8000l int14_into_hash_eq_0
let false_int = Int32.logand 0x8000l int14_into_hash_eq_1
let stdlib_true () = Int32.to_string true_int
let stdlib_false () = Int32.to_string false_int
let eqaf_true () = Eqaf.ascii_of_int32 ~digits:5 true_int
let eqaf_false () = Eqaf.ascii_of_int32 ~digits:5 false_int
end)
let limit = 20
let () =
let rec _0 tried =
if tried > 20 then invalid_arg "Too many tried for Eqaf.equal" ;
let res = Equal.test () in
if res = exit_success then tried else _0 (succ tried) in
let rec _1 tried =
if tried > 20 then invalid_arg "Too many tried for Eqaf.compare" ;
let res = Compare.test () in
if res = exit_success then tried else _1 (succ tried) in
let rec _2 tried =
if tried > 20 then invalid_arg "Too many tried for Eqaf.exists" ;
let res = Exists.test () in
if res = exit_success then tried else _2 (succ tried) in
let rec _3 tried =
if tried > 20 then invalid_arg "Too many tried for Eqaf.find_uint8" ;
let res = Find.test () in
if res = exit_success then tried else _3 (succ tried) in
let rec _4 tried =
if tried > 20 then invalid_arg "Too many tried for Eqaf.divmod" ;
let res = Divmod32.test () in
if res = exit_success then tried else _4 (succ tried) in
let pr_bench name value =
Fmt.pr {|{"results": [{"name": "check", "metrics": [{"name": "%s", "value": %d}]}]}@.|} name value in
let _0 = _0 1 in
Fmt.pr "%d trial(s) for Eqaf.equal.\n%!" _0 ;
pr_bench "equal" _0 ;
let _1 = _1 1 in
Fmt.pr "%d trial(s) for Eqaf.compare.\n%!" _1 ;
pr_bench "compare" _1 ;
let _2 = _2 1 in
Fmt.pr "%d trial(s) for Eqaf.exists.\n%!" _2 ;
pr_bench "exists" _2 ;
let _3 = _3 1 in
Fmt.pr "%d trial(s) for Eqaf.find_uint8.\n%!" _3 ;
pr_bench "find_uint8" _3 ;
let _4 = _4 1 in
Fmt.pr "%d trial(s) for Eqaf.divmod.\n%!" _4 ;
pr_bench "divmod" _4 ;
exit exit_success

20
unikernel/duniverse/eqaf/check/dune Normal file
View file

@ -0,0 +1,20 @@
(executable
(name check)
(modules check linear_algebra benchmark fmt unsafe)
(libraries eqaf base64 clock))
(executable
(name bench)
(modules bench)
(libraries bechamel eqaf base64))
(rule
(copy %{read:../config/which-unsafe-file} unsafe.ml))
(rule
(alias runbench)
(package eqaf)
(deps
(:check check.exe))
(action
(run %{check})))

4
unikernel/duniverse/eqaf/check/fmt.ml Normal file
View file

@ -0,0 +1,4 @@
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

129
unikernel/duniverse/eqaf/check/linear_algebra.ml Normal file
View file

@ -0,0 +1,129 @@
(* 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

1
unikernel/duniverse/eqaf/check/unsafe_pre407.ml Normal file
View file

@ -0,0 +1 @@
external get_int32_ne : bytes -> int -> int32 = "%caml_string_get32"

1
unikernel/duniverse/eqaf/check/unsafe_pre408.ml Normal file
View file

@ -0,0 +1 @@
external get_int32_ne : bytes -> int -> int32 = "%caml_bytes_get32"

1
unikernel/duniverse/eqaf/check/unsafe_stable.ml Normal file
View file

@ -0,0 +1 @@
let get_int32_ne b i = Bytes.get_int32_ne b i

6
unikernel/duniverse/eqaf/clock/clock_linux.ml Normal file
View file

@ -0,0 +1,6 @@
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 ()

57
unikernel/duniverse/eqaf/clock/clock_linux_stubs.c Normal file
View file

@ -0,0 +1,57 @@
#define CAML_NAME_SPACE
#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 caml_copy_int64(ts.tv_sec * 1000000000LL + ts.tv_nsec);
}
// XXX(dinosaure): commented because to be able to compile the test into any
// platform (ARM)
//
// uint64_t
// clock_linux_get_tick(__unit ())
// {
// // struct timespec ts;
// unsigned hi, lo;
// __asm__ __volatile__ ("rdtsc" : "=a"(lo), "=d"(hi));
//
// // XXX(dinosaure): [clock_gettime] costs a lot and are
// // not really precise. [rdtsc] (Read Time Stamp Counter)
// // is more reliable.
//
// return (((unsigned long long) lo) | (((unsigned long long) hi) << 32));
// }
uint64_t
clock_linux_get_time_native(__unit ())
{
struct timespec ts;
(void) clock_gettime(CLOCK_MONOTONIC, &ts);
// XXX(dinosaure): assume that it will never fail.
// [caml_invalid_argument] allocs.
return (ts.tv_sec * 1000000000LL + ts.tv_nsec);
}

5
unikernel/duniverse/eqaf/clock/clock_mach.ml Normal file
View file

@ -0,0 +1,5 @@
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 ()

35
unikernel/duniverse/eqaf/clock/clock_mach_stubs.c Normal file
View file

@ -0,0 +1,35 @@
#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 caml_copy_int64(now * s.numer / s.denom);
}

5
unikernel/duniverse/eqaf/clock/clock_windows.ml Normal file
View file

@ -0,0 +1,5 @@
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 ()

30
unikernel/duniverse/eqaf/clock/clock_windows_stubs.c Normal file
View file

@ -0,0 +1,30 @@
#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 = caml_copy_int64(now.QuadPart * frequency.QuadPart);
CAMLreturn(res);
}

21
unikernel/duniverse/eqaf/clock/dune Normal file
View file

@ -0,0 +1,21 @@
(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))))

68
unikernel/duniverse/eqaf/clock/select/select.ml Normal file
View file

@ -0,0 +1,68 @@
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
| "win32" | "win64" | "mingw64" | "mingw" | "cygwin" -> `Windows
| "freebsd" -> `FreeBSD
| "macosx" -> `MacOSX
| "beos" | "dragonfly" | "bsd" | "openbsd" | "netbsd" | "gnu"
| "solaris" | "unknown" ->
invalid_arg "Unsupported system: %s" system
| v ->
if String.sub system 0 5 = "linux"
then `Linux
else invalid_arg "Invalid argument of system option: %s" v
in
(system, output)
| _ -> invalid_arg "%s --system system -o <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

10
unikernel/duniverse/eqaf/config/config.ml Normal file
View file

@ -0,0 +1,10 @@
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"

7
unikernel/duniverse/eqaf/config/dune Normal file
View file

@ -0,0 +1,7 @@
(executable
(name config))
(rule
(with-stdout-to
which-unsafe-file
(run ./config.exe)))

3
unikernel/duniverse/eqaf/dune-project Normal file
View file

@ -0,0 +1,3 @@
(lang dune 2.0)
(name eqaf)
(version v0.10)

25
unikernel/duniverse/eqaf/eqaf-cstruct.opam Normal file
View file

@ -0,0 +1,25 @@
version: "0.10"
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 ]
]
depends: [
"ocaml" {>= "4.07.0"}
"dune" {>= "2.0"}
"cstruct" {>= "1.1.0"}
"eqaf" {= version}
]

29
unikernel/duniverse/eqaf/eqaf.opam Normal file
View file

@ -0,0 +1,29 @@
version: "0.10"
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"}
"base64" {with-test & >= "3.0.0"}
"alcotest" {with-test}
"crowbar" {with-test}
"fmt" {with-test & >= "0.8.7"}
"bechamel" {with-test}
]

11
unikernel/duniverse/eqaf/fuzz/dune Normal file
View file

@ -0,0 +1,11 @@
(executable
(name fuzz)
(libraries crowbar eqaf))
(rule
(alias runtest)
(package eqaf)
(deps
(:fuzz fuzz.exe))
(action
(run %{fuzz})))

133
unikernel/duniverse/eqaf/fuzz/fuzz.ml Normal file
View file

@ -0,0 +1,133 @@
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)

25
unikernel/duniverse/eqaf/lib/dune Normal file
View file

@ -0,0 +1,25 @@
(library
(name eqaf)
(public_name eqaf)
(modules unsafe eqaf))
(rule
(copy %{read:../config/which-unsafe-file} unsafe.ml))
(library
(name eqaf_bigstring)
(public_name eqaf.bigstring)
(modules eqaf_bigstring)
(libraries eqaf))
(library
(name eqaf_bytes)
(public_name eqaf.bytes)
(modules eqaf_bytes)
(libraries eqaf))
(library
(name eqaf_cstruct)
(public_name eqaf-cstruct)
(modules eqaf_cstruct)
(libraries cstruct eqaf.bigstring))

389
unikernel/duniverse/eqaf/lib/eqaf.ml Normal file
View file

@ -0,0 +1,389 @@
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

318
unikernel/duniverse/eqaf/lib/eqaf.mli Normal file
View file

@ -0,0 +1,318 @@
(** 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}.
*)

106
unikernel/duniverse/eqaf/lib/eqaf_bigstring.ml Normal file
View file

@ -0,0 +1,106 @@
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

9
unikernel/duniverse/eqaf/lib/eqaf_bigstring.mli Normal file
View file

@ -0,0 +1,9 @@
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

32
unikernel/duniverse/eqaf/lib/eqaf_bytes.ml Normal file
View file

@ -0,0 +1,32 @@
let equal a b =
let a' = Bytes.unsafe_to_string a in
let b' = Bytes.unsafe_to_string b in
Eqaf.equal a' b'
let compare_le_with_len ~len a b =
let a' = Bytes.unsafe_to_string a in
let b' = Bytes.unsafe_to_string b in
Eqaf.compare_le_with_len ~len a' b'
let compare_le a b =
let a' = Bytes.unsafe_to_string a in
let b' = Bytes.unsafe_to_string b in
Eqaf.compare_le a' b'
let compare_be_with_len ~len a b =
let a' = Bytes.unsafe_to_string a in
let b' = Bytes.unsafe_to_string b in
Eqaf.compare_be_with_len ~len a' b'
let compare_be a b =
let a' = Bytes.unsafe_to_string a in
let b' = Bytes.unsafe_to_string b in
Eqaf.compare_be a' b'
let find_uint8 ?off ~f b =
let str = Bytes.unsafe_to_string b in
Eqaf.find_uint8 ?off ~f str
let exists_uint8 ?off ~f b =
let str = Bytes.unsafe_to_string b in
Eqaf.exists_uint8 ?off ~f str

7
unikernel/duniverse/eqaf/lib/eqaf_bytes.mli Normal file
View file

@ -0,0 +1,7 @@
val equal : bytes -> bytes -> bool
val compare_be : bytes -> bytes -> int
val compare_be_with_len : len:int -> bytes -> bytes -> int
val compare_le : bytes -> bytes -> int
val compare_le_with_len : len:int -> bytes -> bytes -> int
val find_uint8 : ?off:int -> f:(int -> bool) -> bytes -> int
val exists_uint8 : ?off:int -> f:(int -> bool) -> bytes -> bool

26
unikernel/duniverse/eqaf/lib/eqaf_cstruct.ml Normal file
View file

@ -0,0 +1,26 @@
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)

7
unikernel/duniverse/eqaf/lib/eqaf_cstruct.mli Normal file
View file

@ -0,0 +1,7 @@
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

13
unikernel/duniverse/eqaf/lib/unsafe_pre407.ml Normal file
View file

@ -0,0 +1,13 @@
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

13
unikernel/duniverse/eqaf/lib/unsafe_pre408.ml Normal file
View file

@ -0,0 +1,13 @@
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

2
unikernel/duniverse/eqaf/lib/unsafe_stable.ml Normal file
View file

@ -0,0 +1,2 @@
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

27
unikernel/duniverse/eqaf/test/dune Normal file
View file

@ -0,0 +1,27 @@
(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})))

209
unikernel/duniverse/eqaf/test/test.ml Normal file
View file

@ -0,0 +1,209 @@
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.str "be %S %S = %d" a b expected in
Alcotest.test_case title `Quick @@ fun () ->
let expected' = String.compare a b in
Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_be a b) expected ;
Alcotest.(check (value (of_expected expected'))) "string.compare" (Eqaf.compare_be a b) expected'
let le a b expected =
let title = Fmt.str "le %S %S = %d" a b expected in
Alcotest.test_case title `Quick @@ fun () ->
Alcotest.(check (value (of_expected expected))) "result" (Eqaf.compare_le a b) expected
let exists str chr exists =
Alcotest.test_case (Fmt.str "contains %S %c = %b" str chr exists) `Quick @@ fun () ->
let res = Eqaf.exists_uint8 ~f:((=) (Char.code chr)) str in
Alcotest.(check bool) "result" res exists
let find str chr index =
Alcotest.test_case (Fmt.str "index %S %c = %d" str chr index) `Quick @@ fun () ->
let res = Eqaf.find_uint8 ~f:((=) (Char.code chr)) str in
Alcotest.(check int) "result" res index
let int_of_bool bool expect =
Alcotest.test_case
(Fmt.str
"int_of_bool %B = %d" bool expect
) `Quick @@ fun ()->
Alcotest.(check int) "result" expect (Eqaf.int_of_bool bool)
let bool_of_int desc n expect =
Alcotest.test_case
(Fmt.str
"int_of_bool %s = %B" desc expect
) `Quick @@ fun ()->
Alcotest.(check bool) "result" expect (Eqaf.bool_of_int n)
let select_a_if_in_range (low,high) n a b expect =
Alcotest.test_case
(Fmt.str
"select_a_if_in_range (%d,%d) ~n:%d %d %d"
low high n a b
) `Quick @@ fun ()->
let choice = Eqaf.select_a_if_in_range ~low ~high ~n a b in
Alcotest.(check int) "selected" expect choice
let a_uint32 = Alcotest.testable Fmt.uint32 (=)
let divmod str x m q r =
(* (x / m = q) and (x mod m = r) *)
Alcotest.test_case
(Fmt.str
"divmod %s %lu / %lu = %lu, %lu mod %lu = %lu"
str x m q x m r
) `Quick @@ fun ()->
let eq_quot, eq_rem = Eqaf.divmod ~x ~m in
Alcotest.(check (pair a_uint32 a_uint32)) "q,r" (q,r) (eq_quot,eq_rem)
let ascii_of_int32 str digits n expect =
Alcotest.test_case
(Fmt.str
"ascii_of_string %s %d %lu %S"
str digits n expect
) `Quick @@ fun ()->
try
let ascii = Eqaf.ascii_of_int32 ~digits n in
Alcotest.(check string) str expect ascii
with Invalid_argument x when x = "digits < 0" -> ()
let string_of_hex str hex expect =
Alcotest.test_case
(Fmt.str
" %s %S %S"
str hex expect
) `Quick @@ fun ()->
let enc = Eqaf.string_of_hex hex in
Alcotest.(check @@ pair string int) str (expect,0) enc
let hex_of_string str raw expect =
Alcotest.test_case
(Fmt.str
" %s %S %S"
str raw expect
) `Quick @@ fun ()->
let enc = Eqaf.hex_of_string raw in
Alcotest.(check string) str expect enc
let () =
Alcotest.run "eqaf"
[ "be", [ be "a" "a" 0
; be "a" "b" (-1)
; be "b" "a" 1
; be "aa" "ab" (-1)
; be "aaa" "aba" (-1)
; be "bbb" "abc" 1
; be "bbb" "bbc" (-1)
; be "bbb" "abb" 1
; be "\x00\x34\x12" "\x00\x33\x12" 1
; be "\x00\x34\x12" "\x00\x33\x99" 1 ]
; "le", [ le "a" "a" 0
; le "a" "b" (-1)
; le "b" "a" 1
; le "aa" "ab" (-1)
; le "aaa" "aba" (-1)
; le "bbb" "abc" (-1)
; le "bbb" "bbc" (-1)
; le "bbb" "abb" 1
; le "\x00\x34\x12" "\x00\x33\x12" 1
; le "\x00\x34\x12" "\x00\x33\x99" (-1) ]
; "exists", [ exists "a" 'a' true
; exists "a" 'b' false
; exists "abc" 'c' true
; exists "abc" 'a' true
; exists "abc" 'b' true
; exists "abc" 'd' false ]
; "find", [ find "a" 'a' 0
; find "a" 'b' (-1)
; find "aaaa" 'a' 0
; find "bbbb" 'a' (-1)
; find "aabb" 'b' 2
; find "aabb" 'a' 0
; find "aaab" 'b' 3 ]
; "int_of_bool", [ int_of_bool false 0 (* exhaustive :-) *)
; int_of_bool true 1]
; "bool_of_int", [ bool_of_int "0" 0 false
; bool_of_int "-1" ~-1 true
; bool_of_int "2" 2 true
; bool_of_int "max_int" max_int true
; bool_of_int "min_int" min_int true
; bool_of_int "1" 1 true ]
; "select_a_if_in_range",
[ select_a_if_in_range (0,3) 0 22 30 22
; select_a_if_in_range (0,3) 1 22 30 22
; select_a_if_in_range (0,3) 2 22 30 22
; select_a_if_in_range (0,3) 3 22 30 22
; select_a_if_in_range (0,3) 4 22 30 30
; select_a_if_in_range (0,3) ~-1 22 30 30
; select_a_if_in_range (0,0) 0 1 2 1
; select_a_if_in_range (1,1) 0 3 4 4
; select_a_if_in_range (1,1) 1 5 6 5
; select_a_if_in_range (1,1) 2 7 8 8
; select_a_if_in_range (0,0) 0 7904 0 7904
; select_a_if_in_range (0,3) min_int 22 30 30
; select_a_if_in_range (0,3) max_int 22 30 30
; select_a_if_in_range (1,max_int-1) max_int 1 2 2
; select_a_if_in_range (1,max_int-1) min_int 1 2 2
; select_a_if_in_range (1,max_int-1) ~-1 3 4 4
; select_a_if_in_range (1,max_int-1) 0 5 6 6
; select_a_if_in_range (1,max_int) max_int 1 2 1
; select_a_if_in_range (1,max_int) min_int 1 2 2
; select_a_if_in_range (1,max_int) ~-1 3 4 4
; select_a_if_in_range (1,max_int) 0 5 6 6
; select_a_if_in_range (1,max_int) 1 5 6 5
; select_a_if_in_range (0,max_int) max_int 1 2 1
; select_a_if_in_range (0,max_int) min_int 1 2 2
; select_a_if_in_range (0,max_int) ~-1 3 4 4
; select_a_if_in_range (0,max_int) 0 5 6 5
]
; "divmod", [ divmod "" 1l 2l 0l 1l
; divmod "" 123l 1l 123l 0l
; divmod "" 1l 3l 0l 1l
; divmod "" 2l 3l 0l 2l
; divmod "" 3l 2l 1l 1l
; divmod "" 10l 6l 1l 4l
; divmod "" 10l 4l 2l 2l
; divmod "" 1l 2l 0l 1l
; divmod "" 30l 7l 4l 2l
; divmod "" 4l 2l 2l 0l
; divmod "" 1234567l 1l 1234567l 0l
; divmod "" 1234567l 10l 123456l 7l
; divmod "" 1234567l 100l 12345l 67l
; divmod "" 1234567l 1000l 1234l 567l
; divmod "" 1234567l 10000l 123l 4567l
; divmod "" 12345l 100l 123l 45l
; divmod "" 0xffff1234l 1_000_l 4294906l 420l
; divmod "" 1123456789l 10_000_l 112345l 6789l ]
; "ascii_of_int32", [ ascii_of_int32 "" 6 12345678l "345678"
; ascii_of_int32 "" ~-1 1234l "001234"
; ascii_of_int32 "" 1 9876l "6"
; ascii_of_int32 "" 4 0l "0000"
; ascii_of_int32 "" 6 1234l "001234"
; ascii_of_int32 "" 0 1234l ""]
; "string_of_hex", [ string_of_hex "" "2d2d486924" "--Hi$"
; string_of_hex "" "2D2d486924" "--Hi$"
; string_of_hex "" "1234" "\x12\x34"
; string_of_hex "" "ff80" "\xff\x80"
; string_of_hex "" "b7DDdd" "\xb7\xdd\xdd"
; string_of_hex "" "808888Fd" "\x80\x88\x88\xfd"
; string_of_hex "" "E0EE8eEEEE" "\xe0\xee\x8e\xee\xee"
; string_of_hex "empty" "" ""]
; "hex_of_string", [ hex_of_string "" "--Hi$" "2d2d486924"
; hex_of_string "" "\x12\x34" "1234"
; hex_of_string "" "\xff\x80" "ff80"
; hex_of_string "" "\xb7\xff\x20" "b7ff20"
; hex_of_string "" "\x00\x01\x00" "000100"
; hex_of_string "empty" "" ""]
]

140
unikernel/duniverse/eqaf/test/test_branch.ml Normal file
View file

@ -0,0 +1,140 @@
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
;;