Implement unsigned operators

ml-proto/runtests.py

@@ -51,7 +51,7 @@ def find_interpreter(path):
 def rebuild_interpreter(path):
   print("// building %s" % path)
   sys.stdout.flush()
-  exitCode = subprocess.call(["ocamlbuild", "-libs", "bigarray, str", "main.native"], cwd=os.path.abspath("src"))
+  exitCode = subprocess.call(["ocamlbuild", "-libs", "bigarray, nums, str", "main.native"], cwd=os.path.abspath("src"))
   if (exitCode != 0):
     raise Exception("ocamlbuild failed with exit code %i" % exitCode)
   if not os.path.exists(path):
@@ -74,4 +74,4 @@ def rebuild_interpreter(path):
 
   testFiles = glob.glob("test/*.wasm")
   generate_test_cases(RunTests, interpreterPath, testFiles)
-  unittest.main()
+  unittest.main()

ml-proto/src/Makefile

@@ -12,7 +12,7 @@ MODULES = \
 NOMLI = flags types values ast sexpr main
 PARSERS = parser
 LEXERS = lexer
-LIBRARIES = bigarray str
+LIBRARIES = bigarray nums str
 SAMPLES = 
 TEXTS = 
 

ml-proto/src/arithmetic.ml

@@ -38,11 +38,54 @@ sig
   val to_int64 : t -> int64
   val to_float : t -> float
   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 Int32X =
+struct
+  include Int32
+  let size = 32
+  let to_int32 i = i
+  let to_int64 = Int64.of_int32
+  let to_value i = Int32 i
+  let of_value n =
+    function Int32 i -> i | v -> raise (TypeError (n, v, Int32Type))
+  let value_range = Big_int.power_int_positive_int 2 32
+  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 Int64X =
+struct
+  include Int64
+  let size = 64
+  let to_int64 i = i
+  let to_value i = Int64 i
+  let of_value n =
+    function Int64 i -> i | v -> raise (TypeError (n, v, Int64Type))
+  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
 
 module IntOp (IntOpSyntax : module type of Ast.IntOp ()) (Int : INT) =
 struct
   open IntOpSyntax
+  open Big_int
+
+  let unsigned big_op i j = big_op (Int.to_big_int_u i) (Int.to_big_int_u j)
 
   let unop op =
     let f = match op with
@@ -59,69 +102,48 @@ struct
       | Sub -> Int.sub
       | Mul -> Int.mul
       | DivS -> Int.div
-      | DivU -> fun i _ -> i  (* TODO *)
+      | DivU -> fun i j -> Int.of_big_int_u (unsigned div_big_int i j)
       | ModS -> Int.rem
-      | ModU -> fun i _ -> i  (* TODO *)
+      | ModU -> fun i j -> Int.of_big_int_u (unsigned mod_big_int i j)
       | And -> Int.logand
       | Or -> Int.logor
       | Xor -> Int.logxor
-      | Shl -> fun x y -> Int.shift_left x (Int.to_int y)
-      | Shr -> fun x y -> Int.shift_right_logical x (Int.to_int y)
-      | Sar -> fun x y -> Int.shift_right x (Int.to_int y)
+      | Shl -> fun i j -> Int.shift_left i (Int.to_int j)
+      | Shr -> fun i j -> Int.shift_right_logical i (Int.to_int j)
+      | Sar -> fun i j -> Int.shift_right i (Int.to_int j)
     in fun v1 v2 -> Int.to_value (f (Int.of_value 1 v1) (Int.of_value 2 v2))
 
   let relop op =
     let f = match op with
       | Eq -> (=)
       | Neq -> (<>)
       | LtS -> (<)
-      | LtU -> fun _ _ -> false  (* TODO *)
+      | LtU -> unsigned lt_big_int
       | LeS -> (<=)
-      | LeU -> fun _ _ -> false  (* TODO *)
+      | LeU -> unsigned le_big_int
       | GtS -> (>)
-      | GtU -> fun _ _ -> false  (* TODO *)
+      | GtU -> unsigned gt_big_int
       | GeS -> (>=)
-      | GeU -> fun _ _ -> false  (* TODO *)
+      | GeU -> unsigned ge_big_int
     in fun v1 v2 -> f (Int.of_value 1 v1) (Int.of_value 2 v2)
 
   let cvt op =
     let f = match op with
-      | ToInt32S -> fun x -> Int32 (Int.to_int32 x)
-      | ToInt32U -> fun _ -> Int32 Int32.zero  (* TODO *)
-      | ToInt64S -> fun x -> Int64 (Int.to_int64 x)
-      | ToInt64U -> fun _ -> Int64 Int64.zero  (* TODO *)
-      | ToFloat32S -> fun x -> Float32 (Int.to_float x)
-      | ToFloat32U -> fun _ -> Float32 0.0  (* TODO *)
-      | ToFloat64S -> fun x -> Float64 (Int.to_float x)
-      | ToFloat64U -> fun _ -> Float64 0.0  (* TODO *)
-      | ToFloatCast -> fun x ->
+      | ToInt32S -> fun i -> Int32 (Int.to_int32 i)
+      | 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))
+      | 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 x)
-        else Float64 (Int.float_of_bits x)
+        then Float32 (Int.float_of_bits i)
+        else Float64 (Int.float_of_bits i)
     in fun v -> f (Int.of_value 1 v)
 end
 
-module Int32X =
-struct
-  include Int32
-  let size = 32
-  let to_int32 i = i
-  let to_int64 = Int64.of_int32
-  let to_value i = Int32 i
-  let of_value n =
-    function Int32 i -> i | v -> raise (TypeError (n, v, Int32Type))
-end
-
-module Int64X =
-struct
-  include Int64
-  let size = 64
-  let to_int64 i = i
-  let to_value i = Int64 i
-  let of_value n =
-    function Int64 i -> i | v -> raise (TypeError (n, v, Int64Type))
-end
-
 module Int32Op = IntOp (Ast.Int32Op) (Int32X)
 module Int64Op = IntOp (Ast.Int64Op) (Int64X)
 
@@ -135,6 +157,22 @@ sig
   val to_value : float -> value
 end
 
+module Float32X =
+struct
+  let size = 32
+  let to_value z = Float32 z
+  let of_value n =
+    function Float32 z -> z | v -> raise (TypeError (n, v, Float32Type))
+end
+
+module Float64X =
+struct
+  let size = 64
+  let to_value z = Float64 z
+  let of_value n =
+    function Float64 z -> z | v -> raise (TypeError (n, v, Float64Type))
+end
+
 module FloatOp (FloatOpSyntax : module type of Ast.FloatOp ())
   (Float : FLOAT) =
 struct
@@ -174,9 +212,21 @@ struct
   let cvt op =
     let f = match op with
     | ToInt32S -> fun x -> Int32 (Int32.of_float x)
-    | ToInt32U -> fun _ -> Int32 Int32.zero  (* TODO *)
+    | ToInt32U -> fun x ->
+      let limit = Int32.to_float Int32.max_int +. 1.0 in
+      let i =
+        if x < 0.0 || x >= 2.0 *. limit then Int32.zero else
+        if x < limit then Int32.of_float x else
+        Int32.add (Int32.of_float (x -. limit +. 1.0)) Int32.max_int
+      in Int32 i
     | ToInt64S -> fun x -> Int64 (Int64.of_float x)
-    | ToInt64U -> fun _ -> Int64 Int64.zero  (* TODO *)
+    | ToInt64U -> fun x ->
+      let limit = Int64.to_float Int64.max_int +. 1.0 in
+      let i =
+        if x < 0.0 || x >= 2.0 *. limit then Int64.zero else
+        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
     | ToFloat64 -> fun x -> Float64 x
     | ToIntCast -> fun x ->
@@ -186,22 +236,6 @@ struct
     in fun v -> f (Float.of_value 1 v)
 end
 
-module Float32X =
-struct
-  let size = 32
-  let to_value z = Float32 z
-  let of_value n =
-    function Float32 z -> z | v -> raise (TypeError (n, v, Float32Type))
-end
-
-module Float64X =
-struct
-  let size = 64
-  let to_value z = Float64 z
-  let of_value n =
-    function Float64 z -> z | v -> raise (TypeError (n, v, Float64Type))
-end
-
 module Float32Op = FloatOp (Ast.Float32Op) (Float32X)
 module Float64Op = FloatOp (Ast.Float64Op) (Float64X)
 

ml-proto/test/unsigned.ml

@@ -0,0 +1,75 @@
+(module
+  (func $divmod (param $i i64) (param $j i64) (result i64 i64 i64 i64)
+    (return
+      (divs.i64 (getlocal $i) (getlocal $j))
+      (divu.i64 (getlocal $i) (getlocal $j))
+      (mods.i64 (getlocal $i) (getlocal $j))
+      (modu.i64 (getlocal $i) (getlocal $j))
+    )
+  )
+
+  (func $compare (param $i i64) (param $j i64) (result i32 i32 i32 i32)
+    (return
+      (lts.i64 (getlocal $i) (getlocal $j))
+      (ltu.i64 (getlocal $i) (getlocal $j))
+      (ges.i64 (getlocal $i) (getlocal $j))
+      (geu.i64 (getlocal $i) (getlocal $j))
+    )
+  )
+
+  (func $cvt_float (param $x f64) (result i32 i64)
+    (return (convertu.f64.i32 (getlocal $x)) (convertu.f64.i64 (getlocal $x)))
+  )
+
+  (export "divmod" $divmod)
+  (export "compare" $compare)
+  (export "cvt_float" $cvt_float)
+)
+
+(asserteq
+  (invoke "divmod"
+    (add.i64 (const.i64 9223372036854775807) (const.i64 2))  ;; max_int64+2
+    (const.i64 1000)
+  )
+  (const.i64 -9223372036854775)  ;; divs
+  (const.i64 9223372036854775)   ;; divu
+  (const.i64 -807)               ;; divs
+  (const.i64 809)                ;; divu
+)
+
+(asserteq
+  (invoke "compare"
+    (add.i64 (const.i64 9223372036854775807) (const.i64 1))  ;; max_int64+1
+    (const.i64 9223372036854775807)
+  )
+  (const.i32 1)  ;; lts
+  (const.i32 0)  ;; ltu
+  (const.i32 0)  ;; ges
+  (const.i32 1)  ;; geu
+)
+
+(asserteq (invoke "cvt_float" (const.f64 1e8))
+  (const.i32 100000000) (const.i64 100000000)
+)
+
+(asserteq (invoke "cvt_float" (const.f64 1e16))
+  (const.i32 0) (const.i64 10000000000000000)
+)
+
+(asserteq (invoke "cvt_float" (const.f64 1e30))
+  (const.i32 0) (const.i64 0)
+)
+
+(asserteq (invoke "cvt_float" (const.f64 -1))
+  (const.i32 0) (const.i64 0)
+)
+
+(asserteq
+  (invoke "cvt_float" (const.f64 4294967295))  ;; max_uint32
+  (const.i32 -1) (const.i64 4294967295)
+)
+
+(asserteq
+  (invoke "cvt_float" (const.f64 9223372036854775808))  ;; max_int64+1
+  (const.i32 0) (const.i64 -9223372036854775808)
+)

ml-proto/travis/build-test.sh

@@ -11,7 +11,7 @@ export PATH=$PWD/ocaml/install/bin:$PATH
 
 cd src
 
-ocamlbuild -libs "bigarray, str" main.native
+ocamlbuild -libs "bigarray, nums, str" main.native
 
 cd ..