forked from zapashcanon/woi
refactor, add some instructions
This commit is contained in:
parent
da69787b23
commit
35e4b1ff1c
1
.gitignore
vendored
1
.gitignore
vendored
@ -1 +1,2 @@
|
||||
_build
|
||||
_coverage
|
||||
|
321
src/convert.ml
Normal file
321
src/convert.ml
Normal file
@ -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
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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
Normal file
424
src/float64.ml
Normal file
@ -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
Normal file
61
src/float64.mli
Normal file
@ -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
Normal file
10
src/int32.ml
Normal file
@ -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)
|
@ -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
|
@ -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)"
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
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
Normal file
1
src/uint32.ml
Normal file
@ -0,0 +1 @@
|
||||
include Unsigned.UInt32
|
12
test/main.ml
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 () =
|
||||
Format.eprintf "error: %s@." e;
|
||||
has_error := true
|
||||
end;
|
||||
Format.printf "results : %d / %d !@." !count_total_failed !count_total;
|
||||
if !has_error then exit 1
|
||||
|
@ -4,7 +4,7 @@
|
||||
(func (export "call") (result i32) (call $g))
|
||||
(func $g (result i32) (i32.const 2))
|
||||
)
|
||||
;; TODO (register "Mf" $Mf)
|
||||
(register "Mf" $Mf)
|
||||
|
||||
(module $Nf
|
||||
(func $f (import "Mf" "call") (result i32))
|
||||
@ -24,7 +24,7 @@
|
||||
(export "print" (func $f))
|
||||
)
|
||||
(register "reexport_f")
|
||||
(; TODO (assert_unlinkable
|
||||
(assert_unlinkable
|
||||
(module (import "reexport_f" "print" (func (param i64))))
|
||||
"incompatible import type"
|
||||
)
|
||||
@ -32,7 +32,6 @@
|
||||
(module (import "reexport_f" "print" (func (param i32) (result i32))))
|
||||
"incompatible import type"
|
||||
)
|
||||
;)
|
||||
|
||||
|
||||
;; Globals
|
||||
@ -46,7 +45,7 @@
|
||||
(func (export "get_mut") (result i32) (global.get $mut_glob))
|
||||
(func (export "set_mut") (param i32) (global.set $mut_glob (local.get 0)))
|
||||
)
|
||||
;; TODO (register "Mg" $Mg)
|
||||
(register "Mg" $Mg)
|
||||
|
||||
(module $Ng
|
||||
(global $x (import "Mg" "glob") i32)
|
||||
@ -65,7 +64,6 @@
|
||||
(export "Mg.set_mut" (func $set_mut))
|
||||
)
|
||||
|
||||
(; TODO
|
||||
(assert_return (get $Mg "glob") (i32.const 42))
|
||||
(assert_return (get $Ng "Mg.glob") (i32.const 42))
|
||||
(assert_return (get $Ng "glob") (i32.const 43))
|
||||
@ -101,7 +99,7 @@
|
||||
(global (export "g-const-extern") externref (ref.null extern))
|
||||
(global (export "g-var-extern") (mut externref) (ref.null extern))
|
||||
)
|
||||
;; (register "Mref_ex" $Mref_ex)
|
||||
(register "Mref_ex" $Mref_ex)
|
||||
|
||||
(module $Mref_im
|
||||
(global (import "Mref_ex" "g-const-func") funcref)
|
||||
@ -111,7 +109,6 @@
|
||||
(global (import "Mref_ex" "g-var-extern") (mut externref))
|
||||
)
|
||||
|
||||
(; TODO
|
||||
(assert_unlinkable
|
||||
(module (global (import "Mref_ex" "g-const-extern") funcref))
|
||||
"incompatible import type"
|
||||
@ -130,7 +127,6 @@
|
||||
(module (global (import "Mref_ex" "g-var-extern") (mut funcref)))
|
||||
"incompatible import type"
|
||||
)
|
||||
;)
|
||||
|
||||
|
||||
;; Tables
|
||||
@ -148,7 +144,6 @@
|
||||
(call_indirect (type 0) (local.get 0))
|
||||
)
|
||||
)
|
||||
;; TODO (register "Mt" $Mt)
|
||||
|
||||
(module $Nt
|
||||
(type (func))
|
||||
@ -174,7 +169,6 @@
|
||||
(assert_return (invoke $Nt "call" (i32.const 2)) (i32.const 5))
|
||||
(assert_return (invoke $Nt "call Mt.call" (i32.const 2)) (i32.const 4))
|
||||
|
||||
(; TODO
|
||||
(assert_trap (invoke $Mt "call" (i32.const 1)) "uninitialized element")
|
||||
(assert_trap (invoke $Nt "Mt.call" (i32.const 1)) "uninitialized element")
|
||||
(assert_return (invoke $Nt "call" (i32.const 1)) (i32.const 5))
|
||||
@ -192,7 +186,6 @@
|
||||
|
||||
(assert_return (invoke $Nt "call" (i32.const 3)) (i32.const -4))
|
||||
(assert_trap (invoke $Nt "call" (i32.const 4)) "indirect call type mismatch")
|
||||
;)
|
||||
|
||||
(module $Ot
|
||||
(type (func (result i32)))
|
||||
@ -224,7 +217,6 @@
|
||||
(assert_return (invoke $Nt "call Mt.call" (i32.const 1)) (i32.const 6))
|
||||
(assert_return (invoke $Ot "call" (i32.const 1)) (i32.const 6))
|
||||
|
||||
(; TODO
|
||||
(assert_trap (invoke $Mt "call" (i32.const 0)) "uninitialized element")
|
||||
(assert_trap (invoke $Nt "Mt.call" (i32.const 0)) "uninitialized element")
|
||||
(assert_return (invoke $Nt "call" (i32.const 0)) (i32.const 5))
|
||||
@ -232,7 +224,6 @@
|
||||
(assert_trap (invoke $Ot "call" (i32.const 0)) "uninitialized element")
|
||||
|
||||
(assert_trap (invoke $Ot "call" (i32.const 20)) "undefined element")
|
||||
;)
|
||||
|
||||
(module
|
||||
(table (import "Mt" "tab") 0 funcref)
|
||||
@ -241,12 +232,12 @@
|
||||
)
|
||||
|
||||
(module $G1 (global (export "g") i32 (i32.const 5)))
|
||||
;; TODO (register "G1" $G1)
|
||||
(register "G1" $G1)
|
||||
(module $G2
|
||||
(global (import "G1" "g") i32)
|
||||
(global (export "g") i32 (global.get 0))
|
||||
)
|
||||
(; TODO (assert_return (get $G2 "g") (i32.const 5))
|
||||
(assert_return (get $G2 "g") (i32.const 5))
|
||||
|
||||
(assert_trap
|
||||
(module
|
||||
@ -301,14 +292,13 @@
|
||||
(table $t1 (export "t-func") 1 funcref)
|
||||
(table $t2 (export "t-extern") 1 externref)
|
||||
)
|
||||
;; TODO (register "Mtable_ex" $Mtable_ex)
|
||||
(register "Mtable_ex" $Mtable_ex)
|
||||
|
||||
(module
|
||||
(table (import "Mtable_ex" "t-func") 1 funcref)
|
||||
(table (import "Mtable_ex" "t-extern") 1 externref)
|
||||
)
|
||||
|
||||
(; TODO
|
||||
(assert_unlinkable
|
||||
(module (table (import "Mtable_ex" "t-func") 1 externref))
|
||||
"incompatible import type"
|
||||
@ -317,7 +307,6 @@
|
||||
(module (table (import "Mtable_ex" "t-extern") 1 funcref))
|
||||
"incompatible import type"
|
||||
)
|
||||
;)
|
||||
|
||||
|
||||
;; Memories
|
||||
@ -330,7 +319,7 @@
|
||||
(i32.load8_u (local.get 0))
|
||||
)
|
||||
)
|
||||
;; TODO (register "Mm" $Mm)
|
||||
(register "Mm" $Mm)
|
||||
|
||||
(module $Nm
|
||||
(func $loadM (import "Mm" "load") (param i32) (result i32))
|
||||
@ -367,7 +356,6 @@
|
||||
(data (i32.const 0xffff) "a")
|
||||
)
|
||||
|
||||
(; TODO
|
||||
(assert_trap
|
||||
(module
|
||||
(memory (import "Mm" "mem") 0)
|
||||
@ -375,7 +363,6 @@
|
||||
)
|
||||
"out of bounds memory access"
|
||||
)
|
||||
;)
|
||||
|
||||
(module $Pm
|
||||
(memory (import "Mm" "mem") 1 8)
|
||||
@ -394,7 +381,6 @@
|
||||
(assert_return (invoke $Pm "grow" (i32.const 1)) (i32.const -1))
|
||||
(assert_return (invoke $Pm "grow" (i32.const 0)) (i32.const 5))
|
||||
|
||||
(; TODO
|
||||
(assert_unlinkable
|
||||
(module
|
||||
(func $host (import "spectest" "print"))
|
||||
@ -404,12 +390,11 @@
|
||||
)
|
||||
"unknown import"
|
||||
)
|
||||
;)
|
||||
(assert_return (invoke $Mm "load" (i32.const 0)) (i32.const 0))
|
||||
|
||||
;; Unlike in v1 spec, active data segments written before an
|
||||
;; out-of-bounds access persist after the instantiation failure.
|
||||
(; TODO (assert_trap
|
||||
(assert_trap
|
||||
(module
|
||||
;; Note: the memory is 5 pages large by the time we get here.
|
||||
(memory (import "Mm" "mem") 1)
|
||||
@ -418,11 +403,9 @@
|
||||
)
|
||||
"out of bounds memory access"
|
||||
)
|
||||
;)
|
||||
(assert_return (invoke $Mm "load" (i32.const 0)) (i32.const 97))
|
||||
(assert_return (invoke $Mm "load" (i32.const 327670)) (i32.const 0))
|
||||
|
||||
(; TODO
|
||||
(assert_trap
|
||||
(module
|
||||
(memory (import "Mm" "mem") 1)
|
||||
@ -434,7 +417,6 @@
|
||||
"out of bounds table access"
|
||||
)
|
||||
(assert_return (invoke $Mm "load" (i32.const 0)) (i32.const 97))
|
||||
;)
|
||||
|
||||
;; Store is modified if the start function traps.
|
||||
(module $Ms
|
||||
@ -448,7 +430,7 @@
|
||||
(call_indirect (type $t) (i32.const 0))
|
||||
)
|
||||
)
|
||||
(; TODO (register "Ms" $Ms)
|
||||
(register "Ms" $Ms)
|
||||
|
||||
(assert_trap
|
||||
(module
|
||||
@ -466,7 +448,6 @@
|
||||
)
|
||||
"unreachable"
|
||||
)
|
||||
;)
|
||||
|
||||
(assert_return (invoke $Ms "get memory[0]") (i32.const 104)) ;; 'h'
|
||||
(assert_return (invoke $Ms "get table[0]") (i32.const 0xdead))
|
||||
|
@ -17,8 +17,8 @@
|
||||
(assert_trap (invoke "no_dce.i32.div_u" (i32.const 1) (i32.const 0)) "integer divide by zero")
|
||||
(assert_trap (invoke "no_dce.i64.div_s" (i64.const 1) (i64.const 0)) "integer divide by zero")
|
||||
(assert_trap (invoke "no_dce.i64.div_u" (i64.const 1) (i64.const 0)) "integer divide by zero")
|
||||
;; TODO (assert_trap (invoke "no_dce.i32.div_s" (i32.const 0x80000000) (i32.const -1)) "integer overflow")
|
||||
;; TODO (assert_trap (invoke "no_dce.i64.div_s" (i64.const 0x8000000000000000) (i64.const -1)) "integer overflow")
|
||||
(assert_trap (invoke "no_dce.i32.div_s" (i32.const 0x80000000) (i32.const -1)) "integer overflow")
|
||||
(assert_trap (invoke "no_dce.i64.div_s" (i64.const 0x8000000000000000) (i64.const -1)) "integer overflow")
|
||||
|
||||
(module
|
||||
(func (export "no_dce.i32.rem_s") (param $x i32) (param $y i32)
|
||||
|
Loading…
x
Reference in New Issue
Block a user