refactor, add some instructions

.gitignore

@@ -1 +1,2 @@
 _build
+_coverage

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

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)

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
 

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

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

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

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)

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

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

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

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
 

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

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
 

src/uint32.ml

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

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.