Skip to content

Commit df77a0a

Browse files
rossbergrossberg
committed
Merge pull request #84 from AndrewScheidecker/removed_magic_from_memory
Got rid of Obj.magic use in memory module
2 parents 261f0a1 + 8f3c6f4 commit df77a0a

File tree

2 files changed

+73
-38
lines changed

2 files changed

+73
-38
lines changed

‎ml-proto/src/spec/memory.ml

Lines changed: 41 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -24,21 +24,6 @@ type memory' = (int, int8_unsigned_elt, c_layout) Array1.t
2424
type memory = memory' ref
2525
type t = memory
2626

27-
type char_view = (char, int8_unsigned_elt, c_layout) Array1.t
28-
type sint8_view = (int, int8_signed_elt, c_layout) Array1.t
29-
type sint16_view = (int, int16_signed_elt, c_layout) Array1.t
30-
type sint32_view = (int32, int32_elt, c_layout) Array1.t
31-
type sint64_view = (int64, int64_elt, c_layout) Array1.t
32-
type uint8_view = (int, int8_unsigned_elt, c_layout) Array1.t
33-
type uint16_view = (int, int16_unsigned_elt, c_layout) Array1.t
34-
type uint32_view = (int32, int32_elt, c_layout) Array1.t
35-
type uint64_view = (int64, int64_elt, c_layout) Array1.t
36-
type float32_view = (int32, int32_elt, c_layout) Array1.t
37-
type float64_view = (int64, int64_elt, c_layout) Array1.t
38-
39-
let view : memory' -> ('c, 'd, c_layout) Array1.t = Obj.magic
40-
41-
4227
(* Queries *)
4328

4429
let mem_size = function
@@ -65,7 +50,7 @@ let create n =
6550
let init_seg mem seg =
6651
(* There currently is no way to blit from a string. *)
6752
for i = 0 to String.length seg.data - 1 do
68-
(view !mem : char_view).{seg.addr + i} <- seg.data.[i]
53+
!mem.{seg.addr + i} <- Char.code seg.data.[i]
6954
done
7055

7156
let init mem segs =
@@ -91,38 +76,56 @@ let address_of_value = function
9176

9277
(* Load and store *)
9378

94-
let int32_mask = Int64.shift_right_logical (Int64.of_int (-1)) 32
95-
let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask
79+
let load8 mem a ext =
80+
(match ext with
81+
| SX -> Int32.shift_right (Int32.shift_left (Int32.of_int !mem.{a}) 24) 24
82+
| _ -> Int32.of_int !mem.{a})
83+
84+
let load16 mem a ext =
85+
Int32.logor (load8 mem a NX) (Int32.shift_left (load8 mem (a+1) ext) 8)
86+
87+
let load32 mem a =
88+
Int32.logor (load16 mem a NX) (Int32.shift_left (load16 mem (a+2) NX) 16)
89+
90+
let load64 mem a =
91+
Int64.logor (Int64.of_int32 (load32 mem a)) (Int64.shift_left (Int64.of_int32 (load32 mem (a+4))) 32)
92+
93+
let store8 mem a bits =
94+
!mem.{a} <- Int32.to_int (Int32.logand bits (Int32.of_int 255))
95+
96+
let store16 mem a bits =
97+
store8 mem (a+0) bits;
98+
store8 mem (a+1) (Int32.shift_right_logical bits 8)
99+
100+
let store32 mem a bits =
101+
store16 mem (a+0) bits;
102+
store16 mem (a+2) (Int32.shift_right_logical bits 16)
96103

97-
let buf = create' 8
104+
let store64 mem a bits =
105+
store32 mem (a+0) (Int64.to_int32 bits);
106+
store32 mem (a+4) (Int64.to_int32 (Int64.shift_right_logical bits 32))
98107

99108
let load mem a memty ext =
100-
let sz = mem_size memty in
101109
let open Types in
102110
try
103-
Array1.blit (Array1.sub !mem a sz) (Array1.sub buf 0 sz);
104111
match memty, ext with
105-
| Int8Mem, SX -> Int32 (Int32.of_int (view buf : sint8_view).{0})
106-
| Int8Mem, ZX -> Int32 (Int32.of_int (view buf : uint8_view).{0})
107-
| Int16Mem, SX -> Int32 (Int32.of_int (view buf : sint16_view).{0})
108-
| Int16Mem, ZX -> Int32 (Int32.of_int (view buf : uint16_view).{0})
109-
| Int32Mem, NX -> Int32 (view buf : sint32_view).{0}
110-
| Int64Mem, NX -> Int64 (view buf : sint64_view).{0}
111-
| Float32Mem, NX -> Float32 (Float32.of_bits (view buf : float32_view).{0})
112-
| Float64Mem, NX -> Float64 (Float64.of_bits (view buf : float64_view).{0})
112+
| Int8Mem, _ -> Int32 (load8 mem a ext)
113+
| Int16Mem, _ -> Int32 (load16 mem a ext)
114+
| Int32Mem, NX -> Int32 (load32 mem a)
115+
| Int64Mem, NX -> Int64 (load64 mem a)
116+
| Float32Mem, NX -> Float32 (Float32.of_bits (load32 mem a))
117+
| Float64Mem, NX -> Float64 (Float64.of_bits (load64 mem a))
113118
| _ -> raise Type
114119
with Invalid_argument _ -> raise Bounds
115120

116121
let store mem a memty v =
117-
let sz = mem_size memty in
118122
try
119123
(match memty, v with
120-
| Int8Mem, Int32 x -> (view buf : sint8_view).{0} <- Int32.to_int x
121-
| Int16Mem, Int32 x -> (view buf : sint16_view).{0} <- Int32.to_int x
122-
| Int32Mem, Int32 x -> (view buf : sint32_view).{0} <- x
123-
| Int64Mem, Int64 x -> (view buf : sint64_view).{0} <- x
124-
| Float32Mem, Float32 x -> (view buf : float32_view).{0} <- Float32.to_bits x
125-
| Float64Mem, Float64 x -> (view buf : float64_view).{0} <- Float64.to_bits x
126-
| _ -> raise Type);
127-
Array1.blit (Array1.sub buf 0 sz) (Array1.sub !mem a sz)
124+
| Int8Mem, Int32 x -> store8 mem a x
125+
| Int16Mem, Int32 x -> store16 mem a x
126+
| Int32Mem, Int32 x -> store32 mem a x
127+
| Int64Mem, Int64 x -> store64 mem a x
128+
| Float32Mem, Float32 x -> store32 mem a (Float32.to_bits x)
129+
| Float64Mem, Float64 x -> store64 mem a (Float64.to_bits x)
130+
| _ -> raise Type)
128131
with Invalid_argument _ -> raise Bounds

‎ml-proto/test/memory.wasm

Lines changed: 32 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -139,13 +139,45 @@
139139
(return (f64.load/1 (i32.const 9)))
140140
)
141141

142+
;; Sign and zero extending memory loads
143+
(func $load8_s (param $i i32) (result i32)
144+
(i32.store8 (i32.const 8) (get_local $i))
145+
(return (i32.load8_s (i32.const 8)))
146+
)
147+
(func $load8_u (param $i i32) (result i32)
148+
(i32.store8 (i32.const 8) (get_local $i))
149+
(return (i32.load8_u (i32.const 8)))
150+
)
151+
(func $load16_s (param $i i32) (result i32)
152+
(i32.store16 (i32.const 8) (get_local $i))
153+
(return (i32.load16_s (i32.const 8)))
154+
)
155+
(func $load16_u (param $i i32) (result i32)
156+
(i32.store16 (i32.const 8) (get_local $i))
157+
(return (i32.load16_u (i32.const 8)))
158+
)
159+
142160
(export "data" $data)
143161
(export "aligned" $aligned)
144162
(export "unaligned" $unaligned)
145163
(export "cast" $cast)
164+
(export "load8_s" $load8_s)
165+
(export "load8_u" $load8_u)
166+
(export "load16_s" $load16_s)
167+
(export "load16_u" $load16_u)
146168
)
147169

148170
(assert_eq (invoke "data") (i32.const 1))
149171
(assert_eq (invoke "aligned") (i32.const 1))
150172
(assert_eq (invoke "unaligned") (i32.const 1))
151173
(assert_eq (invoke "cast") (f64.const 42.0))
174+
175+
(assert_eq (invoke "load8_s" (i32.const -1)) (i32.const -1))
176+
(assert_eq (invoke "load8_u" (i32.const -1)) (i32.const 255))
177+
(assert_eq (invoke "load16_s" (i32.const -1)) (i32.const -1))
178+
(assert_eq (invoke "load16_u" (i32.const -1)) (i32.const 65535))
179+
180+
(assert_eq (invoke "load8_s" (i32.const 100)) (i32.const 100))
181+
(assert_eq (invoke "load8_u" (i32.const 200)) (i32.const 200))
182+
(assert_eq (invoke "load16_s" (i32.const 20000)) (i32.const 20000))
183+
(assert_eq (invoke "load16_u" (i32.const 40000)) (i32.const 40000))

0 commit comments

Comments
 (0)