diff --git a/ml-proto/README.md b/ml-proto/README.md index 53e441a3ae..3d9267620a 100644 --- a/ml-proto/README.md +++ b/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: ( . ) ( . ) ( ./ ) + ( page_size ) + ( memory_size ) + ( resize_memory ) case: ( case * fallthrough? ) ;; = (case (block *) fallthrough?) diff --git a/ml-proto/src/Makefile b/ml-proto/src/Makefile index 864e47b5c7..a08bad649f 100644 --- a/ml-proto/src/Makefile +++ b/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 diff --git a/ml-proto/src/host/lexer.mll b/ml-proto/src/host/lexer.mll index 6d7bd75663..e8860a99af 100644 --- a/ml-proto/src/host/lexer.mll +++ b/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 } diff --git a/ml-proto/src/host/params.ml b/ml-proto/src/host/params.ml new file mode 100644 index 0000000000..e733d788fd --- /dev/null +++ b/ml-proto/src/host/params.ml @@ -0,0 +1 @@ +let page_size = 4096 diff --git a/ml-proto/src/host/parser.mly b/ml-proto/src/host/parser.mly index 35ca13d224..81ce2c72f4 100644 --- a/ml-proto/src/host/parser.mly +++ b/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 } diff --git a/ml-proto/src/host/script.ml b/ml-proto/src/host/script.ml index d32f91ad43..3c94a69487 100644 --- a/ml-proto/src/host/script.ml +++ b/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..."; diff --git a/ml-proto/src/spec/ast.ml b/ml-proto/src/spec/ast.ml index 0630f4b770..39677ff863 100644 --- a/ml-proto/src/spec/ast.ml +++ b/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' = diff --git a/ml-proto/src/spec/check.ml b/ml-proto/src/spec/check.ml index f9442dcf9c..073d2ef33b 100644 --- a/ml-proto/src/spec/check.ml +++ b/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 diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index e5eac9bd49..a9d81d8136 100644 --- a/ml-proto/src/spec/eval.ml +++ b/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 [] diff --git a/ml-proto/src/spec/eval.mli b/ml-proto/src/spec/eval.mli index dc855592b2..f6f6c70fa4 100644 --- a/ml-proto/src/spec/eval.mli +++ b/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 *) diff --git a/ml-proto/src/spec/memory.ml b/ml-proto/src/spec/memory.ml index 00f3f745ec..b953a1e205 100644 --- a/ml-proto/src/spec/memory.ml +++ b/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 diff --git a/ml-proto/src/spec/memory.mli b/ml-proto/src/spec/memory.mli index 72e91ec809..08cba1bc18 100644 --- a/ml-proto/src/spec/memory.mli +++ b/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 diff --git a/ml-proto/test/resizing.wasm b/ml-proto/test/resizing.wasm new file mode 100644 index 0000000000..7a350371f2 --- /dev/null +++ b/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")