diff --git a/ml-proto/src/ast.ml b/ml-proto/src/ast.ml index 659db2b990..04839eea60 100644 --- a/ml-proto/src/ast.ml +++ b/ml-proto/src/ast.ml @@ -105,6 +105,15 @@ and arm' = (* Functions and Modules *) +type memory = memory' Source.phrase +and memory' = +{ + initial : Memory.size; + max : Memory.size; + segments : segment list; +} +and segment = Memory.segment Source.phrase + type func = func' Source.phrase and func' = { @@ -122,8 +131,7 @@ type table = var list Source.phrase type modul = modul' Source.phrase and modul' = { - memory : int64 * int64; - data : string; + memory : memory option; funcs : func list; exports : export list; tables : table list; diff --git a/ml-proto/src/check.ml b/ml-proto/src/check.ml index 13d6fa562d..9a96b892d1 100644 --- a/ml-proto/src/check.ml +++ b/ml-proto/src/check.ml @@ -275,10 +275,24 @@ let check_export c ex = let {name = _; func = x} = ex.it in ignore (func c x) -let check_module m = - let {funcs; exports; tables; globals; memory; data} = m.it in - require (fst memory >= Int64.of_int (String.length data)) m.at +let check_segment memory prev_end seg = + let seg_end = seg.it.Memory.addr + String.length seg.it.Memory.data in + require (seg.it.Memory.addr >= prev_end) seg.at + "data section not disjoint and ordered"; + require (memory.it.initial >= seg_end) seg.at "data section does not fit memory"; + seg_end + +let check_memory memory = + require (memory.it.initial <= memory.it.max) memory.at + "initial memory size must be less than maximum"; + ignore (List.fold_left (check_segment memory) 0 memory.it.segments) + +let check_module m = + let {funcs; exports; tables; globals; memory} = m.it in + match memory with + | Some memory -> check_memory memory + | None -> (); let c = {c0 with funcs = List.map type_func funcs; globals = List.map it globals} in let c' = List.fold_left check_table c tables in diff --git a/ml-proto/src/eval.ml b/ml-proto/src/eval.ml index 6bf6922d8a..7d2bc8a652 100644 --- a/ml-proto/src/eval.ml +++ b/ml-proto/src/eval.ml @@ -244,9 +244,14 @@ and eval_func m f vs = (* Modules *) let init m = - let {Ast.funcs; exports; tables; globals; memory = (n, _); data} = m.it in - let memory = Memory.create (Int64.to_int n) in - Memory.init memory data; + let {Ast.funcs; exports; tables; globals; memory} = m.it in + let memory = match memory with + | Some {it = {initial; segments} } -> + let m = Memory.create initial in + Memory.init m (List.map (fun seg -> seg.it) segments); + m + | None -> Memory.create 0 + in let func x = List.nth funcs x.it in let export ex = ExportMap.add ex.it.name (func ex.it.func) in let exports = List.fold_right export exports ExportMap.empty in diff --git a/ml-proto/src/lexer.mll b/ml-proto/src/lexer.mll index f6e84f08e0..914f78dffb 100644 --- a/ml-proto/src/lexer.mll +++ b/ml-proto/src/lexer.mll @@ -245,7 +245,7 @@ rule token = parse | "local" { LOCAL } | "module" { MODULE } | "memory" { MEMORY } - | "data" { DATA } + | "segment" { SEGMENT } | "global" { GLOBAL } | "import" { IMPORT } | "export" { EXPORT } diff --git a/ml-proto/src/memory.ml b/ml-proto/src/memory.ml index a4885b7f15..f13a081be6 100644 --- a/ml-proto/src/memory.ml +++ b/ml-proto/src/memory.ml @@ -8,11 +8,17 @@ open Bigarray (* Types and view types *) type address = int +type size = address type alignment = Aligned | Unaligned type mem_type = | SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem | UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem | Float32Mem | Float64Mem +type segment = +{ + addr : address; + data : string +} type memory = (int, int8_unsigned_elt, c_layout) Array1.t type t = memory @@ -43,13 +49,14 @@ let create n = Array1.fill mem 0; mem -let init mem s = - if String.length s > Array1.dim mem then raise Bounds; +let init_seg mem seg = (* There currently is no way to blit from a string. *) - for i = 0 to String.length s - 1 do - (view mem : char_view).{i} <- s.[i] + for i = 0 to String.length seg.data - 1 do + (view mem : char_view).{seg.addr + i} <- seg.data.[i] done +let init mem segs = + try List.iter (init_seg mem) segs with Invalid_argument _ -> raise Bounds (* Alignment *) diff --git a/ml-proto/src/memory.mli b/ml-proto/src/memory.mli index 5d2b1527b3..40e61aa846 100644 --- a/ml-proto/src/memory.mli +++ b/ml-proto/src/memory.mli @@ -5,18 +5,25 @@ type memory type t = memory type address = int +type size = address type alignment = Aligned | Unaligned type mem_type = | SInt8Mem | SInt16Mem | SInt32Mem | SInt64Mem | UInt8Mem | UInt16Mem | UInt32Mem | UInt64Mem | Float32Mem | Float64Mem +type segment = +{ + addr : address; + data : string +} + exception Bounds exception Align exception Address -val create : int -> memory -val init : memory -> string -> unit +val create : size -> memory +val init : memory -> segment list -> unit val load : memory -> alignment -> address -> mem_type -> Values.value val store : memory -> alignment -> address -> mem_type -> Values.value -> unit diff --git a/ml-proto/src/parser.mly b/ml-proto/src/parser.mly index bfe4cdba73..1b04f6cd77 100644 --- a/ml-proto/src/parser.mly +++ b/ml-proto/src/parser.mly @@ -97,7 +97,7 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} %token CALL DISPATCH RETURN DESTRUCT %token GETLOCAL SETLOCAL GETGLOBAL SETGLOBAL GETMEMORY SETMEMORY %token CONST UNARY BINARY COMPARE CONVERT -%token FUNC PARAM RESULT LOCAL MODULE MEMORY DATA GLOBAL IMPORT EXPORT TABLE +%token FUNC PARAM RESULT LOCAL MODULE MEMORY SEGMENT GLOBAL IMPORT EXPORT TABLE %token INVOKE ASSERTEQ %token EOF @@ -251,6 +251,21 @@ func : /* Modules */ +segment : + | LPAR SEGMENT INT TEXT RPAR { {Memory.addr = int_of_string $3; Memory.data = $4} @@ at() } +; +segment_list : + | /* empty */ { [] } + | segment segment_list { $1 :: $2 } +; + +memory : + | LPAR MEMORY INT INT segment_list RPAR + { {initial = int_of_string $3; max = int_of_string $4; segments = $5 } @@ at() } + | LPAR MEMORY INT segment_list RPAR + { {initial = int_of_string $3; max = int_of_string $3; segments = $4 } @@ at() } +; + export : | LPAR EXPORT TEXT var RPAR { let at = at() in fun c -> {name = $3; func = $4 c func} @@ at } @@ -258,8 +273,8 @@ export : module_fields : | /* empty */ - { fun c -> let memory = (Int64.zero, Int64.zero) in - {memory; data = ""; funcs = []; exports = []; globals = []; tables = []} } + { fun c -> + {memory = None; funcs = []; exports = []; globals = []; tables = []} } | func module_fields { fun c -> let f = $1 c in let m = $2 c in {m with funcs = f () :: m.funcs} } @@ -275,15 +290,11 @@ module_fields : | LPAR TABLE var_list RPAR module_fields { fun c -> let m = $5 c in {m with tables = ($3 c func @@ ati 3) :: m.tables} } - | LPAR MEMORY INT INT RPAR module_fields - { fun c -> let m = $6 c in - {m with memory = (Int64.of_string $3, Int64.of_string $4)} } - | LPAR MEMORY INT RPAR module_fields /* Sugar */ - { fun c -> let m = $5 c in - {m with memory = (Int64.of_string $3, Int64.of_string $3)} } - | LPAR DATA TEXT RPAR module_fields - { fun c -> let m = $5 c in - {m with data = $3 ^ m.data} } + | memory module_fields + { fun c -> let m = $2 c in + match m.memory with + | Some _ -> Error.error $1.at "more than one memory section" + | None -> {m with memory = Some $1} } ; modul : | LPAR MODULE module_fields RPAR { $3 (c0 ()) @@ at() } diff --git a/ml-proto/src/types.ml b/ml-proto/src/types.ml index be9e56f5c5..2a325e7411 100644 --- a/ml-proto/src/types.ml +++ b/ml-proto/src/types.ml @@ -16,7 +16,6 @@ type value_type = Int32Type | Int64Type | Float32Type | Float64Type type expr_type = value_type list type func_type = {ins : expr_type; outs : expr_type} - (* String conversion *) let string_of_value_type = function diff --git a/ml-proto/test/memory.wasm b/ml-proto/test/memory.wasm index 93d8634743..a2b112ae80 100644 --- a/ml-proto/test/memory.wasm +++ b/ml-proto/test/memory.wasm @@ -1,14 +1,19 @@ ;; (c) 2015 Andreas Rossberg (module - (memory 1024) - (data "ABC\a7D") + (memory 1024 (segment 0 "ABC\a7D") (segment 20 "WASM")) ;; Data section (func $data (result i32) (and.i32 - (eq.i32 (getnearu.i8 (const.i32 0)) (const.i32 65)) - (eq.i32 (getfaru.i8 (const.i64 3)) (const.i32 167)) + (and.i32 + (eq.i32 (getnearu.i8 (const.i32 0)) (const.i32 65)) + (eq.i32 (getfaru.i8 (const.i64 3)) (const.i32 167)) + ) + (and.i32 + (eq.i32 (getnearu.i8 (const.i32 20)) (const.i32 87)) + (eq.i32 (getfaru.i8 (const.i64 23)) (const.i32 77)) + ) ) )