exception Overflow
exception DivideByZero
exception InvalidConversion
module type RepType =
sig
type t
val zero : t
val one : t
val minus_one : t
val max_int : t
val min_int : t
val abs : t -> t
val neg : t -> t
val add : t -> t -> t
val sub : t -> t -> t
val mul : t -> t -> t
val div : t -> t -> t (* raises DivideByZero *)
val rem : t -> t -> t (* raises DivideByZero *)
val logand : t -> t -> t
val lognot : t -> t
val logor : t -> t -> t
val logxor : t -> t -> t
val shift_left : t -> int -> t
val shift_right : t -> int -> t
val shift_right_logical : t -> int -> t
val of_int : int -> t
val to_int : t -> int
val of_int64 : int64 -> t
val to_int64 : t -> int64
val to_string : t -> string
val to_hex_string : t -> string
val bitwidth : int
end
module type S =
sig
type t
type bits
val of_bits : bits -> t
val to_bits : t -> bits
val zero : t
val lognot : t -> t
val abs : t -> t
val neg : t -> t
val add : t -> t -> t
val sub : t -> t -> t
val mul : t -> t -> t
val div_s : t -> t -> t (* raises IntegerDivideByZero, IntegerOverflow *)
val div_u : t -> t -> t (* raises IntegerDivideByZero *)
val rem_s : t -> t -> t (* raises IntegerDivideByZero *)
val rem_u : t -> t -> t (* raises IntegerDivideByZero *)
val avgr_u : t -> t -> t
val and_ : t -> t -> t
val or_ : t -> t -> t
val xor : t -> t -> t
val shl : t -> t -> t
val shr_s : t -> t -> t
val shr_u : t -> t -> t
val rotl : t -> t -> t
val rotr : t -> t -> t
val clz : t -> t
val ctz : t -> t
val popcnt : t -> t
val extend_s : int -> t -> t
val eqz : t -> bool
val eq : t -> t -> bool
val ne : t -> t -> bool
val lt_s : t -> t -> bool
val lt_u : t -> t -> bool
val le_s : t -> t -> bool
val le_u : t -> t -> bool
val gt_s : t -> t -> bool
val gt_u : t -> t -> bool
val ge_s : t -> t -> bool
val ge_u : t -> t -> bool
val as_unsigned : t -> t
(* Saturating arithmetic, used for small ints. *)
val saturate_s : t -> t
val saturate_u : t -> t
val add_sat_s : t -> t -> t
val add_sat_u : t -> t -> t
val sub_sat_s : t -> t -> t
val sub_sat_u : t -> t -> t
val q15mulr_sat_s : t -> t -> t
val of_int_s : int -> t
val of_int_u : int -> t
val of_string_s : string -> t
val of_string_u : string -> t
val of_string : string -> t
val to_int_s : t -> int
val to_int_u : t -> int
val to_string_s : t -> string
val to_string_u : t -> string
val to_hex_string : t -> string
end
module Make (Rep : RepType) : S with type bits = Rep.t and type t = Rep.t =
struct
(*
* Unsigned comparison in terms of signed comparison.
*)
let cmp_u x op y =
op (Rep.add x Rep.min_int) (Rep.add y Rep.min_int)
(*
* Unsigned division and remainder in terms of signed division; algorithm from
* Hacker's Delight, Second Edition, by Henry S. Warren, Jr., section 9-3
* "Unsigned Short Division from Signed Division".
*)
let divrem_u n d =
if d = Rep.zero then raise DivideByZero else
let t = Rep.shift_right d (Rep.bitwidth - 1) in
let n' = Rep.logand n (Rep.lognot t) in
let q = Rep.shift_left (Rep.div (Rep.shift_right_logical n' 1) d) 1 in
let r = Rep.sub n (Rep.mul q d) in
if cmp_u r (<) d then
q, r
else
Rep.add q Rep.one, Rep.sub r d
type t = Rep.t
type bits = Rep.t
let of_bits x = x
let to_bits x = x
let zero = Rep.zero
let one = Rep.one
let ten = Rep.of_int 10
let lognot = Rep.lognot
let abs = Rep.abs
let neg = Rep.neg
(* If bit (bitwidth - 1) is set, sx will sign-extend t to maintain the
* invariant that small ints are stored sign-extended inside a wider int. *)
let sx x =
let i = 64 - Rep.bitwidth in
Rep.of_int64 Int64.(shift_right (shift_left (Rep.to_int64 x) i) i)
(* add, sub, and mul are sign-agnostic and do not trap on overflow. *)
let add x y = sx (Rep.add x y)
let sub x y = sx (Rep.sub x y)
let mul x y = sx (Rep.mul x y)
(* We don't override min_int and max_int since those are used
* by other functions (like parsing), and rely on it being
* min/max for int32 *)
(* The smallest signed |bitwidth|-bits int. *)
let low_int = Rep.shift_left Rep.minus_one (Rep.bitwidth - 1)
(* The largest signed |bitwidth|-bits int. *)
let high_int = Rep.logxor low_int Rep.minus_one
(* result is truncated toward zero *)
let div_s x y =
if y = Rep.zero then
raise DivideByZero
else if x = low_int && y = Rep.minus_one then
raise Overflow
else
Rep.div x y
(* result is floored (which is the same as truncating for unsigned values) *)
let div_u x y =
let q, r = divrem_u x y in q
(* result has the sign of the dividend *)
let rem_s x y =
if y = Rep.zero then
raise DivideByZero
else
Rep.rem x y
let rem_u x y =
let q, r = divrem_u x y in r
let avgr_u x y =
let open Int64 in
(* Mask with bottom #bitwidth bits set *)
let mask = shift_right_logical minus_one (64 - Rep.bitwidth) in
let x64 = logand mask (Rep.to_int64 x) in
let y64 = logand mask (Rep.to_int64 y) in
Rep.of_int64 (div (add (add x64 y64) one) (of_int 2))
let and_ = Rep.logand
let or_ = Rep.logor
let xor = Rep.logxor
(* WebAssembly's shifts mask the shift count according to the bitwidth. *)
let shift f x y =
f x Rep.(to_int (logand y (of_int (bitwidth - 1))))
let shl x y =
sx (shift Rep.shift_left x y)
let shr_s x y =
shift Rep.shift_right x y
(* Check if we are storing smaller ints. *)
let needs_extend = shl one (Rep.of_int (Rep.bitwidth - 1)) <> Rep.min_int
(*
* When Int is used to store a smaller int, it is stored in signed extended
* form. Some instructions require the unsigned form, which requires masking
* away the top 32-bitwidth bits.
*)
let as_unsigned x =
if not needs_extend then x else
(* Mask with bottom #bitwidth bits set *)
let mask = Rep.(shift_right_logical minus_one (32 - bitwidth)) in
Rep.logand x mask
let shr_u x y =
sx (shift Rep.shift_right_logical (as_unsigned x) y)
(* We must mask the count to implement rotates via shifts. *)
let clamp_rotate_count n =
Rep.to_int (Rep.logand n (Rep.of_int (Rep.bitwidth - 1)))
let rotl x y =
let n = clamp_rotate_count y in
or_ (shl x (Rep.of_int n)) (shr_u x (Rep.of_int (Rep.bitwidth - n)))
let rotr x y =
let n = clamp_rotate_count y in
or_ (shr_u x (Rep.of_int n)) (shl x (Rep.of_int (Rep.bitwidth - n)))
(* clz is defined for all values, including all-zeros. *)
let clz x =
let rec loop acc n =
if n = Rep.zero then
Rep.bitwidth
else if and_ n (Rep.shift_left Rep.one (Rep.bitwidth - 1)) = zero then
loop (1 + acc) (Rep.shift_left n 1)
else
acc
in Rep.of_int (loop 0 x)
(* ctz is defined for all values, including all-zeros. *)
let ctz x =
let rec loop acc n =
if n = Rep.zero then
Rep.bitwidth
else if and_ n Rep.one = Rep.one then
acc
else
loop (1 + acc) (Rep.shift_right_logical n 1)
in Rep.of_int (loop 0 x)
let popcnt x =
let rec loop acc i n =
if i = 0 then
acc
else
let acc' = if and_ n Rep.one = Rep.one then acc + 1 else acc in
loop acc' (i - 1) (Rep.shift_right_logical n 1)
in Rep.of_int (loop 0 Rep.bitwidth x)
let extend_s n x =
let shift = Rep.bitwidth - n in
Rep.shift_right (Rep.shift_left x shift) shift
let eqz x = x = Rep.zero
let eq x y = x = y
let ne x y = x <> y
let lt_s x y = x < y
let lt_u x y = cmp_u x (<) y
let le_s x y = x <= y
let le_u x y = cmp_u x (<=) y
let gt_s x y = x > y
let gt_u x y = cmp_u x (>) y
let ge_s x y = x >= y
let ge_u x y = cmp_u x (>=) y
let saturate_s x = sx (min (max x low_int) high_int)
let saturate_u x = sx (min (max x Rep.zero) (as_unsigned Rep.minus_one))
(* add/sub for int, used for higher-precision arithmetic for I8 and I16 *)
let add_int x y =
assert (Rep.bitwidth < 32);
Rep.(of_int ((to_int x) + (to_int y)))
let sub_int x y =
assert (Rep.bitwidth < 32);
Rep.(of_int ((to_int x) - (to_int y)))
let add_sat_s x y = saturate_s (add_int x y)
let add_sat_u x y = saturate_u (add_int (as_unsigned x) (as_unsigned y))
let sub_sat_s x y = saturate_s (sub_int x y)
let sub_sat_u x y = saturate_u (sub_int (as_unsigned x) (as_unsigned y))
let q15mulr_sat_s x y =
(* mul x64 y64 can overflow int64 when both are int32 min, but this is only
* used by i16x8, so we are fine for now. *)
assert (Rep.bitwidth < 32);
let x64 = Rep.to_int64 x in
let y64 = Rep.to_int64 y in
saturate_s (Rep.of_int64 Int64.((shift_right (add (mul x64 y64) 0x4000L) 15)))
let to_int_s = Rep.to_int
let to_int_u i = Rep.to_int i land ((Rep.to_int Rep.max_int lsl 1) lor 1)
let of_int_s = Rep.of_int
let of_int_u i = and_ (Rep.of_int i) (or_ (shl (Rep.of_int max_int) one) one)
(* String conversion that allows leading signs and unsigned values *)
let require b = if not b then failwith "of_string"
let dec_digit = function
| '0' .. '9' as c -> Char.code c - Char.code '0'
| _ -> failwith "of_string"
let hex_digit = function
| '0' .. '9' as c -> Char.code c - Char.code '0'
| 'a' .. 'f' as c -> 0xa + Char.code c - Char.code 'a'
| 'A' .. 'F' as c -> 0xa + Char.code c - Char.code 'A'
| _ -> failwith "of_string"
let max_upper, max_lower = divrem_u Rep.minus_one ten
let sign_extend i =
(* This module is used with I32 and I64, but the bitwidth can be less
* than that, e.g. for I16. When used for smaller integers, the stored value
* needs to be signed extended, e.g. parsing -1 into a I16 (backed by Int32)
* should have all high bits set. We can do that by logor with a mask,
* where the mask is minus_one left shifted by bitwidth. But if bitwidth
* matches the number of bits of Rep, the shift will be incorrect.
* -1 (Int32) << 32 = -1
* Then the logor will be also wrong. So we check and bail out early.
* *)
if not needs_extend then i else
let sign_bit = Rep.logand (Rep.of_int (1 lsl (Rep.bitwidth - 1))) i in
if sign_bit = Rep.zero then i else
(* Build a sign-extension mask *)
let sign_mask = (Rep.shift_left Rep.minus_one Rep.bitwidth) in
Rep.logor sign_mask i
let of_string s =
let open Rep in
let len = String.length s in
let rec parse_hex i num =
if i = len then num else
if s.[i] = '_' then parse_hex (i + 1) num else
let digit = of_int (hex_digit s.[i]) in
require (le_u num (shr_u minus_one (of_int 4)));
parse_hex (i + 1) (logor (shift_left num 4) digit)
in
let rec parse_dec i num =
if i = len then num else
if s.[i] = '_' then parse_dec (i + 1) num else
let digit = of_int (dec_digit s.[i]) in
require (lt_u num max_upper || num = max_upper && le_u digit max_lower);
parse_dec (i + 1) (add (mul num ten) digit)
in
let parse_int i =
require (len - i > 0);
if i + 2 <= len && s.[i] = '0' && s.[i + 1] = 'x'
then parse_hex (i + 2) zero
else parse_dec i zero
in
require (len > 0);
let parsed =
match s.[0] with
| '+' -> parse_int 1
| '-' ->
let n = parse_int 1 in
require (ge_s (sub n one) minus_one);
Rep.neg n
| _ -> parse_int 0
in
let n = sign_extend parsed in
require (low_int <= n && n <= high_int);
n
let of_string_s s =
let n = of_string s in
require (s.[0] = '-' || ge_s n Rep.zero);
n
let of_string_u s =
let n = of_string s in
require (s.[0] <> '+' && s.[0] <> '-');
n
(* String conversion that groups digits for readability *)
let rec add_digits buf s i j k n =
if i < j then begin
if k = 0 then Buffer.add_char buf '_';
Buffer.add_char buf s.[i];
add_digits buf s (i + 1) j ((k + n - 1) mod n) n
end
let group_digits n s =
let len = String.length s in
let num = if s.[0] = '-' then 1 else 0 in
let buf = Buffer.create (len*(n+1)/n) in
Buffer.add_substring buf s 0 num;
add_digits buf s num len ((len - num) mod n + n) n;
Buffer.contents buf
let to_string_s i = group_digits 3 (Rep.to_string i)
let to_string_u i =
if i >= Rep.zero then
group_digits 3 (Rep.to_string i)
else
group_digits 3 (Rep.to_string (div_u i ten) ^ Rep.to_string (rem_u i ten))
let to_hex_string i = "0x" ^ group_digits 4 (Rep.to_hex_string i)
end