You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('') and can be up to 35 characters long.
237 lines
6.3 KiB
237 lines
6.3 KiB
include Stdlib.Int32




let clz = Ocaml_intrinsics.Int32.count_leading_zeros




let ctz = Ocaml_intrinsics.Int32.count_trailing_zeros




(* Taken from Base *)


let popcnt =


let mask = 0xffff_ffffL in


fun [@inline] x > Int64.popcnt (Int64.logand (Int64.of_int32 x) mask)




let to_hex_string = Printf.sprintf "%lx"




let of_int64 = Int64.to_int32




let to_int64 = Int64.of_int32




exception Overflow




(*


* Unsigned comparison in terms of signed comparison.


*)


let cmp_u x op y = op (add x min_int) (add y min_int)




(*


* Unsigned division and remainder in terms of signed division; algorithm from


* Hacker's Delight, Second Edition, by Henry S. Warren, Jr., section 93


* "Unsigned Short Division from Signed Division".


*)


let divrem_u n d =


if d = zero then raise Division_by_zero


else


let t = shift_right d (32  1) in


let n' = logand n (lognot t) in


let q = shift_left (div (shift_right_logical n' 1) d) 1 in


let r = sub n (mul q d) in


if cmp_u r ( < ) d then (q, r) else (add q one, sub r d)




let of_bits x = x




let to_bits x = x




let ten = of_int 10




(* If bit (32  1) is set, sx will signextend t to maintain the


* invariant that small ints are stored signextended inside a wider int. *)


let sx x =


Int64.to_int32 @@ Int64.(shift_right (shift_left (Int64.of_int32 x) 32) 32)




(* 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 32bits int. *)


let low_int = shift_left minus_one 31




(* The largest signed 32bits int. *)


let high_int = logxor low_int minus_one




(* result is truncated toward zero *)


let div_s x y =


if y = zero then raise Division_by_zero


else if x = low_int && y = minus_one then raise Overflow


else 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 = zero then raise Division_by_zero else 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 #32 bits set *)


let mask = shift_right_logical minus_one 32 in


let x64 = logand mask (to_int64 x) in


let y64 = logand mask (to_int64 y) in


of_int64 (div (add (add x64 y64) one) 2L)




let and_ = logand




let or_ = logor




let xor = logxor




(* WebAssembly's shifts mask the shift count according to the 32. *)


let shift f x y = f x (to_int (logand y 31l))




let shl x y = sx (shift shift_left x y)




let shr_s x y = shift shift_right x y




(* Check if we are storing smaller ints. *)


let needs_extend = shl one 31l <> 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 3232 bits.


*)


let as_unsigned x =


if not needs_extend then x


else


(* Mask with bottom #32 bits set *)


let mask = shift_right_logical minus_one 0 in


logand x mask




let shr_u x y = sx (shift shift_right_logical (as_unsigned x) y)




(* We must mask the count to implement rotates via shifts. *)


let clamp_rotate_count n = to_int (logand n 31l)




let rotl x y =


let n = clamp_rotate_count y in


or_ (shl x (of_int n)) (shr_u x (of_int (32  n)))




let rotr x y =


let n = clamp_rotate_count y in


or_ (shr_u x (of_int n)) (shl x (of_int (32  n)))




let extend_s n x =


let shift = 32  n in


shift_right (shift_left x shift) shift




let eqz x = x = 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 zero) (as_unsigned minus_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 minus_one ten




let sign_extend i =


(* This module is used with I32 and I64, but the 32 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 32. But if 32


* 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 = logand (of_int (1 lsl (32  1))) i in


if sign_bit = zero then i


else


(* Build a signextension mask *)


let sign_mask = shift_left minus_one 32 in


logor sign_mask i




let of_string s =


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);


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 zero);


n




let of_string_u s =


let n = of_string s in


require (s.[0] <> '+' && s.[0] <> '');


n


