Float32

ml-proto/src/arithmetic.ml

@@ -80,7 +80,7 @@ struct
   let of_big_int_u = of_big_int_u_for size Big_int.int64_of_big_int
 end
 
-module IntOp (IntOpSyntax : module type of Ast.IntOp ()) (Int : INT) =
+module IntOp (IntOpSyntax : module type of Ast.IntOp()) (Int : INT) =
 struct
   open IntOpSyntax
   open Big_int
@@ -133,13 +133,14 @@ struct
       | ToInt32U -> fun i -> Int32 (Int32X.of_big_int_u (Int.to_big_int_u i))
       | ToInt64S -> fun i -> Int64 (Int.to_int64 i)
       | ToInt64U -> fun i -> Int64 (Int64X.of_big_int_u (Int.to_big_int_u i))
-      | ToFloat32S -> fun i -> Float32 (Int.to_float i)
-      | ToFloat32U -> fun i -> Float32 (float_of_big_int (Int.to_big_int_u i))
+      | ToFloat32S -> fun i -> Float32 (float32 (Int.to_float i))
+      | ToFloat32U -> fun i ->
+        Float32 (float32 (float_of_big_int (Int.to_big_int_u i)))
       | ToFloat64S -> fun i -> Float64 (Int.to_float i)
       | ToFloat64U -> fun i -> Float64 (float_of_big_int (Int.to_big_int_u i))
       | ToFloatCast -> fun i ->
         if Int.size = 32
-        then Float32 (Int.float_of_bits i)
+        then Float32 (float32 (Int.float_of_bits i))
         else Float64 (Int.float_of_bits i)
     in fun v -> f (Int.of_value 1 v)
 end
@@ -160,7 +161,7 @@ end
 module Float32X =
 struct
   let size = 32
-  let to_value z = Float32 z
+  let to_value z = Float32 (float32 z)
   let of_value n =
     function Float32 z -> z | v -> raise (TypeError (n, v, Float32Type))
 end
@@ -173,8 +174,7 @@ struct
     function Float64 z -> z | v -> raise (TypeError (n, v, Float64Type))
 end
 
-module FloatOp (FloatOpSyntax : module type of Ast.FloatOp ())
-  (Float : FLOAT) =
+module FloatOp (FloatOpSyntax : module type of Ast.FloatOp()) (Float : FLOAT) =
 struct
   open FloatOpSyntax
 
@@ -194,7 +194,6 @@ struct
       | Sub -> (-.)
       | Mul -> ( *.)
       | Div -> (/.)
-      | Mod -> mod_float
       | CopySign -> copysign
     in
     fun v1 v2 -> Float.to_value (f (Float.of_value 1 v1) (Float.of_value 2 v2))
@@ -227,7 +226,7 @@ struct
         if x < limit then Int64.of_float x else
         Int64.add (Int64.of_float (x -. limit +. 1.0)) Int64.max_int
       in Int64 i
-    | ToFloat32 -> fun x -> Float32 x
+    | ToFloat32 -> fun x -> Float32 (float32 x)
     | ToFloat64 -> fun x -> Float64 x
     | ToIntCast -> fun x ->
       if Float.size = 32

ml-proto/src/ast.ml

@@ -44,7 +44,7 @@ end
 module FloatOp () =
 struct
   type unop = Neg | Abs | Ceil | Floor | Trunc | Round
-  type binop = Add | Sub | Mul | Div | Mod | CopySign
+  type binop = Add | Sub | Mul | Div | CopySign
   type relop = Eq | Neq | Lt | Le | Gt | Ge
   type cvt = ToInt32S | ToInt32U | ToInt64S | ToInt64U | ToIntCast
            | ToFloat32 | ToFloat64

ml-proto/src/lexer.mll

@@ -104,7 +104,7 @@ let character = [^'"''\\''\n'] | '\\'escape | '\\'hexdigit hexdigit
 
 let num = ('+' | '-')? digit+
 let int = num
-let float = (num '.' digit+) | num ('e' | 'E') num
+let float = (num '.' digit+) | num ('.' digit+)? ('e' | 'E') num
 let text = '"' character* '"'
 let name = '$' (letter | digit | '_' | tick | symbol)+
 
@@ -189,7 +189,6 @@ rule token = parse
   | "sub."(fxx as t) { BINARY (floatop t F32.Sub F64.Sub) }
   | "mul."(fxx as t) { BINARY (floatop t F32.Mul F64.Mul) }
   | "div."(fxx as t) { BINARY (floatop t F32.Div F64.Div) }
-  | "mod."(fxx as t) { BINARY (floatop t F32.Mod F64.Mod) }
   | "copysign."(fxx as t) { BINARY (floatop t F32.CopySign F64.CopySign) }
 
   | "eq."(ixx as t) { COMPARE (intop t I32.Eq I64.Eq) }

ml-proto/src/parser.mly

@@ -36,7 +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 (float_of_string s) @@ at
+    | Types.Float32Type ->
+      Values.Float32 (Values.float32 (float_of_string s)) @@ at
     | Types.Float64Type -> Values.Float64 (float_of_string s) @@ at
   with _ -> Error.error at "constant out of range"
 

ml-proto/src/values.ml

@@ -38,3 +38,8 @@ let string_of_value = function
 let string_of_values = function
   | [v] -> string_of_value v
   | vs -> "(" ^ String.concat " " (List.map string_of_value vs) ^ ")"
+
+
+(* Float32 truncation *)
+
+let float32 x = Int32.float_of_bits (Int32.bits_of_float x)

ml-proto/test/float32.wasm

@@ -0,0 +1,64 @@
+(module
+  (func $eq_float32 (param $x f32) (param $y f32) (result i32)
+    (eq.f32 (getlocal $x) (getlocal $y))
+  )
+
+  (func $eq_float64 (param $x f64) (param $y f64) (result i32)
+    (eq.f64 (getlocal $x) (getlocal $y))
+  )
+
+  (func $div_float32 (param $x f32) (param $y f32) (result f32)
+    (div.f32 (getlocal $x) (getlocal $y))
+  )
+
+  (func $div_float64 (param $x f64) (param $y f64) (result f64)
+    (div.f64 (getlocal $x) (getlocal $y))
+  )
+
+  (export "eq_float32" $eq_float32)
+  (export "eq_float64" $eq_float64)
+  (export "div_float32" $div_float32)
+  (export "div_float64" $div_float64)
+)
+
+(asserteq
+  (invoke "eq_float32"
+    (add.f32 (const.f32 1.1234567890) (const.f32 1.2345e-10))
+    (const.f32 1.123456789)
+  )
+  (const.i32 1)
+)
+
+(asserteq
+  (invoke "eq_float64"
+    (add.f64 (const.f64 1.1234567890) (const.f64 1.2345e-10))
+    (const.f64 1.123456789)
+  )
+  (const.i32 0)
+)
+
+(asserteq
+  (invoke "eq_float32"
+    (mul.f32 (const.f32 1e20) (const.f32 1e20))
+    (mul.f32 (const.f32 1e25) (const.f32 1e25))
+  )
+  (const.i32 1)
+)
+
+(asserteq
+  (invoke "eq_float64"
+    (mul.f64 (const.f64 1e20) (const.f64 1e20))
+    (mul.f64 (const.f64 1e25) (const.f64 1e25))
+  )
+  (const.i32 0)
+)
+
+(asserteq
+  (invoke "div_float32" (const.f32 1.123456789) (const.f32 100))
+  (const.f32 0.011234568432)
+)
+
+(asserteq
+  (invoke "div_float64" (const.f64 1.123456789) (const.f64 100))
+  (const.f64 0.01123456789)
+)