Source file int63_emul.ml

(* A 63bit integer is a 64bit integer with its bits shifted to the left
   and its lowest bit set to 0.
   This is the same kind of encoding as OCaml int on 64bit architecture.
   The only difference being the lowest bit (immediate bit) set to 1. *)

open! Import
include Int64_replace_polymorphic_compare

module T0 = struct
  module T = struct
    type t = int64
    [@@deriving_inline compare ~localize, globalize, hash, sexp, sexp_grammar]

    let compare__local = (compare_int64__local : t -> t -> int)
    let compare = (fun a b -> compare__local a b : t -> t -> int)
    let (globalize : t -> t) = (globalize_int64 : t -> t)

    let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
      hash_fold_int64

    and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
      let func = hash_int64 in
      fun x -> func x
    ;;

    let t_of_sexp = (int64_of_sexp : Sexplib0.Sexp.t -> t)
    let sexp_of_t = (sexp_of_int64 : t -> Sexplib0.Sexp.t)
    let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = int64_sexp_grammar

    [@@@end]

    let hashable : t Hashable.t = { hash; compare; sexp_of_t }
  end

  include T
  include Comparator.Make (T)
end

module Conv = Int_conversions

module W : sig
  include module type of struct
    include T0
  end

  type t = int64

  val wrap_exn : Stdlib.Int64.t -> t
  val wrap_modulo : Stdlib.Int64.t -> t
  val unwrap : t -> Stdlib.Int64.t

  (** Returns a non-negative int64 that is equal to the input int63 modulo 2^63. *)
  val unwrap_unsigned : t -> Stdlib.Int64.t

  val invariant : t -> unit
  val add : t -> t -> t
  val sub : t -> t -> t
  val neg : t -> t
  val abs : t -> t
  val succ : t -> t
  val pred : t -> t
  val mul : t -> t -> t
  val pow : t -> t -> t
  val div : t -> t -> t
  val rem : t -> t -> t
  val popcount : t -> int
  val bit_not : t -> t
  val bit_xor : t -> t -> t
  val bit_or : t -> t -> t
  val bit_and : t -> t -> t
  val shift_left : t -> int -> t
  val shift_right : t -> int -> t
  val shift_right_logical : t -> int -> t
  val min_value : t
  val max_value : t
  val to_int64 : t -> Stdlib.Int64.t
  val of_int64 : Stdlib.Int64.t -> t option
  val of_int64_exn : Stdlib.Int64.t -> t
  val of_int64_trunc : Stdlib.Int64.t -> t
  val compare : t -> t -> int
  val compare__local : t -> t -> int
  val equal__local : t -> t -> bool
  val ceil_pow2 : t -> t
  val floor_pow2 : t -> t
  val ceil_log2 : t -> int
  val floor_log2 : t -> int
  val is_pow2 : t -> bool
  val clz : t -> int
  val ctz : t -> int
end = struct
  include T0

  type t = int64

  let wrap_exn x =
    (* Raises if the int64 value does not fit on int63. *)
    Conv.int64_fit_on_int63_exn x;
    Stdlib.Int64.mul x 2L
  ;;

  let wrap x =
    if Conv.int64_is_representable_as_int63 x then Some (Stdlib.Int64.mul x 2L) else None
  ;;

  let wrap_modulo x = Stdlib.Int64.mul x 2L
  let unwrap x = Stdlib.Int64.shift_right x 1
  let unwrap_unsigned x = Stdlib.Int64.shift_right_logical x 1

  (* This does not use wrap or unwrap to avoid generating exceptions in the case of
     overflows. This is to preserve the semantics of int type on 64 bit architecture. *)
  let f2 f a b =
    Stdlib.Int64.mul (f (Stdlib.Int64.shift_right a 1) (Stdlib.Int64.shift_right b 1)) 2L
  ;;

  let mask = 0xffff_ffff_ffff_fffeL
  let m x = Stdlib.Int64.logand x mask
  let invariant t = assert (m t = t)
  let add x y = Stdlib.Int64.add x y
  let sub x y = Stdlib.Int64.sub x y
  let neg x = Stdlib.Int64.neg x
  let abs x = Stdlib.Int64.abs x
  let one = wrap_exn 1L
  let succ a = add a one
  let pred a = sub a one
  let min_value = m Stdlib.Int64.min_int
  let max_value = m Stdlib.Int64.max_int
  let bit_not x = m (Stdlib.Int64.lognot x)
  let bit_and = Stdlib.Int64.logand
  let bit_xor = Stdlib.Int64.logxor
  let bit_or = Stdlib.Int64.logor
  let shift_left x i = Stdlib.Int64.shift_left x i
  let shift_right x i = m (Stdlib.Int64.shift_right x i)
  let shift_right_logical x i = m (Stdlib.Int64.shift_right_logical x i)
  let pow = f2 Int_math.Private.int63_pow_on_int64
  let mul a b = Stdlib.Int64.mul a (Stdlib.Int64.shift_right b 1)
  let div a b = wrap_modulo (Stdlib.Int64.div a b)
  let rem a b = Stdlib.Int64.rem a b
  let popcount x = Popcount.int64_popcount x
  let to_int64 t = unwrap t
  let of_int64 t = wrap t
  let of_int64_exn t = wrap_exn t
  let of_int64_trunc t = wrap_modulo t
  let t_of_sexp x = wrap_exn (int64_of_sexp x)
  let sexp_of_t x = sexp_of_int64 (unwrap x)
  let compare (x : t) y = compare x y
  let compare__local (x : t) y = compare__local x y
  let equal__local (x : t) y = equal__local x y
  let is_pow2 x = Int64.is_pow2 (unwrap x)

  let clz x =
    (* We run Int64.clz directly on the wrapped int63 value. This is correct because the
       bits of the int63_emul are left-aligned in the Int64. *)
    Int64.clz x
  ;;

  let ctz x = Int64.ctz (unwrap x)
  let floor_pow2 x = Int64.floor_pow2 (unwrap x) |> wrap_exn
  let ceil_pow2 x = Int64.floor_pow2 (unwrap x) |> wrap_exn
  let floor_log2 x = Int64.floor_log2 (unwrap x)
  let ceil_log2 x = Int64.ceil_log2 (unwrap x)
end

open W

module T = struct
  type t = W.t [@@deriving_inline globalize, hash, sexp, sexp_grammar]

  let (globalize : t -> t) = (W.globalize : t -> t)

  let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
    W.hash_fold_t

  and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
    let func = W.hash in
    fun x -> func x
  ;;

  let t_of_sexp = (W.t_of_sexp : Sexplib0.Sexp.t -> t)
  let sexp_of_t = (W.sexp_of_t : t -> Sexplib0.Sexp.t)
  let (t_sexp_grammar : t Sexplib0.Sexp_grammar.t) = W.t_sexp_grammar

  [@@@end]

  type comparator_witness = W.comparator_witness

  let comparator = W.comparator
  let compare = W.compare
  let compare__local = W.compare__local
  let equal__local = W.equal__local
  let invariant = W.invariant

  (* We don't expect [hash] to follow the behavior of int in 64bit architecture *)
  let _ = hash
  let hash (x : t) = Stdlib.Hashtbl.hash x
  let hashable : t Hashable.t = { hash; compare; sexp_of_t }
  let invalid_str x = Printf.failwithf "Int63.of_string: invalid input %S" x ()

  (*
     "sign" refers to whether the number starts with a '-'
     "signedness = false" means the rest of the number is parsed as unsigned and then cast
     to signed with wrap-around modulo 2^i
     "signedness = true" means no such craziness happens

     The terminology and the logic is due to the code in byterun/ints.c in ocaml 4.03
     ([parse_sign_and_base] function).

     Signedness equals true for plain decimal number (e.g. 1235, -6789)

     Signedness equals false in the following cases:
     - [0xffff], [-0xffff] (hexadecimal representation)
     - [0b0101], [-0b0101] (binary representation)
     - [0o1237], [-0o1237] (octal representation)
     - [0u9812], [-0u9812] (unsigned decimal representation - available from OCaml 4.03) *)
  let sign_and_signedness x =
    let len = String.length x in
    let open Int_replace_polymorphic_compare in
    let pos, sign =
      if 0 < len
      then (
        match x.[0] with
        | '-' -> 1, `Neg
        | '+' -> 1, `Pos
        | _ -> 0, `Pos)
      else 0, `Pos
    in
    if pos + 2 < len
    then (
      let c1 = x.[pos] in
      let c2 = x.[pos + 1] in
      match c1, c2 with
      | '0', '0' .. '9' -> sign, true
      | '0', _ -> sign, false
      | _ -> sign, true)
    else sign, true
  ;;

  let to_string x = Stdlib.Int64.to_string (unwrap x)

  let of_string_raw str =
    let sign, signedness = sign_and_signedness str in
    if signedness
    then of_int64_exn (Stdlib.Int64.of_string str)
    else (
      let pos_str =
        match sign with
        | `Neg -> String.sub str ~pos:1 ~len:(String.length str - 1)
        | `Pos -> str
      in
      let int64 = Stdlib.Int64.of_string pos_str in
      (* unsigned 63-bit int must parse as a positive signed 64-bit int *)
      if Int64_replace_polymorphic_compare.( < ) int64 0L then invalid_str str;
      let int63 = wrap_modulo int64 in
      match sign with
      | `Neg -> neg int63
      | `Pos -> int63)
  ;;

  let of_string str =
    try of_string_raw str with
    | _ -> invalid_str str
  ;;

  let of_string_opt str =
    match of_string_raw str with
    | t -> Some t
    | exception _ -> None
  ;;

  let bswap16 t = wrap_modulo (Int64.bswap16 (unwrap t))
  let bswap32 t = wrap_modulo (Int64.bswap32 (unwrap t))
  let bswap48 t = wrap_modulo (Int64.bswap48 (unwrap t))
end

include T

let num_bits = 63
let float_lower_bound = Float0.lower_bound_for_int num_bits
let float_upper_bound = Float0.upper_bound_for_int num_bits
let shift_right_logical = shift_right_logical
let shift_right = shift_right
let shift_left = shift_left
let bit_not = bit_not
let bit_xor = bit_xor
let bit_or = bit_or
let bit_and = bit_and
let popcount = popcount
let abs = abs
let pred = pred
let succ = succ
let pow = pow
let rem = rem
let neg = neg
let max_value = max_value
let min_value = min_value
let minus_one = wrap_exn Stdlib.Int64.minus_one
let one = wrap_exn Stdlib.Int64.one
let zero = wrap_exn Stdlib.Int64.zero
let is_pow2 = is_pow2
let floor_pow2 = floor_pow2
let ceil_pow2 = ceil_pow2
let floor_log2 = floor_log2
let ceil_log2 = ceil_log2
let clz = clz
let ctz = ctz
let to_float x = Stdlib.Int64.to_float (unwrap x)
let of_float_unchecked x = wrap_modulo (Stdlib.Int64.of_float x)

let of_float t =
  let open Float_replace_polymorphic_compare in
  if t >= float_lower_bound && t <= float_upper_bound
  then wrap_modulo (Stdlib.Int64.of_float t)
  else
    Printf.invalid_argf
      "Int63.of_float: argument (%f) is out of range or NaN"
      (Float0.box t)
      ()
;;

let of_int64 = of_int64
let of_int64_exn = of_int64_exn
let of_int64_trunc = of_int64_trunc
let to_int64 = to_int64

include Comparable.With_zero (struct
  include T

  let zero = zero
end)

let between t ~low ~high = low <= t && t <= high
let clamp_unchecked t ~min:min_ ~max:max_ = min t max_ |> max min_

let clamp_exn t ~min ~max =
  assert (min <= max);
  clamp_unchecked t ~min ~max
;;

let clamp t ~min ~max =
  if min > max
  then
    Or_error.error_s
      (Sexp.message
         "clamp requires [min <= max]"
         [ "min", T.sexp_of_t min; "max", T.sexp_of_t max ])
  else Ok (clamp_unchecked t ~min ~max)
;;

let ( / ) = div
let ( * ) = mul
let ( - ) = sub
let ( + ) = add
let ( ~- ) = neg
let ( ** ) b e = pow b e
let incr r = r := !r + one
let decr r = r := !r - one

(* We can reuse conversion function from/to int64 here. *)
let of_int x = wrap_exn (Conv.int_to_int64 x)
let of_int_exn x = of_int x
let to_int x = Conv.int64_to_int (unwrap x)
let to_int_exn x = Conv.int64_to_int_exn (unwrap x)
let to_int_trunc x = Conv.int64_to_int_trunc (unwrap x)
let of_int32 x = wrap_exn (Conv.int32_to_int64 x)
let of_int32_exn x = of_int32 x
let to_int32 x = Conv.int64_to_int32 (unwrap x)
let to_int32_exn x = Conv.int64_to_int32_exn (unwrap x)
let to_int32_trunc x = Conv.int64_to_int32_trunc (unwrap x)
let of_nativeint x = of_int64 (Conv.nativeint_to_int64 x)
let of_nativeint_exn x = wrap_exn (Conv.nativeint_to_int64 x)
let of_nativeint_trunc x = of_int64_trunc (Conv.nativeint_to_int64 x)
let to_nativeint x = Conv.int64_to_nativeint (unwrap x)
let to_nativeint_exn x = Conv.int64_to_nativeint_exn (unwrap x)
let to_nativeint_trunc x = Conv.int64_to_nativeint_trunc (unwrap x)

include Int_string_conversions.Make (T)

include Int_string_conversions.Make_hex (struct
  type t = T.t [@@deriving_inline compare ~localize, hash]

  let compare__local = (T.compare__local : t -> t -> int)
  let compare = (fun a b -> compare__local a b : t -> t -> int)

  let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
    T.hash_fold_t

  and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
    let func = T.hash in
    fun x -> func x
  ;;

  [@@@end]

  let zero = zero
  let neg = ( ~- )
  let ( < ) = ( < )

  let to_string i =
    (* the use of [unwrap_unsigned] here is important for the case of [min_value] *)
    Printf.sprintf "%Lx" (unwrap_unsigned i)
  ;;

  let of_string s = of_string ("0x" ^ s)
  let module_name = "Base.Int63.Hex"
end)

include Pretty_printer.Register (struct
  type nonrec t = t

  let to_string x = to_string x
  let module_name = "Base.Int63"
end)

module Pre_O = struct
  let ( + ) = ( + )
  let ( - ) = ( - )
  let ( * ) = ( * )
  let ( / ) = ( / )
  let ( ~- ) = ( ~- )
  let ( ** ) = ( ** )

  include (Int64_replace_polymorphic_compare : Comparisons.Infix with type t := t)

  let abs = abs
  let neg = neg
  let zero = zero
  let of_int_exn = of_int_exn
end

module O = struct
  include Pre_O

  include Int_math.Make (struct
    type nonrec t = t

    include Pre_O

    let rem = rem
    let to_float = to_float
    let of_float = of_float
    let of_string = T.of_string
    let to_string = T.to_string
  end)

  let ( land ) = bit_and
  let ( lor ) = bit_or
  let ( lxor ) = bit_xor
  let lnot = bit_not
  let ( lsl ) = shift_left
  let ( asr ) = shift_right
  let ( lsr ) = shift_right_logical
end

include O

include Int_string_conversions.Make_binary (struct
  type t = T.t [@@deriving_inline compare ~localize, equal ~localize, hash]

  let compare__local = (T.compare__local : t -> t -> int)
  let compare = (fun a b -> compare__local a b : t -> t -> int)
  let equal__local = (T.equal__local : t -> t -> bool)
  let equal = (fun a b -> equal__local a b : t -> t -> bool)

  let (hash_fold_t : Ppx_hash_lib.Std.Hash.state -> t -> Ppx_hash_lib.Std.Hash.state) =
    T.hash_fold_t

  and (hash : t -> Ppx_hash_lib.Std.Hash.hash_value) =
    let func = T.hash in
    fun x -> func x
  ;;

  [@@@end]

  let ( land ) = ( land )
  let ( lsr ) = ( lsr )
  let clz = clz
  let num_bits = num_bits
  let one = one
  let to_int_exn = to_int_exn
  let zero = zero
end)

(* [Int63] and [Int63.O] agree value-wise *)

module Repr = struct
  type emulated = t

  type ('underlying_type, 'intermediate_type) t =
    | Int : (int, int) t
    | Int64 : (int64, emulated) t
end

let repr = Repr.Int64

(* Include type-specific [Replace_polymorphic_compare] at the end, after
   including functor application that could shadow its definitions. This is
   here so that efficient versions of the comparison functions are exported by
   this module. *)
include Int64_replace_polymorphic_compare