Add resizing

ml-proto/README.md

@@ -135,6 +135,9 @@ type expr =
   | Binary of binop * expr * expr           (* binary arithmetic operator
   | Compare of relop * expr * expr          (* arithmetic comparison
   | Convert of cvt * expr                   (* conversion
+  | PageSize                                (* return host-defined page_size
+  | MemorySize                              (* return current size of linear memory
+  | ResizeMemory                            (* resize linear memory
 
 and arm = {value : value; expr : expr; fallthru : bool}
 ```
@@ -184,6 +187,9 @@ expr:
   ( <type>.<binop> <expr> <expr> )
   ( <type>.<relop> <expr> <expr> )
   ( <type>.<cvtop>/<type> <expr> )
+  ( page_size )
+  ( memory_size )
+  ( resize_memory <expr> )
 
 case:
   ( case <value> <expr>* fallthrough? )  ;; = (case <int> (block <expr>*) fallthrough?)

ml-proto/src/Makefile

@@ -5,13 +5,13 @@
 NAME = wasm
 INCLUDES = -I host -I given -I spec
 MODULES = \
-  host/flags given/lib given/source given/float32 given/float64 spec/error \
+  host/params host/flags given/lib given/source given/float32 given/float64 spec/error \
   spec/types spec/values spec/memory spec/ast \
   spec/check spec/arithmetic spec/eval \
   host/print host/builtins host/script \
   host/lexer host/parser \
   host/main
-NOMLI = host/flags spec/types spec/values spec/ast host/main
+NOMLI = host/params host/flags spec/types spec/values spec/ast host/main
 PARSERS = host/parser
 LEXERS = host/lexer
 LIBRARIES = bigarray nums str

ml-proto/src/host/lexer.mll

@@ -235,6 +235,10 @@ rule token = parse
   | "i32.reinterpret/f32" { CONVERT (Values.Int32 Int32Op.ReinterpretFloat) }
   | "i64.reinterpret/f64" { CONVERT (Values.Int64 Int64Op.ReinterpretFloat) }
 
+  | "page_size" { PAGESIZE }
+  | "memory_size" { MEMORYSIZE }
+  | "resize_memory" { RESIZEMEMORY }
+
   | "func" { FUNC }
   | "param" { PARAM }
   | "result" { RESULT }

ml-proto/src/host/params.ml

@@ -0,0 +1 @@
+let page_size = 4096

ml-proto/src/host/parser.mly

@@ -103,6 +103,7 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels}
 %token GETLOCAL SETLOCAL LOADGLOBAL STOREGLOBAL LOAD STORE
 %token CONST UNARY BINARY COMPARE CONVERT
 %token FUNC PARAM RESULT LOCAL MODULE MEMORY SEGMENT GLOBAL IMPORT EXPORT TABLE
+%token PAGESIZE MEMORYSIZE RESIZEMEMORY
 %token ASSERTINVALID ASSERTEQ ASSERTFAULT INVOKE
 %token EOF
 
@@ -190,6 +191,9 @@ oper :
   | BINARY expr expr { fun c -> Binary ($1, $2 c, $3 c) }
   | COMPARE expr expr { fun c -> Compare ($1, $2 c, $3 c) }
   | CONVERT expr { fun c -> Convert ($1, $2 c) }
+  | PAGESIZE { fun c -> PageSize }
+  | MEMORYSIZE { fun c -> MemorySize }
+  | RESIZEMEMORY expr { fun c -> ResizeMemory ($2 c) }
 ;
 expr_opt :
   | /* empty */ { fun c -> None }

ml-proto/src/host/script.ml

@@ -49,7 +49,8 @@ let run_command cmd =
     end;
     trace "Initializing...";
     let imports = Builtins.match_imports m.it.Ast.imports in
-    current_module := Some (Eval.init m imports)
+    let host_params = {Eval.page_size = Params.page_size} in
+    current_module := Some (Eval.init m imports host_params)
 
   | AssertInvalid (m, re) ->
     trace "Checking invalid...";

ml-proto/src/spec/ast.ml

@@ -96,6 +96,9 @@ and expr' =
   | Binary of binop * expr * expr
   | Compare of relop * expr * expr
   | Convert of cvt * expr
+  | PageSize
+  | MemorySize
+  | ResizeMemory of expr
 
 and arm = arm' Source.phrase
 and arm' =

ml-proto/src/spec/check.ml

@@ -227,6 +227,16 @@ let rec check_expr c et e =
     check_expr c (Some t1) e1;
     check_type (Some t) et e.at
 
+  | PageSize ->
+    check_type (Some Int32Type) et e.at
+
+  | MemorySize ->
+    check_type (Some Int32Type) et e.at
+
+  | ResizeMemory e ->
+    check_expr c (Some Int32Type) e;
+    check_type None et e.at
+
 and check_exprs c ts es =
   let ets = List.map (fun x -> Some x) ts in
   try List.iter2 (check_expr c) ets es

ml-proto/src/spec/eval.ml

@@ -14,6 +14,7 @@ let error = Error.error
 type value = Values.value
 type func = Ast.func
 type import = value list -> value option
+type host_params = {page_size : Memory.size}
 
 module ExportMap = Map.Make(String)
 type export_map = func ExportMap.t
@@ -25,7 +26,8 @@ type instance =
   exports : export_map;
   tables : func list list;
   globals : value ref list;
-  memory : Memory.t
+  memory : Memory.t;
+  host : host_params
 }
 
 
@@ -41,6 +43,9 @@ type config =
   return : label
 }
 
+let page_size c =
+  Int32.of_int c.modul.host.page_size
+
 let lookup category list x =
   try List.nth list x.it with Failure _ ->
     error x.at ("runtime: undefined " ^ category ^ " " ^ string_of_int x.it)
@@ -204,6 +209,19 @@ let rec eval_expr (c : config) (e : expr) =
     (try Some (Arithmetic.eval_cvt cvt v1)
     with Arithmetic.TypeError (_, v, t) -> type_error e1.at v t)
 
+  | PageSize ->
+    Some (Int32 (page_size c))
+
+  | MemorySize ->
+    Some (Int32 (Int32.of_int (Memory.size c.modul.memory)))
+
+  | ResizeMemory e ->
+    let i = int32 (eval_expr c e) e.at in
+    if (Int32.rem i (page_size c)) <> Int32.zero then
+      error e.at "runtime: resize_memory operand not multiple of page_size";
+    Memory.resize c.modul.memory (Int32.to_int i);
+    None
+
 and eval_expr_option c eo =
   match eo with
   | Some e -> eval_expr c e
@@ -234,31 +252,38 @@ and eval_func (m : instance) (f : func) (evs : value list) =
 
 (* Modules *)
 
-let init m imports =
+let init_memory ast =
+  match ast with
+  | None ->
+    Memory.create 0
+  | Some {it = {initial; segments; _}} ->
+    let mem = Memory.create initial in
+    Memory.init mem (List.map it segments);
+    mem
+
+let init m imports host =
   assert (List.length imports = List.length m.it.Ast.imports);
+  assert (host.page_size > 0);
+  assert (Lib.Int.is_power_of_two host.page_size);
   let {Ast.exports; globals; tables; funcs; memory; _} = m.it in
-  let mem =
-    match memory with
-    | None -> Memory.create 0
-    | Some {it = {initial; segments; _}} ->
-      let mem = Memory.create initial in
-      Memory.init mem (List.map it segments);
-      mem
-  in
+  let mem = init_memory memory 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
   let tables = List.map (fun tab -> List.map func tab.it) tables in
   let globals = List.map eval_decl globals in
-  {funcs; imports; exports; tables; globals; memory = mem}
+  {funcs; imports; exports; tables; globals; memory = mem; host}
 
 let invoke m name vs =
   let f = export m (name @@ no_region) in
+  assert (List.length vs = List.length f.it.params);
   eval_func m f vs
 
 let eval e =
   let f = {params = []; result = None; locals = []; body = e} @@ no_region in
   let memory = Memory.create 0 in
   let exports = ExportMap.singleton "eval" f in
-  let m = {imports = []; exports; globals = []; tables = []; funcs = [f]; memory} in
+  let host = {page_size = 1} in
+  let m = {imports = []; exports; globals = []; tables = []; funcs = [f];
+           memory; host} in
   eval_func m f []

ml-proto/src/spec/eval.mli

@@ -5,8 +5,9 @@
 type instance
 type value = Values.value
 type import = value list -> value option
+type host_params = {page_size : Memory.size}
 
-val init : Ast.modul -> import list -> instance
+val init : Ast.modul -> import list -> host_params -> instance
 val invoke : instance -> string -> value list -> value option
   (* raise Error.Error *)
 val eval : Ast.expr -> value option (* raise Error.Error *)

ml-proto/src/spec/memory.ml

@@ -20,7 +20,8 @@ type segment =
   data : string
 }
 
-type memory = (int, int8_unsigned_elt, c_layout) Array1.t
+type memory' = (int, int8_unsigned_elt, c_layout) Array1.t
+type memory = memory' ref
 type t = memory
 
 type char_view = (char, int8_unsigned_elt, c_layout) Array1.t
@@ -35,7 +36,7 @@ type uint64_view = (int64, int64_elt, c_layout) Array1.t
 type float32_view = (int32, int32_elt, c_layout) Array1.t
 type float64_view = (int64, int64_elt, c_layout) Array1.t
 
-let view : memory -> ('c, 'd, c_layout) Array1.t = Obj.magic
+let view : memory' -> ('c, 'd, c_layout) Array1.t = Obj.magic
 
 
 (* Queries *)
@@ -53,21 +54,34 @@ exception Type
 exception Bounds
 exception Address
 
-let create n =
+let create' n =
   let mem = Array1.create Int8_unsigned C_layout n in
   Array1.fill mem 0;
   mem
 
+let create n =
+  ref (create' n)
+
 let init_seg mem seg =
   (* There currently is no way to blit from a string. *)
   for i = 0 to String.length seg.data - 1 do
-    (view mem : char_view).{seg.addr + i} <- seg.data.[i]
+    (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
 
 
+let size mem =
+  Array1.dim !mem
+
+let resize mem n =
+  let before = !mem in
+  let after = create' n in
+  let min = min (Array1.dim before) n in
+  Array1.blit (Array1.sub before 0 min) (Array1.sub after 0 min);
+  mem := after
+
 open Values
 
 let address_of_value = function
@@ -80,13 +94,13 @@ let address_of_value = function
 let int32_mask = Int64.shift_right_logical (Int64.of_int (-1)) 32
 let int64_of_int32_u i = Int64.logand (Int64.of_int32 i) int32_mask
 
-let buf = create 8
+let buf = create' 8
 
 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);
+    Array1.blit (Array1.sub !mem a sz) (Array1.sub buf 0 sz);
     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})
@@ -110,5 +124,5 @@ let store mem a memty v =
     | Float32Mem, Float32 x -> (view buf : float32_view).{0} <- Float32.to_bits x
     | Float64Mem, Float64 x -> (view buf : float64_view).{0} <- Float64.to_bits x
     | _ -> raise Type);
-    Array1.blit (Array1.sub buf 0 sz) (Array1.sub mem a sz)
+    Array1.blit (Array1.sub buf 0 sz) (Array1.sub !mem a sz)
   with Invalid_argument _ -> raise Bounds

ml-proto/src/spec/memory.mli

@@ -19,6 +19,8 @@ exception Address
 
 val create : size -> memory
 val init : memory -> segment list -> unit
+val size : memory -> size
+val resize : memory -> size -> unit
 val load : memory -> address -> mem_type -> extension -> Values.value
 val store : memory -> address -> mem_type -> Values.value -> unit
 

ml-proto/test/resizing.wasm

@@ -0,0 +1,32 @@
+(module
+    (memory 4096)
+
+    (export "load" $load)
+    (func $load (param $i i32) (result i32) (i32.load (get_local $i)))
+
+    (export "store" $store)
+    (func $store (param $i i32) (param $v i32) (i32.store (get_local $i) (get_local $v)))
+
+    (export "resize" $resize)
+    (func $resize (param $sz i32) (resize_memory (get_local $sz)))
+
+    (export "size" $size)
+    (func $size (result i32) (memory_size))
+)
+
+(assert_eq (invoke "size") (i32.const 4096))
+(invoke "store" (i32.const 0) (i32.const 42))
+(assert_eq (invoke "load" (i32.const 0)) (i32.const 42))
+(assert_fault (invoke "store" (i32.const 4096) (i32.const 42)) "runtime: out of bounds memory access")
+(assert_fault (invoke "load" (i32.const 4096)) "runtime: out of bounds memory access")
+(invoke "resize" (i32.const 8192))
+(assert_eq (invoke "size") (i32.const 8192))
+(assert_eq (invoke "load" (i32.const 0)) (i32.const 42))
+(assert_eq (invoke "load" (i32.const 4096)) (i32.const 0))
+(invoke "store" (i32.const 4096) (i32.const 43))
+(assert_eq (invoke "load" (i32.const 4096)) (i32.const 43))
+(invoke "resize" (i32.const 4096))
+(assert_eq (invoke "size") (i32.const 4096))
+(assert_eq (invoke "load" (i32.const 0)) (i32.const 42))
+(assert_fault (invoke "store" (i32.const 4096) (i32.const 42)) "runtime: out of bounds memory access")
+(assert_fault (invoke "load" (i32.const 4096)) "runtime: out of bounds memory access")