From 6f56262db585435a40170bf5ebc007526de4773f Mon Sep 17 00:00:00 2001 From: Andrew Scheidecker Date: Tue, 22 Sep 2015 17:23:39 -0400 Subject: [PATCH 1/3] Got rid of Obj.magic use in memory module: Instead of doing magical casts of Bigarrays, it unpacks values into bytes before storing them, and packs them from bytes on load. --- ml-proto/src/spec/memory.ml | 81 +++++++++++++++++++------------------ ml-proto/test/memory.wasm | 32 +++++++++++++++ 2 files changed, 74 insertions(+), 39 deletions(-) diff --git a/ml-proto/src/spec/memory.ml b/ml-proto/src/spec/memory.ml index b953a1e205..63a0cc98d5 100644 --- a/ml-proto/src/spec/memory.ml +++ b/ml-proto/src/spec/memory.ml @@ -24,21 +24,6 @@ type memory' = (int, int8_unsigned_elt, c_layout) Array1.t type memory = memory' ref type t = memory -type char_view = (char, int8_unsigned_elt, c_layout) Array1.t -type sint8_view = (int, int8_signed_elt, c_layout) Array1.t -type sint16_view = (int, int16_signed_elt, c_layout) Array1.t -type sint32_view = (int32, int32_elt, c_layout) Array1.t -type sint64_view = (int64, int64_elt, c_layout) Array1.t -type uint8_view = (int, int8_unsigned_elt, c_layout) Array1.t -type uint16_view = (int, int16_unsigned_elt, c_layout) Array1.t -type uint32_view = (int32, int32_elt, c_layout) Array1.t -type uint64_view = (int64, int64_elt, c_layout) Array1.t -type float32_view = (int32, int32_elt, c_layout) Array1.t -type float64_view = (int64, int64_elt, c_layout) Array1.t - -let view : memory' -> ('c, 'd, c_layout) Array1.t = Obj.magic - - (* Queries *) let mem_size = function @@ -65,7 +50,7 @@ let create n = let init_seg mem seg = (* There currently is no way to blit from a string. *) for i = 0 to String.length seg.data - 1 do - (view !mem : char_view).{seg.addr + i} <- seg.data.[i] + !mem.{seg.addr + i} <- Char.code seg.data.[i] done let init mem segs = @@ -91,38 +76,56 @@ let address_of_value = function (* Load and store *) -let int32_mask = Int64.shift_right_logical (Int64.of_int (-1)) 32 -let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask +let load8 mem a ext = + (match ext with + | SX -> Int32.shift_right (Int32.shift_left (Int32.of_int !mem.{a}) 24) 24 + | _ -> Int32.of_int !mem.{a}) + +let load16 mem a ext = + Int32.logor (load8 mem a NX) (Int32.shift_left (load8 mem (a+1) ext) 8) + +let load32 mem a = + Int32.logor (load16 mem a NX) (Int32.shift_left (load16 mem (a+2) NX) 16) + +let load64 mem a = + Int64.logor (Int64.of_int32 (load32 mem a)) (Int64.shift_left (Int64.of_int32 (load32 mem (a+4))) 32) + +let store8 mem a value = + !mem.{a} <- Int32.to_int (Int32.logand value (Int32.of_int 255)) + +let store16 mem a value = + store8 mem (a+0) value; + store8 mem (a+1) (Int32.shift_right_logical value 8) + +let store32 mem a value = + store16 mem (a+0) value; + store16 mem (a+2) (Int32.shift_right_logical value 16) -let buf = create' 8 +let store64 mem a value = + store32 mem (a+0) (Int64.to_int32 value); + store32 mem (a+4) (Int64.to_int32 (Int64.shift_right_logical value 32)) let load mem a memty ext = - let sz = mem_size memty in let open Types in try - Array1.blit (Array1.sub !mem a sz) (Array1.sub buf 0 sz); match memty, ext with - | Int8Mem, SX -> Int32 (Int32.of_int (view buf : sint8_view).{0}) - | Int8Mem, ZX -> Int32 (Int32.of_int (view buf : uint8_view).{0}) - | Int16Mem, SX -> Int32 (Int32.of_int (view buf : sint16_view).{0}) - | Int16Mem, ZX -> Int32 (Int32.of_int (view buf : uint16_view).{0}) - | Int32Mem, NX -> Int32 (view buf : sint32_view).{0} - | Int64Mem, NX -> Int64 (view buf : sint64_view).{0} - | Float32Mem, NX -> Float32 (Float32.of_bits (view buf : float32_view).{0}) - | Float64Mem, NX -> Float64 (Float64.of_bits (view buf : float64_view).{0}) + | Int8Mem, _ -> Int32 (load8 mem a ext) + | Int16Mem, _ -> Int32 (load16 mem a ext) + | Int32Mem, NX -> Int32 (load32 mem a) + | Int64Mem, NX -> Int64 (load64 mem a) + | Float32Mem, NX -> Float32 (Float32.of_bits (load32 mem a)) + | Float64Mem, NX -> Float64 (Float64.of_bits (load64 mem a)) | _ -> raise Type with Invalid_argument _ -> raise Bounds -let store mem a memty v = - let sz = mem_size memty in +let store (mem : t) (a : int) (memty : mem_type) v = try (match memty, v with - | Int8Mem, Int32 x -> (view buf : sint8_view).{0} <- Int32.to_int x - | Int16Mem, Int32 x -> (view buf : sint16_view).{0} <- Int32.to_int x - | Int32Mem, Int32 x -> (view buf : sint32_view).{0} <- x - | Int64Mem, Int64 x -> (view buf : sint64_view).{0} <- x - | Float32Mem, Float32 x -> (view buf : float32_view).{0} <- Float32.to_bits x - | Float64Mem, Float64 x -> (view buf : float64_view).{0} <- Float64.to_bits x - | _ -> raise Type); - Array1.blit (Array1.sub buf 0 sz) (Array1.sub !mem a sz) + | Int8Mem, Int32 x -> store8 mem a x + | Int16Mem, Int32 x -> store16 mem a x + | Int32Mem, Int32 x -> store32 mem a x + | Int64Mem, Int64 x -> store64 mem a x + | Float32Mem, Float32 x -> store32 mem a (Float32.to_bits x) + | Float64Mem, Float64 x -> store64 mem a (Float64.to_bits x) + | _ -> raise Type) with Invalid_argument _ -> raise Bounds diff --git a/ml-proto/test/memory.wasm b/ml-proto/test/memory.wasm index 03f100e0d0..873d052ec0 100644 --- a/ml-proto/test/memory.wasm +++ b/ml-proto/test/memory.wasm @@ -139,13 +139,45 @@ (return (f64.load/1 (i32.const 9))) ) + ;; Sign and zero extending memory loads + (func $load8_s (param $i i32) (result i32) + (i32.store8 (i32.const 8) (get_local $i)) + (return (i32.load8_s (i32.const 8))) + ) + (func $load8_u (param $i i32) (result i32) + (i32.store8 (i32.const 8) (get_local $i)) + (return (i32.load8_u (i32.const 8))) + ) + (func $load16_s (param $i i32) (result i32) + (i32.store16 (i32.const 8) (get_local $i)) + (return (i32.load16_s (i32.const 8))) + ) + (func $load16_u (param $i i32) (result i32) + (i32.store16 (i32.const 8) (get_local $i)) + (return (i32.load16_u (i32.const 8))) + ) + (export "data" $data) (export "aligned" $aligned) (export "unaligned" $unaligned) (export "cast" $cast) + (export "load8_s" $load8_s) + (export "load8_u" $load8_u) + (export "load16_s" $load16_s) + (export "load16_u" $load16_u) ) (assert_eq (invoke "data") (i32.const 1)) (assert_eq (invoke "aligned") (i32.const 1)) (assert_eq (invoke "unaligned") (i32.const 1)) (assert_eq (invoke "cast") (f64.const 42.0)) + +(assert_eq (invoke "load8_s" (i32.const -1)) (i32.const -1)) +(assert_eq (invoke "load8_u" (i32.const -1)) (i32.const 255)) +(assert_eq (invoke "load16_s" (i32.const -1)) (i32.const -1)) +(assert_eq (invoke "load16_u" (i32.const -1)) (i32.const 65535)) + +(assert_eq (invoke "load8_s" (i32.const 100)) (i32.const 100)) +(assert_eq (invoke "load8_u" (i32.const 200)) (i32.const 200)) +(assert_eq (invoke "load16_s" (i32.const 20000)) (i32.const 20000)) +(assert_eq (invoke "load16_u" (i32.const 40000)) (i32.const 40000)) \ No newline at end of file From 056e48f349b43c144cf6ee47f2b36e918b2be038 Mon Sep 17 00:00:00 2001 From: Andrew Scheidecker Date: Wed, 23 Sep 2015 07:11:03 -0400 Subject: [PATCH 2/3] renamed value -> bits --- ml-proto/src/spec/memory.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/ml-proto/src/spec/memory.ml b/ml-proto/src/spec/memory.ml index 63a0cc98d5..6a93255a05 100644 --- a/ml-proto/src/spec/memory.ml +++ b/ml-proto/src/spec/memory.ml @@ -90,20 +90,20 @@ let load32 mem a = let load64 mem a = Int64.logor (Int64.of_int32 (load32 mem a)) (Int64.shift_left (Int64.of_int32 (load32 mem (a+4))) 32) -let store8 mem a value = - !mem.{a} <- Int32.to_int (Int32.logand value (Int32.of_int 255)) +let store8 mem a bits = + !mem.{a} <- Int32.to_int (Int32.logand bits (Int32.of_int 255)) -let store16 mem a value = - store8 mem (a+0) value; - store8 mem (a+1) (Int32.shift_right_logical value 8) +let store16 mem a bits = + store8 mem (a+0) bits; + store8 mem (a+1) (Int32.shift_right_logical bits 8) -let store32 mem a value = - store16 mem (a+0) value; - store16 mem (a+2) (Int32.shift_right_logical value 16) +let store32 mem a bits = + store16 mem (a+0) bits; + store16 mem (a+2) (Int32.shift_right_logical bits 16) -let store64 mem a value = - store32 mem (a+0) (Int64.to_int32 value); - store32 mem (a+4) (Int64.to_int32 (Int64.shift_right_logical value 32)) +let store64 mem a bits = + store32 mem (a+0) (Int64.to_int32 bits); + store32 mem (a+4) (Int64.to_int32 (Int64.shift_right_logical bits 32)) let load mem a memty ext = let open Types in From 8f3c6f4dc208897f52c035ab99011a79bf128b43 Mon Sep 17 00:00:00 2001 From: Andrew Scheidecker Date: Wed, 23 Sep 2015 07:13:08 -0400 Subject: [PATCH 3/3] Removed unnecessary type annotations --- ml-proto/src/spec/memory.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ml-proto/src/spec/memory.ml b/ml-proto/src/spec/memory.ml index 6a93255a05..16181ec418 100644 --- a/ml-proto/src/spec/memory.ml +++ b/ml-proto/src/spec/memory.ml @@ -118,7 +118,7 @@ let load mem a memty ext = | _ -> raise Type with Invalid_argument _ -> raise Bounds -let store (mem : t) (a : int) (memty : mem_type) v = +let store mem a memty v = try (match memty, v with | Int8Mem, Int32 x -> store8 mem a x