Source file `int63_emul.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
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