Refactor the Float32 and Float64 modules into a Float functor.

ml-proto/src/Makefile

@@ -5,7 +5,7 @@
 NAME = wasm
 INCLUDES = -I host -I given -I spec
 MODULES = \
-  host/flags given/lib given/source spec/error \
+  host/flags given/lib given/source given/basicint given/basicfloat spec/error \
   spec/types spec/values spec/memory spec/ast \
   spec/check spec/arithmetic spec/eval \
   host/print host/builtins host/script \

ml-proto/src/given/basicfloat.ml

@@ -0,0 +1,154 @@
+(* WebAssembly-compatible floating point implementation *)
+
+module type BASIC_FLOAT = sig
+  type t
+  type bits
+
+  val size : int
+
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_bits : bits -> t
+  val to_bits : t -> bits
+  val of_string : string -> t
+  val to_string : t -> string
+
+  val zero : t
+
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> 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 abs : t -> t
+  val neg : t -> t
+  val copysign : t -> t -> t
+  val eq : t -> t -> bool
+  val ne : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val gt : t -> t -> bool
+  val ge : t -> t -> bool
+end
+
+module type FLOAT_TRAITS = sig
+  type t
+  val size : int
+  val nondeterministic_nan : t
+end
+
+module Float32Traits : FLOAT_TRAITS = struct
+  type t = int32
+  let size = 32
+
+  (* TODO: Do something meaningful with nondeterminism *)
+  let nondeterministic_nan = 0x7fc0f0f0l
+end
+
+module Float64Traits : FLOAT_TRAITS = struct
+  type t = int64
+  let size = 64
+
+  (* TODO: Do something meaningful with nondeterminism *)
+  let nondeterministic_nan = 0x7fff0f0f0f0f0f0fL
+end
+
+module Float (Traits : FLOAT_TRAITS) (Int : Basicint.BASIC_INT with type t = Traits.t) : BASIC_FLOAT = struct
+  include Traits
+
+  type bits = Int.t
+
+  let of_bits x = x
+  let to_bits x = x
+  let of_float x = of_bits (Int.bits_of_float x)
+  let to_float x = to_bits (Int.float_of_bits x)
+
+  (* TODO: OCaml's string_of_float and float_of_string are insufficient *)
+  let of_string x = of_float (float_of_string x)
+  let to_string x = string_of_float (to_float x)
+
+  let zero = of_float 0.0
+
+  (* Most arithmetic ops that return NaN return a nondeterministic NaN *)
+  let arith_of_bits = to_float
+  let bits_of_arith f = if f <> f then nondeterministic_nan else of_float f
+
+  let add x y = bits_of_arith ((arith_of_bits x) +. (arith_of_bits y))
+  let sub x y = bits_of_arith ((arith_of_bits x) -. (arith_of_bits y))
+  let mul x y = bits_of_arith ((arith_of_bits x) *. (arith_of_bits y))
+  let div x y = bits_of_arith ((arith_of_bits x) /. (arith_of_bits y))
+  let sqrt  x = bits_of_arith (Pervasives.sqrt (arith_of_bits x))
+
+  let ceil  x = bits_of_arith (Pervasives.ceil  (arith_of_bits x))
+  let floor x = bits_of_arith (Pervasives.floor (arith_of_bits x))
+
+  let trunc x =
+    let xf = arith_of_bits 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 Pervasives.ceil xf else Pervasives.floor xf in
+    bits_of_arith f
+
+  let nearest x =
+    let xf = arith_of_bits 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 = Pervasives.ceil xf in
+    let d = Pervasives.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) && (mod_float u 2.0 = 0.0)) in
+    let f = if u_or_d then u else d in
+    bits_of_arith f
+
+  let min x y =
+    let xf = arith_of_bits x in
+    let yf = arith_of_bits y in
+    (* min(-0, 0) is -0 *)
+    if xf = 0.0 && yf = 0.0 then (Int.logor x y) else
+    if xf < yf then x else
+    if xf > yf then y else
+    nondeterministic_nan
+
+  let max x y =
+    let xf = arith_of_bits x in
+    let yf = arith_of_bits y in
+    (* max(-0, 0) is 0 *)
+    if xf = 0.0 && yf = 0.0 then (Int.logand x y) else
+    if xf > yf then x else
+    if xf < yf then y else
+    nondeterministic_nan
+
+  (* abs, neg, and copysign are purely bitwise operations, even on NaN values *)
+  let abs x =
+    Int.logand x Int.max_int
+
+  let neg x =
+    Int.logxor x Int.min_int
+
+  let copysign x y =
+    Int.logor (abs x) (Int.logand y Int.min_int)
+
+  let eq x y = (arith_of_bits x) =  (arith_of_bits y)
+  let ne x y = (arith_of_bits x) <> (arith_of_bits y)
+  let lt x y = (arith_of_bits x) <  (arith_of_bits y)
+  let gt x y = (arith_of_bits x) >  (arith_of_bits y)
+  let le x y = (arith_of_bits x) <= (arith_of_bits y)
+  let ge x y = (arith_of_bits x) >= (arith_of_bits y)
+end
+
+module BasicFloat32 : BASIC_FLOAT = struct
+  include Float(Float32Traits) (Basicint.BasicInt32)
+end
+
+module BasicFloat64 : BASIC_FLOAT = struct
+  include Float(Float64Traits) (Basicint.BasicInt64)
+end

ml-proto/src/given/basicfloat.mli

@@ -0,0 +1,41 @@
+(* WebAssembly-compatible floating point implementation *)
+
+module type BASIC_FLOAT = sig
+  type t
+  type bits
+
+  val size : int
+
+  val of_float : float -> t
+  val to_float : t -> float
+  val of_bits : bits -> t
+  val to_bits : t -> bits
+  val of_string : string -> t
+  val to_string : t -> string
+
+  val zero : t
+
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> 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 abs : t -> t
+  val neg : t -> t
+  val copysign : t -> t -> t
+  val eq : t -> t -> bool
+  val ne : t -> t -> bool
+  val lt : t -> t -> bool
+  val le : t -> t -> bool
+  val gt : t -> t -> bool
+  val ge : t -> t -> bool
+end
+
+module BasicFloat32 : BASIC_FLOAT
+module BasicFloat64 : BASIC_FLOAT

ml-proto/src/given/basicint.ml

@@ -0,0 +1,64 @@
+(* WebAssembly-compatible integer implementation *)
+
+module type BASIC_INT =
+sig
+  type t
+  val size : int
+  val max_int : t
+  val min_int : t
+  val neg : t -> t
+  val abs : t -> t
+  val lognot : t -> t
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val rem : t -> t -> t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  (* TODO: type should be t -> t -> t for wasm *)
+  val shift_left : t -> int -> t
+  val shift_right : t -> int -> t
+  val shift_right_logical : t -> int -> t
+
+  (* TODO obviate these *)
+  val to_float : t -> float
+  val of_float : float -> t
+  val bits_of_float : float -> t
+  val float_of_bits : t -> float
+
+  val to_big_int_u : t -> Big_int.big_int
+  val of_big_int_u : Big_int.big_int -> t
+end
+
+let to_big_int_u_for size to_big_int i =
+  let open Big_int in
+  let value_range = Big_int.power_int_positive_int 2 size in
+  let i' = to_big_int i in
+  if ge_big_int i' zero_big_int then i' else add_big_int i' value_range
+
+let of_big_int_u_for size of_big_int i =
+  let open Big_int in
+  let value_range = Big_int.power_int_positive_int 2 size in
+  let i' = if ge_big_int i zero_big_int then i else sub_big_int i value_range
+  in of_big_int i'
+
+module BasicInt32 =
+struct
+  include Int32
+  let size = 32
+  let of_int32 i = i
+  let of_int64 = Int64.to_int32
+  let to_big_int_u = to_big_int_u_for size Big_int.big_int_of_int32
+  let of_big_int_u = of_big_int_u_for size Big_int.int32_of_big_int
+end
+
+module BasicInt64 =
+struct
+  include Int64
+  let size = 64
+  let of_int64 i = i
+  let to_big_int_u = to_big_int_u_for size Big_int.big_int_of_int64
+  let of_big_int_u = of_big_int_u_for size Big_int.int64_of_big_int
+end

ml-proto/src/given/basicint.mli

@@ -0,0 +1,36 @@
+(* WebAssembly-compatible integer implementation *)
+
+module type BASIC_INT =
+sig
+  type t
+  val size : int
+  val max_int : t
+  val min_int : t
+  val neg : t -> t
+  val abs : t -> t
+  val lognot : t -> t
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val rem : t -> t -> t
+  val logand : t -> t -> t
+  val logor : t -> t -> t
+  val logxor : t -> t -> t
+  (* TODO: type should be t -> t -> t for wasm *)
+  val shift_left : t -> int -> t
+  val shift_right : t -> int -> t
+  val shift_right_logical : t -> int -> t
+
+  (* TODO obviate these *)
+  val to_float : t -> float
+  val of_float : float -> t
+  val bits_of_float : float -> t
+  val float_of_bits : t -> float
+
+  val to_big_int_u : t -> Big_int.big_int
+  val of_big_int_u : Big_int.big_int -> t
+end
+
+module BasicInt32 : BASIC_INT
+module BasicInt64 : BASIC_INT

ml-proto/src/host/parser.mly

@@ -36,9 +36,8 @@ let literal at s t =
     match t with
     | Types.Int32Type -> Values.Int32 (Int32.of_string s) @@ at
     | Types.Int64Type -> Values.Int64 (Int64.of_string s) @@ at
-    | Types.Float32Type ->
-      Values.Float32 (Values.float32 (float_of_string s)) @@ at
-    | Types.Float64Type -> Values.Float64 (float_of_string s) @@ at
+    | Types.Float32Type -> Values.Float32 (Float32.of_string s) @@ at
+    | Types.Float64Type -> Values.Float64 (Float64.of_string s) @@ at
   with _ -> Error.error at "constant out of range"