Browse Source

refactor, add some instructions

pull/2/head
zapashcanon 6 months ago
parent
commit
35e4b1ff1c
Signed by: zapashcanon GPG Key ID: 8981C3C62D1D28F1
  1. 1
      .gitignore
  2. 321
      src/convert.ml
  3. 12
      src/dune
  4. 2
      src/float32.ml
  5. 6
      src/float32.mli
  6. 424
      src/float64.ml
  7. 61
      src/float64.mli
  8. 10
      src/int32.ml
  9. 42
      src/int64.ml
  10. 85
      src/interpret.ml
  11. 6
      src/menhir_parser.mly
  12. 2
      src/pp.ml
  13. 44
      src/simplify.ml
  14. 67
      src/types.ml
  15. 1
      src/uint32.ml
  16. 12
      test/main.ml
  17. 39
      test/reference/linking.wast
  18. 4
      test/reference/traps.wast

1
.gitignore

@ -1 +1,2 @@
_build
_coverage

321
src/convert.ml

@ -0,0 +1,321 @@
module MInt32 = struct
let wrap_i64 x = Int64.to_int32 x
let trunc_f32_s x =
if Float32.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float32.to_float x in
if xf >= -.Int32.(to_float min_int) || xf < Int32.(to_float min_int) then
raise @@ Types.Trap "integer overflow"
else
Int32.of_float xf
let trunc_f32_u x =
if Float32.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float32.to_float x in
if xf >= -.Int32.(to_float min_int) *. 2.0 || xf <= -1.0 then
raise @@ Types.Trap "integer overflow"
else
Int64.(to_int32 (of_float xf))
let trunc_f64_s x =
if Float64.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float64.to_float x in
if
xf >= -.Int32.(to_float min_int)
|| xf <= Int32.(to_float min_int) -. 1.0
then
raise @@ Types.Trap "integer overflow"
else
Int32.of_float xf
let trunc_f64_u x =
if Float64.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float64.to_float x in
if xf >= -.Int32.(to_float min_int) *. 2.0 || xf <= -1.0 then
raise @@ Types.Trap "integer overflow"
else
Int64.(to_int32 (of_float xf))
let trunc_sat_f32_s x =
if Float32.ne x x then
0l
else
let xf = Float32.to_float x in
if xf < Int32.(to_float min_int) then
Int32.min_int
else if xf >= -.Int32.(to_float min_int) then
Int32.max_int
else
Int32.of_float xf
let trunc_sat_f32_u x =
if Float32.ne x x then
0l
else
let xf = Float32.to_float x in
if xf <= -1.0 then
0l
else if xf >= -.Int32.(to_float min_int) *. 2.0 then
-1l
else
Int64.(to_int32 (of_float xf))
let trunc_sat_f64_s x =
if Float64.ne x x then
0l
else
let xf = Float64.to_float x in
if xf < Int32.(to_float min_int) then
Int32.min_int
else if xf >= -.Int32.(to_float min_int) then
Int32.max_int
else
Int32.of_float xf
let trunc_sat_f64_u x =
if Float64.ne x x then
0l
else
let xf = Float64.to_float x in
if xf <= -1.0 then
0l
else if xf >= -.Int32.(to_float min_int) *. 2.0 then
-1l
else
Int64.(to_int32 (of_float xf))
let reinterpret_f32 = Float32.to_bits
end
module MInt64 = struct
let extend_i32_s x = Int64.of_int32 x
let extend_i32_u x = Int64.logand (Int64.of_int32 x) 0x0000_0000_ffff_ffffL
let trunc_f32_s x =
if Float32.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float32.to_float x in
if xf >= -.Int64.(to_float min_int) || xf < Int64.(to_float min_int) then
raise @@ Types.Trap "integer overflow"
else
Int64.of_float xf
let trunc_f32_u x =
if Float32.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float32.to_float x in
if xf >= -.Int64.(to_float min_int) *. 2.0 || xf <= -1.0 then
raise @@ Types.Trap "integer overflow"
else if xf >= -.Int64.(to_float min_int) then
Int64.(logxor (of_float (xf -. 0x1p63)) min_int)
else
Int64.of_float xf
let trunc_f64_s x =
if Float64.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float64.to_float x in
if xf >= -.Int64.(to_float min_int) || xf < Int64.(to_float min_int) then
raise @@ Types.Trap "integer overflow"
else
Int64.of_float xf
let trunc_f64_u x =
if Float64.ne x x then
raise @@ Types.Trap "invalid conversion to integer"
else
let xf = Float64.to_float x in
if xf >= -.Int64.(to_float min_int) *. 2.0 || xf <= -1.0 then
raise @@ Types.Trap "integer overflow"
else if xf >= -.Int64.(to_float min_int) then
Int64.(logxor (of_float (xf -. 0x1p63)) min_int)
else
Int64.of_float xf
let trunc_sat_f32_s x =
if Float32.ne x x then
0L
else
let xf = Float32.to_float x in
if xf < Int64.(to_float min_int) then
Int64.min_int
else if xf >= -.Int64.(to_float min_int) then
Int64.max_int
else
Int64.of_float xf
let trunc_sat_f32_u x =
if Float32.ne x x then
0L
else
let xf = Float32.to_float x in
if xf <= -1.0 then
0L
else if xf >= -.Int64.(to_float min_int) *. 2.0 then
-1L
else if xf >= -.Int64.(to_float min_int) then
Int64.(logxor (of_float (xf -. 9223372036854775808.0)) min_int)
else
Int64.of_float xf
let trunc_sat_f64_s x =
if Float64.ne x x then
0L
else
let xf = Float64.to_float x in
if xf < Int64.(to_float min_int) then
Int64.min_int
else if xf >= -.Int64.(to_float min_int) then
Int64.max_int
else
Int64.of_float xf
let trunc_sat_f64_u x =
if Float64.ne x x then
0L
else
let xf = Float64.to_float x in
if xf <= -1.0 then
0L
else if xf >= -.Int64.(to_float min_int) *. 2.0 then
-1L
else if xf >= -.Int64.(to_float min_int) then
Int64.(logxor (of_float (xf -. 9223372036854775808.0)) min_int)
else
Int64.of_float xf
let reinterpret_f64 = Float64.to_bits
end
module MFloat32 = struct
let demote_f64 x =
let xf = Float64.to_float x in
if xf = xf then
Float32.of_float xf
else
let nan64bits = Float64.to_bits x in
let sign_field =
Int64.(shift_left (shift_right_logical nan64bits 63) 31)
in
let significand_field =
Int64.(shift_right_logical (shift_left nan64bits 12) 41)
in
let fields = Int64.logor sign_field significand_field in
let nan32bits = Int32.logor 0x7fc0_0000l (MInt32.wrap_i64 fields) in
Float32.of_bits nan32bits
let convert_i32_s x = Float32.of_float (Int32.to_float x)
(*
* Similar to convert_i64_u below, the high half of the i32 range are beyond
* the range where f32 can represent odd numbers, though we do need to adjust
* the least significant bit to round correctly.
*)
let convert_i32_u x =
Float32.of_float
Int32.(
if x >= zero then
to_float x
else
to_float (logor (shift_right_logical x 1) (logand x 1l)) *. 2.0)
(*
* Values that are too large would get rounded when represented in f64,
* but double rounding via i64->f64->f32 can produce inaccurate results.
* Hence, for large values we shift right but make sure to accumulate the lost
* bits in the least significant bit, such that rounding still is correct.
*)
let convert_i64_s x =
Float32.of_float
Int64.(
if abs x < 0x10_0000_0000_0000L then
to_float x
else
let r =
if logand x 0xfffL = 0L then
0L
else
1L
in
to_float (logor (shift_right x 12) r) *. 0x1p12)
let convert_i64_u x =
Float32.of_float
Int64.(
if lt_u x 0x10_0000_0000_0000L then
to_float x
else
let r =
if logand x 0xfffL = 0L then
0L
else
1L
in
to_float (logor (shift_right_logical x 12) r) *. 0x1p12)
let reinterpret_i32 = Float32.of_bits
end
module MFloat64 = struct
let promote_f32 x =
let xf = Float32.to_float x in
if xf = xf then
Float64.of_float xf
else
let nan32bits = MInt64.extend_i32_u (Float32.to_bits x) in
let sign_field =
Int64.(shift_left (shift_right_logical nan32bits 31) 63)
in
let significand_field =
Int64.(shift_right_logical (shift_left nan32bits 41) 12)
in
let fields = Int64.logor sign_field significand_field in
let nan64bits = Int64.logor 0x7ff8_0000_0000_0000L fields in
Float64.of_bits nan64bits
let convert_i32_s x = Float64.of_float (Int32.to_float x)
(*
* Unlike the other convert_u functions, the high half of the i32 range is
* within the range where f32 can represent odd numbers, so we can't do the
* shift. Instead, we can use int64 signed arithmetic.
*)
let convert_i32_u x =
Float64.of_float
Int64.(to_float (logand (of_int32 x) 0x0000_0000_ffff_ffffL))
let convert_i64_s x = Float64.of_float (Int64.to_float x)
(*
* Values in the low half of the int64 range can be converted with a signed
* conversion. The high half is beyond the range where f64 can represent odd
* numbers, so we can shift the value right, adjust the least significant
* bit to round correctly, do a conversion, and then scale it back up.
*)
let convert_i64_u x =
Float64.of_float
Int64.(
if x >= zero then
to_float x
else
to_float (logor (shift_right_logical x 1) (logand x 1L)) *. 2.0)
let reinterpret_i64 = Float64.of_bits
end
module Int32 = MInt32
module Int64 = MInt64
module Float32 = MFloat32
module Float64 = MFloat64

12
src/dune

@ -2,21 +2,27 @@
(name woi)
(modules
check
convert
debug
float32
float64
handle
int32
int64
interpret
lexer
menhir_parser
menhir_parser_errors
op
pp
simplify
stack
types)
types
uint32)
(libraries integers menhirLib ocaml_intrinsics ppxlib sedlex)
(preprocess
(pps sedlex.ppx)))
(pps sedlex.ppx))
(instrumentation
(backend bisect_ppx)))
(executable
(name woi)

2
src/float32.ml

@ -193,7 +193,7 @@ let abs x = Int32.logand x Int32.max_int
let neg x = Int32.logxor x Int32.min_int
let copysign x y = Int32.logor (abs x) (Int32.logand y Int32.min_int)
let copy_sign x y = Int32.logor (abs x) (Int32.logand y Int32.min_int)
let eq x y = to_float x = to_float y

6
src/float32.mli

@ -36,7 +36,7 @@ val min : t -> t -> t
val max : t -> t -> t
val copysign : t -> t -> t
val copy_sign : t -> t -> t
val eq : t -> t -> bool
@ -55,3 +55,7 @@ val of_string : string -> t
val to_hex_string : t -> string
val to_string : t -> string
val to_float : t -> Float.t
val of_float : Float.t -> t

424
src/float64.ml

@ -0,0 +1,424 @@
let mantissa = 52
let pos_nan = 0x7ff8_0000_0000_0000L
let neg_nan = 0xfff8_0000_0000_0000L
let bare_nan = 0x7ff0_0000_0000_0000L
let to_hex_string = Printf.sprintf "%Lx"
type t = Int64.t
let pos_inf = Int64.bits_of_float (1.0 /. 0.0)
let neg_inf = Int64.bits_of_float (-.(1.0 /. 0.0))
let pos_nan = pos_nan
let neg_nan = neg_nan
let bare_nan = bare_nan
let of_float = Int64.bits_of_float
let to_float = Int64.float_of_bits
let of_bits x = x
let to_bits x = x
let is_inf x = x = pos_inf || x = neg_inf
let is_nan x =
let xf = Int64.float_of_bits x in
xf <> xf
(*
* When the result of an arithmetic operation is NaN, the most significant
* bit of the significand field is set.
*)
let canonicalize_nan x = Int64.logor x pos_nan
(*
* When the result of a binary operation is NaN, the resulting NaN is computed
* from one of the NaN inputs, if there is one. If both are NaN, one is
* selected nondeterminstically. If neither, we use a default NaN value.
*)
let determine_binary_nan x y =
(*
* TODO: There are two nondeterministic things we could do here. When both
* x and y are NaN, we can nondeterministically pick which to return. And
* when neither is NaN, we can nondeterministically pick whether to return
* pos_nan or neg_nan.
*)
let nan =
if is_nan x then
x
else if is_nan y then
y
else
pos_nan
in
canonicalize_nan nan
(*
* When the result of a unary operation is NaN, the resulting NaN is computed
* from one of the NaN input, if there it is NaN. Otherwise, we use a default
* NaN value.
*)
let determine_unary_nan x =
(*
* TODO: There is one nondeterministic thing we could do here. When the
* operand is not NaN, we can nondeterministically pick whether to return
* pos_nan or neg_nan.
*)
let nan =
if is_nan x then
x
else
pos_nan
in
canonicalize_nan nan
let binary x op y =
let xf = to_float x in
let yf = to_float y in
let t = op xf yf in
if t = t then
of_float t
else
determine_binary_nan x y
let unary op x =
let t = op (to_float x) in
if t = t then
of_float t
else
determine_unary_nan x
let zero = of_float 0.0
let add x y = binary x ( +. ) y
let sub x y = binary x ( -. ) y
let mul x y = binary x ( *. ) y
let div x y = binary x ( /. ) y
let sqrt x = unary Stdlib.sqrt x
let ceil x = unary Stdlib.ceil x
let floor x = unary Stdlib.floor x
let trunc x =
let xf = to_float x in
(* preserve the sign of zero *)
if xf = 0.0 then
x
else
(* trunc is either ceil or floor depending on which one is toward zero *)
let f =
if xf < 0.0 then
Stdlib.ceil xf
else
Stdlib.floor xf
in
let result = of_float f in
if is_nan result then
determine_unary_nan result
else
result
let nearest x =
let xf = to_float x in
(* preserve the sign of zero *)
if xf = 0.0 then
x
else
(* nearest is either ceil or floor depending on which is nearest or even *)
let u = Stdlib.ceil xf in
let d = Stdlib.floor xf in
let um = abs_float (xf -. u) in
let dm = abs_float (xf -. d) in
let u_or_d =
um < dm
|| um = dm
&&
let h = u /. 2. in
Stdlib.floor h = h
in
let f =
if u_or_d then
u
else
d
in
let result = of_float f in
if is_nan result then
determine_unary_nan result
else
result
let min x y =
let xf = to_float x in
let yf = to_float y in
(* min -0 0 is -0 *)
if xf = yf then
Int64.logor x y
else if xf < yf then
x
else if xf > yf then
y
else
determine_binary_nan x y
let max x y =
let xf = to_float x in
let yf = to_float y in
(* max -0 0 is 0 *)
if xf = yf then
Int64.logand x y
else if xf > yf then
x
else if xf < yf then
y
else
determine_binary_nan x y
(* abs, neg, copysign are purely bitwise operations, even on NaN values *)
let abs x = Int64.logand x Int64.max_int
let neg x = Int64.logxor x Int64.min_int
let copy_sign x y = Int64.logor (abs x) (Int64.logand y Int64.min_int)
let eq x y = to_float x = to_float y
let ne x y = to_float x <> to_float y
let lt x y = to_float x < to_float y
let gt x y = to_float x > to_float y
let le x y = to_float x <= to_float y
let ge x y = to_float x >= to_float y
(*
* Compare mantissa of two floats in string representation (hex or dec).
* This is a gross hack to detect rounding during parsing of floats.
*)
let is_hex c = ('0' <= c && c <= '9') || ('A' <= c && c <= 'F')
let is_exp hex c =
c
=
if hex then
'P'
else
'E'
let at_end hex s i = i = String.length s || is_exp hex s.[i]
let rec skip_non_hex s i =
(* to skip sign, 'x', '.', '_', etc. *)
if at_end true s i || is_hex s.[i] then
i
else
skip_non_hex s (i + 1)
let rec skip_zeroes s i =
let i' = skip_non_hex s i in
if at_end true s i' || s.[i'] <> '0' then
i'
else
skip_zeroes s (i' + 1)
let rec compare_mantissa_str' hex s1 i1 s2 i2 =
let i1' = skip_non_hex s1 i1 in
let i2' = skip_non_hex s2 i2 in
match (at_end hex s1 i1', at_end hex s2 i2') with
| true, true -> 0
| true, false ->
if at_end hex s2 (skip_zeroes s2 i2') then
0
else
-1
| false, true ->
if at_end hex s1 (skip_zeroes s1 i1') then
0
else
1
| false, false -> (
match compare s1.[i1'] s2.[i2'] with
| 0 -> compare_mantissa_str' hex s1 (i1' + 1) s2 (i2' + 1)
| n -> n )
let compare_mantissa_str hex s1 s2 =
let s1' = String.uppercase_ascii s1 in
let s2' = String.uppercase_ascii s2 in
compare_mantissa_str' hex s1' (skip_zeroes s1' 0) s2' (skip_zeroes s2' 0)
(*
* Convert a string to a float in target precision by going through
* OCaml's 64 bit floats. This may incur double rounding errors in edge
* cases, i.e., when rounding to target precision involves a tie that
* was created by earlier rounding during parsing to float. If both
* end up rounding in the same direction, we would "over round".
* This function tries to detect this case and correct accordingly.
*)
let float_of_string_prevent_double_rounding s =
(* First parse to a 64 bit float. *)
let z = float_of_string s in
(* If value is already infinite we are done. *)
if abs_float z = 1.0 /. 0.0 then
z
else
(* Else, bit twiddling to see what rounding to target precision will do. *)
let open Int64 in
let bits = bits_of_float z in
let lsb = shift_left 1L (52 - mantissa) in
(* Check for tie, i.e. whether the bits right of target LSB are 10000... *)
let tie = shift_right lsb 1 in
let mask = lognot (shift_left (-1L) (52 - mantissa)) in
(* If we have no tie, we are good. *)
if logand bits mask <> tie then
z
else
(* Else, define epsilon to be the value of the tie bit. *)
let exp = float_of_bits (logand bits 0xfff0_0000_0000_0000L) in
let eps = float_of_bits (logor tie (bits_of_float exp)) -. exp in
(* Convert 64 bit float back to string to compare to input. *)
let hex = String.contains s 'x' in
let s' =
if not hex then
Printf.sprintf "%.*g" (String.length s) z
else
let m =
logor (logand bits 0xf_ffff_ffff_ffffL) 0x10_0000_0000_0000L
in
(* Shift mantissa to match msb position in most significant hex digit *)
let i = skip_zeroes (String.uppercase_ascii s) 0 in
if i = String.length s then
Printf.sprintf "%.*g" (String.length s) z
else
let sh =
match s.[i] with
| '1' -> 0
| '2' .. '3' -> 1
| '4' .. '7' -> 2
| _ -> 3
in
Printf.sprintf "%Lx" (shift_left m sh)
in
(* - If mantissa became larger, float was rounded up to tie already;
* round-to-even might round up again: sub epsilon to round down.
* - If mantissa became smaller, float was rounded down to tie already;
* round-to-even migth round down again: add epsilon to round up.
* - If tie is not the result of prior rounding, then we are good.
*)
match compare_mantissa_str hex s s' with
| -1 -> z -. eps
| 1 -> z +. eps
| _ -> z
let of_signless_string s =
if s = "inf" then
pos_inf
else if s = "nan" then
pos_nan
else if String.length s > 6 && String.sub s 0 6 = "nan:0x" then
let x = Int64.of_string (String.sub s 4 (String.length s - 4)) in
if x = Int64.zero then
raise (Failure "nan payload must not be zero")
else if Int64.logand x bare_nan <> Int64.zero then
raise (Failure "nan payload must not overlap with exponent bits")
else if x < Int64.zero then
raise (Failure "nan payload must not overlap with sign bit")
else
Int64.logor x bare_nan
else
let s' = String.concat "" (String.split_on_char '_' s) in
let x = of_float (float_of_string_prevent_double_rounding s') in
if is_inf x then
failwith "of_string"
else
x
let of_string s =
if s = "" then
failwith "of_string"
else if s.[0] = '+' || s.[0] = '-' then
let x = of_signless_string (String.sub s 1 (String.length s - 1)) in
if s.[0] = '+' then
x
else
neg x
else
of_signless_string s
(* String conversion that groups digits for readability *)
let is_digit c = '0' <= c && c <= '9'
let is_hex_digit c = is_digit c || ('a' <= c && c <= 'f')
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 =
let rec find_from_opt f s i =
if i = String.length s then
None
else if f s.[i] then
Some i
else
find_from_opt f s (i + 1)
in
fun is_digit n s ->
let isnt_digit c = not (is_digit c) in
let len = String.length s in
let x = Option.value (find_from_opt (( = ) 'x') s 0) ~default:0 in
let mant = Option.value (find_from_opt is_digit s x) ~default:len in
let point = Option.value (find_from_opt isnt_digit s mant) ~default:len in
let frac = Option.value (find_from_opt is_digit s point) ~default:len in
let exp = Option.value (find_from_opt isnt_digit s frac) ~default:len in
let buf = Buffer.create (len * (n + 1) / n) in
Buffer.add_substring buf s 0 mant;
add_digits buf s mant point (((point - mant) mod n) + n) n;
Buffer.add_substring buf s point (frac - point);
add_digits buf s frac exp n n;
Buffer.add_substring buf s exp (len - exp);
Buffer.contents buf
let to_string' convert is_digit n x =
( if x < Int64.zero then
"-"
else
"" )
^
if is_nan x then
let payload = Int64.logand (abs x) (Int64.lognot bare_nan) in
"nan:0x" ^ group_digits is_hex_digit 4 (to_hex_string payload)
else
let s = convert (to_float (abs x)) in
group_digits is_digit n
( if s.[String.length s - 1] = '.' then
s ^ "0"
else
s )
let to_string = to_string' (Printf.sprintf "%.17g") is_digit 3
let to_hex_string x =
if is_inf x then
to_string x
else
to_string' (Printf.sprintf "%h") is_hex_digit 4 x

61
src/float64.mli

@ -0,0 +1,61 @@
type t
val neg_nan : t
val pos_nan : t
val of_bits : Int64.t -> t
val to_bits : t -> Int64.t
val zero : t
val add : t -> t -> t
val sub : t -> t -> t
val mul : t -> t -> t
val div : t -> t -> t
val neg : t -> t
val abs : t -> t
val sqrt : t -> t
val ceil : t -> t
val floor : t -> t
val trunc : t -> t
val nearest : t -> t
val min : t -> t -> t
val max : t -> t -> t
val copy_sign : t -> t -> t
val eq : t -> t -> bool
val ne : t -> t -> bool
val lt : t -> t -> bool
val gt : t -> t -> bool
val le : t -> t -> bool
val ge : t -> t -> bool
val of_string : string -> t
val to_hex_string : t -> string
val to_string : t -> string
val to_float : t -> Float.t
val of_float : Float.t -> t

10
src/int32.ml

@ -0,0 +1,10 @@
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)

42
src/op.ml → src/int64.ml

@ -1,14 +1,15 @@
let i32_clz = Ocaml_intrinsics.Int32.count_leading_zeros
include Stdlib.Int64
let i64_clz = Ocaml_intrinsics.Int64.count_leading_zeros
let clz = Ocaml_intrinsics.Int64.count_leading_zeros
let i32_ctz = Ocaml_intrinsics.Int32.count_trailing_zeros
let ctz = Ocaml_intrinsics.Int64.count_trailing_zeros
let i64_ctz = Ocaml_intrinsics.Int64.count_trailing_zeros
exception InvalidConversion
exception Overflow
(* Taken from Base *)
let i64_popcnt =
let open Int64 in
let popcnt =
let ( + ) = add in
let ( - ) = sub in
let ( * ) = mul in
@ -32,8 +33,27 @@ let i64_popcnt =
(* sum the bit counts in the top byte and shift it down *)
to_int ((x * h01) lsr 56)
(* Taken from Base *)
let i32_popcnt =
(* On 64-bit systems, this is faster than implementing using [int32] arithmetic. *)
let mask = 0xffff_ffffL in
fun [@inline] x -> i64_popcnt (Int64.logand (Int64.of_int32 x) mask)
(*
* Unsigned comparison in terms of signed comparison.
*)
let cmp_u x op y = op (add x min_int) (add y min_int)
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

85
src/interpret.ml

@ -22,19 +22,21 @@ let exec_iunop stack nn op =
| S32 ->
let n = Stack.pop_i32 stack in
let res =
let open Int32 in
match op with
| Clz -> Op.i32_clz n
| Ctz -> Op.i32_ctz n
| Popcnt -> Op.i32_popcnt n
| Clz -> clz n
| Ctz -> ctz n
| Popcnt -> popcnt n
in
Stack.push_i32_of_int stack res
| S64 ->
let n = Stack.pop_i64 stack in
let res =
let open Int64 in
match op with
| Clz -> Op.i64_clz n
| Ctz -> Op.i64_ctz n
| Popcnt -> Op.i64_popcnt n
| Clz -> clz n
| Ctz -> ctz n
| Popcnt -> popcnt n
in
Stack.push_i64_of_int stack res
@ -55,7 +57,7 @@ let exec_funop stack nn op =
in
Stack.push_f32 stack res
| S64 ->
let open Float in
let open Float64 in
let f = Stack.pop_f64 stack in
let res =
match op with
@ -69,8 +71,6 @@ let exec_funop stack nn op =
in
Stack.push_f64 stack res
exception Trap of string
let exec_ibinop stack nn (op : Types.ibinop) =
match nn with
| S32 ->
@ -164,11 +164,11 @@ let exec_fbinop stack nn (op : Types.fbinop) =
| Div -> div f1 f2
| Min -> min f1 f2
| Max -> max f1 f2
| Copysign -> copysign f1 f2)
| Copysign -> copy_sign f1 f2)
| S64 ->
let f1, f2 = Stack.pop2_f64 stack in
Stack.push_f64 stack
(let open Float in
(let open Float64 in
match op with
| Add -> add f1 f2
| Sub -> sub f1 f2
@ -239,16 +239,16 @@ exception Branch of int
let fmt = Format.std_formatter
let indice_to_int = function
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic id ->
failwith @@ Format.sprintf "interpreter internal error: unbound id %s" id
let init_local (_id, t) =
match t with
| Num_type I32 -> Const_I32 0l
| Num_type I64 -> Const_I64 0L
| Num_type I32 -> Const_I32 Int32.zero
| Num_type I64 -> Const_I64 Int64.zero
| Num_type F32 -> Const_F32 Float32.zero
| Num_type F64 -> Const_F64 0.
| Num_type F64 -> Const_F64 Float64.zero
| Ref_type rt -> Const_null rt
let rec exec_instr env module_indice locals stack instr =
@ -273,8 +273,40 @@ let rec exec_instr env module_indice locals stack instr =
| I_extend16_s _n -> failwith "TODO exec_instr"
| I64_extend32_s -> failwith "TODO exec_instr"
| I32_wrap_i64 -> failwith "TODO exec_instr"
| I64_extend_i32 _s -> failwith "TODO exec_instr"
| I_trunc_f (_n, _n', _s) -> failwith "TODO exec_instr"
| I64_extend_i32 _s ->
let n = Stack.pop_i32 stack in
let n = Int64.of_int32 n in
Stack.push_i64 stack n
| I_trunc_f (n, n', s) -> (
match (n, n') with
| S32, S32 -> (
let f = Stack.pop_f32 stack in
Stack.push_i32 stack
@@
match s with
| S -> Convert.Int32.trunc_f32_s f
| U -> Convert.Int32.trunc_f32_u f )
| S32, S64 -> (
let f = Stack.pop_f64 stack in
Stack.push_i32 stack
@@
match s with
| S -> Convert.Int32.trunc_f64_s f
| U -> Convert.Int32.trunc_f64_u f )
| S64, S32 -> (
let f = Stack.pop_f32 stack in
Stack.push_i64 stack
@@
match s with
| S -> Convert.Int64.trunc_f32_s f
| U -> Convert.Int64.trunc_f32_u f )
| S64, S64 -> (
let f = Stack.pop_f64 stack in
Stack.push_i64 stack
@@
match s with
| S -> Convert.Int64.trunc_f64_s f
| U -> Convert.Int64.trunc_f64_u f ) )
| I_trunc_sat_f (_n, _n', _s) -> failwith "TODO exec_instr"
| F32_demote_f64 -> failwith "TODO exec_instr"
| F64_promote_f32 -> failwith "TODO exec_instr"
@ -425,7 +457,7 @@ let rec exec_instr env module_indice locals stack instr =
| Table_init _ -> failwith "TODO Table_init"
| Elem_drop _ -> failwith "TODO Elem_drop"
| I_load16 (nn, sx, { offset; align }) -> (
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
(* TODO: use align *)
@ -445,7 +477,7 @@ let rec exec_instr env module_indice locals stack instr =
| S32 -> Stack.push_i32_of_int stack res
| S64 -> Stack.push_i64_of_int stack res )
| I_load (nn, { offset; align }) -> (
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
(* TODO: use align *)
@ -464,7 +496,7 @@ let rec exec_instr env module_indice locals stack instr =
let res = Bytes.get_int64_le mem offset in
Stack.push_i64 stack res )
| F_load (nn, { offset; align }) -> (
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
(* TODO: use align *)
@ -482,10 +514,10 @@ let rec exec_instr env module_indice locals stack instr =
if Bytes.length mem < offset + 8 || pos < 0 then
raise (Trap "out of bounds memory access");
let res = Bytes.get_int64_le mem offset in
let res = Int64.float_of_bits res in
let res = Float64.of_bits res in
Stack.push_f64 stack res )
| I_store (nn, { offset; align }) -> (
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
ignore align;
@ -507,7 +539,7 @@ let rec exec_instr env module_indice locals stack instr =
Bytes.set_int64_le mem offset n )
| F_store (_, _) -> failwith "TODO F_store"
| I_load8 (nn, sx, { offset; align }) -> (
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
(* TODO: use align *)
@ -536,7 +568,7 @@ let rec exec_instr env module_indice locals stack instr =
in
Stack.push_i64_of_int stack res )
| I64_load32 (sx, { offset; align }) ->
let offset = Unsigned.UInt32.to_int offset in
let offset = Uint32.to_int offset in
let mem, _max = env.modules.(module_indice).memories.(0) in
let mem = !mem in
(* TODO: use align *)
@ -650,11 +682,6 @@ let exec_action env = function
let compare_result_const result const =
match result with
| Result_const (Const_F64 f) -> begin
match const with
| Const_F64 f2 -> Float.equal f f2
| _ -> false
end
| Result_const c -> const = c
| Result_func_ref -> failwith "TODO (compare_result_const)"
| Result_extern_ref -> failwith "TODO (compare_result_const)"

6
src/menhir_parser.mly

@ -32,11 +32,11 @@ let i64 s =
Obj.magic u64
let f64 s =
try Float.of_string s
try Float64.of_string s
with Failure _ ->
(* TODO *)
Format.ifprintf Format.err_formatter "error: f64_of_string: `%s` (using `nan` instead)@." s;
Float.nan
Format.ifprintf Format.err_formatter "error: f64_of_string: `%s` (using `pos_nan` instead)@." s;
Float64.pos_nan
let f32 s =
try Float32.of_string s

2
src/pp.ml

@ -16,7 +16,7 @@ let i64 fmt i = Signed.Int64.pp fmt i
let f32 fmt f = Format.fprintf fmt "%s" (Float32.to_string f)
let f64 fmt f = Format.fprintf fmt "%f" f
let f64 fmt f = Format.fprintf fmt "%s" (Float64.to_string f)
let name fmt name = Format.pp_print_string fmt name

44
src/simplify.ml

@ -104,7 +104,7 @@ let mk_module m =
| Export_func indice ->
let i =
match indice with
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic id -> begin
match Hashtbl.find_opt seen_funcs id with
| None ->
@ -122,15 +122,13 @@ let mk_module m =
| MMem (id, { min; max }) ->
incr curr_memory;
Option.iter (fun id -> Hashtbl.add seen_memories id !curr_memory) id;
mem_max_size := Option.map Unsigned.UInt32.to_int max;
mem_bytes := Bytes.create (Unsigned.UInt32.to_int min * page_size)
mem_max_size := Option.map Uint32.to_int max;
mem_bytes := Bytes.create (Uint32.to_int min * page_size)
| MTable (id, ({ min; max }, rt)) ->
incr curr_table;
Option.iter (fun id -> Hashtbl.add seen_tables id !curr_table) id;
let tbl =
( rt
, Array.make (Unsigned.UInt32.to_int min) None
, Option.map Unsigned.UInt32.to_int max )
(rt, Array.make (Uint32.to_int min) None, Option.map Uint32.to_int max)
in
tables := tbl :: !tables
| MType (id, t) -> (
@ -157,7 +155,7 @@ let mk_module m =
| Ref_func (Symbolic id) -> begin
match Hashtbl.find_opt seen_funcs id with
| None -> failwith @@ Format.sprintf "unbound id %s" id
| Some i -> Some (Ref_func (Raw (Unsigned.UInt32.of_int i)))
| Some i -> Some (Ref_func (Raw (Uint32.of_int i)))
end
| e -> Some e ) )
*)
@ -182,7 +180,7 @@ let mk_module m =
(* An active data segment copies its contents into a memory during instantiation, as specified by a memory index and a constant expression defining an offset into that memory. *)
let indice =
match indice with
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic i -> (
match Hashtbl.find_opt seen_memories i with
| None -> failwith @@ Format.sprintf "unbound memory indice $%s" i
@ -218,7 +216,7 @@ let mk_module m =
let (table_ref_type, table, table_max_size), table_indice =
let indice =
match indice with
| Raw indice -> Unsigned.UInt32.to_int indice
| Raw indice -> Uint32.to_int indice
| Symbolic id -> (
if id = "TODO_table" then begin
Debug.debug Format.std_formatter "this may fail...@.";
@ -249,7 +247,7 @@ let mk_module m =
| Ref_func rf ->
let rf =
match rf with
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic rf -> (
match Hashtbl.find_opt seen_funcs rf with
| None ->
@ -303,7 +301,7 @@ let mk_module m =
| FTId i -> (
let i =
match i with
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic i -> (
match Hashtbl.find_opt seen_types i with
| None -> failwith @@ Format.sprintf "unbound type indice $%s" i
@ -338,17 +336,17 @@ let mk_module m =
| Call (Symbolic id) -> begin
match Hashtbl.find_opt seen_funcs id with
| None -> failwith @@ Format.sprintf "unbound func: %s" id
| Some i -> Call (Raw (Unsigned.UInt32.of_int i))
| Some i -> Call (Raw (Uint32.of_int i))
end
| Local_set (Symbolic id) -> begin
match Hashtbl.find_opt local_tbl id with
| None -> failwith @@ Format.sprintf "unbound local: %s" id
| Some i -> Local_set (Raw (Unsigned.UInt32.of_int i))
| Some i -> Local_set (Raw (Uint32.of_int i))
end
| Local_get (Symbolic id) -> begin
match Hashtbl.find_opt local_tbl id with
| None -> failwith @@ Format.sprintf "unbound local: %s" id
| Some i -> Local_get (Raw (Unsigned.UInt32.of_int i))
| Some i -> Local_get (Raw (Uint32.of_int i))
end
| If_else (bt, e1, e2) -> If_else (bt, expr e1, expr e2)
| Loop (bt, e) -> Loop (bt, expr e)
@ -359,7 +357,7 @@ let mk_module m =
| FTId i -> (
let i =
match i with
| Raw i -> Unsigned.UInt32.to_int i
| Raw i -> Uint32.to_int i
| Symbolic i -> (
match Hashtbl.find_opt seen_types i with
| None ->
@ -378,43 +376,43 @@ let mk_module m =
match Hashtbl.find_opt seen_tables tbl_i with
| None ->
failwith @@ Format.sprintf "unbound table id $%s" tbl_i
| Some i -> Raw (Unsigned.UInt32.of_int i) )
| Some i -> Raw (Uint32.of_int i) )
in
Call_indirect (tbl_i, typ_i)
| Global_set (Symbolic id) -> begin
match Hashtbl.find_opt seen_globals id with
| None -> failwith @@ Format.sprintf "unbound global indice $%s" id
| Some i -> Global_set (Raw (Unsigned.UInt32.of_int i))
| Some i -> Global_set (Raw (Uint32.of_int i))
end
| Global_get (Symbolic id) -> begin
match Hashtbl.find_opt seen_globals id with
| None -> failwith @@ Format.sprintf "unbound global indice $%s" id
| Some i -> Global_get (Raw (Unsigned.UInt32.of_int i))
| Some i -> Global_get (Raw (Uint32.of_int i))
end
| Ref_func (Symbolic id) -> begin
match Hashtbl.find_opt seen_funcs id with
| None -> failwith @@ Format.sprintf "unbound func indice $%s" id
| Some i -> Ref_func (Raw (Unsigned.UInt32.of_int i))
| Some i -> Ref_func (Raw (Uint32.of_int i))
end
| Table_size (Symbolic id) -> begin
match Hashtbl.find_opt seen_tables id with
| None -> failwith @@ Format.sprintf "unbound table indice $%s" id
| Some i -> Table_size (Raw (Unsigned.UInt32.of_int i))
| Some i -> Table_size (Raw (Uint32.of_int i))
end
| Table_get (Symbolic id) -> begin
match Hashtbl.find_opt seen_tables id with
| None -> failwith @@ Format.sprintf "unbound table indice $%s" id
| Some i -> Table_get (Raw (Unsigned.UInt32.of_int i))
| Some i -> Table_get (Raw (Uint32.of_int i))
end
| Table_set (Symbolic id) -> begin
match Hashtbl.find_opt seen_tables id with
| None -> failwith @@ Format.sprintf "unbound table indice $%s" id
| Some i -> Table_set (Raw (Unsigned.UInt32.of_int i))
| Some i -> Table_set (Raw (Uint32.of_int i))
end
| Table_grow (Symbolic id) -> begin
match Hashtbl.find_opt seen_tables id with
| None -> failwith @@ Format.sprintf "unbound table indice $%s" id
| Some i -> Table_grow (Raw (Unsigned.UInt32.of_int i))
| Some i -> Table_grow (Raw (Uint32.of_int i))
end
| i -> i
and expr e = List.map body e in

67
src/types.ml

@ -1,41 +1,12 @@
let pp_pos out { Ppxlib.pos_lnum; pos_cnum; pos_bol; _ } =
Format.fprintf out "line %d:%d" pos_lnum (pos_cnum - pos_bol)
exception Trap of string
(** Structure *)
(** Values *)
type nonrec u8 = Unsigned.UInt8.t
type nonrec u16 = Unsigned.UInt16.t
type nonrec u32 = Unsigned.UInt32.t
type nonrec u64 = Unsigned.UInt64.t
(* TODO: no Int8 module ? *)
type nonrec s8 = Signed.Int32.t
(* TODO: no Int16 module ? *)
type nonrec s16 = Signed.Int32.t
type nonrec s32 = Signed.Int32.t
type nonrec s64 = Signed.Int64.t
type nonrec i8 = s8
type nonrec i16 = s16
type nonrec i32 = s32
type nonrec i64 = s64
(* TODO: Float32 module ? *)
type nonrec f32 = Float32.t
type nonrec f64 = Float.t
(* TODO: this must be utf8 *)
type nonrec name = string
@ -50,14 +21,6 @@ type nonrec num_type =
| F32
| F64
let bit_width = function
| I32
| F32 ->
32
| I64
| F64 ->
64
(* TODO: heap_type missing ? *)
type nonrec ref_type =
| Func_ref
@ -79,8 +42,8 @@ type nonrec result_type = result_ list
type nonrec func_type = param_type * result_type
type nonrec limits =
{ min : u32
; max : u32 option
{ min : Uint32.t
; max : Uint32.t option
}
type nonrec mem_type = limits
@ -169,12 +132,12 @@ type nonrec frelop =
| Ge
type indice =
| Raw of u32
| Raw of Uint32.t
| Symbolic of id
type memarg =
{ offset : u32
; align : u32
{ offset : Uint32.t
; align : Uint32.t
}
type block_type =
@ -188,10 +151,10 @@ type func_type_bis =
type instr =
(* Numeric Instructions *)
| I32_const of i32
| I64_const of i64
| F32_const of f32
| F64_const of f64
| I32_const of Int32.t
| I64_const of Int64.t
| F32_const of Float32.t
| F64_const of Float64.t
| I_unop of nn * iunop
| F_unop of nn * funop
| I_binop of nn * ibinop
@ -351,10 +314,10 @@ type module_ =
}
type const =
| Const_I32 of i32
| Const_I64 of i64
| Const_F32 of f32
| Const_F64 of f64
| Const_I32 of Int32.t
| Const_I64 of Int64.t
| Const_F32 of Float32.t
| Const_F64 of Float64.t
| Const_null of ref_type
| Const_host of int

1
src/uint32.ml

@ -0,0 +1 @@
include Unsigned.UInt32

12
test/main.ml

@ -1,3 +1,7 @@
let count_total = ref 0
let count_total_failed = ref 0
let test_file f =
Format.printf "testing file : `%a`... " Fpath.pp f;
match Bos.OS.File.read f with
@ -29,10 +33,13 @@ let test_directory d =
| Ok l ->
List.iter
(fun file ->
incr count_total;
match test_file file with
| Ok () -> ()
| Error _e -> incr count_error )
l;
| Error _e ->
incr count_error;
incr count_total_failed )
(List.sort compare l);
if !count_error > 0 then
Error (Format.sprintf "%d test failed !" !count_error)
else
@ -57,4 +64,5 @@ let () =