Skip to content

Commit ae419ca

Browse files
lukewagnerlukewagner
committed
Merge pull request #86 from WebAssembly/update-load-store
Update load/store to match design repo changes
2 parents 70817af + 658123a commit ae419ca

File tree

8 files changed

+225
-158
lines changed

8 files changed

+225
-158
lines changed

‎ml-proto/src/host/lexer.mll

Lines changed: 31 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -60,31 +60,25 @@ let floatop t f32 f64 =
6060
| "f64" -> Values.Float64 f64
6161
| _ -> assert false
6262

63-
let mem_type mty =
64-
let open Memory in
65-
match mty with
66-
| "i8" -> Int8Mem
67-
| "i16" -> Int16Mem
68-
| "i32" -> Int32Mem
69-
| "i64" -> Int64Mem
70-
| "f32" -> Float32Mem
71-
| "f64" -> Float64Mem
63+
let memop t a =
64+
{ty = value_type t; align = if a = "" then None else Some (int_of_string a)}
65+
66+
let mem_size = function
67+
| "8" -> Memory.Mem8
68+
| "16" -> Memory.Mem16
69+
| "32" -> Memory.Mem32
70+
| _ -> assert false
71+
72+
let extension = function
73+
| 's' -> Memory.SX
74+
| 'u' -> Memory.ZX
7275
| _ -> assert false
7376

74-
let loadop t sign a =
75-
let mem = mem_type t in
76-
let ext = match sign with
77-
| ' ' -> Memory.NX
78-
| 's' -> Memory.SX
79-
| 'u' -> Memory.ZX
80-
| _ -> assert false in
81-
let align = if a = "" then Memory.mem_size mem else int_of_string a in
82-
{mem; ext; align}
83-
84-
let storeop t a =
85-
let mem = mem_type t in
86-
let align = if a = "" then Memory.mem_size mem else int_of_string a in
87-
{mem; align}
77+
let extendop t sz s a =
78+
{memop = memop t a; sz = mem_size sz; ext = extension s}
79+
80+
let truncop t sz a =
81+
{memop = memop t a; sz = mem_size sz}
8882
}
8983

9084
let space = [' ''\t']
@@ -110,7 +104,7 @@ let mixx = "i" ("8" | "16" | "32" | "64")
110104
let mfxx = "f" ("32" | "64")
111105
let sign = "s" | "u"
112106
let align = digit+
113-
let width = digit+
107+
let mem_size = "8" | "16" | "32"
114108

115109
rule token = parse
116110
| "(" { LPAR }
@@ -143,14 +137,19 @@ rule token = parse
143137
| "get_local" { GETLOCAL }
144138
| "set_local" { SETLOCAL }
145139

146-
| (nxx as t)".load" { LOAD (loadop t ' ' "") }
147-
| (nxx as t)".load/"(align as a) { LOAD (loadop t ' ' a) }
148-
| (ixx)".load"(width as w)"_"(sign as s) { LOAD (loadop ("i" ^ w) s "") }
149-
| (ixx)".load"(width as w)"_"(sign as s)"/"(align as a) { LOAD (loadop ("i" ^ w) s a) }
150-
| (nxx as t)".store" { STORE (storeop t "") }
151-
| (nxx as t)".store/"(align as a) { STORE (storeop t a) }
152-
| (ixx)".store"(width as w) { STORE (storeop ("i" ^ w) "") }
153-
| (ixx)".store"(width as w)"/"(align as a) { STORE (storeop ("i" ^ w) a) }
140+
| (nxx as t)".load" { LOAD (memop t "") }
141+
| (nxx as t)".load/"(align as a) { LOAD (memop t a) }
142+
| (nxx as t)".store" { STORE (memop t "") }
143+
| (nxx as t)".store/"(align as a) { STORE (memop t a) }
144+
145+
| (ixx as t)".load"(mem_size as sz)"_"(sign as s)
146+
{ LOADEXTEND (extendop t sz s "") }
147+
| (ixx as t)".load"(mem_size as sz)"_"(sign as s)"/"(align as a)
148+
{ LOADEXTEND (extendop t sz s a) }
149+
| (ixx as t)".store"(mem_size as sz)
150+
{ STORETRUNC (truncop t sz "") }
151+
| (ixx as t)".store"(mem_size as sz)"/"(align as a)
152+
{ STORETRUNC (truncop t sz a) }
154153

155154
| (nxx as t)".switch" { SWITCH (value_type t) }
156155
| (nxx as t)".const" { CONST (value_type t) }

‎ml-proto/src/host/parser.mly

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -113,8 +113,10 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels}
113113
%token<Ast.binop> BINARY
114114
%token<Ast.relop> COMPARE
115115
%token<Ast.cvt> CONVERT
116-
%token<Ast.loadop> LOAD
117-
%token<Ast.storeop> STORE
116+
%token<Ast.memop> LOAD
117+
%token<Ast.memop> STORE
118+
%token<Ast.extendop> LOADEXTEND
119+
%token<Ast.truncop> STORETRUNC
118120

119121
%start script
120122
%type<Script.script> script
@@ -179,7 +181,9 @@ oper :
179181
| SETLOCAL var expr { fun c -> SetLocal ($2 c local, $3 c) }
180182
| LOAD expr { fun c -> Load ($1, $2 c) }
181183
| STORE expr expr { fun c -> Store ($1, $2 c, $3 c) }
182-
| CONST literal { fun c -> Const (literal (ati 2) $2 $1) }
184+
| LOADEXTEND expr { fun c -> LoadExtend ($1, $2 c) }
185+
| STORETRUNC expr expr { fun c -> StoreTrunc ($1, $2 c, $3 c) }
186+
| CONST literal { let at = at() in fun c -> Const (literal at $2 $1) }
183187
| UNARY expr { fun c -> Unary ($1, $2 c) }
184188
| BINARY expr expr { fun c -> Binary ($1, $2 c, $3 c) }
185189
| COMPARE expr expr { fun c -> Compare ($1, $2 c, $3 c) }

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

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -63,9 +63,9 @@ type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op
6363
type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op
6464
type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op
6565

66-
type loadop = {mem : Memory.mem_type; ext : Memory.extension; align : int}
67-
type storeop = {mem : Memory.mem_type; align : int}
68-
66+
type memop = {ty : Types.value_type; align : int option}
67+
type extendop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension}
68+
type truncop = {memop : memop; sz : Memory.mem_size}
6969

7070
(* Expressions *)
7171

@@ -87,8 +87,10 @@ and expr' =
8787
| Return of expr option
8888
| GetLocal of var
8989
| SetLocal of var * expr
90-
| Load of loadop * expr
91-
| Store of storeop * expr * expr
90+
| Load of memop * expr
91+
| Store of memop * expr * expr
92+
| LoadExtend of extendop * expr
93+
| StoreTrunc of truncop * expr * expr
9294
| Const of literal
9395
| Unary of unop * expr
9496
| Binary of binop * expr * expr

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

Lines changed: 28 additions & 18 deletions
Original file line numberDiff line numberDiff line change
@@ -53,14 +53,6 @@ let check_func_type actual expected at =
5353

5454
(* Type Synthesis *)
5555

56-
let type_mem = function
57-
| Memory.Int8Mem -> Int32Type
58-
| Memory.Int16Mem -> Int32Type
59-
| Memory.Int32Mem -> Int32Type
60-
| Memory.Int64Mem -> Int64Type
61-
| Memory.Float32Mem -> Float32Type
62-
| Memory.Float64Mem -> Float64Type
63-
6456
let type_value = Values.type_of
6557
let type_unop = Values.type_of
6658
let type_binop = Values.type_of
@@ -182,16 +174,19 @@ let rec check_expr c et e =
182174
check_expr c (Some (local c x)) e1;
183175
check_type None et e.at
184176

185-
| Load (loadop, e1) ->
186-
check_align loadop.align e.at;
187-
check_expr c (Some Int32Type) e1;
188-
check_type (Some (type_mem loadop.mem)) et e.at
177+
| Load (memop, e1) ->
178+
check_load c et memop e1 e.at
189179

190-
| Store (storeop, e1, e2) ->
191-
check_align storeop.align e.at;
192-
check_expr c (Some Int32Type) e1;
193-
check_expr c (Some (type_mem storeop.mem)) e2;
194-
check_type None et e.at
180+
| Store (memop, e1, e2) ->
181+
check_store c et memop e1 e2 e.at
182+
183+
| LoadExtend (extendop, e1) ->
184+
check_mem_type extendop.memop.ty extendop.sz e.at;
185+
check_load c et extendop.memop e1 e.at
186+
187+
| StoreTrunc (truncop, e1, e2) ->
188+
check_mem_type truncop.memop.ty truncop.sz e.at;
189+
check_store c et truncop.memop e1 e2 e.at
195190

196191
| Const v ->
197192
check_literal c et v
@@ -246,8 +241,23 @@ and check_arm c t et arm =
246241
check_literal c (Some t) l;
247242
check_expr c (if fallthru then None else et) e
248243

244+
and check_load c et memop e1 at =
245+
check_align memop.align at;
246+
check_expr c (Some Int32Type) e1;
247+
check_type (Some memop.ty) et at
248+
249+
and check_store c et memop e1 e2 at =
250+
check_align memop.align at;
251+
check_expr c (Some Int32Type) e1;
252+
check_expr c (Some memop.ty) e2;
253+
check_type None et at
254+
249255
and check_align align at =
250-
require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment"
256+
Lib.Option.app (fun a ->
257+
require (Lib.Int.is_power_of_two a) at "non-power-of-two alignment") align
258+
259+
and check_mem_type ty sz at =
260+
require (ty = Int64Type || sz <> Memory.Mem32) at "memory size too big"
251261

252262

253263
(*

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

Lines changed: 20 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -168,15 +168,31 @@ let rec eval_expr (c : config) (e : expr) =
168168
local c x := v1;
169169
None
170170

171-
| Load ({mem; ext; align = _}, e1) ->
171+
| Load ({ty; align = _}, e1) ->
172172
let v1 = some (eval_expr c e1) e1.at in
173-
(try Some (Memory.load c.modul.memory (Memory.address_of_value v1) mem ext)
173+
let a = Memory.address_of_value v1 in
174+
(try Some (Memory.load c.modul.memory a ty)
174175
with exn -> memory_error e.at exn)
175176

176-
| Store ({mem; align = _}, e1, e2) ->
177+
| Store ({ty = _; align = _}, e1, e2) ->
177178
let v1 = some (eval_expr c e1) e1.at in
178179
let v2 = some (eval_expr c e2) e2.at in
179-
(try Memory.store c.modul.memory (Memory.address_of_value v1) mem v2
180+
let a = Memory.address_of_value v1 in
181+
(try Memory.store c.modul.memory a v2
182+
with exn -> memory_error e.at exn);
183+
None
184+
185+
| LoadExtend ({memop = {ty; align = _}; sz; ext}, e1) ->
186+
let v1 = some (eval_expr c e1) e1.at in
187+
let a = Memory.address_of_value v1 in
188+
(try Some (Memory.load_extend c.modul.memory a sz ext ty)
189+
with exn -> memory_error e.at exn)
190+
191+
| StoreTrunc ({memop = {ty; align = _}; sz}, e1, e2) ->
192+
let v1 = some (eval_expr c e1) e1.at in
193+
let v2 = some (eval_expr c e2) e2.at in
194+
let a = Memory.address_of_value v1 in
195+
(try Memory.store_trunc c.modul.memory a sz v2
180196
with exn -> memory_error e.at exn);
181197
None
182198

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

Lines changed: 64 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -3,35 +3,24 @@
33
*)
44

55
open Bigarray
6+
open Types
7+
open Values
68

79

810
(* Types and view types *)
911

1012
type address = int
1113
type size = address
12-
type mem_size = int
13-
type extension = SX | ZX | NX
14-
type mem_type =
15-
Int8Mem | Int16Mem | Int32Mem | Int64Mem | Float32Mem | Float64Mem
16-
17-
type segment =
18-
{
19-
addr : address;
20-
data : string
21-
}
14+
type mem_size = Mem8 | Mem16 | Mem32
15+
type extension = SX | ZX
16+
type segment = {addr : address; data : string}
17+
type value_type = Types.value_type
18+
type value = Values.value
2219

2320
type memory' = (int, int8_unsigned_elt, c_layout) Array1.t
2421
type memory = memory' ref
2522
type t = memory
2623

27-
(* Queries *)
28-
29-
let mem_size = function
30-
| Int8Mem -> 1
31-
| Int16Mem -> 2
32-
| Int32Mem | Float32Mem -> 4
33-
| Int64Mem | Float64Mem -> 8
34-
3524

3625
(* Creation and initialization *)
3726

@@ -77,57 +66,60 @@ let address_of_value = function
7766

7867
(* Load and store *)
7968

80-
let load8 mem a ext =
81-
(match ext with
82-
| SX -> Int32.shift_right (Int32.shift_left (Int32.of_int !mem.{a}) 24) 24
83-
| _ -> Int32.of_int !mem.{a})
84-
85-
let load16 mem a ext =
86-
Int32.logor (load8 mem a NX) (Int32.shift_left (load8 mem (a+1) ext) 8)
87-
88-
let load32 mem a =
89-
Int32.logor (load16 mem a NX) (Int32.shift_left (load16 mem (a+2) NX) 16)
90-
91-
let load64 mem a =
92-
Int64.logor (Int64.of_int32 (load32 mem a)) (Int64.shift_left (Int64.of_int32 (load32 mem (a+4))) 32)
93-
94-
let store8 mem a bits =
95-
(* Store the lowest 8 bits of "bits" at byte index a, discarding the rest. *)
96-
!mem.{a} <- Int32.to_int bits
97-
98-
let store16 mem a bits =
99-
store8 mem (a+0) bits;
100-
store8 mem (a+1) (Int32.shift_right_logical bits 8)
101-
102-
let store32 mem a bits =
103-
store16 mem (a+0) bits;
104-
store16 mem (a+2) (Int32.shift_right_logical bits 16)
105-
106-
let store64 mem a bits =
107-
store32 mem (a+0) (Int64.to_int32 bits);
108-
store32 mem (a+4) (Int64.to_int32 (Int64.shift_right_logical bits 32))
109-
110-
let load mem a memty ext =
111-
let open Types in
112-
try
113-
match memty, ext with
114-
| Int8Mem, _ -> Int32 (I32.of_int32 (load8 mem a ext))
115-
| Int16Mem, _ -> Int32 (I32.of_int32 (load16 mem a ext))
116-
| Int32Mem, NX -> Int32 (I32.of_int32 (load32 mem a))
117-
| Int64Mem, NX -> Int64 (I64.of_int64 (load64 mem a))
118-
| Float32Mem, NX -> Float32 (F32.of_bits (load32 mem a))
119-
| Float64Mem, NX -> Float64 (F64.of_bits (load64 mem a))
120-
| _ -> raise Type
121-
with Invalid_argument _ -> raise Bounds
122-
123-
let store mem a memty v =
124-
try
125-
(match memty, v with
126-
| Int8Mem, Int32 x -> store8 mem a (I32.to_int32 x)
127-
| Int16Mem, Int32 x -> store16 mem a (I32.to_int32 x)
128-
| Int32Mem, Int32 x -> store32 mem a (I32.to_int32 x)
129-
| Int64Mem, Int64 x -> store64 mem a (I64.to_int64 x)
130-
| Float32Mem, Float32 x -> store32 mem a (F32.to_bits x)
131-
| Float64Mem, Float64 x -> store64 mem a (F64.to_bits x)
132-
| _ -> raise Type)
133-
with Invalid_argument _ -> raise Bounds
69+
let rec loadn mem n a =
70+
assert (n > 0 && n <= 8);
71+
let byte = try Int64.of_int !mem.{a} with Invalid_argument _ -> raise Bounds in
72+
if n = 1 then
73+
byte
74+
else
75+
Int64.logor byte (Int64.shift_left (loadn mem (n-1) (a+1)) 8)
76+
77+
let rec storen mem n a v =
78+
assert (n > 0 && n <= 8);
79+
let byte = (Int64.to_int v) land 255 in
80+
(try !mem.{a} <- byte with Invalid_argument _ -> raise Bounds);
81+
if (n > 1) then
82+
storen mem (n-1) (a+1) (Int64.shift_right v 8)
83+
84+
let load mem a t =
85+
match t with
86+
| Int32Type -> Int32 (Int64.to_int32 (loadn mem 4 a))
87+
| Int64Type -> Int64 (loadn mem 8 a)
88+
| Float32Type -> Float32 (F32.of_bits (Int64.to_int32 (loadn mem 4 a)))
89+
| Float64Type -> Float64 (F64.of_bits (loadn mem 8 a))
90+
91+
let store mem a v =
92+
match v with
93+
| Int32 x -> storen mem 4 a (Int64.of_int32 x)
94+
| Int64 x -> storen mem 8 a x
95+
| Float32 x -> storen mem 4 a (Int64.of_int32 (F32.to_bits x))
96+
| Float64 x -> storen mem 8 a (F64.to_bits x)
97+
98+
let loadn_sx mem n a =
99+
assert (n > 0 && n <= 8);
100+
let v = loadn mem n a in
101+
let shift = 64 - (8 * n) in
102+
Int64.shift_right (Int64.shift_left v shift) shift
103+
104+
let load_extend mem a sz ext t =
105+
match sz, ext, t with
106+
| Mem8, ZX, Int32Type -> Int32 (Int64.to_int32 (loadn mem 1 a))
107+
| Mem8, SX, Int32Type -> Int32 (Int64.to_int32 (loadn_sx mem 1 a))
108+
| Mem8, ZX, Int64Type -> Int64 (loadn mem 1 a)
109+
| Mem8, SX, Int64Type -> Int64 (loadn_sx mem 1 a)
110+
| Mem16, ZX, Int32Type -> Int32 (Int64.to_int32 (loadn mem 2 a))
111+
| Mem16, SX, Int32Type -> Int32 (Int64.to_int32 (loadn_sx mem 2 a))
112+
| Mem16, ZX, Int64Type -> Int64 (loadn mem 2 a)
113+
| Mem16, SX, Int64Type -> Int64 (loadn_sx mem 2 a)
114+
| Mem32, ZX, Int64Type -> Int64 (loadn mem 4 a)
115+
| Mem32, SX, Int64Type -> Int64 (loadn_sx mem 4 a)
116+
| _ -> raise Type
117+
118+
let store_trunc mem a sz v =
119+
match sz, v with
120+
| Mem8, Int32 x -> storen mem 1 a (Int64.of_int32 x)
121+
| Mem8, Int64 x -> storen mem 1 a x
122+
| Mem16, Int32 x -> storen mem 2 a (Int64.of_int32 x)
123+
| Mem16, Int64 x -> storen mem 2 a x
124+
| Mem32, Int64 x -> storen mem 4 a x
125+
| _ -> raise Type

0 commit comments

Comments
 (0)