Allow multiple data segments

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;

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

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

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 }

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 *)
 

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
 

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,15 +251,30 @@ 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 }
 ;
 
 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() }

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

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))
+      )
     )
   )