unikernel/duniverse/optint/.gitignore

@@ -0,0 +1,4 @@
+*.install
+_build
+_opam
+.merlin

unikernel/duniverse/optint/.travis.yml

@@ -0,0 +1,12 @@
+language: c
+install:
+  - wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh
+script: bash -ex .travis-opam.sh
+env:
+  global:
+  - PINS="optint.dev:."
+  matrix:
+  - PACKAGE="optint" OCAML_VERSION=4.08 TESTS=true
+  - PACKAGE="optint" OCAML_VERSION=4.09 TESTS=true
+  - PACKAGE="optint" OCAML_VERSION=4.10 TESTS=true
+  - PACKAGE="optint" OCAML_VERSION=4.11 TESTS=true

unikernel/duniverse/optint/CHANGES.md

@@ -0,0 +1,56 @@
+### v0.3.0 2022-12-16 Paris (France)
+
+- Add infix operators for bitwise operations (@reynir, #23)
+- Add a deprecation about old infix operators
+  They will be removed at the next minor release
+
+### v0.2.0 2022-04-08 Paris (France)
+
+- Fix the README.md (@sidkshatriya, #19)
+- Fix fuzzers (@dinosaure, #20)
+- Add a proof to introspect the type of `Optint.t` (@dinosaure, #21)
+
+### v0.1.0 2021-03-30 Paris (France)
+
+- Annotate integer types with `[@@immediate64]` (@CraigFe, #13)
+- Move unwrapped module `Int63` to `Optint.Int63` (@CraigFe, #13)
+
+### v0.0.5 2021-02-22 Paris (France)
+
+- Update the README.md (@CraigFe, #9)
+- Add a representation of 63-bit integers (@CraigFe, #9)
+- Allow to compile fuzzers on 32-bit architectures (@dinosaure, #9)
+- Add encode / decode functions for integers (@CraigFe, #9)
+- Fix `optint` about sign and cast on all architectures (@dinosaure, #9)
+- **breaking changes**, rename and handle properly sign-bit:
+  `{of,to}_int` become `{of,to}_unsigned_int`
+  `{of,to}_int32` become `{of,to}_unsigned_int32`
+  Previous functions handle sign-bit correctly
+
+### v0.0.4 2020-03-09 Paris (France)
+
+- Fix 32bit backend where we miss to fully apply
+  an `invalid_arg`
+- Fix 64bit backend where `Native.unsigned_compare`
+  and `Nativeint.unsigned_div` exists (OCaml 4.08.0)
+
+### v0.0.3 2010-09-12 Paris (France)
+
+- Avoid partial application of function (#2, @dinosaure)
+- Add `[@immediate]` tag (#4, @dinosaure)
+- Fix `select.ml` in 32bit (#5, @IndiscriminateCoding)
+- Fix typo (#6, @hannesm)
+- Add fuzzer (#8, @dinosaure)
+- Fix `lsr` and `asr` in 64bit (#8, @cfcs, @dinosaure)
+- Optimization on `of_int` function (64bit) (#8, @cfcs, @dinosaure)
+- Optimization on `abs` function (64bit) (#8, @cfcs, @dinosaure)
+- Fix 32bit architecture, keep bit-sign in the same place (#8, @dinosaure, review @cfcs)
+
+### v0.0.2 2018-10-15 Paris (France)
+
+- _Dunify_ project
+- Fix dependencies on `dune` file when we select impl. (@rgrinberg)
+
+### v0.0.1 2018-06-28 Paris (France)
+
+- First version of `optint`

unikernel/duniverse/optint/LICENSE.md

@@ -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.

unikernel/duniverse/optint/README.md

@@ -0,0 +1,40 @@
+Optint - Efficient integer types on 64-bit architectures
+========================================================
+
+This library provides two new integer types, `Optint.t` and `Int63.t`, which
+guarantee efficient representation on 64-bit architectures and provide a
+best-effort boxed representation on 32-bit architectures.
+
+## Goal
+
+The standard `Int32.t` and `Int64.t` types provided by the standard library have
+the same heap-allocated representation on all architectures. This consistent
+representation has costs in both memory and run-time performance.
+
+On 64-bit architectures, it's often more efficient to use the native `int`
+directly.
+This library provides types to do exactly this: 
+
+- `Optint.t`: an integer containing _at least_ 32 bits. On 64-bit, this is an
+  immediate integer; on 32-bit, it is a boxed 32-bit value. The overflow
+  behaviour is platform-dependent.
+
+- `Int63.t`: an integer containing _exactly_ 63 bits. On 64-bit, this is an
+  immediate integer; on 32-bit, it is a boxed 64-bit integer that is wrapped to
+  provide 63-bit two's complement semantics. The two implementations are
+  observationally equivalent, modulo use of `Marshal` and `Obj`.
+
+In summary:
+
+| Integer type         | 32-bit representation  | 64-bit representation  | Semantics          |
+| --                   | --                  | --                  | --                 |
+| `Stdlib.Int.t`       | 31-bit immediate ✅ | 63-bit immediate ✅ | Always immediate   |
+| `Stdlib.Nativeint.t` | 32-bit boxed ❌     | 64-bit boxed ❌     | Exactly word size  |
+| `Stdlib.Int32.t`     | 32-bit boxed ❌     | 32-bit boxed ❌     | Exactly 32 bits    |
+| `Stdlib.Int64.t`     | 64-bit boxed ❌     | 64-bit boxed ❌     | Exactly 64 bits    |
+| `Optint.t` (_new_)   | 32-bit boxed ❌     | 63-bit immediate ✅ | _At least_ 32 bits |
+| `Int63.t` (_new_)    | 64-bit boxed ❌     | 63-bit immediate ✅ | Exactly 63 bits    |
+
+These new types are safe and well-tested, but their architecture-dependent
+implementation makes them unsuitable for use with the `Marshal` module. Use the
+provided encode and decode functions instead.

unikernel/duniverse/optint/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name optint)
+(version v0.3.0)

unikernel/duniverse/optint/fuzz/dune

@@ -0,0 +1,19 @@
+(executable
+ (name fuzz)
+ (modules fuzz)
+ (libraries fmt crowbar optint))
+
+(alias
+ (name runtest)
+ (deps (:fuzz fuzz.exe))
+ (action (run %{fuzz})))
+
+(executable
+ (name fuzz_int63)
+ (modules fuzz_int63)
+ (libraries monolith optint))
+
+(alias
+ (name monolith)
+ (deps (:fuzz fuzz_int63.exe))
+ (action (run %{fuzz})))

unikernel/duniverse/optint/fuzz/fuzz.ml

@@ -0,0 +1,135 @@
+let max_intl = 0x3fffffff
+
+let () =
+  Crowbar.add_test ~name:"identity with int32" Crowbar.[ int32 ] @@ fun i32 ->
+  let v = Optint.of_int32 i32 in
+  let u = Optint.to_int32 v in
+  Crowbar.check_eq ~pp:Fmt.int32 ~eq:Int32.equal ~cmp:Int32.compare i32 u
+
+let () =
+  Crowbar.add_test ~name:"identity with int" Crowbar.[ bool; range max_intl ] @@ fun s i ->
+  let i = if s then - i else i in
+  let v = Optint.of_int i in
+  let u = Optint.to_int v in
+  Crowbar.check_eq ~pp:Fmt.int ~eq:(=) ~cmp:compare i u
+
+let binary_operator =
+  Crowbar.(choose [ const `Add
+                  ; const `Sub
+                  ; const `Mul
+                  ; const `Div
+                  ; const `Rem
+                  ; const `Lor
+                  ; const `Land
+                  ; const `Lxor ])
+let unary_operator =
+  Crowbar.(choose [ const `Neg
+                  ; const `Succ
+                  ; const `Pred
+                  ; const `Lnot ])
+
+type binary = [ `Add | `Sub | `Mul | `Div | `Rem | `Lor | `Land | `Lxor ]
+type unary = [ `Neg | `Succ | `Pred | `Lnot ]
+
+let generate ~of_int =
+  let edge = Crowbar.map Crowbar.[ bool; range max_intl ] @@ fun sign v -> match sign with
+    | false -> `V (of_int v)
+    | true  -> `V (of_int (- v)) in
+
+  let edge_binary = Crowbar.map [ edge; edge; binary_operator ] @@ fun a b o -> [ a; b; o ] in
+  let node_binary = Crowbar.map [ edge; binary_operator ] @@ fun x o -> [ x; o ] in
+
+  let edge_unary = Crowbar.map [ edge; unary_operator ] @@ fun x o -> [ x; o ] in
+  let node_unary = Crowbar.map [ unary_operator ] @@ fun o -> [ o ] in
+
+  let edge = Crowbar.map [ edge ] @@ fun x -> [ x ] in
+  let edge = Crowbar.choose [ edge; edge_binary; edge_unary ] in
+  let node = Crowbar.choose [ node_binary; node_unary ] in
+
+  Crowbar.(map [ edge; list node ] @@ fun x r -> List.concat (x :: r))
+
+module type ARITHMETIC = sig
+  type t
+
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val rem : t -> t -> t
+  val logor : t -> t -> t
+  val logand : t -> t -> t
+  val logxor : t -> t -> t
+
+  val abs : t -> t
+  val neg : t -> t
+  val succ : t -> t
+  val pred : t -> t
+  val lognot : t -> t
+end
+
+type 'v p = [ binary | unary | `V of 'v ]
+
+let pp_p ~pp_v ppf = function
+  | `Add -> Fmt.string ppf "+" | `Sub -> Fmt.string ppf "-" | `Mul -> Fmt.string ppf "*" | `Div -> Fmt.string ppf "/" | `Rem -> Fmt.string ppf "%"
+  | `Lor -> Fmt.string ppf "|" | `Land -> Fmt.string ppf "&" | `Lxor -> Fmt.string ppf "^"
+  | `Neg -> Fmt.string ppf "neg" | `Succ -> Fmt.string ppf "succ" | `Pred -> Fmt.string ppf "pred"
+  | `Lnot -> Fmt.string ppf "~"
+  | `V v -> pp_v ppf v
+
+let rec binary
+  : type v. (module ARITHMETIC with type t = v) -> v -> v -> binary -> v p list -> v
+  = fun (module Arith) a b o r ->
+    let open Arith in
+
+    match o with
+    | `Add -> eval (module Arith) (`V (add a b) :: r)
+    | `Sub -> eval (module Arith) (`V (sub a b) :: r)
+    | `Mul -> eval (module Arith) (`V (mul a b) :: r)
+    | `Div -> eval (module Arith) (`V (div a b) :: r)
+    | `Rem -> eval (module Arith) (`V (rem a b) :: r)
+    | `Lor -> eval (module Arith) (`V (logor a b) :: r)
+    | `Land -> eval (module Arith) (`V (logand a b) :: r)
+    | `Lxor -> eval (module Arith) (`V (logxor a b) :: r)
+
+and unary
+  : type v. (module ARITHMETIC with type t = v) -> v -> unary -> v p list -> v
+  = fun (module Arith) x o r ->
+    let open Arith in
+
+    match o with
+    | `Neg -> eval (module Arith) (`V (neg x) :: r)
+    | `Succ -> eval (module Arith) (`V (succ x) :: r)
+    | `Pred -> eval (module Arith) (`V (pred x) :: r)
+    | `Lnot -> eval (module Arith) (`V (lognot x) :: r)
+
+and eval
+  : type v. (module ARITHMETIC with type t = v) -> v p list -> v
+  = fun arith -> function
+    | (`V a) :: (`V b) :: (#binary as o) :: r -> binary arith a b o r
+    | (`V x) :: (#unary as o) :: r -> unary arith x o r
+    | [ `V v ] -> v
+    | _ -> Crowbar.bad_test ()
+
+let () =
+  Crowbar.add_test ~name:"computation" Crowbar.[ generate ~of_int:(fun x -> x) ] @@ fun l ->
+  (* XXX(dinosaure): FIXME even if it's not used. *)
+  if Sys.word_size = 32
+  then
+  let la = List.map
+      (function `V x -> `V (Optint.of_int x)
+        | (#binary | #unary) as x -> (x :> Optint.t p)) l in
+  let lb = List.map
+      (function `V x -> `V (Int32.of_int x)
+        | (#binary | #unary) as x -> (x :> int32 p)) l in
+
+  let a = try Some (eval (module Optint) la) with Division_by_zero -> None in
+  let b = try Some (eval (module Int32) lb) with Division_by_zero -> None in
+  match a, b with
+  | None, None -> ()
+  | Some _, None | None, Some _ -> Crowbar.bad_test ()
+  | Some a, Some b ->
+    if (b > 0x3fffffffl || b < -0x3fffffffl) then Crowbar.bad_test () ;
+    let a = Optint.to_int a in
+    let b = Int32.to_int b in
+
+    Crowbar.check_eq ~pp:(Fmt.fmt "%x") ~eq:(=) ~cmp:compare a b

unikernel/duniverse/optint/fuzz/fuzz_int63.ml

@@ -0,0 +1,105 @@
+open Monolith
+
+let int = le Int.max_int
+
+let int32 =
+  let gen_random =
+    let open Int32 in
+    let bits () = of_int (Gen.bits ()) in
+    fun () -> logxor (bits ()) (shift_left (bits ()) 30)
+  in
+  let pos = easily_constructible gen_random PPrint.OCaml.int32 in
+  let neg = deconstructible PPrint.OCaml.int32 in
+  ifpol pos neg
+
+let float = deconstructible PPrint.OCaml.float
+let string = deconstructible PPrint.string
+
+module type INTEGER = module type of Optint.Int63.Boxed
+
+module Fuzz_integer_equivalence (Reference : INTEGER) (Candidate : INTEGER) =
+struct
+  module R = Reference
+  module C = Candidate
+
+  let encoded_string : (string, string) spec =
+    let check_valid r c =
+      let exception Incorrect_length of string in
+      let exception Different of string * string in
+      if not (String.length c = R.encoded_size) then raise (Incorrect_length c);
+      if not (String.equal r c) then raise (Different (r, c))
+    in
+    declare_abstract_type
+      ~check:(fun r -> (check_valid r, document (PPrint.string r)))
+      ()
+
+  module Wrap = struct
+    let pp f x =
+      f Format.str_formatter x;
+      Format.flush_str_formatter ()
+
+    let encode f x =
+      let buf = Bytes.create R.encoded_size in
+      f buf ~off:0 x;
+      Bytes.unsafe_to_string buf
+
+    let decode f s = f s ~off:0
+  end
+
+  let run t fuel =
+    let endo = t ^> t in
+    let binop = t ^> t ^> t in
+    let binop_exn = t ^> t ^!> t in
+
+    declare "zero" t R.zero C.zero;
+    declare "one" t R.one C.one;
+    declare "minus_one" t R.minus_one C.minus_one;
+    declare "max_int" t R.max_int C.max_int;
+    declare "min_int" t R.min_int C.min_int;
+
+    declare "succ" endo R.succ C.succ;
+    declare "pred" endo R.pred C.pred;
+    declare "abs" endo R.abs C.abs;
+    declare "neg" endo R.neg C.neg;
+    declare "add" binop R.add C.add;
+    declare "sub" binop R.sub C.sub;
+    declare "mul" binop R.mul C.mul;
+    declare "div" binop_exn R.div C.div;
+    declare "rem" binop_exn R.rem C.rem;
+    declare "logand" binop R.logand C.logand;
+    declare "logor" binop R.logor C.logor;
+    declare "logxor" binop R.logxor C.logxor;
+    declare "lognot" endo R.lognot C.lognot;
+    declare "shift_left" (t ^> int ^> t) R.shift_left C.shift_left;
+    declare "shift_right" (t ^> int ^> t) R.shift_right C.shift_right;
+    declare "shift_right_logical"
+      (t ^> int ^> t)
+      R.shift_right_logical C.shift_right_logical;
+
+    declare "compare" (t ^> t ^> int) R.compare C.compare;
+    declare "equal" (t ^> t ^> bool) R.equal C.equal;
+
+    declare "of_int" (int ^> t) R.of_int C.of_int;
+    declare "to_int" (t ^> int) R.to_int C.to_int;
+    declare "of_int32" (int32 ^> t) R.of_int32 C.of_int32;
+    declare "to_int32" (t ^> int32) R.to_int32 C.to_int32;
+    declare "to_float" (t ^> float) R.to_float C.to_float;
+    declare "to_string" (t ^> string) R.to_string C.to_string;
+
+    declare "pp" (t ^> string) (Wrap.pp R.pp) (Wrap.pp C.pp);
+    declare "encoded_size" int R.encoded_size C.encoded_size;
+    declare "encode" (t ^> encoded_string) (Wrap.encode R.encode)
+      (Wrap.encode C.encode);
+    declare "decode" (encoded_string ^> t) (Wrap.decode R.decode)
+      (Wrap.decode C.decode);
+
+    main fuel
+end
+
+module Reference = Optint.Int63
+module Candidate = Optint.Int63.Boxed
+module Int63_equiv = Fuzz_integer_equivalence (Reference) (Candidate)
+
+let () =
+  let t : (Reference.t, Candidate.t) spec = declare_abstract_type () in
+  Int63_equiv.run t 5

unikernel/duniverse/optint/fuzz/fuzz_int63.mli

@@ -0,0 +1 @@
+(* Intentionally empty *)

unikernel/duniverse/optint/optint.opam

@@ -0,0 +1,28 @@
+version: "0.3.0"
+opam-version: "2.0"
+maintainer:   [ "romain.calascibetta@gmail.com" ]
+authors:      "Romain Calascibetta"
+license:      "ISC"
+homepage:     "https://github.com/mirage/optint"
+bug-reports:  "https://github.com/mirage/optint/issues"
+dev-repo:     "git+https://github.com/mirage/optint.git"
+doc:          "https://mirage.github.io/optint/"
+synopsis:     "Efficient integer types on 64-bit architectures"
+description: """
+This library provides two new integer types, `Optint.t` and `Int63.t`, which
+guarantee efficient representation on 64-bit architectures and provide a
+best-effort boxed representation on 32-bit architectures.
+
+Implementation depends on target architecture.
+"""
+
+build: ["dune" "build" "-p" name "-j" jobs]
+run-test: [ "dune" "runtest" "-p" name "-j" jobs ]
+
+depends: [
+  "ocaml" {>= "4.07.0"}
+  "dune"
+  "crowbar" {with-test & >= "0.2"}
+  "monolith" {with-test}
+  "fmt" {with-test}
+]

unikernel/duniverse/optint/src/dune

@@ -0,0 +1,3 @@
+(library
+ (name optint)
+ (public_name optint))

unikernel/duniverse/optint/src/int63_emul.ml

@@ -0,0 +1,152 @@
+(* On 32-bit systems, we emulate a 63-bit integer via a boxed 64-bit integer
+   with its lowest bit set to 0. The remaining 63 bits are left-shifted by one
+   place. This is analogous to the standard encoding of [int], with the bottom
+   bit set to 0 rather than 1.
+
+   See {{:https://github.com/janestreet/base/blob/master/src/int63_emul.ml}[Base.Int63_emul]}
+   for a similar encoding that has subtly different guarantees. This
+   implementation seeks to be strictly observationally equivalent to the
+   unemulated one (on 64-bit architectures), at the cost of performance of
+   certain functions.
+*)
+
+type t = int64
+
+(* The following all preserve semantics under our chosen encoding. *)
+include (Int64 : sig
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val rem : t -> t -> t
+  val neg : t -> t
+  val abs : t -> t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val shift_left : t -> int -> t
+  val equal : t -> t -> bool
+  val compare : t -> t -> int
+end)
+
+let invalid_arg fmt = Format.kasprintf invalid_arg fmt
+
+module Conv : sig
+  val wrap_exn : int64 -> t      (* Raises if the [int64] has its topmost bit set. *)
+  val wrap_modulo : int64 -> t   (* Discards the topmost bit of the [int64]. *)
+
+  val unwrap : t -> int64        (* Lossless, assuming [t] satisfies the encoding. *)
+end = struct
+  let int64_fits_on_int63 =
+    let min = Int64.(shift_right min_int) 1 in
+    let max = Int64.(shift_right max_int) 1 in
+    fun x -> Int64.compare min x <= 0 && Int64.compare x max <= 0
+
+  let wrap_modulo x = Int64.mul x 2L
+  let wrap_exn x =
+    if int64_fits_on_int63 x then
+      Int64.mul x 2L
+    else
+      Printf.ksprintf failwith
+        "Conversion from int64 to int63 failed: %Ld is out of range" x
+
+  let unwrap x = Int64.shift_right x 1
+end
+
+let unset_bottom_bit =
+  let mask = 0xffff_ffff_ffff_fffEL in
+  fun x -> Int64.logand x mask
+
+let min_int = unset_bottom_bit Int64.min_int
+let max_int = unset_bottom_bit Int64.max_int
+let minus_one = Conv.wrap_exn (-1L)
+let zero = Conv.wrap_exn 0L
+let one = Conv.wrap_exn 1L
+
+let succ x = add x one
+let pred x = sub x one
+
+let mul x y = Int64.mul x (Conv.unwrap y)
+let div x y =
+  let r = Int64.div x y in
+  if Int64.equal r 0x4000_0000_0000_0000L then
+    (* This case happens when we overflow via [ min_int / 1 ], in which case we
+       should wrap back to [ min_int ]. *)
+    min_int
+  else
+    Conv.wrap_modulo r
+
+let lognot x = unset_bottom_bit (Int64.lognot x)
+let logxor x y = unset_bottom_bit (Int64.logxor x y)
+let shift_right x i = unset_bottom_bit (Int64.shift_right x i)
+let shift_right_logical x i = unset_bottom_bit (Int64.shift_right_logical x i)
+
+let to_int x = Int64.to_int (Conv.unwrap x)
+let of_int x = Conv.wrap_exn (Int64.of_int x)
+let to_int32 x = Int64.to_int32 (Conv.unwrap x)
+let of_int32 x = Conv.wrap_exn (Int64.of_int32 x)
+let to_int64 x = Conv.unwrap x
+let of_int64 x = Conv.wrap_exn x
+let to_float x = Int64.to_float (Conv.unwrap x)
+let of_float x = Conv.wrap_exn (Int64.of_float x)
+
+let to_string x = Int64.to_string (Conv.unwrap x)
+let of_string x = Conv.wrap_exn (Int64.of_string x)
+let of_string_opt x = try Some (of_string x) with _ -> None
+
+let pp ppf x = Format.fprintf ppf "%Ld" (Conv.unwrap x)
+
+let to_unsigned_int x =
+  let max_int = of_int Stdlib.max_int in
+  if compare zero x <= 0 && compare x max_int <= 0
+  then to_int x
+  else invalid_arg "Int63.to_unsigned_int: %Lx can not fit into a 31 bits unsigned integer" x
+
+let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000)
+
+let of_unsigned_int x =
+  if x < 0
+  then logor 0x40000000L (of_int (without_bit_sign x))
+  else of_int x
+
+let to_unsigned_int32 x =
+  let max_int = of_int32 Int32.max_int in
+  if compare zero x <= 0 && compare x max_int <= 0
+  then to_int32 x
+  else invalid_arg "Int63.to_unsigned_int32: %Lx can not fit into a 32 bits unsigned integer" x
+
+let of_unsigned_int32 x =
+  if x < 0l
+  then logor 0x80000000L (of_int32 (Int32.logand x (Int32.lognot 0x80000000l)))
+  else of_int32 x
+
+let encoded_size = 8
+
+external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u"
+external get_64 : string -> int -> int64 = "%caml_string_get64"
+external swap64 : int64 -> int64 = "%bswap_int64"
+
+let encode buf ~off t =
+  let t = to_int64 t in
+  let t = if not Sys.big_endian then swap64 t else t in
+  set_64 buf off t
+
+let decode buf ~off =
+  let t = get_64 buf off in
+  let t = if not Sys.big_endian then swap64 t else t in
+  of_int64 t
+
+module Infix = struct
+  let ( + ) a b = add a b
+  let ( - ) a b = sub a b
+  let ( * ) a b = mul a b
+  let ( % ) a b = rem a b
+  let ( / ) a b = div a b
+  let ( land ) a b = logand a b
+  let ( lor ) a b = logor a b
+  let ( lsr ) a b = shift_right a b
+  let ( lsl ) a b = shift_left a b
+
+  let ( && ) = ( land )
+  let ( || ) = ( lor )
+  let ( >> ) = ( lsr )
+  let ( << ) = ( lsl )
+
+end

unikernel/duniverse/optint/src/int63_emul.mli

@@ -0,0 +1 @@
+include Integer_interface.S

unikernel/duniverse/optint/src/int63_native.ml

@@ -0,0 +1,95 @@
+type t = int
+
+let zero = 0
+let one = 1
+let minus_one = -1
+let neg x = -x
+let add a b = a + b
+let sub a b = a - b
+let mul a b = a * b
+let div a b = a / b
+let rem a b = a mod b
+let succ x = succ x
+let pred x = pred x
+let logand a b = a land b
+let logor a b = a lor b
+let logxor a b = a lxor b
+let lognot x = lnot x
+let shift_left a n = a lsl n
+let shift_right a n = a asr n
+let shift_right_logical a n = a lsr n
+let abs x = abs x
+let max_int = max_int
+let min_int = min_int
+
+external of_int : t -> t = "%identity"
+external to_int : t -> t = "%identity"
+
+let to_int32 = Stdlib.Int32.of_int
+let of_int32 = Stdlib.Int32.to_int
+let to_int64 = Stdlib.Int64.of_int
+let of_int64 = Stdlib.Int64.to_int
+let of_float x = int_of_float x
+let to_float x = float_of_int x
+let of_string x = int_of_string x
+let of_string_opt x = try Some (of_string x) with Failure _ -> None
+let to_string x = string_of_int x
+let equal : int -> int -> bool = fun a b -> a = b
+let compare : int -> int -> int = fun a b -> compare a b
+let pp = Format.pp_print_int
+
+external to_unsigned_int : t -> int = "%identity"
+external of_unsigned_int : int -> t = "%identity"
+
+let invalid_arg fmt = Format.kasprintf invalid_arg fmt
+
+let to_unsigned_int32 =
+  let uint32_mask = (0xffff lsl 16) lor 0xffff in
+  fun x ->
+    let truncated = x land uint32_mask in
+    if x <> truncated
+    then invalid_arg "Int63.to_unsigned_int32: %d can not fit into a 32 bits integer" x
+    else Int32.of_int truncated
+
+let of_unsigned_int32 =
+  let int32_sign_mask = 1 lsl 31 in
+  let int32_sign_maskl = 0x80000000l in
+  fun x ->
+    if x < 0l then
+      let x = Int32.logand x (Int32.lognot int32_sign_maskl) in
+      Int32.to_int x lor int32_sign_mask
+    else Int32.to_int x
+
+let encoded_size = 8
+
+external set_64 : bytes -> int -> int64 -> unit = "%caml_bytes_set64u"
+external get_64 : string -> int -> int64 = "%caml_string_get64"
+external swap64 : int64 -> int64 = "%bswap_int64"
+
+let encode buf ~off t =
+  let t = to_int64 t in
+  let t = if not Sys.big_endian then swap64 t else t in
+  set_64 buf off t
+
+let decode buf ~off =
+  let t = get_64 buf off in
+  let t = if not Sys.big_endian then swap64 t else t in
+  of_int64 t
+
+module Infix = struct
+  let ( + ) a b = add a b
+  let ( - ) a b = sub a b
+  let ( * ) a b = mul a b
+  let ( % ) a b = rem a b
+  let ( / ) a b = div a b
+  let ( land ) a b = logand a b
+  let ( lor ) a b = logor a b
+  let ( lsr ) a b = shift_right a b
+  let ( lsl ) a b = shift_left a b
+
+  let ( && ) = ( land )
+  let ( || ) = ( lor )
+  let ( >> ) = ( lsr )
+  let ( << ) = ( lsl )
+
+end

unikernel/duniverse/optint/src/int63_native.mli

@@ -0,0 +1,3 @@
+type t = int [@@immediate]
+
+include Integer_interface.S with type t := t

unikernel/duniverse/optint/src/integer_interface.ml

@@ -0,0 +1,175 @@
+module type S = sig
+  type t
+
+  val zero : t
+  (** Integer 0. *)
+
+  val one : t
+  (** Integer 1. *)
+
+  val minus_one : t
+  (** Integer (-1). *)
+
+  val neg : t -> t
+  (** Unary negation. *)
+
+  val add : t -> t -> t
+  (** Addition. *)
+
+  val sub : t -> t -> t
+  (** Subtraction. *)
+
+  val mul : t -> t -> t
+  (** Mulitplication. *)
+
+  val div : t -> t -> t
+  (** Integer division. Raise [Division_by_zero] if the second argument is zero.
+      This division rounds the real quotient of its arguments towrds zero. *)
+
+  val rem : t -> t -> t
+  (** Integer remainder. If [y] is not zero, the result of [rem x y] satisfies
+      the following property: [x = add (mul (div x y) y) (rem x y)]. if [y = 0],
+      [rem x y] raises [Division_by_zero]. *)
+
+  val succ : t -> t
+  (** Successor. [succ x] is [add x one]. *)
+
+  val pred : t -> t
+  (** Predecessor. [pred x] is [sub x one]. *)
+
+  val abs : t -> t
+  (** Return the absolute value its argument. *)
+
+  val max_int : t
+  (** The greatest representable integer. *)
+
+  val min_int : t
+  (** The smallest representable integer. *)
+
+  val logand : t -> t -> t
+  (** Bitwise logical and. *)
+
+  val logor : t -> t -> t
+  (** Bitwise logical or. *)
+
+  val logxor : t -> t -> t
+  (** Bitwise logical exclusive or. *)
+
+  val lognot : t -> t
+  (** Bitwise logical negation. *)
+
+  val shift_left : t -> int -> t
+  (** [shift_left x y] shifts [x] to the left by [y] bits. The result is
+      unspecified if [y < 0] or [y >= (32 || 63)]. *)
+
+  val shift_right : t -> int -> t
+  (** [shift_right x y] shifts [x] to the right by [y] bits. This is an
+      arithmetic shift: the sign bit of [x] is replicated and inserted in the
+      vacated bits. The result is unspecified if [y < 0] or [y >= (32 || 63)]. *)
+
+  val shift_right_logical : t -> int -> t
+  (** [shift_right_logical x y] shifts [x] to the right by [y] bits. This is a
+      logical shift: zeroes are inserted in the vacated bits regardless of the
+      sign of [x] / The result is unspecified if [y < 0] or [y >= (32 || 63)]. *)
+
+  val of_int : int -> t
+  (** Convert the given integer (type [int] ) to {!t}. It's an unsafe function
+      whose semantic is different from architecture. *)
+
+  val to_int : t -> int
+  (** Convert the given {!t} integer to an integer (type [int] ). On 64-bit
+      platforms, the conversion is exact. On 32-bit platforms, the 32-bit
+      integer is taken modulo 2 {^ 31}, i.e. the high-order bit is lost during
+      the conversion. *)
+
+  val of_int32 : int32 -> t
+  (** Convert the given 32-bit integer (type [int32]) to {!t} integer. It's an
+      unsafe function whose semantic is different from architecture. *)
+
+  val to_int32 : t -> int32
+  (** Convert the given {!t} integer to a 32-bit integer. *)
+
+  val of_int64 : int64 -> t
+  (** Convert the given 64-bit integer (type [int64]) to {!t} integer. *)
+
+  val to_int64 : t -> int64
+  (** Covert the given {!t} integer to a 64-bit integer. *)
+
+  val of_float : float -> t
+  (** Convert the given floating-point number to a {!t} integer, discarding the
+      fractional part (truncate towards 0). The result of the conversion is
+      undefined if, after truncation, the number is outside the range
+      {!min_int}, {!max_int}. *)
+
+  val to_float : t -> float
+  (** Convert the given {!t} integer to a floating-point number. *)
+
+  val of_string : string -> t
+  (** Convert the given string to a {!t} integer. The string is read in decimal
+      (by default, or if the string begins with [0u]) or in hexadecimal, octal
+      or binary if the string begins with [0x], [0o] or [0b] respectively.
+
+      The [0u] prefix reads the input as an unsigned integer in the range
+      [\[0, 2 * max_int + 1\]]. If the input exceeds {!max_int} it is converted
+      to the signed integer [min_int + input - max_int - 1].
+
+      The [_] (underscore) character can appear anywhere in the string is
+      ignored. Raise [Failure _] if the given string is not a valid
+      representation of an integer, or if the integer represented exceeds the
+      range of integer, or if the integer represented exceeds the range of
+      integers representable in type {!t}. *)
+
+  val of_string_opt : string -> t option
+  (** Same as [of_string], but return [None] instead of raising. *)
+
+  val to_string : t -> string
+  (** Return the string representation of its argument, in decimal. *)
+
+  val compare : t -> t -> int
+  (** The comparison function for {!t} integers, with the same specification as
+      {!Stdlib.compare}. Along with the type [t], this function [compare] allows
+      the module [Optint] to be passed as argument to the functors {!Set.Make}
+      and {!Map.Make}. *)
+
+  val equal : t -> t -> bool
+  (** The equal function for {!t}. *)
+
+  val pp : Format.formatter -> t -> unit
+  (** The pretty-printer for {!t}. *)
+
+  (** {2 Encoding functions}
+
+      Efficient fixed-length big-endian encoding functions for {!t} integers: *)
+
+  val encode : bytes -> off:int -> t -> unit
+  val decode : string -> off:int -> t
+
+  val encoded_size : int
+  (** The number of bytes in the {{!encode} encoded} form of {!t}. *)
+
+  val to_unsigned_int32 : t -> int32
+  val of_unsigned_int32 : int32 -> t
+  val to_unsigned_int : t -> int
+  val of_unsigned_int : int -> t
+
+  module Infix : sig
+    val ( + ) : t -> t -> t
+    val ( - ) : t -> t -> t
+    val ( * ) : t -> t -> t
+    val ( % ) : t -> t -> t
+    val ( / ) : t -> t -> t
+    val ( land ) : t -> t -> t
+    val ( lor ) : t -> t -> t
+    val ( lsr ) : t -> int -> t
+    val ( lsl ) : t -> int -> t
+
+    val ( && ) : t -> t -> t
+    [@@ocaml.deprecated "Please use ( land )."]
+    val ( || ) : t -> t -> t
+    [@@ocaml.deprecated "Please use ( lor )."]
+    val ( >> ) : t -> int -> t
+    [@@ocaml.deprecated "Please use ( lsr )."]
+    val ( << ) : t -> int -> t
+    [@@ocaml.deprecated "Please use ( lsl )."]
+  end
+end

unikernel/duniverse/optint/src/optint.ml

@@ -0,0 +1,77 @@
+(** Extraction of [Stdlib.Sys.Immediate64] for pre-4.10 compatibility.
+    [Immediate64] was originally authored by Jeremie Dimino <jeremie@dimino.org>,
+    and is licensed along with the OCaml compiler system under LGPLv2. See the
+    {{:https://github.com/ocaml/ocaml/blob/trunk/LICENSE} compiler license} for
+    details.
+
+    For soundness of the [@@immediate64] annotation, we ensure to use the boxed
+    representation only when not on 64-bit platforms, but we need to use The
+    Force to convince the type system of this fact. *)
+module Immediate64 = struct
+  module type Non_immediate = sig
+    type t
+  end
+
+  module type Immediate = sig
+    type t [@@immediate]
+  end
+
+  module Make (Immediate : Immediate) (Non_immediate : Non_immediate) = struct
+    type t [@@immediate64]
+
+    type 'a repr =
+      | Immediate : Immediate.t repr
+      | Non_immediate : Non_immediate.t repr
+
+    external magic : _ repr -> t repr = "%identity"
+
+    let repr =
+      if Sys.word_size = 64 then magic Immediate else magic Non_immediate
+  end
+end
+
+module Conditional = struct
+  type ('t, 'u, 'v) t =
+    | True : ('t, 't, _) t (** therefore ['t] = ['u] *)
+    | False : ('t, _, 't) t (** therefore ['t] = ['v] *)
+end
+
+module Optint = struct
+  include Immediate64.Make (Optint_native) (Optint_emul)
+
+  module type S = Integer_interface.S with type t := t
+
+  let impl : (module S) =
+    match repr with
+    | Immediate -> (module Optint_native : S)
+    | Non_immediate -> (module Optint_emul : S)
+
+  include (val impl : S)
+
+  let is_immediate : (t, int, int32) Conditional.t =
+    match repr with
+    | Immediate -> True
+    | Non_immediate -> False
+end
+
+module Int63 = struct
+  include Immediate64.Make (Int63_native) (Int63_emul)
+
+  module type S = Integer_interface.S with type t := t
+
+  let impl : (module S) =
+    match repr with
+    | Immediate -> (module Int63_native : S)
+    | Non_immediate -> (module Int63_emul : S)
+
+  include (val impl : S)
+
+  module Boxed = Int63_emul
+
+  let is_immediate : (t, int, Boxed.t) Conditional.t =
+    match repr with
+    | Immediate -> True
+    | Non_immediate -> False
+end
+
+include Optint

unikernel/duniverse/optint/src/optint.mli

@@ -0,0 +1,36 @@
+type t [@@immediate64]
+(** The type of integers with {i at least} 32 bits.
+    For 63-bit integers, see {!Int63}. *)
+
+include Integer_interface.S with type t := t
+(** @inline *)
+
+(** {1 Other modules} *)
+
+(** A conditional type equality, used for revealing that a type [t] has one of
+    two possible implementation types [u] and [v]. *)
+module Conditional : sig
+  type ('t, 'u, 'v) t =
+    | True : ('t, 't, _) t (** therefore ['t] = ['u] *)
+    | False : ('t, _, 't) t (** therefore ['t] = ['v] *)
+end
+
+val is_immediate : (t, int, int32) Conditional.t
+
+(** 63-bit integers. *)
+module Int63 : sig
+  type t [@@immediate64]
+  (** The type of integers with exactly 63-bits. *)
+
+  include Integer_interface.S with type t := t
+  (** @inline *)
+
+  module Boxed : Integer_interface.S
+  (** An implementation of 63-bit integers that always uses a boxed
+      representation regardless of word size. *)
+
+    (** [is_immediate] reveals the implementation of {!t} on the current
+        platform, and can be used to build [Int63] operations that behave
+        differently depending on the underlying representation, such as FFIs. *)
+  val is_immediate : (t, int, Boxed.t) Conditional.t
+end

unikernel/duniverse/optint/src/optint_emul.ml

@@ -0,0 +1,89 @@
+include Int32
+
+external of_int32 : int32 -> t = "%identity"
+external of_unsigned_int32 : int32 -> t = "%identity"
+external to_int32 : t -> int32 = "%identity"
+external to_unsigned_int32 : t -> int32 = "%identity"
+
+let to_int64 = Int64.of_int32
+let of_int64 = Int64.to_int32
+
+let pp ppf (x:t) = Format.fprintf ppf "%ld" x
+
+let without_bit_sign (x:int) = if x >= 0 then x else x land (lnot 0x40000000)
+
+let invalid_arg fmt = Format.kasprintf invalid_arg fmt
+
+(* XXX(dinosaure): the diff between [to_int] and [to_unsigned_int]
+ * is about the sign-bit [0x40000000][int]/[0x80000000][int32].
+ *
+ * For [to_int], we ensure for a negative number that we use only
+ * [0x3fffffff][int32] bits two most significant bits are set to [1].
+ * In that case, it safes to cast the [int32] to and [int] (31 bits).
+ *
+ * For [to_unsigned_int], we don't want to interpret if the value is
+ * negative or positive. However, if the number can be interpreted as a
+ * negative nnumber, due to the two's complement layout, we are sure
+ * to lost, at least, the most significant bit which is a part of unsigned
+ * [int32]. So we are able to only accept "positive" numbers.
+ *
+ * NOTE: we trust on the two's complement! *)
+
+let to_int x =
+  let max_int = of_int Stdlib.max_int in
+  if compare zero x <= 0 && compare x max_int <= 0
+  then to_int x (* XXX(dinosaure): positive and can fit into a 31-bit integer. *)
+  else if compare zero x > 0 && Int32.logand 0xC0000000l x = 0xC0000000l
+  then let x = Int32.logand x 0x7fffffffl in to_int x
+  else invalid_arg "Optint.to_int: %lx can not fit into a 31 bits integer" x
+
+let to_unsigned_int x =
+  let max_int = of_int Stdlib.max_int in
+  if compare zero x <= 0 && compare x max_int <= 0
+  then to_int x
+  else invalid_arg "Optint.to_unsigned_int: %lx can not fit into a 31 bits unsigned integer" x
+
+let of_int x =
+  if x < 0
+  then logor 0xC0000000l (of_int (without_bit_sign x))
+  else of_int x
+
+let of_unsigned_int x =
+  if x < 0
+  then logor 0x40000000l (of_int (without_bit_sign x))
+  else of_int x
+
+let encoded_size = 4
+
+external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u"
+external get_32 : string -> int -> int32 = "%caml_string_get32"
+external swap32 : int32 -> int32 = "%bswap_int32"
+
+let encode buf ~off t =
+  let t = to_int32 t in
+  let t = if not Sys.big_endian then swap32 t else t in
+  set_32 buf off t
+
+let decode buf ~off =
+  let t = get_32 buf off in
+  let t = if not Sys.big_endian then swap32 t else t in
+  of_int32 t
+
+module Infix = struct
+  let ( + ) a b = add a b
+  let ( - ) a b = sub a b
+  let ( * ) a b = mul a b
+  let ( % ) a b = rem a b
+  let ( / ) a b = div a b
+
+  let ( land ) a b = logand a b
+  let ( lor ) a b = logor a b
+  let ( lsr ) a b = shift_right a b
+  let ( lsl ) a b = shift_left a b
+
+  let ( && ) = ( land )
+  let ( || ) = ( lor )
+  let ( >> ) = ( lsr )
+  let ( << ) = ( lsl )
+
+end

unikernel/duniverse/optint/src/optint_emul.mli

@@ -0,0 +1 @@
+include Integer_interface.S with type t = int32

unikernel/duniverse/optint/src/optint_native.ml

@@ -0,0 +1,126 @@
+type t = int
+
+let zero = 0
+let one = 1
+let minus_one = (-1)
+let neg x = (-x)
+let add a b = a + b
+let sub a b = a - b
+let mul a b = a * b
+
+let _unsigned_compare n m =
+  let open Nativeint in
+  compare (sub n min_int) (sub m min_int)
+
+let _unsigned_div n d =
+  let open Nativeint in
+  if d < zero then
+    if _unsigned_compare n d < 0 then zero else one
+  else
+    let q = shift_left (div (shift_right_logical n 1) d) 1 in
+    let r = sub n (mul q d) in
+    if _unsigned_compare r d >= 0 then succ q else q
+
+let div a b = Nativeint.to_int (_unsigned_div (Nativeint.of_int a) (Nativeint.of_int b))
+let rem a b = a mod b
+let succ x = x + 1
+let pred x = x - 1
+let abs x =
+  let mask = x asr Sys.int_size in (* extract sign: -1 if signed, 0 if not signed *)
+  (x + mask) lxor mask
+let max_int = Int32.(to_int max_int)
+let min_int = Int32.(to_int min_int)
+let logand a b = a land b
+let logor a b = a lor b
+let logxor a b = a lxor b
+let lognot x = lnot x
+let shift_left a n = a lsl n
+let shift_right a n = a asr n
+let shift_right_logical a n = a lsr n
+external of_int : int -> t = "%identity"
+external of_unsigned_int : int -> t = "%identity"
+external to_int : t -> int = "%identity"
+external to_unsigned_int : t -> int = "%identity"
+let to_int64 = Stdlib.Int64.of_int
+let of_int64 = Stdlib.Int64.to_int
+let of_float x = int_of_float x
+let to_float x = (* allocation *) float_of_int x
+let of_string x = int_of_string x
+let of_string_opt x = try (* allocation *) Some (of_string x) with Failure _ -> None
+let to_string x = string_of_int x
+let compare : int -> int -> int = fun a b -> a - b
+let equal : int -> int -> bool = fun a b -> a = b
+
+let invalid_arg fmt = Format.kasprintf invalid_arg fmt
+
+let uint32_max = (0xffff lsl 16) lor 0xffff
+let int32_sign_maskl = 0x80000000l
+let int32_sign_mask = 1 lsl 31
+let int32_maxl = 0x7fffffffl
+let int32_max = 0x7fffffff
+
+let to_int32 x =
+  let truncated = x land uint32_max in
+  if x = truncated then Int32.of_int truncated
+  else if compare 0 x > 0 && (x lsr 31) = uint32_max
+  then Int32.(logor int32_sign_maskl (of_int (x land int32_max)))
+  else invalid_arg "Optint.to_int32: %d can not fit into a 32 bits integer" x
+
+let to_unsigned_int32 x =
+  let truncated = x land uint32_max in
+  if x <> truncated
+  then invalid_arg "Optint.to_unsigned_int32: %d can not fit into a 32 bits integer" x
+  else Int32.of_int truncated
+
+let of_int32 =
+  let negative_int32_mask = (int32_max lsl 32) lor int32_sign_mask in
+  fun x ->
+    if x < 0l
+    then
+      let x = Int32.logand x int32_maxl in
+      negative_int32_mask lor (Int32.to_int x)
+    else Int32.to_int x
+
+let of_unsigned_int32 x =
+  if x < 0l
+  then
+    let x = Int32.logand x (Int32.lognot int32_sign_maskl) in
+    (Int32.to_int x) lor int32_sign_mask
+  else Int32.to_int x
+
+let pp ppf (x:t) = Format.fprintf ppf "%d" x
+
+let encoded_size = 4
+
+external set_32 : bytes -> int -> int32 -> unit = "%caml_bytes_set32u"
+external get_32 : string -> int -> int32 = "%caml_string_get32"
+external swap32 : int32 -> int32 = "%bswap_int32"
+
+let encode buf ~off t =
+  let t = to_int32 t in
+  let t = if not Sys.big_endian then swap32 t else t in
+  set_32 buf off t
+
+let decode buf ~off =
+  let t = get_32 buf off in
+  let t = if not Sys.big_endian then swap32 t else t in
+  of_int32 t
+
+module Infix = struct
+  let ( + ) a b = add a b
+  let ( - ) a b = sub a b
+  let ( * ) a b = mul a b
+  let ( % ) a b = rem a b
+  let ( / ) a b = div a b
+
+  let ( land ) a b = logand a b
+  let ( lor ) a b = logor a b
+  let ( lsr ) a b = shift_right a b
+  let ( lsl ) a b = shift_left a b
+
+  let ( && ) = ( land )
+  let ( || ) = ( lor )
+  let ( >> ) = ( lsr )
+  let ( << ) = ( lsl )
+
+end

unikernel/duniverse/optint/src/optint_native.mli

@@ -0,0 +1,3 @@
+type t = int [@@immediate]
+
+include Integer_interface.S with type t := t