Skip to content

Commit 6f5b968

Browse files
rossbergrossberg
committed
Adapt memory operations
1 parent 453f64d commit 6f5b968

File tree

12 files changed

+153
-120
lines changed

12 files changed

+153
-120
lines changed

‎ml-proto/src/ast.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -62,7 +62,7 @@ type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op
6262
type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op
6363
type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op
6464

65-
type memop = {align : int; mem : Memory.mem_type}
65+
type memop = {ty : Types.value_type; mem : Memory.mem_type; align : int}
6666

6767

6868
(* Expressions *)

‎ml-proto/src/check.ml

Lines changed: 12 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -196,7 +196,7 @@ let rec check_expr c ts e =
196196
| Store (memop, e1, e2) ->
197197
check_memop memop e.at;
198198
check_expr c [Int32Type] e1;
199-
check_expr c [type_mem memop.mem] e2;
199+
check_expr c [memop.ty] e2;
200200
check_type [] ts e.at
201201

202202
| Const v ->
@@ -239,8 +239,17 @@ and check_arm c t ts arm =
239239
check_literal c [t] l;
240240
check_expr c (if fallthru then [] else ts) e
241241

242-
and check_memop memop at =
243-
require (Lib.is_power_of_two memop.align) at "non-power-of-two alignment"
242+
and check_memop {ty; mem; align} at =
243+
require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment";
244+
let open Memory in
245+
match mem, ty with
246+
| (SInt8Mem | SInt16Mem | SInt32Mem), Int32Type
247+
| (UInt8Mem | UInt16Mem | UInt32Mem), Int32Type
248+
| (SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem), Int64Type
249+
| (UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem), Int64Type
250+
| Float32Mem, Float32Type
251+
| Float64Mem, Float64Type -> ()
252+
| _ -> error at "type-inconsistent memory operator"
244253

245254

246255
(*

‎ml-proto/src/eval.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -162,9 +162,9 @@ let rec eval_expr c e =
162162
global c x := v1;
163163
[]
164164

165-
| Load ({mem; _}, e1) ->
165+
| Load ({mem; ty; _}, e1) ->
166166
let v1 = unary (eval_expr c e1) e1.at in
167-
(try [Memory.load c.modul.memory (Memory.address_of_value v1) mem]
167+
(try [Memory.load c.modul.memory (Memory.address_of_value v1) mem ty]
168168
with exn -> memory_error e.at exn)
169169

170170
| Store ({mem; _}, e1, e2) ->

‎ml-proto/src/lexer.mll

Lines changed: 46 additions & 49 deletions
Original file line numberDiff line numberDiff line change
@@ -48,21 +48,6 @@ let value_type = function
4848
| "f64" -> Types.Float64Type
4949
| _ -> assert false
5050

51-
let mem_type s t =
52-
let open Memory in
53-
match s, t with
54-
| 's', "i8" -> SInt8Mem
55-
| 's', "i16" -> SInt16Mem
56-
| 's', "i32" -> SInt32Mem
57-
| 's', "i64" -> SInt64Mem
58-
| 'u', "i8" -> UInt8Mem
59-
| 'u', "i16" -> UInt16Mem
60-
| 'u', "i32" -> UInt32Mem
61-
| 'u', "i64" -> UInt64Mem
62-
| ' ', "f32" -> Float32Mem
63-
| ' ', "f64" -> Float64Mem
64-
| _ -> assert false
65-
6651
let intop t i32 i64 =
6752
match t with
6853
| "i32" -> Values.Int32 i32
@@ -75,16 +60,25 @@ let floatop t f32 f64 =
7560
| "f64" -> Values.Float64 f64
7661
| _ -> assert false
7762

78-
let default_alignment = function
79-
| "i8" -> 1
80-
| "i16" -> 2
81-
| "i32" | "f32" -> 4
82-
| "i64" | "f64" -> 8
63+
let mem_type t sign memty =
64+
let open Memory in
65+
match t, sign, memty with
66+
| ("i32" | "i64"), 's', "i8" -> SInt8Mem
67+
| ("i32" | "i64"), 's', "i16" -> SInt16Mem
68+
| ("i32" | "i64"), 's', "i32" -> SInt32Mem
69+
| "i64", 's', "i64" -> SInt64Mem
70+
| ("i32" | "i64"), 'u', "i8" -> UInt8Mem
71+
| ("i32" | "i64"), 'u', "i16" -> UInt16Mem
72+
| ("i32" | "i64"), 'u', "i32" -> UInt32Mem
73+
| "i64", 'u', "i64" -> UInt64Mem
74+
| "f32", ' ', "f32" -> Float32Mem
75+
| "f64", ' ', "f64" -> Float64Mem
8376
| _ -> assert false
8477

85-
let memop a s t =
86-
let align = if a = "" then default_alignment t else int_of_string a in
87-
{align; mem = mem_type s t}
78+
let memop ty sign memsize a =
79+
let memty = mem_type ty sign memsize in
80+
let align = if a = "" then Memory.mem_size memty else int_of_string a in
81+
{ty = value_type ty; mem = memty; align}
8882
}
8983

9084

@@ -145,16 +139,19 @@ rule token = parse
145139
| "load_global" { LOADGLOBAL }
146140
| "store_global" { STOREGLOBAL }
147141

148-
| "load_"(sign as s)"."(align as a)"."(mixx as t) { LOAD (memop a s t) }
149-
| "store_"(sign as s)"."(align as a)"."(mixx as t) { STORE (memop a s t) }
150-
| "load_"(sign as s)"."(mixx as t) { LOAD (memop "" s t) }
151-
| "store_"(sign as s)"."(mixx as t) { STORE (memop "" s t) }
152-
| "load."(align as a)"."(mfxx as t) { LOAD (memop a ' ' t) }
153-
| "store."(align as a)"."(mfxx as t) { STORE (memop a ' ' t) }
154-
| "load."(mfxx as t) { LOAD (memop "" ' ' t) }
155-
| "store."(mfxx as t) { STORE (memop "" ' ' t) }
142+
| (ixx as t)".load_"(sign as s)"/"(mixx as m)"/"(align as a)
143+
{ LOAD (memop t s m a) }
144+
| (ixx as t)".load_"(sign as s)"/"(mixx as m) { LOAD (memop t s m "") }
145+
| (ixx as t)".load/"(mixx as m)"/"(align as a) { LOAD (memop t 's' m a) }
146+
| (ixx as t)".load/"(mixx as m) { LOAD (memop t 's' m "") }
147+
| (ixx as t)".store/"(mixx as m)"/"(align as a) { STORE (memop t 's' m a) }
148+
| (ixx as t)".store/"(mixx as m) { STORE (memop t 's' m "") }
149+
| (fxx as t)".load/"(mfxx as m)"/"(align as a) { LOAD (memop t ' ' m a) }
150+
| (fxx as t)".store/"(mfxx as m)"/"(align as a) { STORE (memop t ' ' m a) }
151+
| (fxx as t)".load/"(mfxx as m) { LOAD (memop t ' ' m "") }
152+
| (fxx as t)".store/"(mfxx as m) { STORE (memop t ' ' m "") }
156153

157-
| "switch."(nxx as t) { SWITCH (value_type t) }
154+
| "switch/"(nxx as t) { SWITCH (value_type t) }
158155
| (nxx as t)".const" { CONST (value_type t) }
159156

160157
| (ixx as t)".neg" { UNARY (intop t Int32Op.Neg Int64Op.Neg) }
@@ -206,31 +203,31 @@ rule token = parse
206203
| (fxx as t)".gt" { COMPARE (floatop t Float32Op.Gt Float64Op.Gt) }
207204
| (fxx as t)".ge" { COMPARE (floatop t Float32Op.Ge Float64Op.Ge) }
208205

209-
| "i64.extend_s.i32" { CONVERT (Values.Int64 Int64Op.ExtendSInt32) }
210-
| "i64.extend_u.i32" { CONVERT (Values.Int64 Int64Op.ExtendUInt32) }
211-
| "i64.wrap.i64" { CONVERT (Values.Int32 Int32Op.WrapInt64) }
212-
| (ixx as t)".trunc_s.f32"
206+
| "i64.extend_s/i32" { CONVERT (Values.Int64 Int64Op.ExtendSInt32) }
207+
| "i64.extend_u/i32" { CONVERT (Values.Int64 Int64Op.ExtendUInt32) }
208+
| "i64.wrap/i64" { CONVERT (Values.Int32 Int32Op.WrapInt64) }
209+
| (ixx as t)".trunc_s/f32"
213210
{ CONVERT (intop t Int32Op.TruncSFloat32 Int64Op.TruncSFloat32) }
214-
| (ixx as t)".trunc_u.f32"
211+
| (ixx as t)".trunc_u/f32"
215212
{ CONVERT (intop t Int32Op.TruncUFloat32 Int64Op.TruncUFloat32) }
216-
| (ixx as t)".trunc_s.f64"
213+
| (ixx as t)".trunc_s/f64"
217214
{ CONVERT (intop t Int32Op.TruncSFloat64 Int64Op.TruncSFloat64) }
218-
| (ixx as t)".trunc_u.f64"
215+
| (ixx as t)".trunc_u/f64"
219216
{ CONVERT (intop t Int32Op.TruncUFloat64 Int64Op.TruncUFloat64) }
220-
| (fxx as t)".convert_s.i32"
217+
| (fxx as t)".convert_s/i32"
221218
{ CONVERT (floatop t Float32Op.ConvertSInt32 Float64Op.ConvertSInt32) }
222-
| (fxx as t)".convert_u.i32"
219+
| (fxx as t)".convert_u/i32"
223220
{ CONVERT (floatop t Float32Op.ConvertUInt32 Float64Op.ConvertUInt32) }
224-
| (fxx as t)".convert_s.i64"
221+
| (fxx as t)".convert_s/i64"
225222
{ CONVERT (floatop t Float32Op.ConvertSInt64 Float64Op.ConvertSInt64) }
226-
| (fxx as t)".convert_u.i64"
223+
| (fxx as t)".convert_u/i64"
227224
{ CONVERT (floatop t Float32Op.ConvertUInt64 Float64Op.ConvertUInt64) }
228-
| "f64.promote.f32" { CONVERT (Values.Float64 Float64Op.PromoteFloat32) }
229-
| "f32.demote.f64" { CONVERT (Values.Float32 Float32Op.DemoteFloat64) }
230-
| "f32.reinterpret.i32" { CONVERT (Values.Float32 Float32Op.ReinterpretInt) }
231-
| "f64.reinterpret.i64" { CONVERT (Values.Float64 Float64Op.ReinterpretInt) }
232-
| "i32.reinterpret.f32" { CONVERT (Values.Int32 Int32Op.ReinterpretFloat) }
233-
| "i64.reinterpret.f64" { CONVERT (Values.Int64 Int64Op.ReinterpretFloat) }
225+
| "f64.promote/f32" { CONVERT (Values.Float64 Float64Op.PromoteFloat32) }
226+
| "f32.demote/f64" { CONVERT (Values.Float32 Float32Op.DemoteFloat64) }
227+
| "f32.reinterpret/i32" { CONVERT (Values.Float32 Float32Op.ReinterpretInt) }
228+
| "f64.reinterpret/i64" { CONVERT (Values.Float64 Float64Op.ReinterpretInt) }
229+
| "i32.reinterpret/f32" { CONVERT (Values.Int32 Int32Op.ReinterpretFloat) }
230+
| "i64.reinterpret/f64" { CONVERT (Values.Int64 Int64Op.ReinterpretFloat) }
234231

235232
| "func" { FUNC }
236233
| "param" { PARAM }

‎ml-proto/src/lib.ml

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,9 @@ struct
3838
| None -> ()
3939
end
4040

41-
let is_power_of_two x =
42-
assert (x >= 0);
43-
x <> 0 && (x land (x - 1)) == 0
41+
module Int =
42+
struct
43+
let is_power_of_two x =
44+
if x < 0 then failwith "is_power_of_two";
45+
x <> 0 && (x land (x - 1)) = 0
46+
end

‎ml-proto/src/lib.mli

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -19,4 +19,7 @@ sig
1919
val app : ('a -> unit) -> 'a option -> unit
2020
end
2121

22-
val is_power_of_two : int -> bool
22+
module Int :
23+
sig
24+
val is_power_of_two : int -> bool
25+
end

‎ml-proto/src/memory.ml

Lines changed: 47 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -9,18 +9,12 @@ open Bigarray
99

1010
type address = int
1111
type size = address
12-
type alignment = Aligned | Unaligned
12+
type mem_size = int
1313
type mem_type =
1414
| SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
1515
| UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
1616
| Float32Mem | Float64Mem
1717

18-
let mem_size = function
19-
| SInt8Mem | UInt8Mem -> 1
20-
| SInt16Mem | UInt16Mem -> 2
21-
| SInt32Mem | UInt32Mem | Float32Mem -> 4
22-
| SInt64Mem | UInt64Mem | Float64Mem -> 8
23-
2418
type segment =
2519
{
2620
addr : address;
@@ -45,8 +39,18 @@ type float64_view = (float, float64_elt, c_layout) Array1.t
4539
let view : memory -> ('c, 'd, c_layout) Array1.t = Obj.magic
4640

4741

42+
(* Queries *)
43+
44+
let mem_size = function
45+
| SInt8Mem | UInt8Mem -> 1
46+
| SInt16Mem | UInt16Mem -> 2
47+
| SInt32Mem | UInt32Mem | Float32Mem -> 4
48+
| SInt64Mem | UInt64Mem | Float64Mem -> 8
49+
50+
4851
(* Creation and initialization *)
4952

53+
exception Type
5054
exception Bounds
5155
exception Address
5256

@@ -74,39 +78,58 @@ let address_of_value = function
7478

7579
(* Load and store *)
7680

81+
let int32_mask = Int64.shift_right_logical (Int64.of_int (-1)) 32
82+
let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask
83+
7784
let buf = create 8
7885

79-
let load mem a ty =
80-
let sz = mem_size ty in
86+
let load mem a memty valty =
87+
let sz = mem_size memty in
88+
let open Types in
8189
try
8290
Array1.blit (Array1.sub mem a sz) (Array1.sub buf 0 sz);
83-
match ty with
84-
| SInt8Mem -> Int32 (Int32.of_int (view buf : sint8_view).{0})
85-
| SInt16Mem -> Int32 (Int32.of_int (view buf : sint16_view).{0})
86-
| SInt32Mem -> Int32 (view buf : sint32_view).{0}
87-
| SInt64Mem -> Int64 (view buf : sint64_view).{0}
88-
| UInt8Mem -> Int32 (Int32.of_int (view buf : uint8_view).{0})
89-
| UInt16Mem -> Int32 (Int32.of_int (view buf : uint16_view).{0})
90-
| UInt32Mem -> Int32 (view buf : uint32_view).{0}
91-
| UInt64Mem -> Int64 (view buf : uint64_view).{0}
92-
| Float32Mem -> Float32 (view buf : float32_view).{0}
93-
| Float64Mem -> Float64 (view buf : float64_view).{0}
91+
match memty, valty with
92+
| SInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint8_view).{0})
93+
| SInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint8_view).{0})
94+
| SInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint16_view).{0})
95+
| SInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint16_view).{0})
96+
| SInt32Mem, Int32Type -> Int32 (view buf : sint32_view).{0}
97+
| SInt32Mem, Int64Type ->
98+
Int64 (Int64.of_int32 (view buf : sint32_view).{0})
99+
| SInt64Mem, Int64Type -> Int64 (view buf : sint64_view).{0}
100+
| UInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint8_view).{0})
101+
| UInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint8_view).{0})
102+
| UInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint16_view).{0})
103+
| UInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint16_view).{0})
104+
| UInt32Mem, Int32Type -> Int32 (view buf : uint32_view).{0}
105+
| UInt32Mem, Int64Type ->
106+
Int64 (int64_of_int32_u (view buf : uint32_view).{0})
107+
| UInt64Mem, Int64Type -> Int64 (view buf : uint64_view).{0}
108+
| Float32Mem, Float32Type -> Float32 (view buf : float32_view).{0}
109+
| Float64Mem, Float64Type -> Float64 (view buf : float64_view).{0}
110+
| _ -> raise Type
94111
with Invalid_argument _ -> raise Bounds
95112

96-
let store mem a ty v =
97-
let sz = mem_size ty in
113+
let store mem a memty v =
114+
let sz = mem_size memty in
98115
try
99-
(match ty, v with
116+
(match memty, v with
100117
| SInt8Mem, Int32 x -> (view buf : sint8_view).{0} <- Int32.to_int x
118+
| SInt8Mem, Int64 x -> (view buf : sint8_view).{0} <- Int64.to_int x
101119
| SInt16Mem, Int32 x -> (view buf : sint16_view).{0} <- Int32.to_int x
120+
| SInt16Mem, Int64 x -> (view buf : sint16_view).{0} <- Int64.to_int x
102121
| SInt32Mem, Int32 x -> (view buf : sint32_view).{0} <- x
122+
| SInt32Mem, Int64 x -> (view buf : sint32_view).{0} <- Int64.to_int32 x
103123
| SInt64Mem, Int64 x -> (view buf : sint64_view).{0} <- x
104124
| UInt8Mem, Int32 x -> (view buf : uint8_view).{0} <- Int32.to_int x
125+
| UInt8Mem, Int64 x -> (view buf : uint8_view).{0} <- Int64.to_int x
105126
| UInt16Mem, Int32 x -> (view buf : uint16_view).{0} <- Int32.to_int x
127+
| UInt16Mem, Int64 x -> (view buf : uint16_view).{0} <- Int64.to_int x
106128
| UInt32Mem, Int32 x -> (view buf : uint32_view).{0} <- x
129+
| UInt32Mem, Int64 x -> (view buf : uint32_view).{0} <- Int64.to_int32 x
107130
| UInt64Mem, Int64 x -> (view buf : uint64_view).{0} <- x
108131
| Float32Mem, Float32 x -> (view buf : float32_view).{0} <- x
109132
| Float64Mem, Float64 x -> (view buf : float64_view).{0} <- x
110-
| _ -> assert false);
133+
| _ -> raise Type);
111134
Array1.blit (Array1.sub buf 0 sz) (Array1.sub mem a sz)
112135
with Invalid_argument _ -> raise Bounds

‎ml-proto/src/memory.mli

Lines changed: 5 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,24 +6,22 @@ type memory
66
type t = memory
77
type address = int
88
type size = address
9+
type mem_size = int
910
type mem_type =
1011
| SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
1112
| UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
1213
| Float32Mem | Float64Mem
13-
val mem_size : mem_type -> int
1414

15-
type segment =
16-
{
17-
addr : address;
18-
data : string
19-
}
15+
type segment = {addr : address; data : string}
2016

17+
exception Type
2118
exception Bounds
2219
exception Address
2320

2421
val create : size -> memory
2522
val init : memory -> segment list -> unit
26-
val load : memory -> address -> mem_type -> Values.value
23+
val load : memory -> address -> mem_type -> Types.value_type -> Values.value
2724
val store : memory -> address -> mem_type -> Values.value -> unit
2825

26+
val mem_size : mem_type -> mem_size
2927
val address_of_value : Values.value -> address

0 commit comments

Comments
 (0)