diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index e8e2198d74..609297cc19 100755 --- a/ml-proto/runtests.py +++ b/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() \ No newline at end of file + unittest.main() diff --git a/ml-proto/src/Makefile b/ml-proto/src/Makefile index c16f723efc..f0a7728f59 100644 --- a/ml-proto/src/Makefile +++ b/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 = diff --git a/ml-proto/src/arithmetic.ml b/ml-proto/src/arithmetic.ml index 62e786667b..0d66fa2f59 100644 --- a/ml-proto/src/arithmetic.ml +++ b/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,15 +102,15 @@ 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 = @@ -75,53 +118,32 @@ struct | 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) diff --git a/ml-proto/test/unsigned.ml b/ml-proto/test/unsigned.ml new file mode 100644 index 0000000000..ffa4bc185c --- /dev/null +++ b/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) +) diff --git a/ml-proto/travis/build-test.sh b/ml-proto/travis/build-test.sh index 28d80f5de3..edacabd66e 100755 --- a/ml-proto/travis/build-test.sh +++ b/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 ..