Merge pull request #55 from WebAssembly/update-load-store

Update load/store to match design changes

Author: lukewagner

ml-proto/README.md

@@ -127,8 +127,8 @@ type expr =
   | SetLocal of var * expr                  (* write local variable
   | LoadGlobal of var                       (* read global variable
   | StoreGlobal of var * expr               (* write global variable
-  | Load of memop * expr                    (* read memory address
-  | Store of memop * expr * expr            (* write memory address
+  | Load of loadop * expr                   (* read memory address
+  | Store of storeop * expr * expr          (* write memory address
   | Const of value                          (* constant
   | Unary of unop * expr                    (* unary arithmetic operator
   | Binary of binop * expr * expr           (* binary arithmetic operator
@@ -147,7 +147,6 @@ The S-expression syntax is defined in `parser.mly`, the opcodes in `lexer.mll`.
 
 ```
 type: i32 | i64 | f32 | f64
-memtype: <type> | i8 | i16
 
 value: <int> | <float>
 var: <int> | $<name>
@@ -157,7 +156,6 @@ binop: add | sub | mul | ...
 relop: eq | neq | lt | ...
 sign: s|u
 align: 1|2|4|8|...
-memop: (<sign>.)?(<align>.)?
 cvtop: trunc_s | trunc_u | extend_s | extend_u | ...
 
 expr:
@@ -177,8 +175,8 @@ expr:
   ( set_local <var> <expr> )
   ( load_global <var> )
   ( store_global <var> <expr> )
-  ( <type>.load<memop><memtype> <expr> )
-  ( <type>.store<memop><memtype> <expr> <expr> )
+  ( <type>.load((8|16)_<sign>)?(/<align>)? <expr> )
+  ( <type>.store(/<align>)? <expr> <expr> )
   ( <type>.const <value> )
   ( <type>.<unop> <expr> )
   ( <type>.<binop> <expr> <expr> )

ml-proto/src/host/lexer.mll

@@ -60,27 +60,32 @@ let floatop t f32 f64 =
   | "f64" -> Values.Float64 f64
   | _ -> assert false
 
-let mem_type t sign memty =
+let mem_type mty =
   let open Memory in
-  match t, sign, memty with
-  | ("i32" | "i64"), 's', "i8" -> SInt8Mem
-  | ("i32" | "i64"), 's', "i16" -> SInt16Mem
-  | ("i32" | "i64"), 's', "i32" -> SInt32Mem
-  | "i64", 's', "i64" -> SInt64Mem
-  | ("i32" | "i64"), 'u', "i8" -> UInt8Mem
-  | ("i32" | "i64"), 'u', "i16" -> UInt16Mem
-  | ("i32" | "i64"), 'u', "i32" -> UInt32Mem
-  | "i64", 'u', "i64" -> UInt64Mem
-  | "f32", ' ', "f32" -> Float32Mem
-  | "f64", ' ', "f64" -> Float64Mem
+  match mty with
+  | "i8" -> Int8Mem
+  | "i16" -> Int16Mem
+  | "i32" -> Int32Mem
+  | "i64" -> Int64Mem
+  | "f32" -> Float32Mem
+  | "f64" -> Float64Mem
   | _ -> assert false
 
-let memop ty sign memsize a =
-  let memty = mem_type ty sign memsize in
-  let align = if a = "" then Memory.mem_size memty else int_of_string a in
-  {ty = value_type ty; mem = memty; align}
-}
+let loadop t sign a =
+  let mem = mem_type t in
+  let ext = match sign with
+    | ' ' -> Memory.NX
+    | 's' -> Memory.SX
+    | 'u' -> Memory.ZX
+    | _ -> assert false in
+  let align = if a = "" then Memory.mem_size mem else int_of_string a in
+  {mem; ext; align}
 
+let storeop t a =
+  let mem = mem_type t in
+  let align = if a = "" then Memory.mem_size mem else int_of_string a in
+  {mem; align}
+}
 
 let space = [' ''\t']
 let digit = ['0'-'9']
@@ -104,6 +109,7 @@ let mixx = "i" ("8" | "16" | "32" | "64")
 let mfxx = "f" ("32" | "64")
 let sign = "s" | "u"
 let align = digit+
+let width = digit+
 
 rule token = parse
   | "(" { LPAR }
@@ -138,17 +144,14 @@ rule token = parse
   | "load_global" { LOADGLOBAL }
   | "store_global" { STOREGLOBAL }
 
-  | (ixx as t)".load_"(sign as s)"/"(mixx as m)"/"(align as a)
-    { LOAD (memop t s m a) }
-  | (ixx as t)".load_"(sign as s)"/"(mixx as m) { LOAD (memop t s m "") }
-  | (ixx as t)".load/"(mixx as m)"/"(align as a) { LOAD (memop t 's' m a) }
-  | (ixx as t)".load/"(mixx as m) { LOAD (memop t 's' m "") }
-  | (ixx as t)".store/"(mixx as m)"/"(align as a) { STORE (memop t 's' m a) }
-  | (ixx as t)".store/"(mixx as m) { STORE (memop t 's' m "") }
-  | (fxx as t)".load/"(mfxx as m)"/"(align as a) { LOAD (memop t ' ' m a) }
-  | (fxx as t)".store/"(mfxx as m)"/"(align as a) { STORE (memop t ' ' m a) }
-  | (fxx as t)".load/"(mfxx as m) { LOAD (memop t ' ' m "") }
-  | (fxx as t)".store/"(mfxx as m) { STORE (memop t ' ' m "") }
+  | (nxx as t)".load" { LOAD (loadop t ' ' "") }
+  | (nxx as t)".load/"(align as a) { LOAD (loadop t ' ' a) }
+  | (ixx)".load"(width as w)"_"(sign as s) { LOAD (loadop ("i" ^ w) s "") }
+  | (ixx)".load"(width as w)"_"(sign as s)"/"(align as a) { LOAD (loadop ("i" ^ w) s a) }
+  | (nxx as t)".store" { STORE (storeop t "") }
+  | (nxx as t)".store/"(align as a) { STORE (storeop t a) }
+  | (ixx)".store"(width as w) { STORE (storeop ("i" ^ w) "") }
+  | (ixx)".store"(width as w)"/"(align as a) { STORE (storeop ("i" ^ w) a) }
 
   | (nxx as t)".switch" { SWITCH (value_type t) }
   | (nxx as t)".const" { CONST (value_type t) }

ml-proto/src/host/parser.mly

@@ -113,8 +113,8 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels}
 %token<Ast.binop> BINARY
 %token<Ast.relop> COMPARE
 %token<Ast.cvt> CONVERT
-%token<Ast.memop> LOAD
-%token<Ast.memop> STORE
+%token<Ast.loadop> LOAD
+%token<Ast.storeop> STORE
 
 %start script
 %type<Script.script> script

ml-proto/src/spec/ast.ml

@@ -63,7 +63,8 @@ type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op
 type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op
 type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op
 
-type memop = {ty : Types.value_type; mem : Memory.mem_type; align : int}
+type loadop = {mem : Memory.mem_type; ext : Memory.extension; align : int}
+type storeop = {mem : Memory.mem_type; align : int}
 
 
 (* Expressions *)
@@ -87,8 +88,8 @@ and expr' =
   | SetLocal of var * expr
   | LoadGlobal of var
   | StoreGlobal of var * expr
-  | Load of memop * expr
-  | Store of memop * expr * expr
+  | Load of loadop * expr
+  | Store of storeop * expr * expr
   | Const of literal
   | Unary of unop * expr
   | Binary of binop * expr * expr

ml-proto/src/spec/check.ml

@@ -54,14 +54,10 @@ let check_func_type actual expected at =
 (* Type Synthesis *)
 
 let type_mem = function
-  | Memory.SInt8Mem -> Int32Type
-  | Memory.SInt16Mem -> Int32Type
-  | Memory.SInt32Mem -> Int32Type
-  | Memory.SInt64Mem -> Int64Type
-  | Memory.UInt8Mem -> Int32Type
-  | Memory.UInt16Mem -> Int32Type
-  | Memory.UInt32Mem -> Int32Type
-  | Memory.UInt64Mem -> Int64Type
+  | Memory.Int8Mem -> Int32Type
+  | Memory.Int16Mem -> Int32Type
+  | Memory.Int32Mem -> Int32Type
+  | Memory.Int64Mem -> Int64Type
   | Memory.Float32Mem -> Float32Type
   | Memory.Float64Mem -> Float64Type
 
@@ -184,15 +180,15 @@ let rec check_expr c et e =
     check_expr c (Some (global c x)) e1;
     check_type None et e.at
 
-  | Load (memop, e1) ->
-    check_memop memop e.at;
+  | Load (loadop, e1) ->
+    check_align loadop.align e.at;
     check_expr c (Some Int32Type) e1;
-    check_type (Some (type_mem memop.mem)) et e.at
+    check_type (Some (type_mem loadop.mem)) et e.at
 
-  | Store (memop, e1, e2) ->
-    check_memop memop e.at;
+  | Store (storeop, e1, e2) ->
+    check_align storeop.align e.at;
     check_expr c (Some Int32Type) e1;
-    check_expr c (Some memop.ty) e2;
+    check_expr c (Some (type_mem storeop.mem)) e2;
     check_type None et e.at
 
   | Const v ->
@@ -238,17 +234,8 @@ and check_arm c t et arm =
   check_literal c (Some t) l;
   check_expr c (if fallthru then None else et) e
 
-and check_memop {ty; mem; align} at =
-  require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment";
-  let open Memory in
-  match mem, ty with
-  | (SInt8Mem | SInt16Mem | SInt32Mem), Int32Type
-  | (UInt8Mem | UInt16Mem | UInt32Mem), Int32Type
-  | (SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem), Int64Type
-  | (UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem), Int64Type
-  | Float32Mem, Float32Type
-  | Float64Mem, Float64Type -> ()
-  | _ -> error at "type-inconsistent memory operator"
+and check_align align at =
+  require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment"
 
 
 (*

ml-proto/src/spec/eval.ml

@@ -156,12 +156,12 @@ let rec eval_expr (c : config) (e : expr) =
     global c x := v1;
     None
 
-  | Load ({mem; ty; _}, e1) ->
+  | Load ({mem; ext; align = _}, e1) ->
     let v1 = some (eval_expr c e1) e1.at in
-    (try Some (Memory.load c.modul.memory (Memory.address_of_value v1) mem ty)
+    (try Some (Memory.load c.modul.memory (Memory.address_of_value v1) mem ext)
     with exn -> memory_error e.at exn)
 
-  | Store ({mem; _}, e1, e2) ->
+  | Store ({mem; align = _}, e1, e2) ->
     let v1 = some (eval_expr c e1) e1.at in
     let v2 = some (eval_expr c e2) e2.at in
     (try Memory.store c.modul.memory (Memory.address_of_value v1) mem v2

ml-proto/src/spec/memory.ml

@@ -10,10 +10,9 @@ open Bigarray
 type address = int
 type size = address
 type mem_size = int
+type extension = SX | ZX | NX
 type mem_type =
-  | SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
-  | UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
-  | Float32Mem | Float64Mem
+  Int8Mem | Int16Mem | Int32Mem | Int64Mem | Float32Mem | Float64Mem
 
 type segment =
 {
@@ -42,10 +41,10 @@ let view : memory -> ('c, 'd, c_layout) Array1.t = Obj.magic
 (* Queries *)
 
 let mem_size = function
-  | SInt8Mem | UInt8Mem -> 1
-  | SInt16Mem | UInt16Mem -> 2
-  | SInt32Mem | UInt32Mem | Float32Mem -> 4
-  | SInt64Mem | UInt64Mem | Float64Mem -> 8
+  | Int8Mem -> 1
+  | Int16Mem -> 2
+  | Int32Mem | Float32Mem -> 4
+  | Int64Mem | Float64Mem -> 8
 
 
 (* Creation and initialization *)
@@ -83,51 +82,31 @@ let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask
 
 let buf = create 8
 
-let load mem a memty valty =
+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, valty with
-    | SInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint8_view).{0})
-    | SInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint8_view).{0})
-    | SInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : sint16_view).{0})
-    | SInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : sint16_view).{0})
-    | SInt32Mem, Int32Type -> Int32 (view buf : sint32_view).{0}
-    | SInt32Mem, Int64Type ->
-      Int64 (Int64.of_int32 (view buf : sint32_view).{0})
-    | SInt64Mem, Int64Type -> Int64 (view buf : sint64_view).{0}
-    | UInt8Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint8_view).{0})
-    | UInt8Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint8_view).{0})
-    | UInt16Mem, Int32Type -> Int32 (Int32.of_int (view buf : uint16_view).{0})
-    | UInt16Mem, Int64Type -> Int64 (Int64.of_int (view buf : uint16_view).{0})
-    | UInt32Mem, Int32Type -> Int32 (view buf : uint32_view).{0}
-    | UInt32Mem, Int64Type ->
-      Int64 (int64_of_int32_u (view buf : uint32_view).{0})
-    | UInt64Mem, Int64Type -> Int64 (view buf : uint64_view).{0}
-    | Float32Mem, Float32Type -> Float32 (view buf : float32_view).{0}
-    | Float64Mem, Float64Type -> Float64 (view buf : float64_view).{0}
+    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 (view buf : float32_view).{0}
+    | Float64Mem, NX -> Float64 (view buf : float64_view).{0}
     | _ -> raise Type
   with Invalid_argument _ -> raise Bounds
 
 let store mem a memty v =
   let sz = mem_size memty in
   try
     (match memty, v with
-    | SInt8Mem, Int32 x -> (view buf : sint8_view).{0} <- Int32.to_int x
-    | SInt8Mem, Int64 x -> (view buf : sint8_view).{0} <- Int64.to_int x
-    | SInt16Mem, Int32 x -> (view buf : sint16_view).{0} <- Int32.to_int x
-    | SInt16Mem, Int64 x -> (view buf : sint16_view).{0} <- Int64.to_int x
-    | SInt32Mem, Int32 x -> (view buf : sint32_view).{0} <- x
-    | SInt32Mem, Int64 x -> (view buf : sint32_view).{0} <- Int64.to_int32 x
-    | SInt64Mem, Int64 x -> (view buf : sint64_view).{0} <- x
-    | UInt8Mem, Int32 x -> (view buf : uint8_view).{0} <- Int32.to_int x
-    | UInt8Mem, Int64 x -> (view buf : uint8_view).{0} <- Int64.to_int x
-    | UInt16Mem, Int32 x -> (view buf : uint16_view).{0} <- Int32.to_int x
-    | UInt16Mem, Int64 x -> (view buf : uint16_view).{0} <- Int64.to_int x
-    | UInt32Mem, Int32 x -> (view buf : uint32_view).{0} <- x
-    | UInt32Mem, Int64 x -> (view buf : uint32_view).{0} <- Int64.to_int32 x
-    | UInt64Mem, Int64 x -> (view buf : uint64_view).{0} <- x
+    | 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} <- x
     | Float64Mem, Float64 x -> (view buf : float64_view).{0} <- x
     | _ -> raise Type);

ml-proto/src/spec/memory.mli

@@ -7,10 +7,9 @@ type t = memory
 type address = int
 type size = address
 type mem_size = int
+type extension = SX | ZX | NX
 type mem_type =
-  | SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem
-  | UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem
-  | Float32Mem | Float64Mem
+  Int8Mem | Int16Mem | Int32Mem | Int64Mem | Float32Mem | Float64Mem
 
 type segment = {addr : address; data : string}
 
@@ -20,7 +19,7 @@ exception Address
 
 val create : size -> memory
 val init : memory -> segment list -> unit
-val load : memory -> address -> mem_type -> Types.value_type -> Values.value
+val load : memory -> address -> mem_type -> extension -> Values.value
 val store : memory -> address -> mem_type -> Values.value -> unit
 
 val mem_size : mem_type -> mem_size