unikernel/duniverse/Zarith/z.ml

@@ -0,0 +1,555 @@
+(**
+   Integers.
+
+
+   This file is part of the Zarith library
+   http://forge.ocamlcore.org/projects/zarith .
+   It is distributed under LGPL 2 licensing, with static linking exception.
+   See the LICENSE file included in the distribution.
+
+   Copyright (c) 2010-2011 Antoine Miné, Abstraction project.
+   Abstraction is part of the LIENS (Laboratoire d'Informatique de l'ENS),
+   a joint laboratory by:
+   CNRS (Centre national de la recherche scientifique, France),
+   ENS (École normale supérieure, Paris, France),
+   INRIA Rocquencourt (Institut national de recherche en informatique, France).
+
+ *)
+
+type t
+
+exception Overflow
+
+external init: unit -> unit = "ml_z_init"
+let _ = init ()
+
+let _ = Callback.register_exception "ml_z_overflow" Overflow
+
+external is_small_int: t -> bool = "%obj_is_int"
+external unsafe_to_int: t -> int = "%identity"
+external of_int: int -> t = "%identity"
+
+external c_neg: t -> t = "ml_z_neg"
+
+let neg x =
+  if is_small_int x && unsafe_to_int x <> min_int
+  then of_int (- unsafe_to_int x)
+  else c_neg x
+
+external c_add: t -> t -> t = "ml_z_add"
+
+let add x y =
+  if is_small_int x && is_small_int y then begin
+    let z = unsafe_to_int x + unsafe_to_int y in
+    (* Overflow check -- Hacker's Delight, section 2.12 *)
+    if (z lxor unsafe_to_int x) land (z lxor unsafe_to_int y) >= 0 
+    then of_int z
+    else c_add x y
+  end else
+    c_add x y
+
+external c_sub: t -> t -> t = "ml_z_sub"
+
+let sub x y =
+  if is_small_int x && is_small_int y then begin
+    let z = unsafe_to_int x - unsafe_to_int y in
+    (* Overflow check -- Hacker's Delight, section 2.12 *)
+    if (unsafe_to_int x lxor unsafe_to_int y)
+       land (z lxor unsafe_to_int x) >= 0 
+    then of_int z
+    else c_sub x y
+  end else
+    c_sub x y
+
+external mul_overflows: int -> int -> bool = "ml_z_mul_overflows" [@@noalloc]
+external c_mul: t -> t -> t = "ml_z_mul"
+
+let mul x y =
+  if is_small_int x && is_small_int y
+  && not (mul_overflows (unsafe_to_int x) (unsafe_to_int y))
+  then of_int (unsafe_to_int x * unsafe_to_int y)
+  else c_mul x y
+
+external c_div: t -> t -> t = "ml_z_div"
+
+let div x y =
+  if is_small_int y then
+    if unsafe_to_int y = -1 then
+      neg x
+    else if is_small_int x then
+      of_int (unsafe_to_int x / unsafe_to_int y)
+    else
+      c_div x y
+  else
+    c_div x y
+
+external cdiv: t -> t -> t = "ml_z_cdiv"
+external fdiv: t -> t -> t = "ml_z_fdiv"
+
+external c_rem: t -> t -> t = "ml_z_rem"
+
+let rem x y =
+  if is_small_int y then
+    if unsafe_to_int y = -1 then
+      of_int 0
+    else if is_small_int x then
+      of_int (unsafe_to_int x mod unsafe_to_int y)
+    else
+      c_rem x y
+  else
+    c_rem x y
+
+external div_rem: t -> t -> (t * t) = "ml_z_div_rem"
+
+external c_divexact: t -> t -> t = "ml_z_divexact"
+
+let divexact x y =
+  if is_small_int y then
+    if unsafe_to_int y = -1 then
+      neg x
+    else if is_small_int x then
+      of_int (unsafe_to_int x / unsafe_to_int y)
+    else
+      c_divexact x y
+  else
+    c_divexact x y
+
+external c_succ: t -> t = "ml_z_succ"
+
+let succ x =
+  if is_small_int x && unsafe_to_int x <> max_int
+  then of_int (unsafe_to_int x + 1)
+  else c_succ x
+
+external c_pred: t -> t = "ml_z_pred"
+
+let pred x =
+  if is_small_int x && unsafe_to_int x <> min_int
+  then of_int (unsafe_to_int x - 1)
+  else c_pred x
+
+external c_abs: t -> t = "ml_z_abs"
+
+let abs x =
+  if is_small_int x then
+    if unsafe_to_int x >= 0 then x
+    else if unsafe_to_int x <> min_int then
+      of_int (- unsafe_to_int x)
+    else
+      c_abs x
+  else
+    c_abs x
+
+external c_logand: t -> t -> t = "ml_z_logand"
+
+let logand x y =
+  if is_small_int x && is_small_int y
+  then of_int (unsafe_to_int x land unsafe_to_int y)
+  else c_logand x y
+
+external c_logor: t -> t -> t = "ml_z_logor"
+
+let logor x y =
+  if is_small_int x && is_small_int y
+  then of_int (unsafe_to_int x lor unsafe_to_int y)
+  else c_logor x y
+
+external c_logxor: t -> t -> t = "ml_z_logxor"
+
+let logxor x y =
+  if is_small_int x && is_small_int y
+  then of_int (unsafe_to_int x lxor unsafe_to_int y)
+  else c_logxor x y
+
+external c_lognot: t -> t = "ml_z_lognot"
+
+let lognot x =
+  if is_small_int x
+  then of_int (unsafe_to_int x lxor (-1))
+  else c_lognot x
+
+external c_shift_left: t -> int -> t = "ml_z_shift_left"
+
+let shift_left x y =
+  if is_small_int x && y >= 0 && y < Sys.word_size then begin
+    let z = unsafe_to_int x lsl y in
+    if z asr y = unsafe_to_int x
+    then of_int z
+    else c_shift_left x y
+  end else
+    c_shift_left x y
+
+external c_shift_right: t -> int -> t = "ml_z_shift_right"
+
+let shift_right x y =
+  if is_small_int x && y >= 0 then
+    of_int
+      (unsafe_to_int x asr (if y < Sys.word_size then y else Sys.word_size - 1))
+  else
+    c_shift_right x y
+
+external c_shift_right_trunc: t -> int -> t = "ml_z_shift_right_trunc"
+
+let shift_right_trunc x y =
+  if is_small_int x && y >= 0 then
+    if y >= Sys.word_size then
+      of_int 0
+    else if unsafe_to_int x >= 0 then
+      of_int (unsafe_to_int x lsr y)
+    else
+      of_int (- ((- unsafe_to_int x) lsr y))
+  else
+    c_shift_right_trunc x y
+
+external of_int32: int32 -> t = "ml_z_of_int32"
+external of_int64: int64 -> t = "ml_z_of_int64"
+external of_nativeint: nativeint -> t = "ml_z_of_nativeint"
+external of_float: float -> t = "ml_z_of_float"
+
+let uint32_mask = pred (shift_left (of_int 1) 32)
+let of_int32_unsigned x = logand (of_int32 x) uint32_mask
+
+let uint64_mask = pred (shift_left (of_int 1) 64)
+let of_int64_unsigned x = logand (of_int64 x) uint64_mask
+
+let uintnat_mask = pred (shift_left (of_int 1) Nativeint.size)
+let of_nativeint_unsigned x = logand (of_nativeint x) uintnat_mask
+
+external c_to_int: t -> int = "ml_z_to_int"
+
+let to_int x =
+  if is_small_int x then unsafe_to_int x else c_to_int x
+
+external to_int32: t -> int32 = "ml_z_to_int32"
+external to_int64: t -> int64 = "ml_z_to_int64"
+external to_nativeint: t -> nativeint = "ml_z_to_nativeint"
+external to_int32_unsigned: t -> int32 = "ml_z_to_int32_unsigned"
+external to_int64_unsigned: t -> int64 = "ml_z_to_int64_unsigned"
+external to_nativeint_unsigned: t -> nativeint = "ml_z_to_nativeint_unsigned"
+external format: string -> t -> string = "ml_z_format"
+external of_substring_base: int -> string -> pos:int -> len:int -> t = "ml_z_of_substring_base"
+external compare: t -> t -> int = "ml_z_compare" [@@noalloc]
+external equal: t -> t -> bool = "ml_z_equal" [@@noalloc]
+external sign: t -> int = "ml_z_sign" [@@noalloc]
+external gcd: t -> t -> t = "ml_z_gcd"
+external gcdext_intern: t -> t -> (t * t * bool) = "ml_z_gcdext_intern"
+external sqrt: t -> t = "ml_z_sqrt"
+external sqrt_rem: t -> (t * t) = "ml_z_sqrt_rem"
+external numbits: t -> int = "ml_z_numbits" [@@noalloc]
+external trailing_zeros: t -> int = "ml_z_trailing_zeros" [@@noalloc]
+external popcount: t -> int = "ml_z_popcount"
+external hamdist: t -> t -> int = "ml_z_hamdist"
+external size: t -> int = "ml_z_size" [@@noalloc]
+external fits_int: t -> bool = "ml_z_fits_int" [@@noalloc]
+external fits_int32: t -> bool = "ml_z_fits_int32" [@@noalloc]
+external fits_int64: t -> bool = "ml_z_fits_int64" [@@noalloc]
+external fits_nativeint: t -> bool = "ml_z_fits_nativeint" [@@noalloc]
+external fits_int32_unsigned: t -> bool = "ml_z_fits_int32_unsigned" [@@noalloc]
+external fits_int64_unsigned: t -> bool = "ml_z_fits_int64_unsigned" [@@noalloc]
+external fits_nativeint_unsigned: t -> bool = "ml_z_fits_nativeint_unsigned" [@@noalloc]
+external extract: t -> int -> int -> t = "ml_z_extract"
+external powm: t -> t -> t -> t = "ml_z_powm"
+external pow: t -> int -> t = "ml_z_pow"
+external powm_sec: t -> t -> t -> t = "ml_z_powm_sec"
+external root: t -> int -> t = "ml_z_root"
+external rootrem: t -> int -> t * t = "ml_z_rootrem"
+external invert: t -> t -> t = "ml_z_invert"
+external perfect_power: t -> bool = "ml_z_perfect_power"
+external perfect_square: t -> bool = "ml_z_perfect_square"
+external probab_prime: t -> int -> int = "ml_z_probab_prime"
+external nextprime: t -> t = "ml_z_nextprime"
+let hash: t -> int = Stdlib.Hashtbl.hash
+let seeded_hash: int -> t -> int = Stdlib.Hashtbl.seeded_hash
+external to_bits: t -> string = "ml_z_to_bits"
+external of_bits: string -> t = "ml_z_of_bits"
+
+external c_divisible: t -> t -> bool = "ml_z_divisible"
+
+let divisible x y =
+  if is_small_int x then
+    if is_small_int y then
+      if unsafe_to_int y = 0
+      then unsafe_to_int x = 0
+      else (unsafe_to_int x) mod (unsafe_to_int y) = 0
+    else
+      (* If y divides x, we have |y| <= |x| or x = 0.
+         Here, x is small:  min_int <= x <= max_int
+         and y is not small:  y < min_int \/ y > max_int.
+         |y| <= |x| is possible only if
+         x = min_int and y = -min_int = max_int+1 .
+         So, the only two cases where y divides x are
+         x = 0 or x = min_int /\ y = -min_int. *)
+      unsafe_to_int x = 0 || (unsafe_to_int x = min_int && y = c_neg x)
+  else
+    c_divisible x y
+
+external congruent: t -> t -> t -> bool = "ml_z_congruent"
+external jacobi: t -> t -> int = "ml_z_jacobi"
+external legendre: t -> t -> int = "ml_z_legendre"
+external kronecker: t -> t -> int = "ml_z_kronecker"
+external remove: t -> t -> t * int = "ml_z_remove"
+external fac: int -> t = "ml_z_fac"
+external fac2: int -> t = "ml_z_fac2"
+external facM: int -> int -> t = "ml_z_facM"
+external primorial: int -> t = "ml_z_primorial"
+external bin: t -> int -> t = "ml_z_bin"
+external fib: int -> t = "ml_z_fib"
+external lucnum: int -> t = "ml_z_lucnum"
+
+let zero = of_int 0
+let one = of_int 1
+let minus_one = of_int (-1)
+
+let min a b = if compare a b <= 0 then a else b
+let max a b = if compare a b >= 0 then a else b
+
+let leq a b = compare a b <= 0
+let geq a b = compare a b >= 0
+let lt a b = compare a b < 0
+let gt a b = compare a b > 0
+
+let to_string = format "%d"
+
+let of_string s = of_substring_base 0 s ~pos:0 ~len:(String.length s)
+let of_substring = of_substring_base 0
+let of_string_base base s = of_substring_base base s ~pos:0 ~len:(String.length s)
+
+let ediv_rem a b =
+  (* we have a = q * b + r, but [Big_int]'s remainder satisfies 0 <= r < |b|,
+     while [Z]'s remainder satisfies -|b| < r < |b| and sign(r) = sign(a)
+   *)
+   let q,r = div_rem a b in
+   if sign r >= 0 then (q,r) else
+   if sign b >= 0 then (pred q, add r b)
+   else (succ q, sub r b)
+
+let ediv a b =
+   if sign b >= 0 then fdiv a b else cdiv a b
+
+let erem a b =
+   let r = rem a b in
+   if sign r >= 0 then r else add r (abs b)
+
+let gcdext u v =
+  match sign u, sign v with
+  (* special cases: one argument is null *)
+  |  0,  0 -> zero, zero, zero
+  |  0,  1 -> v, zero, one
+  |  0, -1 -> neg v, zero, minus_one
+  |  1,  0 -> u, one, zero
+  | -1,  0 -> neg u, minus_one, zero
+  | _ ->
+     (* general case *)
+     let g,s,z = gcdext_intern u v in
+     if z then g, s, div (sub g (mul u s)) v
+     else g, div (sub g (mul v s)) u, s
+
+let lcm u v =
+  if u = zero || v = zero then zero
+  else
+    let g = gcd u v in
+    abs (mul (divexact u g) v)
+
+external testbit_internal: t -> int -> bool = "ml_z_testbit" [@@noalloc]
+let testbit x n =
+  if n >= 0 then testbit_internal x n else invalid_arg "Z.testbit"
+(* The test [n >= 0] is done in Caml rather than in the C stub code
+   so that the latter raises no exceptions and can be declared [@@noalloc]. *)
+
+let is_odd x = testbit_internal x 0
+let is_even x  = not (testbit_internal x 0)
+
+external c_extract_small: t -> int -> int -> t
+  = "ml_z_extract_small" [@@noalloc]
+external c_extract: t -> int -> int -> t = "ml_z_extract"
+
+let extract_internal x o l =
+  if is_small_int x then
+    (* Fast path *)
+    let o = if o >= Sys.int_size then Sys.int_size - 1 else o in
+    (* Shift away low "o" bits.  If "o" too big, just replicate sign bit. *)
+    let z = unsafe_to_int x asr o in
+    if l < Sys.int_size then
+      (* Extract "l" low bits, if "l" is small enough *)
+      of_int (z land ((1 lsl l) - 1))
+    else if z >= 0 then
+      (* If x >= 0, the extraction of "l" low bits keeps x unchanged. *)
+      of_int z
+    else
+      (* If x < 0, fall through slow path *)
+      c_extract x o l
+  else if l < Sys.int_size then
+    (* Alternative fast path since no allocation is required *)
+    c_extract_small x o l
+  else
+    c_extract x o l
+
+let extract x o l =
+  if o < 0 then invalid_arg "Z.extract: negative bit offset";
+  if l < 1 then invalid_arg "Z.extract: nonpositive bit length";
+  extract_internal x o l
+
+let signed_extract x o l =
+  if o < 0 then invalid_arg "Z.signed_extract: negative bit offset";
+  if l < 1 then invalid_arg "Z.signed_extract: nonpositive bit length";
+  if testbit x (o + l - 1)
+  then lognot (extract (lognot x) o l)
+  else extract x o l
+
+let log2 x =
+  if sign x > 0 then (numbits x) - 1 else invalid_arg "Z.log2"
+let log2up x =
+  if sign x > 0 then numbits (pred x) else invalid_arg "Z.log2up"
+
+(* Consider a real number [r] such that
+   - the integral part of [r] is the bigint [x]
+   - 2^54 <= |x| < 2^63
+   - the fractional part of [r] is 0 if [exact = true],
+     nonzero if [exact = false].
+   Then, the following function returns [r] correctly rounded
+   according to the current rounding mode of the processor.
+   This is an instance of the "round to odd" technique formalized in
+   "When double rounding is odd" by S. Boldo and G. Melquiond.
+   The claim above is lemma Fappli_IEEE_extra.round_odd_fix
+   from the CompCert Coq development. *)
+
+let round_to_float x exact =
+  let m = to_int64 x in
+  (* Unless the fractional part is exactly 0, round m to an odd integer *)
+  let m = if exact then m else Int64.logor m 1L in
+  (* Then convert m to float, with the current rounding mode. *)
+  Int64.to_float m
+
+let to_float x =
+  if Obj.is_int (Obj.repr x) then
+    (* Fast path *)
+    float_of_int (Obj.magic x : int)
+  else begin
+    let n = numbits x in
+    if n <= 63 then
+      Int64.to_float (to_int64 x)
+    else begin
+      let n = n - 55 in
+      (* Extract top 55 bits of x *)
+      let top = shift_right x n in
+      (* Check if the other bits are all zero *)
+      let exact = equal x (shift_left top n) in
+      (* Round to float and apply exponent *)
+      ldexp (round_to_float top exact) n
+    end
+  end
+
+(* Formatting *)
+
+let print x = print_string (to_string x)
+let output chan x = output_string chan (to_string x)
+let sprint () x = to_string x
+let bprint b x = Buffer.add_string b (to_string x)
+let pp_print f x = Format.pp_print_string f (to_string x)
+
+(* Pseudo-random generation *)
+
+let rec raw_bits_random ?(rng: Random.State.t option) nbits =
+  let rec raw_bits accu n =
+    if n >= nbits then (accu, n) else begin
+      let i =
+        match rng with
+        | None -> Random.bits ()
+        | Some r -> Random.State.bits r in
+      raw_bits (logxor (shift_left accu 30) (of_int i)) (n + 30)
+    end in
+  raw_bits zero 0
+
+let raw_bits_from_bytes ~(fill: bytes -> int -> int -> unit) nbits =
+  let nbytes = (nbits + 7) / 8 in
+  let buf = Bytes.create nbytes in
+  fill buf 0 nbytes;
+  (of_bits (Bytes.to_string buf), nbytes * 8)
+
+let random_bits_aux (f: int -> t * int) nbits =
+  if nbits < 0 then invalid_arg "random_bits: number of bits must be >= 0";
+  let (x, _) = f nbits in
+  extract x 0 nbits
+
+let random_int_aux (f: int -> t * int) bound =
+  if sign bound <= 0 then invalid_arg "random_int: bound must be > 0";
+  let nbits1 = log2up bound in
+  let rec draw () =
+    (* The minimal number of random bits we need to draw is nbits1.
+       However, in the worst case, rejection (as described below)
+       will occur with probability almost 1/2.  So, we draw more bits
+       than strictly necessary to make rejection much less likely.
+       With 4 extra bits, the probability of rejection is less than
+       1/32. *)
+    let (x, nbits) = f (nbits1 + 4) in
+    let y = rem x bound in
+    (* We divide the range of x, namely [0 .. 2^nbits), into
+         - k intervals of width bound :
+             [0 .. bound) [bound.. 2*bound) .. [(k-1) * bound.. k * bound)
+         - the remaining numbers: [k * bound .. 2^nbits)
+
+       k is chosen as large as possible: k = floor (2^nbits / bound).
+
+       If x falls within the k intervals of width bound,
+       y = x mod bound is evenly distributed in [0 .. bound)
+       and we can use it as the pseudo-random number.
+       If x falls within the [k * bound .. 2^nbits) interval,
+       y = x mod bound may not be evenly distributed;
+       we reject and draw again.
+
+       We can decide efficiently whether to reject, as follows.
+       Write 2^nbits = k * bound + r and x = q * bound + y,
+       with r and y in [0 .. bound).
+       If x - y <= 2^nbits - bound, then
+         q * bound = x - y <= 2^nbits - bound < 2^nbits - r = k * bound,
+       hence q < k and we can accept x.
+       Otherwise, 
+         q * bound = x - y > 2^nbits - bound = (k - 1) * bound + r
+       hence q >= k and we must reject x.
+    *)
+    if leq (sub x y) (sub (shift_left one nbits) bound)
+    then y
+    else draw () in
+  draw ()
+
+let random_int ?rng bound =
+  random_int_aux (raw_bits_random ?rng) bound
+let random_bits ?rng nbits =
+  random_bits_aux (raw_bits_random ?rng) nbits
+
+let random_int_gen ~fill bound =
+  random_int_aux (raw_bits_from_bytes ~fill) bound
+let random_bits_gen ~fill nbits =
+  random_bits_aux (raw_bits_from_bytes ~fill) nbits
+
+(* Infix notations *)
+
+let (~-) = neg
+let (~+) x = x
+let (+) = add
+let (-) = sub
+let ( * ) = mul
+let (/) = div
+external (/>): t -> t -> t = "ml_z_cdiv"
+external (/<): t -> t -> t = "ml_z_fdiv"
+let (/|) = divexact
+let (mod) = rem
+let (land) = logand
+let (lor) = logor
+let (lxor) = logxor
+let (~!) = lognot
+let (lsl) = shift_left
+let (asr) = shift_right
+external (~$): int -> t = "%identity"
+external ( ** ): t -> int -> t = "ml_z_pow"
+
+module Compare = struct
+  let (=) = equal
+  let (<) = lt
+  let (>) = gt
+  let (<=) = leq
+  let (>=) = geq
+  let (<>) a b = not (equal a b)
+end
+
+let version = Zarith_version.version