diff --git a/ml-proto/README.md b/ml-proto/README.md index 4d204f1f71..ee0a63e980 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -116,39 +116,54 @@ unop: ctz | clz | popcnt | ... binop: add | sub | mul | ... relop: eq | ne | lt | ... sign: s|u -offset: offset= +offset: offset= align: align=(1|2|4|8|...) cvtop: trunc_s | trunc_u | extend_s | extend_u | ... expr: - ( nop ) - ( block ? * ) - ( loop ? ? * ) ;; = (block ? (loop ? (block *))) - ( select ) - ( if ( then ? * ) ( else ? * )? ) - ( if ? ) ;; = (if (then ) (else ?)) - ( br ? ) - ( br_if ? ) - ( br_table ? ) - ( return ? ) ;; = (br ?) - ( call * ) - ( call_import * ) - ( call_indirect * ) - ( get_local ) - ( set_local ) - ( .load((8|16|32)_)? ? ? ) - ( .store(8|16|32)? ? ? ) - ( .const ) - ( . ) - ( . ) - ( . ) - ( ./ ) - ( unreachable ) - ( current_memory ) - ( grow_memory ) - -func: ( func ? * * ) - ( func ? ( export ) * * ) ;; = (export (func ) (func ? * *) + ( ) + ( + ) ;; = + () + ( block ? * ) + ( loop ? * ) + ( if ( then ? * ) ( else ? * )? ) + ( if ( then ? * ) ( else ? * )? ) ;; = (if (then ? *) (else ? *)?) + ( if ? ) ;; = (if (then ) (else ?)) + +instr: + + ;; = () + block ? * end ;; = (block ? *) + loop ? * end ;; = (loop ? *) + if ? * end ;; = (if (then ? *)) + if ? * else ? * end ;; = (if (then ? instr>*) (else ? *)) + +op: + unreachable + nop + drop + select + br + br_if + br_table + + return + call + call_indirect + get_local + set_local + tee_local + .const + . + . + . + . + ./ + .load((8|16|32)_)? ? ? + .store(8|16|32)? ? ? + current_memory + grow_memory + +func: ( func ? * * ) + ( func ? ( export ) * * ) ;; = (export (func ) (func ? * *) ( func ? ( import ) ) ;; = (import ? (func )) param: ( param * ) | ( param ) result: ( result ) @@ -166,12 +181,14 @@ table: ( table ? ) ( table ? ( export ) ) ;; = (export (table )) (table ? ) ( table ? ( import ) ) ;; = (import ? (table )) ( table ? ( export )? ( elem * ) ) ;; = (table ? ( export )? ) (elem (i32.const 0) *) -elem: ( elem * ) +elem: ( elem ? (offset * ) * ) + ( elem ? * ) ;; = (elem ? (offset ) *) memory: ( memory ? ) ( memory ? ( export ) ) ;; = (export (memory )) (memory ? ) ( memory ? ( import ) ) ;; = (import ? (memory )) ( memory ? ( export )? ( data * ) ;; = (memory ? ( export )? ) (data (i32.const 0) *) -data: ( data * ) +data: ( data ? ( offset * ) * ) + ( data ? * ) ;; = (data ? (offset ) *) start: ( start ) @@ -192,7 +209,9 @@ module: ( module ? * * * * ? ? + ) ``` -Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the kernel AST below). +Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the AST below). +In particular, WebAssembly is a stack machine, so that all expressions of the form `( +)` are merely abbreviations of a corresponding post-order sequence of instructions. +For raw instructions, the syntax allows omitting the parentheses around the operator name and its immediate operands. In the case of control operators (`block`, `loop`, `if`), this requires marking the end of the nested sequence with an explicit `end` keyword. Any form of naming via `` and `` (including expression labels) is merely notational convenience of this text format. The actual AST has no names, and all bindings are referred to via ordered numeric indices; consequently, names are immediately resolved in the parser and replaced by indices. Indices can also be used directly in the text format. @@ -223,7 +242,7 @@ cmd: ;; define, validate, and initialize module ;; perform action and print results ( register ? ) ;; register module for imports - ( assert_return ? ) ;; assert action has expected results + ( assert_return * ) ;; assert action has expected results ( assert_return_nan ) ;; assert action results in NaN ( assert_trap ) ;; assert action traps with given failure string ( assert_invalid ) ;; assert module is invalid with given failure string @@ -247,13 +266,11 @@ Again, this is only a meta-level for testing, and not a part of the language pro The interpreter also supports a "dry" mode (flag `-d`), in which modules are only validated. In this mode, `invoke` commands are ignored (and not needed). -## Abstract Syntax and Kernel Syntax +## Abstract Syntax The abstract WebAssembly syntax, as described above and in the [design doc](https://github.com/WebAssembly/design/blob/master/AstSemantics.md), is defined in [ast.ml](https://github.com/WebAssembly/spec/blob/master/ml-proto/spec/ast.ml). -However, to simplify the implementation, this AST representation is first "desugared" into a more minimal kernel language that is a subset of the full language. For example, conditionals with no else-branch are desugared into conditionals with `nop` for their else-branch, such that in the kernel language, all conditionals have two branches. The desugaring rules are sketched in the comments of the S-expression grammar given above. - -The representation for that kernel language AST is defined in [kernel.ml](https://github.com/WebAssembly/spec/blob/master/ml-proto/spec/kernel.ml). Besides having fewer constructs, it also raises the level of abstraction further, e.g., by grouping related operators, or decomposing the syntactic structure of operators themselves. +However, to simplify the implementation, this AST representation represents some of the inner structure of the operators more explicitly. The mapping from the operators as given in the design doc to their structured form is defined in [operators.ml](https://github.com/WebAssembly/spec/blob/master/ml-proto/spec/operators.ml). ## Implementation @@ -268,17 +285,17 @@ The implementation is split into three directories: The implementation consists of the following parts: -* *Abstract Syntax* (`ast.ml`, `kernel.ml`, `types.ml`, `source.ml[i]`). Notably, the `phrase` wrapper type around each AST node carries the source position information. +* *Abstract Syntax* (`ast.ml`, `operators.ml`, `types.ml`, `source.ml[i]`). Notably, the `phrase` wrapper type around each AST node carries the source position information. -* *Parser* (`lexer.mll`, `parser.mly`, `desguar.ml[i]`). Generated with ocamllex and ocamlyacc. The lexer does the opcode encoding (non-trivial tokens carry e.g. type information as semantic values, as declared in `parser.mly`), the parser the actual S-expression parsing. The parser generates a full AST that is desugared into the kernel AST in a separate pass. +* *Parser* (`lexer.mll`, `parser.mly`). Generated with ocamllex and ocamlyacc. The lexer does the opcode encoding (non-trivial tokens carry e.g. type information as semantic values, as declared in `parser.mly`), the parser the actual S-expression parsing. * *Pretty Printer* (`arrange.ml[i]`, `sexpr.ml[i]`). Turns a module AST back into the textual S-expression format. * *Decoder*/*Encoder* (`decode.ml[i]`, `encode.ml[i]`). The former parses the binary format and turns it into an AST, the latter does the inverse. -* *Validator* (`check.ml[i]`). Does a recursive walk of the kernel AST, passing down the *expected* type for expressions, and checking each expression against that. An expected empty type can be matched by any result, corresponding to implicit dropping of unused values (e.g. in a block). +* *Validator* (`check.ml[i]`). Does a recursive walk of the AST, passing down the *expected* type for expressions, and checking each expression against that. An expected empty type can be matched by any result, corresponding to implicit dropping of unused values (e.g. in a block). -* *Evaluator* (`eval.ml[i]`, `values.ml`, `arithmetic.ml[i]`, `int.ml`, `float.ml`, `memory.ml[i]`, and a few more). Evaluation of control transfer (`br` and `return`) is implemented using local exceptions as "labels". While these are allocated dynamically in the code and addressed via a stack, that is merely to simplify the code. In reality, these would be static jumps. +* *Evaluator* (`eval.ml[i]`, `values.ml`, `eval_numeric.ml[i]`, `int.ml`, `float.ml`, `memory.ml[i]`, and a few more). Evaluation of control transfer (`br` and `return`) is implemented using local exceptions as "labels". While these are allocated dynamically in the code and addressed via a stack, that is merely to simplify the code. In reality, these would be static jumps. * *Driver* (`main.ml`, `run.ml[i]`, `script.ml[i]`, `error.ml`, `print.ml[i]`, `flags.ml`). Executes scripts, reports results or errors, etc. diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index 999e44ac41..2f23ea7487 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -9,11 +9,15 @@ struct let rec make n x = if n = 0 then [] else x :: make (n - 1) x + let rec table n f = table' 0 n f + and table' i n f = + if i = n then [] else f i :: table' (i + 1) n f + let rec take n xs = match n, xs with | 0, _ -> [] | n, x::xs' when n > 0 -> x :: take (n - 1) xs' - | _ -> failwith "drop" + | _ -> failwith "take" let rec drop n xs = match n, xs with @@ -31,9 +35,7 @@ struct | x::xs -> let ys, y = split_last xs in x::ys, y | [] -> failwith "split_last" - let rec index_of x xs = - index_of' x xs 0 - + let rec index_of x xs = index_of' x xs 0 and index_of' x xs i = match xs with | [] -> None @@ -41,6 +43,34 @@ struct | y::xs' -> index_of' x xs' (i+1) end +module List32 = +struct + let rec length xs = length' xs 0l + and length' xs n = + match xs with + | [] -> n + | _::xs' when n < Int32.max_int -> length' xs' (Int32.add n 1l) + | _ -> failwith "length" + + let rec nth xs n = + match n, xs with + | 0l, x::_ -> x + | n, _::xs' when n > 0l -> nth xs' (Int32.sub n 1l) + | _ -> failwith "nth" + + let rec take n xs = + match n, xs with + | 0l, _ -> [] + | n, x::xs' when n > 0l -> x :: take (Int32.sub n 1l) xs' + | _ -> failwith "take" + + let rec drop n xs = + match n, xs with + | 0l, _ -> xs + | n, _::xs' when n > 0l -> drop (Int32.sub n 1l) xs' + | _ -> failwith "drop" +end + module Option = struct let get o x = diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index f216a8ecfb..fc5916a9c8 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -8,8 +8,9 @@ end module List : sig val make : int -> 'a -> 'a list - val take : int -> 'a list -> 'a list - val drop : int -> 'a list -> 'a list + val table : int -> (int -> 'a) -> 'a list + val take : int -> 'a list -> 'a list (* raise Failure *) + val drop : int -> 'a list -> 'a list (* raise Failure *) val last : 'a list -> 'a (* raise Failure *) val split_last : 'a list -> 'a list * 'a (* raise Failure *) @@ -17,6 +18,14 @@ sig val index_of : 'a -> 'a list -> int option end +module List32 : +sig + val length : 'a list -> int32 + val nth : 'a list -> int32 -> 'a (* raise Failure *) + val take : int32 -> 'a list -> 'a list (* raise Failure *) + val drop : int32 -> 'a list -> 'a list (* raise Failure *) +end + module Option : sig val get : 'a option -> 'a -> 'a diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index f396dcc659..63cbf0234d 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -1,5 +1,5 @@ open Source -open Kernel +open Ast open Values open Types open Sexpr @@ -48,8 +48,8 @@ let elem_type t = string_of_elem_type t let decls kind ts = tab kind (atom value_type) ts -let func_type {ins; out} = - Node ("func", decls "param" ins @ decls "result" (list_of_opt out)) +let func_type (FuncType (ins, out)) = + Node ("func", decls "param" ins @ decls "result" out) let struct_type = func_type @@ -65,7 +65,7 @@ let global_type = function module IntOp = struct - open Kernel.IntOp + open Ast.IntOp let unop xx = function | Clz -> "clz" @@ -105,19 +105,19 @@ struct | GeU -> "ge_u" let cvtop xx = function - | ExtendSInt32 -> "extend_s/i32" - | ExtendUInt32 -> "extend_u/i32" - | WrapInt64 -> "wrap/i64" - | TruncSFloat32 -> "trunc_s/f32" - | TruncUFloat32 -> "trunc_u/f32" - | TruncSFloat64 -> "trunc_s/f64" - | TruncUFloat64 -> "trunc_u/f64" + | ExtendSI32 -> "extend_s/i32" + | ExtendUI32 -> "extend_u/i32" + | WrapI64 -> "wrap/i64" + | TruncSF32 -> "trunc_s/f32" + | TruncUF32 -> "trunc_u/f32" + | TruncSF64 -> "trunc_s/f64" + | TruncUF64 -> "trunc_u/f64" | ReinterpretFloat -> "reinterpret/f" ^ xx end module FloatOp = struct - open Kernel.FloatOp + open Ast.FloatOp let unop xx = function | Neg -> "neg" @@ -148,22 +148,22 @@ struct | Ge -> "ge" let cvtop xx = function - | ConvertSInt32 -> "convert_s/i32" - | ConvertUInt32 -> "convert_u/i32" - | ConvertSInt64 -> "convert_s/i64" - | ConvertUInt64 -> "convert_u/i64" - | PromoteFloat32 -> "promote/f32" - | DemoteFloat64 -> "demote/f64" + | ConvertSI32 -> "convert_s/i32" + | ConvertUI32 -> "convert_u/i32" + | ConvertSI64 -> "convert_s/i64" + | ConvertUI64 -> "convert_u/i64" + | PromoteF32 -> "promote/f32" + | DemoteF64 -> "demote/f64" | ReinterpretInt -> "reinterpret/i" ^ xx end let oper (intop, floatop) op = value_type (type_of op) ^ "." ^ (match op with - | Int32 o -> intop "32" o - | Int64 o -> intop "64" o - | Float32 o -> floatop "32" o - | Float64 o -> floatop "64" o + | I32 o -> intop "32" o + | I64 o -> intop "64" o + | F32 o -> floatop "32" o + | F64 o -> floatop "64" o ) let unop = oper (IntOp.unop, FloatOp.unop) @@ -172,11 +172,6 @@ let testop = oper (IntOp.testop, FloatOp.testop) let relop = oper (IntOp.relop, FloatOp.relop) let cvtop = oper (IntOp.cvtop, FloatOp.cvtop) -let memop name {ty; offset; align} = - value_type ty ^ "." ^ name ^ - (if offset = 0L then "" else " offset=" ^ int64 offset) ^ - (if align = 1 then "" else " align=" ^ int align) - let mem_size = function | Memory.Mem8 -> "8" | Memory.Mem16 -> "16" @@ -186,69 +181,65 @@ let extension = function | Memory.SX -> "_s" | Memory.ZX -> "_u" -let extop {memop = op; sz; ext} = - memop ("load" ^ mem_size sz ^ extension ext) op +let memop name {ty; align; offset; _} = + value_type ty ^ "." ^ name ^ + (if offset = 0L then "" else " offset=" ^ int64 offset) ^ + (if align = size ty then "" else " align=" ^ int align) -let wrapop {memop = op; sz} = - memop ("store" ^ mem_size sz) op +let loadop op = + match op.sz with + | None -> memop "load" op + | Some (sz, ext) -> memop ("load" ^ mem_size sz ^ extension ext) op -let hostop = function - | CurrentMemory -> "current_memory" - | GrowMemory -> "grow_memory" +let storeop op = + match op.sz with + | None -> memop "store" op + | Some sz -> memop ("store" ^ mem_size sz) op (* Expressions *) -let var x = string_of_int x.it +let var x = Int32.to_string x.it let value v = string_of_value v.it let constop v = value_type (type_of v.it) ^ ".const" -let rec expr e = +let rec instr e = let head, inner = match e.it with - | Nop -> "nop", [] | Unreachable -> "unreachable", [] - | Drop e -> "drop", [expr e] - | Block ([], {it = Loop e; _}) -> "loop", [expr e] - | Block (es, e) -> "block", list expr (es @ [e]) - | Loop e -> assert false - | Break (x, eo) -> "br " ^ var x, opt expr eo - | BreakIf (x, eo, e) -> "br_if " ^ var x, opt expr eo @ [expr e] - | BreakTable (xs, x, eo, e) -> - "br_table", list (atom var) (xs @ [x]) @ opt expr eo @ [expr e] - | If (e1, e2, e3) -> - (match block e2, block e3 with - | [sx2], [] -> "if", [expr e1; sx2] - | [sx2], [sx3] -> "if", [expr e1; sx2; sx3] - | sxs2, [] -> "if", [expr e1; Node ("then", sxs2)] - | sxs2, sxs3 -> "if", [expr e1; Node ("then", sxs2); Node ("else", sxs3)] - ) - | Select (e1, e2, e3) -> "select", [expr e1; expr e2; expr e3] - | Call (x, es) -> "call " ^ var x, list expr es - | CallIndirect (x, e, es) -> "call_indirect " ^ var x, list expr (e::es) + | Nop -> "nop", [] + | Drop -> "drop", [] + | Block es -> "block", list instr es + | Loop es -> "loop", list instr es + | Br (n, x) -> "br " ^ int n ^ " " ^ var x, [] + | BrIf (n, x) -> "br_if " ^ int n ^ " " ^ var x, [] + | BrTable (n, xs, x) -> + "br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x])), [] + | Return -> "return", [] + | If (es1, es2) -> + "if", [Node ("then", list instr es1); Node ("else", list instr es2)] + | Select -> "select", [] + | Call x -> "call " ^ var x, [] + | CallIndirect x -> "call_indirect " ^ var x, [] | GetLocal x -> "get_local " ^ var x, [] - | SetLocal (x, e) -> "set_local " ^ var x, [expr e] - | TeeLocal (x, e) -> "tee_local " ^ var x, [expr e] + | SetLocal x -> "set_local " ^ var x, [] + | TeeLocal x -> "tee_local " ^ var x, [] | GetGlobal x -> "get_global " ^ var x, [] - | SetGlobal (x, e) -> "set_global " ^ var x, [expr e] - | Load (op, e) -> memop "load" op, [expr e] - | Store (op, e1, e2) -> memop "store" op, [expr e1; expr e2] - | LoadExtend (op, e) -> extop op, [expr e] - | StoreWrap (op, e1, e2) -> wrapop op, [expr e1; expr e2] - | Const lit -> constop lit, [atom value lit] - | Unary (op, e) -> unop op, [expr e] - | Binary (op, e1, e2) -> binop op, [expr e1; expr e2] - | Test (op, e) -> testop op, [expr e] - | Compare (op, e1, e2) -> relop op, [expr e1; expr e2] - | Convert (op, e) -> cvtop op, [expr e] - | Host (op, es) -> hostop op, list expr es + | SetGlobal x -> "set_global " ^ var x, [] + | Load op -> loadop op, [] + | Store op -> storeop op, [] + | Const lit -> constop lit ^ " " ^ value lit, [] + | Unary op -> unop op, [] + | Binary op -> binop op, [] + | Test op -> testop op, [] + | Compare op -> relop op, [] + | Convert op -> cvtop op, [] + | CurrentMemory -> "current_memory", [] + | GrowMemory -> "grow_memory", [] in Node (head, inner) -and block e = - match e.it with - | Block (es, e) -> list expr (es @ [e]) - | Nop -> [] - | _ -> assert false (* TODO *) +let const c = + list instr c.it (* Functions *) @@ -258,7 +249,7 @@ let func off i f = Node ("func $" ^ string_of_int (off + i), [Node ("type " ^ var ftype, [])] @ decls "local" locals @ - block body + list instr body ) let start x = Node ("start " ^ var x, []) @@ -280,7 +271,7 @@ let memory off i mem = let segment head dat seg = let {index; offset; init} = seg.it in - Node (head, atom var index :: expr offset :: dat init) + Node (head, atom var index :: Node ("offset", const offset) :: dat init) let elems seg = segment "elem" (list (atom var)) seg @@ -323,7 +314,7 @@ let export ex = let global off i g = let {gtype; value} = g.it in - Node ("global $" ^ string_of_int (off + i), [global_type gtype; expr value]) + Node ("global $" ^ string_of_int (off + i), global_type gtype :: const value) (* Modules *) diff --git a/ml-proto/host/arrange.mli b/ml-proto/host/arrange.mli index 764e54fd5e..f9b2268704 100644 --- a/ml-proto/host/arrange.mli +++ b/ml-proto/host/arrange.mli @@ -2,6 +2,6 @@ open Sexpr val func_type : Types.func_type -> sexpr -val expr : Kernel.expr -> sexpr -val module_ : Kernel.module_ -> sexpr +val instr : Ast.instr -> sexpr +val module_ : Ast.module_ -> sexpr diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index f9b8628e9e..5928f45676 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -63,8 +63,8 @@ let encode m = let vec f xs = vu (List.length xs); list f xs let vec1 f xo = bool (xo <> None); opt f xo - let gap () = let p = pos s in u32 0l; u8 0; p - let patch_gap p n = + let gap32 () = let p = pos s in u32 0l; u8 0; p + let patch_gap32 p n = assert (n <= 0x0fff_ffff); (* Strings cannot excess 2G anyway *) let lsb i = Char.chr (i land 0xff) in patch s p (lsb (n lor 0x80)); @@ -78,18 +78,32 @@ let encode m = open Types let value_type = function - | Int32Type -> u8 0x01 - | Int64Type -> u8 0x02 - | Float32Type -> u8 0x03 - | Float64Type -> u8 0x04 + | I32Type -> u8 0x01 + | I64Type -> u8 0x02 + | F32Type -> u8 0x03 + | F64Type -> u8 0x04 let elem_type = function | AnyFuncType -> u8 0x20 - let expr_type t = vec1 value_type t - let func_type = function - | {ins; out} -> u8 0x40; vec value_type ins; expr_type out + | FuncType (ins, out) -> u8 0x40; vec value_type ins; vec value_type out + + let limits vu {min; max} = + bool (max <> None); vu min; opt vu max + + let table_type = function + | TableType (lim, t) -> elem_type t; limits vu32 lim + + let memory_type = function + | MemoryType lim -> limits vu32 lim + + let mutability = function + | Immutable -> u8 0 + | Mutable -> u8 1 + + let global_type = function + | GlobalType (t, mut) -> value_type t; mutability mut let limits vu {min; max} = bool (max <> None); vu min; opt vu max @@ -110,226 +124,259 @@ let encode m = (* Expressions *) open Source - open Kernel open Ast + open Values + open Memory - let op n = u8 n let arity xs = vu (List.length xs) let arity1 xo = bool (xo <> None) - let memop off align = vu32 (I32.ctz (Int32.of_int align)); vu64 off + let op n = u8 n + let memop {align; offset; _} = + vu32 (I32.ctz (Int32.of_int align)); + vu64 offset - let var x = vu x.it - let var32 x = vu32 (Int32.of_int x.it) + let var x = vu32 x.it - let rec expr e = + let rec instr e = match e.it with - | Nop -> op 0x00 - | Block es -> op 0x01; list expr es; op 0x0f - | Loop es -> op 0x02; list expr es; op 0x0f - | If (e, es1, es2) -> - expr e; op 0x03; list expr es1; - if es2 <> [] then op 0x04; list expr es2; op 0x0f - | Select (e1, e2, e3) -> expr e1; expr e2; expr e3; op 0x05 - | Br (x, eo) -> opt expr eo; op 0x06; arity1 eo; var x - | Br_if (x, eo, e) -> opt expr eo; expr e; op 0x07; arity1 eo; var x - | Br_table (xs, x, eo, e) -> - opt expr eo; expr e; op 0x08; arity1 eo; vec var32 xs; var32 x - | Ast.Return eo -> nary1 eo 0x09 - | Ast.Unreachable -> op 0x0a - | Ast.Drop e -> unary e 0x0b - - | Ast.I32_const c -> op 0x10; vs32 c.it - | Ast.I64_const c -> op 0x11; vs64 c.it - | Ast.F32_const c -> op 0x12; f32 c.it - | Ast.F64_const c -> op 0x13; f64 c.it - - | Ast.Get_local x -> op 0x14; var x - | Ast.Set_local (x, e) -> unary e 0x15; var x - | Ast.Tee_local (x, e) -> unary e 0x19; var x - | Ast.Get_global x -> op 0xbb; var x - | Ast.Set_global (x, e) -> unary e 0xbc; var x - - | Ast.Call (x, es) -> nary es 0x16; var x - | Ast.Call_indirect (x, e, es) -> expr e; nary es 0x17; var x - - | I32_load8_s (o, a, e) -> unary e 0x20; memop o a - | I32_load8_u (o, a, e) -> unary e 0x21; memop o a - | I32_load16_s (o, a, e) -> unary e 0x22; memop o a - | I32_load16_u (o, a, e) -> unary e 0x23; memop o a - | I64_load8_s (o, a, e) -> unary e 0x24; memop o a - | I64_load8_u (o, a, e) -> unary e 0x25; memop o a - | I64_load16_s (o, a, e) -> unary e 0x26; memop o a - | I64_load16_u (o, a, e) -> unary e 0x27; memop o a - | I64_load32_s (o, a, e) -> unary e 0x28; memop o a - | I64_load32_u (o, a, e) -> unary e 0x29; memop o a - | I32_load (o, a, e) -> unary e 0x2a; memop o a - | I64_load (o, a, e) -> unary e 0x2b; memop o a - | F32_load (o, a, e) -> unary e 0x2c; memop o a - | F64_load (o, a, e) -> unary e 0x2d; memop o a - - | I32_store8 (o, a, e1, e2) -> binary e1 e2 0x2e; memop o a - | I32_store16 (o, a, e1, e2) -> binary e1 e2 0x2f; memop o a - | I64_store8 (o, a, e1, e2) -> binary e1 e2 0x30; memop o a - | I64_store16 (o, a, e1, e2) -> binary e1 e2 0x31; memop o a - | I64_store32 (o, a, e1, e2) -> binary e1 e2 0x32; memop o a - | I32_store (o, a, e1, e2) -> binary e1 e2 0x33; memop o a - | I64_store (o, a, e1, e2) -> binary e1 e2 0x34; memop o a - | F32_store (o, a, e1, e2) -> binary e1 e2 0x35; memop o a - | F64_store (o, a, e1, e2) -> binary e1 e2 0x36; memop o a - - | Grow_memory e -> unary e 0x39 - | Current_memory -> op 0x3b - - | I32_add (e1, e2) -> binary e1 e2 0x40 - | I32_sub (e1, e2) -> binary e1 e2 0x41 - | I32_mul (e1, e2) -> binary e1 e2 0x42 - | I32_div_s (e1, e2) -> binary e1 e2 0x43 - | I32_div_u (e1, e2) -> binary e1 e2 0x44 - | I32_rem_s (e1, e2) -> binary e1 e2 0x45 - | I32_rem_u (e1, e2) -> binary e1 e2 0x46 - | I32_and (e1, e2) -> binary e1 e2 0x47 - | I32_or (e1, e2) -> binary e1 e2 0x48 - | I32_xor (e1, e2) -> binary e1 e2 0x49 - | I32_shl (e1, e2) -> binary e1 e2 0x4a - | I32_shr_u (e1, e2) -> binary e1 e2 0x4b - | I32_shr_s (e1, e2) -> binary e1 e2 0x4c - | I32_rotl (e1, e2) -> binary e1 e2 0xb6 - | I32_rotr (e1, e2) -> binary e1 e2 0xb7 - | I32_eq (e1, e2) -> binary e1 e2 0x4d - | I32_ne (e1, e2) -> binary e1 e2 0x4e - | I32_lt_s (e1, e2) -> binary e1 e2 0x4f - | I32_le_s (e1, e2) -> binary e1 e2 0x50 - | I32_lt_u (e1, e2) -> binary e1 e2 0x51 - | I32_le_u (e1, e2) -> binary e1 e2 0x52 - | I32_gt_s (e1, e2) -> binary e1 e2 0x53 - | I32_ge_s (e1, e2) -> binary e1 e2 0x54 - | I32_gt_u (e1, e2) -> binary e1 e2 0x55 - | I32_ge_u (e1, e2) -> binary e1 e2 0x56 - | I32_clz e -> unary e 0x57 - | I32_ctz e -> unary e 0x58 - | I32_popcnt e -> unary e 0x59 - | I32_eqz e -> unary e 0x5a - - | I64_add (e1, e2) -> binary e1 e2 0x5b - | I64_sub (e1, e2) -> binary e1 e2 0x5c - | I64_mul (e1, e2) -> binary e1 e2 0x5d - | I64_div_s (e1, e2) -> binary e1 e2 0x5e - | I64_div_u (e1, e2) -> binary e1 e2 0x5f - | I64_rem_s (e1, e2) -> binary e1 e2 0x60 - | I64_rem_u (e1, e2) -> binary e1 e2 0x61 - | I64_and (e1, e2) -> binary e1 e2 0x62 - | I64_or (e1, e2) -> binary e1 e2 0x63 - | I64_xor (e1, e2) -> binary e1 e2 0x64 - | I64_shl (e1, e2) -> binary e1 e2 0x65 - | I64_shr_u (e1, e2) -> binary e1 e2 0x66 - | I64_shr_s (e1, e2) -> binary e1 e2 0x67 - | I64_rotl (e1, e2) -> binary e1 e2 0xb8 - | I64_rotr (e1, e2) -> binary e1 e2 0xb9 - | I64_eq (e1, e2) -> binary e1 e2 0x68 - | I64_ne (e1, e2) -> binary e1 e2 0x69 - | I64_lt_s (e1, e2) -> binary e1 e2 0x6a - | I64_le_s (e1, e2) -> binary e1 e2 0x6b - | I64_lt_u (e1, e2) -> binary e1 e2 0x6c - | I64_le_u (e1, e2) -> binary e1 e2 0x6d - | I64_gt_s (e1, e2) -> binary e1 e2 0x6e - | I64_ge_s (e1, e2) -> binary e1 e2 0x6f - | I64_gt_u (e1, e2) -> binary e1 e2 0x70 - | I64_ge_u (e1, e2) -> binary e1 e2 0x71 - | I64_clz e -> unary e 0x72 - | I64_ctz e -> unary e 0x73 - | I64_popcnt e -> unary e 0x74 - | I64_eqz e -> unary e 0xba - - | F32_add (e1, e2) -> binary e1 e2 0x75 - | F32_sub (e1, e2) -> binary e1 e2 0x76 - | F32_mul (e1, e2) -> binary e1 e2 0x77 - | F32_div (e1, e2) -> binary e1 e2 0x78 - | F32_min (e1, e2) -> binary e1 e2 0x79 - | F32_max (e1, e2) -> binary e1 e2 0x7a - | F32_abs e -> unary e 0x7b - | F32_neg e -> unary e 0x7c - | F32_copysign (e1, e2) -> binary e1 e2 0x7d - | F32_ceil e -> unary e 0x7e - | F32_floor e -> unary e 0x7f - | F32_trunc e -> unary e 0x80 - | F32_nearest e -> unary e 0x81 - | F32_sqrt e -> unary e 0x82 - | F32_eq (e1, e2) -> binary e1 e2 0x83 - | F32_ne (e1, e2) -> binary e1 e2 0x84 - | F32_lt (e1, e2) -> binary e1 e2 0x85 - | F32_le (e1, e2) -> binary e1 e2 0x86 - | F32_gt (e1, e2) -> binary e1 e2 0x87 - | F32_ge (e1, e2) -> binary e1 e2 0x88 - - | F64_add (e1, e2) -> binary e1 e2 0x89 - | F64_sub (e1, e2) -> binary e1 e2 0x8a - | F64_mul (e1, e2) -> binary e1 e2 0x8b - | F64_div (e1, e2) -> binary e1 e2 0x8c - | F64_min (e1, e2) -> binary e1 e2 0x8d - | F64_max (e1, e2) -> binary e1 e2 0x8e - | F64_abs e -> unary e 0x8f - | F64_neg e -> unary e 0x90 - | F64_copysign (e1, e2) -> binary e1 e2 0x91 - | F64_ceil e -> unary e 0x92 - | F64_floor e -> unary e 0x93 - | F64_trunc e -> unary e 0x94 - | F64_nearest e -> unary e 0x95 - | F64_sqrt e -> unary e 0x96 - | F64_eq (e1, e2) -> binary e1 e2 0x97 - | F64_ne (e1, e2) -> binary e1 e2 0x98 - | F64_lt (e1, e2) -> binary e1 e2 0x99 - | F64_le (e1, e2) -> binary e1 e2 0x9a - | F64_gt (e1, e2) -> binary e1 e2 0x9b - | F64_ge (e1, e2) -> binary e1 e2 0x9c - - | I32_trunc_s_f32 e -> unary e 0x9d - | I32_trunc_s_f64 e -> unary e 0x9e - | I32_trunc_u_f32 e -> unary e 0x9f - | I32_trunc_u_f64 e -> unary e 0xa0 - | I32_wrap_i64 e -> unary e 0xa1 - | I64_trunc_s_f32 e -> unary e 0xa2 - | I64_trunc_s_f64 e -> unary e 0xa3 - | I64_trunc_u_f32 e -> unary e 0xa4 - | I64_trunc_u_f64 e -> unary e 0xa5 - | I64_extend_s_i32 e -> unary e 0xa6 - | I64_extend_u_i32 e -> unary e 0xa7 - | F32_convert_s_i32 e -> unary e 0xa8 - | F32_convert_u_i32 e -> unary e 0xa9 - | F32_convert_s_i64 e -> unary e 0xaa - | F32_convert_u_i64 e -> unary e 0xab - | F32_demote_f64 e -> unary e 0xac - | F32_reinterpret_i32 e -> unary e 0xad - | F64_convert_s_i32 e -> unary e 0xae - | F64_convert_u_i32 e -> unary e 0xaf - | F64_convert_s_i64 e -> unary e 0xb0 - | F64_convert_u_i64 e -> unary e 0xb1 - | F64_promote_f32 e -> unary e 0xb2 - | F64_reinterpret_i64 e -> unary e 0xb3 - | I32_reinterpret_f32 e -> unary e 0xb4 - | I64_reinterpret_f64 e -> unary e 0xb5 - - and unary e o = expr e; op o - and binary e1 e2 o = expr e1; expr e2; op o - and nary es o = list expr es; op o; arity es - and nary1 eo o = opt expr eo; op o; arity1 eo - - let const e = expr e; op 0x0f + | Unreachable -> op 0x00 + | Block es -> op 0x01; list instr es; op 0x0f + | Loop es -> op 0x02; list instr es; op 0x0f + | If (es1, es2) -> + op 0x03; list instr es1; + if es2 <> [] then op 0x04; + list instr es2; op 0x0f + | Select -> op 0x05 + | Br (n, x) -> op 0x06; vu n; var x + | BrIf (n, x) -> op 0x07; vu n; var x + | BrTable (n, xs, x) -> op 0x08; vu n; vec var xs; var x + | Return -> op 0x09 + | Nop -> op 0x0a + | Drop -> op 0x0b + + | Const {it = I32 c} -> op 0x10; vs32 c + | Const {it = I64 c} -> op 0x11; vs64 c + | Const {it = F32 c} -> op 0x12; f32 c + | Const {it = F64 c} -> op 0x13; f64 c + + | GetLocal x -> op 0x14; var x + | SetLocal x -> op 0x15; var x + | TeeLocal x -> op 0x19; var x + | GetGlobal x -> op 0xbb; var x + | SetGlobal x -> op 0xbc; var x + + | Call x -> op 0x16; var x + | CallIndirect x -> op 0x17; var x + + | Load ({ty = I32Type; sz = None; _} as mo) -> op 0x2a; memop mo + | Load ({ty = I64Type; sz = None; _} as mo) -> op 0x2b; memop mo + | Load ({ty = F32Type; sz = None; _} as mo) -> op 0x2c; memop mo + | Load ({ty = F64Type; sz = None; _} as mo) -> op 0x2d; memop mo + | Load ({ty = I32Type; sz = Some (Mem8, SX); _} as mo) -> + op 0x20; memop mo + | Load ({ty = I32Type; sz = Some (Mem8, ZX); _} as mo) -> + op 0x21; memop mo + | Load ({ty = I32Type; sz = Some (Mem16, SX); _} as mo) -> + op 0x22; memop mo + | Load ({ty = I32Type; sz = Some (Mem16, ZX); _} as mo) -> + op 0x23; memop mo + | Load {ty = I32Type; sz = Some (Mem32, _); _} -> + assert false + | Load ({ty = I64Type; sz = Some (Mem8, SX); _} as mo) -> + op 0x24; memop mo + | Load ({ty = I64Type; sz = Some (Mem8, ZX); _} as mo) -> + op 0x25; memop mo + | Load ({ty = I64Type; sz = Some (Mem16, SX); _} as mo) -> + op 0x26; memop mo + | Load ({ty = I64Type; sz = Some (Mem16, ZX); _} as mo) -> + op 0x27; memop mo + | Load ({ty = I64Type; sz = Some (Mem32, SX); _} as mo) -> + op 0x28; memop mo + | Load ({ty = I64Type; sz = Some (Mem32, ZX); _} as mo) -> + op 0x29; memop mo + | Load {ty = F32Type | F64Type; sz = Some _; _} -> + assert false + + | Store ({ty = I32Type; sz = None; _} as mo) -> op 0x33; memop mo + | Store ({ty = I64Type; sz = None; _} as mo) -> op 0x34; memop mo + | Store ({ty = F32Type; sz = None; _} as mo) -> op 0x35; memop mo + | Store ({ty = F64Type; sz = None; _} as mo) -> op 0x36; memop mo + | Store ({ty = I32Type; sz = Some Mem8; _} as mo) -> op 0x2e; memop mo + | Store ({ty = I32Type; sz = Some Mem16; _} as mo) -> op 0x2f; memop mo + | Store {ty = I32Type; sz = Some Mem32; _} -> assert false + | Store ({ty = I64Type; sz = Some Mem8; _} as mo) -> op 0x30; memop mo + | Store ({ty = I64Type; sz = Some Mem16; _} as mo) -> op 0x31; memop mo + | Store ({ty = I64Type; sz = Some Mem32; _} as mo) -> op 0x32; memop mo + | Store {ty = F32Type | F64Type; sz = Some _; _} -> assert false + + | GrowMemory -> op 0x39 + | CurrentMemory -> op 0x3b + + | Unary (I32 I32Op.Clz) -> op 0x57 + | Unary (I32 I32Op.Ctz) -> op 0x58 + | Unary (I32 I32Op.Popcnt) -> op 0x59 + + | Unary (I64 I64Op.Clz) -> op 0x72 + | Unary (I64 I64Op.Ctz) -> op 0x73 + | Unary (I64 I64Op.Popcnt) -> op 0x74 + + | Unary (F32 F32Op.Neg) -> op 0x7c + | Unary (F32 F32Op.Abs) -> op 0x7b + | Unary (F32 F32Op.Ceil) -> op 0x7e + | Unary (F32 F32Op.Floor) -> op 0x7f + | Unary (F32 F32Op.Trunc) -> op 0x80 + | Unary (F32 F32Op.Nearest) -> op 0x81 + | Unary (F32 F32Op.Sqrt) -> op 0x82 + + | Unary (F64 F64Op.Neg) -> op 0x90 + | Unary (F64 F64Op.Abs) -> op 0x8f + | Unary (F64 F64Op.Ceil) -> op 0x92 + | Unary (F64 F64Op.Floor) -> op 0x93 + | Unary (F64 F64Op.Trunc) -> op 0x94 + | Unary (F64 F64Op.Nearest) -> op 0x95 + | Unary (F64 F64Op.Sqrt) -> op 0x96 + + | Binary (I32 I32Op.Add) -> op 0x40 + | Binary (I32 I32Op.Sub) -> op 0x41 + | Binary (I32 I32Op.Mul) -> op 0x42 + | Binary (I32 I32Op.DivS) -> op 0x43 + | Binary (I32 I32Op.DivU) -> op 0x44 + | Binary (I32 I32Op.RemS) -> op 0x45 + | Binary (I32 I32Op.RemU) -> op 0x46 + | Binary (I32 I32Op.And) -> op 0x47 + | Binary (I32 I32Op.Or) -> op 0x48 + | Binary (I32 I32Op.Xor) -> op 0x49 + | Binary (I32 I32Op.Shl) -> op 0x4a + | Binary (I32 I32Op.ShrS) -> op 0x4c + | Binary (I32 I32Op.ShrU) -> op 0x4b + | Binary (I32 I32Op.Rotl) -> op 0xb6 + | Binary (I32 I32Op.Rotr) -> op 0xb7 + + | Binary (I64 I64Op.Add) -> op 0x5b + | Binary (I64 I64Op.Sub) -> op 0x5c + | Binary (I64 I64Op.Mul) -> op 0x5d + | Binary (I64 I64Op.DivS) -> op 0x5e + | Binary (I64 I64Op.DivU) -> op 0x5f + | Binary (I64 I64Op.RemS) -> op 0x60 + | Binary (I64 I64Op.RemU) -> op 0x61 + | Binary (I64 I64Op.And) -> op 0x62 + | Binary (I64 I64Op.Or) -> op 0x63 + | Binary (I64 I64Op.Xor) -> op 0x64 + | Binary (I64 I64Op.Shl) -> op 0x65 + | Binary (I64 I64Op.ShrS) -> op 0x67 + | Binary (I64 I64Op.ShrU) -> op 0x66 + | Binary (I64 I64Op.Rotl) -> op 0xb8 + | Binary (I64 I64Op.Rotr) -> op 0xb9 + + | Binary (F32 F32Op.Add) -> op 0x75 + | Binary (F32 F32Op.Sub) -> op 0x76 + | Binary (F32 F32Op.Mul) -> op 0x77 + | Binary (F32 F32Op.Div) -> op 0x78 + | Binary (F32 F32Op.Min) -> op 0x79 + | Binary (F32 F32Op.Max) -> op 0x7a + | Binary (F32 F32Op.CopySign) -> op 0x7d + + | Binary (F64 F64Op.Add) -> op 0x89 + | Binary (F64 F64Op.Sub) -> op 0x8a + | Binary (F64 F64Op.Mul) -> op 0x8b + | Binary (F64 F64Op.Div) -> op 0x8c + | Binary (F64 F64Op.Min) -> op 0x8d + | Binary (F64 F64Op.Max) -> op 0x8e + | Binary (F64 F64Op.CopySign) -> op 0x91 + + | Test (I32 I32Op.Eqz) -> op 0x5a + | Test (I64 I64Op.Eqz) -> op 0xba + | Test (F32 _) -> assert false + | Test (F64 _) -> assert false + + | Compare (I32 I32Op.Eq) -> op 0x4d + | Compare (I32 I32Op.Ne) -> op 0x4e + | Compare (I32 I32Op.LtS) -> op 0x4f + | Compare (I32 I32Op.LtU) -> op 0x51 + | Compare (I32 I32Op.LeS) -> op 0x50 + | Compare (I32 I32Op.LeU) -> op 0x52 + | Compare (I32 I32Op.GtS) -> op 0x53 + | Compare (I32 I32Op.GtU) -> op 0x55 + | Compare (I32 I32Op.GeS) -> op 0x54 + | Compare (I32 I32Op.GeU) -> op 0x56 + + | Compare (I64 I64Op.Eq) -> op 0x68 + | Compare (I64 I64Op.Ne) -> op 0x69 + | Compare (I64 I64Op.LtS) -> op 0x6a + | Compare (I64 I64Op.LtU) -> op 0x6c + | Compare (I64 I64Op.LeS) -> op 0x6b + | Compare (I64 I64Op.LeU) -> op 0x6d + | Compare (I64 I64Op.GtS) -> op 0x6e + | Compare (I64 I64Op.GtU) -> op 0x70 + | Compare (I64 I64Op.GeS) -> op 0x6f + | Compare (I64 I64Op.GeU) -> op 0x71 + + | Compare (F32 F32Op.Eq) -> op 0x83 + | Compare (F32 F32Op.Ne) -> op 0x84 + | Compare (F32 F32Op.Lt) -> op 0x85 + | Compare (F32 F32Op.Le) -> op 0x86 + | Compare (F32 F32Op.Gt) -> op 0x87 + | Compare (F32 F32Op.Ge) -> op 0x88 + + | Compare (F64 F64Op.Eq) -> op 0x97 + | Compare (F64 F64Op.Ne) -> op 0x98 + | Compare (F64 F64Op.Lt) -> op 0x99 + | Compare (F64 F64Op.Le) -> op 0x9a + | Compare (F64 F64Op.Gt) -> op 0x9b + | Compare (F64 F64Op.Ge) -> op 0x9c + + | Convert (I32 I32Op.TruncSF32) -> op 0x9d + | Convert (I32 I32Op.TruncSF64) -> op 0x9e + | Convert (I32 I32Op.TruncUF32) -> op 0x9f + | Convert (I32 I32Op.TruncUF64) -> op 0xa0 + | Convert (I32 I32Op.WrapI64) -> op 0xa1 + | Convert (I32 I32Op.ExtendSI32) -> assert false + | Convert (I32 I32Op.ExtendUI32) -> assert false + | Convert (I32 I32Op.ReinterpretFloat) -> op 0xb4 + + | Convert (I64 I64Op.TruncSF32) -> op 0xa2 + | Convert (I64 I64Op.TruncSF64) -> op 0xa3 + | Convert (I64 I64Op.TruncUF32) -> op 0xa4 + | Convert (I64 I64Op.TruncUF64) -> op 0xa5 + | Convert (I64 I64Op.WrapI64) -> assert false + | Convert (I64 I64Op.ExtendSI32) -> op 0xa6 + | Convert (I64 I64Op.ExtendUI32) -> op 0xa7 + | Convert (I64 I64Op.ReinterpretFloat) -> op 0xb5 + + | Convert (F32 F32Op.ConvertSI32) -> op 0xa8 + | Convert (F32 F32Op.ConvertUI32) -> op 0xa9 + | Convert (F32 F32Op.ConvertSI64) -> op 0xaa + | Convert (F32 F32Op.ConvertUI64) -> op 0xab + | Convert (F32 F32Op.PromoteF32) -> assert false + | Convert (F32 F32Op.DemoteF64) -> op 0xac + | Convert (F32 F32Op.ReinterpretInt) -> op 0xad + + | Convert (F64 F64Op.ConvertSI32) -> op 0xae + | Convert (F64 F64Op.ConvertUI32) -> op 0xaf + | Convert (F64 F64Op.ConvertSI64) -> op 0xb0 + | Convert (F64 F64Op.ConvertUI64) -> op 0xb1 + | Convert (F64 F64Op.PromoteF32) -> op 0xb2 + | Convert (F64 F64Op.DemoteF64) -> assert false + | Convert (F64 F64Op.ReinterpretInt) -> op 0xb3 + + let const c = + list instr c.it; op 0x0f (* Sections *) let section id f x needed = if needed then begin - string id; - let g = gap () in + u8 id; + let g = gap32 () in let p = pos s in f x; - patch_gap g (pos s - p) + patch_gap32 g (pos s - p) end (* Type section *) let type_section ts = - section "type" (vec func_type) ts (ts <> []) + section 1 (vec func_type) ts (ts <> []) (* Import section *) let import_kind k = @@ -344,13 +391,13 @@ let encode m = string module_name; string item_name; import_kind ikind let import_section imps = - section "import" (vec import) imps (imps <> []) + section 2 (vec import) imps (imps <> []) (* Function section *) let func f = var f.it.ftype let func_section fs = - section "function" (vec func) fs (fs <> []) + section 3 (vec func) fs (fs <> []) (* Table section *) let table tab = @@ -358,7 +405,7 @@ let encode m = table_type ttype let table_section tabs = - section "table" (vec table) tabs (tabs <> []) + section 4 (vec table) tabs (tabs <> []) (* Memory section *) let memory mem = @@ -366,15 +413,15 @@ let encode m = memory_type mtype let memory_section mems = - section "memory" (vec memory) mems (mems <> []) + section 5 (vec memory) mems (mems <> []) (* Global section *) let global g = let {gtype; value} = g.it in - global_type gtype; expr value; op 0x0f + global_type gtype; const value let global_section gs = - section "global" (vec global) gs (gs <> []) + section 6 (vec global) gs (gs <> []) (* Export section *) let export_kind k = @@ -389,11 +436,11 @@ let encode m = string name; export_kind ekind; var item let export_section exps = - section "export" (vec export) exps (exps <> []) + section 7 (vec export) exps (exps <> []) (* Start section *) let start_section xo = - section "start" (opt var) xo (xo <> None) + section 8 (opt var) xo (xo <> None) (* Code section *) let compress ts = @@ -406,14 +453,15 @@ let encode m = let code f = let {locals; body; _} = f.it in - let g = gap () in + let g = gap32 () in let p = pos s in vec local (compress locals); - list expr body; - patch_gap g (pos s - p) + list instr body; + u8 0x0f; + patch_gap32 g (pos s - p) let code_section fs = - section "code" (vec code) fs (fs <> []) + section 9 (vec code) fs (fs <> []) (* Element section *) let segment dat seg = @@ -424,14 +472,14 @@ let encode m = segment (vec var) seg let elem_section elems = - section "element" (vec table_segment) elems (elems <> []) + section 10 (vec table_segment) elems (elems <> []) (* Data section *) let memory_segment seg = segment string seg let data_section data = - section "data" (vec memory_segment) data (data <> []) + section 11 (vec memory_segment) data (data <> []) (* Module *) @@ -446,8 +494,8 @@ let encode m = global_section m.it.globals; export_section m.it.exports; start_section m.it.start; - code_section m.it.funcs; elem_section m.it.elems; + code_section m.it.funcs; data_section m.it.data end in E.module_ m; to_string s diff --git a/ml-proto/host/import.ml b/ml-proto/host/import.ml index 481046e470..1e3205b85d 100644 --- a/ml-proto/host/import.ml +++ b/ml-proto/host/import.ml @@ -1,5 +1,5 @@ open Source -open Kernel +open Ast open Values open Types @@ -13,7 +13,7 @@ let register name lookup = registry := Registry.add name lookup !registry let external_type_of_import_kind m ikind = match ikind.it with - | FuncImport x -> ExternalFuncType (List.nth m.it.types x.it) + | FuncImport x -> ExternalFuncType (Lib.List32.nth m.it.types x.it) | TableImport t -> ExternalTableType t | MemoryImport t -> ExternalMemoryType t | GlobalImport t -> ExternalGlobalType t diff --git a/ml-proto/host/import.mli b/ml-proto/host/import.mli index 5ec32397f0..9310553df1 100644 --- a/ml-proto/host/import.mli +++ b/ml-proto/host/import.mli @@ -1,6 +1,6 @@ exception Unknown of Source.region * string -val link : Kernel.module_ -> Instance.extern list (* raises Unknown *) +val link : Ast.module_ -> Instance.extern list (* raises Unknown *) val register : string -> diff --git a/ml-proto/host/import/env.ml b/ml-proto/host/import/env.ml index 6fc7e4a236..9414fd1794 100644 --- a/ml-proto/host/import/env.ml +++ b/ml-proto/host/import/env.ml @@ -6,6 +6,7 @@ open Values open Types +open Instance let error msg = raise (Eval.Crash (Source.no_region, msg)) @@ -25,8 +26,8 @@ let single = function | vs -> error "type error, too many arguments" let int = function - | Int32 i -> Int32.to_int i - | v -> type_error v Int32Type + | I32 i -> Int32.to_int i + | v -> type_error v I32Type let abort vs = @@ -38,10 +39,8 @@ let exit vs = exit (int (single vs)) -open Instance - let lookup name t = - match name with - | "abort" -> ExternalFunc (HostFunc abort) - | "exit" -> ExternalFunc (HostFunc exit) + match name, t with + | "abort", ExternalFuncType t -> ExternalFunc (HostFunc (t, abort)) + | "exit", ExternalFuncType t -> ExternalFunc (HostFunc (t, exit)) | _ -> raise Not_found diff --git a/ml-proto/host/import/spectest.ml b/ml-proto/host/import/spectest.ml index 2bf70e0735..38863b154d 100644 --- a/ml-proto/host/import/spectest.ml +++ b/ml-proto/host/import/spectest.ml @@ -4,30 +4,31 @@ open Types open Values +open Instance -let global = function - | Int32Type -> Int32 666l - | Int64Type -> Int64 666L - | Float32Type -> Float32 (F32.of_float 666.0) - | Float64Type -> Float64 (F64.of_float 666.0) +let global (GlobalType (t, _)) = + match t with + | I32Type -> I32 666l + | I64Type -> I64 666L + | F32Type -> F32 (F32.of_float 666.6) + | F64Type -> F64 (F64.of_float 666.6) let table = Table.create {min = 10l; max = Some 20l} let memory = Memory.create {min = 1l; max = Some 2l} -let print out vs = - List.iter Print.print_value (List.map (fun v -> Some v) vs); - Lib.Option.map default_value out - +let print (FuncType (_, out)) vs = + List.iter Print.print_result (List.map (fun v -> [v]) vs); + List.map default_value out -open Instance let lookup name t = match name, t with - | "print", ExternalFuncType ft -> ExternalFunc (HostFunc (print ft.out)) - | "print", _ -> ExternalFunc (HostFunc (print None)) - | "global", ExternalGlobalType (GlobalType (t, _)) -> ExternalGlobal (global t) - | "global", _ -> ExternalGlobal (global Int32Type) + | "print", ExternalFuncType t -> ExternalFunc (HostFunc (t, print t)) + | "print", _ -> + let t = FuncType ([], []) in ExternalFunc (HostFunc (t, print t)) + | "global", ExternalGlobalType t -> ExternalGlobal (global t) + | "global", _ -> ExternalGlobal (global (GlobalType (I32Type, Immutable))) | "table", _ -> ExternalTable table | "memory", _ -> ExternalMemory memory | _ -> raise Not_found diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 18c67d110a..73846fec3b 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -1,6 +1,6 @@ { open Parser -open Ast +open Operators let convert_pos pos = { Source.file = pos.Lexing.pos_fname; @@ -38,10 +38,10 @@ let text s = Buffer.contents b let value_type = function - | "i32" -> Types.Int32Type - | "i64" -> Types.Int64Type - | "f32" -> Types.Float32Type - | "f64" -> Types.Float64Type + | "i32" -> Types.I32Type + | "i64" -> Types.I64Type + | "f32" -> Types.F32Type + | "f64" -> Types.F64Type | _ -> assert false let intop t i32 i64 = @@ -76,6 +76,8 @@ let ext e s u = | 's' -> s | 'u' -> u | _ -> assert false + +let opt = Lib.Option.get } let space = [' ''\t'] @@ -96,7 +98,7 @@ let int = sign nat let float = sign? num '.' digit* | sign? num ('.' digit*)? ('e' | 'E') sign? num - | sign? "0x" hexdigit+ '.'? hexdigit* 'p' sign? digit+ + | sign? "0x" hexdigit+ '.'? hexdigit* ('e' | 'E' | 'p') sign? digit+ | sign? "inf" | sign? "infinity" | sign? "nan" @@ -130,13 +132,13 @@ rule token = parse { let open Source in CONST (numop t (fun s -> let n = I32.of_string s.it in - I32_const (n @@ s.at), Values.Int32 n) + i32_const (n @@ s.at), Values.I32 n) (fun s -> let n = I64.of_string s.it in - I64_const (n @@ s.at), Values.Int64 n) + i64_const (n @@ s.at), Values.I64 n) (fun s -> let n = F32.of_string s.it in - F32_const (n @@ s.at), Values.Float32 n) + f32_const (n @@ s.at), Values.F32 n) (fun s -> let n = F64.of_string s.it in - F64_const (n @@ s.at), Values.Float64 n)) + f64_const (n @@ s.at), Values.F64 n)) } | "anyfunc" { ANYFUNC } | "mut" { MUT } @@ -146,6 +148,7 @@ rule token = parse | "drop" { DROP } | "block" { BLOCK } | "loop" { LOOP } + | "end" { END } | "br" { BR } | "br_if" { BR_IF } | "br_table" { BR_TABLE } @@ -164,194 +167,119 @@ rule token = parse | "set_global" { SET_GLOBAL } | (nxx as t)".load" - { LOAD (fun (o, a, e) -> - numop t (I32_load (o, (Lib.Option.get a 4), e)) - (I64_load (o, (Lib.Option.get a 8), e)) - (F32_load (o, (Lib.Option.get a 4), e)) - (F64_load (o, (Lib.Option.get a 8), e))) } + { LOAD (fun a o -> + numop t (i32_load (opt a 4)) (i64_load (opt a 8)) + (f32_load (opt a 4)) (f64_load (opt a 8)) o) } | (nxx as t)".store" - { STORE (fun (o, a, e1, e2) -> - numop t (I32_store (o, (Lib.Option.get a 4), e1, e2)) - (I64_store (o, (Lib.Option.get a 8), e1, e2)) - (F32_store (o, (Lib.Option.get a 4), e1, e2)) - (F64_store (o, (Lib.Option.get a 8), e1, e2))) } + { STORE (fun a o -> + numop t (i32_store (opt a 4)) (i64_store (opt a 8)) + (f32_store (opt a 4)) (f64_store (opt a 8)) o) } | (ixx as t)".load"(mem_size as sz)"_"(sign as s) { if t = "i32" && sz = "32" then error lexbuf "unknown operator"; - LOAD (fun (o, a, e) -> + LOAD (fun a o -> intop t (memsz sz - (ext s (I32_load8_s (o, (Lib.Option.get a 1), e)) - (I32_load8_u (o, (Lib.Option.get a 1), e))) - (ext s (I32_load16_s (o, (Lib.Option.get a 2), e)) - (I32_load16_u (o, (Lib.Option.get a 2), e))) - Unreachable) + (ext s i32_load8_s i32_load8_u (opt a 1)) + (ext s i32_load16_s i32_load16_u (opt a 2)) + (fun _ -> unreachable) o) (memsz sz - (ext s (I64_load8_s (o, (Lib.Option.get a 1), e)) - (I64_load8_u (o, (Lib.Option.get a 1), e))) - (ext s (I64_load16_s (o, (Lib.Option.get a 2), e)) - (I64_load16_u (o, (Lib.Option.get a 2), e))) - (ext s (I64_load32_s (o, (Lib.Option.get a 4), e)) - (I64_load32_u (o, (Lib.Option.get a 4), e))))) } + (ext s i64_load8_s i64_load8_u (opt a 1)) + (ext s i64_load16_s i64_load16_u (opt a 2)) + (ext s i64_load32_s i64_load32_u (opt a 4)) o)) } | (ixx as t)".store"(mem_size as sz) { if t = "i32" && sz = "32" then error lexbuf "unknown operator"; - STORE (fun (o, a, e1, e2) -> + STORE (fun a o -> intop t (memsz sz - (I32_store8 (o, (Lib.Option.get a 1), e1, e2)) - (I32_store16 (o, (Lib.Option.get a 2), e1, e2)) - Unreachable) + (i32_store8 (opt a 1)) + (i32_store16 (opt a 2)) + (fun _ -> unreachable) o) (memsz sz - (I64_store8 (o, (Lib.Option.get a 1), e1, e2)) - (I64_store16 (o, (Lib.Option.get a 2), e1, e2)) - (I64_store32 (o, (Lib.Option.get a 4), e1, e2))) - ) } + (i64_store8 (opt a 1)) + (i64_store16 (opt a 2)) + (i64_store32 (opt a 4)) o)) } - | "offset="(nat as s) { OFFSET (Int64.of_string s) } - | "align="(nat as s) { ALIGN (int_of_string s) } + | "offset="(nat as s) { OFFSET_EQ_NAT (Int64.of_string s) } + | "align="(nat as s) { ALIGN_EQ_NAT (int_of_string s) } - | (ixx as t)".clz" - { UNARY (fun e -> intop t (I32_clz e) (I64_clz e)) } - | (ixx as t)".ctz" - { UNARY (fun e -> intop t (I32_ctz e) (I64_ctz e)) } - | (ixx as t)".popcnt" - { UNARY (fun e -> intop t (I32_popcnt e) (I64_popcnt e)) } - | (fxx as t)".neg" - { UNARY (fun e -> floatop t (F32_neg e) (F64_neg e)) } - | (fxx as t)".abs" - { UNARY (fun e -> floatop t (F32_abs e) (F64_abs e)) } - | (fxx as t)".sqrt" - { UNARY (fun e -> floatop t (F32_sqrt e) (F64_sqrt e)) } - | (fxx as t)".ceil" - { UNARY (fun e -> floatop t (F32_ceil e) (F64_ceil e)) } - | (fxx as t)".floor" - { UNARY (fun e -> floatop t (F32_floor e) (F64_floor e)) } - | (fxx as t)".trunc" - { UNARY (fun e -> floatop t (F32_trunc e) (F64_trunc e)) } - | (fxx as t)".nearest" - { UNARY (fun e -> floatop t (F32_nearest e) (F64_nearest e)) } + | (ixx as t)".clz" { UNARY (intop t i32_clz i64_clz) } + | (ixx as t)".ctz" { UNARY (intop t i32_ctz i64_ctz) } + | (ixx as t)".popcnt" { UNARY (intop t i32_popcnt i64_popcnt) } + | (fxx as t)".neg" { UNARY (floatop t f32_neg f64_neg) } + | (fxx as t)".abs" { UNARY (floatop t f32_abs f64_abs) } + | (fxx as t)".sqrt" { UNARY (floatop t f32_sqrt f64_sqrt) } + | (fxx as t)".ceil" { UNARY (floatop t f32_ceil f64_ceil) } + | (fxx as t)".floor" { UNARY (floatop t f32_floor f64_floor) } + | (fxx as t)".trunc" { UNARY (floatop t f32_trunc f64_trunc) } + | (fxx as t)".nearest" { UNARY (floatop t f32_nearest f64_nearest) } - | (ixx as t)".add" - { BINARY (fun (e1, e2) -> intop t (I32_add (e1, e2)) (I64_add (e1, e2))) } - | (ixx as t)".sub" - { BINARY (fun (e1, e2) -> intop t (I32_sub (e1, e2)) (I64_sub (e1, e2))) } - | (ixx as t)".mul" - { BINARY (fun (e1, e2) -> intop t (I32_mul (e1, e2)) (I64_mul (e1, e2))) } - | (ixx as t)".div_s" - { BINARY (fun (e1, e2) -> - intop t (I32_div_s (e1, e2)) (I64_div_s (e1, e2))) } - | (ixx as t)".div_u" - { BINARY (fun (e1, e2) -> - intop t (I32_div_u (e1, e2)) (I64_div_u (e1, e2))) } - | (ixx as t)".rem_s" - { BINARY (fun (e1, e2) -> - intop t (I32_rem_s (e1, e2)) (I64_rem_s (e1, e2))) } - | (ixx as t)".rem_u" - { BINARY (fun (e1, e2) -> - intop t (I32_rem_u (e1, e2)) (I64_rem_u (e1, e2))) } - | (ixx as t)".and" - { BINARY (fun (e1, e2) -> intop t (I32_and (e1, e2)) (I64_and (e1, e2))) } - | (ixx as t)".or" - { BINARY (fun (e1, e2) -> intop t (I32_or (e1, e2)) (I64_or (e1, e2))) } - | (ixx as t)".xor" - { BINARY (fun (e1, e2) -> intop t (I32_xor (e1, e2)) (I64_xor (e1, e2))) } - | (ixx as t)".shl" - { BINARY (fun (e1, e2) -> intop t (I32_shl (e1, e2)) (I64_shl (e1, e2))) } - | (ixx as t)".shr_s" - { BINARY (fun (e1, e2) -> - intop t (I32_shr_s (e1, e2)) (I64_shr_s (e1, e2))) } - | (ixx as t)".shr_u" - { BINARY (fun (e1, e2) -> - intop t (I32_shr_u (e1, e2)) (I64_shr_u (e1, e2))) } - | (ixx as t)".rotl" - { BINARY (fun (e1, e2) -> - intop t (I32_rotl (e1, e2)) (I64_rotl (e1, e2))) } - | (ixx as t)".rotr" - { BINARY (fun (e1, e2) -> - intop t (I32_rotr (e1, e2)) (I64_rotr (e1, e2))) } - | (fxx as t)".add" - { BINARY (fun (e1, e2) -> floatop t (F32_add (e1, e2)) (F64_add (e1, e2))) } - | (fxx as t)".sub" - { BINARY (fun (e1, e2) -> floatop t (F32_sub (e1, e2)) (F64_sub (e1, e2))) } - | (fxx as t)".mul" - { BINARY (fun (e1, e2) -> floatop t (F32_mul (e1, e2)) (F64_mul (e1, e2))) } - | (fxx as t)".div" - { BINARY (fun (e1, e2) -> floatop t (F32_div (e1, e2)) (F64_div (e1, e2))) } - | (fxx as t)".min" - { BINARY (fun (e1, e2) -> floatop t (F32_min (e1, e2)) (F64_min (e1, e2))) } - | (fxx as t)".max" - { BINARY (fun (e1, e2) -> floatop t (F32_max (e1, e2)) (F64_max (e1, e2))) } - | (fxx as t)".copysign" - { BINARY (fun (e1, e2) -> - floatop t (F32_copysign (e1, e2)) (F64_copysign (e1, e2))) } + | (ixx as t)".add" { BINARY (intop t i32_add i64_add) } + | (ixx as t)".sub" { BINARY (intop t i32_sub i64_sub) } + | (ixx as t)".mul" { BINARY (intop t i32_mul i64_mul) } + | (ixx as t)".div_s" { BINARY (intop t i32_div_s i64_div_s) } + | (ixx as t)".div_u" { BINARY (intop t i32_div_u i64_div_u) } + | (ixx as t)".rem_s" { BINARY (intop t i32_rem_s i64_rem_s) } + | (ixx as t)".rem_u" { BINARY (intop t i32_rem_u i64_rem_u) } + | (ixx as t)".and" { BINARY (intop t i32_and i64_and) } + | (ixx as t)".or" { BINARY (intop t i32_or i64_or) } + | (ixx as t)".xor" { BINARY (intop t i32_xor i64_xor) } + | (ixx as t)".shl" { BINARY (intop t i32_shl i64_shl) } + | (ixx as t)".shr_s" { BINARY (intop t i32_shr_s i64_shr_s) } + | (ixx as t)".shr_u" { BINARY (intop t i32_shr_u i64_shr_u) } + | (ixx as t)".rotl" { BINARY (intop t i32_rotl i64_rotl) } + | (ixx as t)".rotr" { BINARY (intop t i32_rotr i64_rotr) } + | (fxx as t)".add" { BINARY (floatop t f32_add f64_add) } + | (fxx as t)".sub" { BINARY (floatop t f32_sub f64_sub) } + | (fxx as t)".mul" { BINARY (floatop t f32_mul f64_mul) } + | (fxx as t)".div" { BINARY (floatop t f32_div f64_div) } + | (fxx as t)".min" { BINARY (floatop t f32_min f64_min) } + | (fxx as t)".max" { BINARY (floatop t f32_max f64_max) } + | (fxx as t)".copysign" { BINARY (floatop t f32_copysign f64_copysign) } - | (ixx as t)".eqz" { TEST (fun e -> intop t (I32_eqz e) (I64_eqz e)) } + | (ixx as t)".eqz" { TEST (intop t i32_eqz i64_eqz) } - | (ixx as t)".eq" - { COMPARE (fun (e1, e2) -> intop t (I32_eq (e1, e2)) (I64_eq (e1, e2))) } - | (ixx as t)".ne" - { COMPARE (fun (e1, e2) -> intop t (I32_ne (e1, e2)) (I64_ne (e1, e2))) } - | (ixx as t)".lt_s" - { COMPARE (fun (e1, e2) -> - intop t (I32_lt_s (e1, e2)) (I64_lt_s (e1, e2))) } - | (ixx as t)".lt_u" - { COMPARE (fun (e1, e2) -> - intop t (I32_lt_u (e1, e2)) (I64_lt_u (e1, e2))) } - | (ixx as t)".le_s" - { COMPARE (fun (e1, e2) -> - intop t (I32_le_s (e1, e2)) (I64_le_s (e1, e2))) } - | (ixx as t)".le_u" - { COMPARE (fun (e1, e2) -> - intop t (I32_le_u (e1, e2)) (I64_le_u (e1, e2))) } - | (ixx as t)".gt_s" - { COMPARE (fun (e1, e2) -> - intop t (I32_gt_s (e1, e2)) (I64_gt_s (e1, e2))) } - | (ixx as t)".gt_u" - { COMPARE (fun (e1, e2) -> - intop t (I32_gt_u (e1, e2)) (I64_gt_u (e1, e2))) } - | (ixx as t)".ge_s" - { COMPARE (fun (e1, e2) -> - intop t (I32_ge_s (e1, e2)) (I64_ge_s (e1, e2))) } - | (ixx as t)".ge_u" - { COMPARE (fun (e1, e2) -> - intop t (I32_ge_u (e1, e2)) (I64_ge_u (e1, e2))) } - | (fxx as t)".eq" - { COMPARE (fun (e1, e2) -> floatop t (F32_eq (e1, e2)) (F64_eq (e1, e2))) } - | (fxx as t)".ne" - { COMPARE (fun (e1, e2) -> floatop t (F32_ne (e1, e2)) (F64_ne (e1, e2))) } - | (fxx as t)".lt" - { COMPARE (fun (e1, e2) -> floatop t (F32_lt (e1, e2)) (F64_lt (e1, e2))) } - | (fxx as t)".le" - { COMPARE (fun (e1, e2) -> floatop t (F32_le (e1, e2)) (F64_le (e1, e2))) } - | (fxx as t)".gt" - { COMPARE (fun (e1, e2) -> floatop t (F32_gt (e1, e2)) (F64_gt (e1, e2))) } - | (fxx as t)".ge" - { COMPARE (fun (e1, e2) -> floatop t (F32_ge (e1, e2)) (F64_ge (e1, e2))) } + | (ixx as t)".eq" { COMPARE (intop t i32_eq i64_eq) } + | (ixx as t)".ne" { COMPARE (intop t i32_ne i64_ne) } + | (ixx as t)".lt_s" { COMPARE (intop t i32_lt_s i64_lt_s) } + | (ixx as t)".lt_u" { COMPARE (intop t i32_lt_u i64_lt_u) } + | (ixx as t)".le_s" { COMPARE (intop t i32_le_s i64_le_s) } + | (ixx as t)".le_u" { COMPARE (intop t i32_le_u i64_le_u) } + | (ixx as t)".gt_s" { COMPARE (intop t i32_gt_s i64_gt_s) } + | (ixx as t)".gt_u" { COMPARE (intop t i32_gt_u i64_gt_u) } + | (ixx as t)".ge_s" { COMPARE (intop t i32_ge_s i64_ge_s) } + | (ixx as t)".ge_u" { COMPARE (intop t i32_ge_u i64_ge_u) } + | (fxx as t)".eq" { COMPARE (floatop t f32_eq f64_eq) } + | (fxx as t)".ne" { COMPARE (floatop t f32_ne f64_ne) } + | (fxx as t)".lt" { COMPARE (floatop t f32_lt f64_lt) } + | (fxx as t)".le" { COMPARE (floatop t f32_le f64_le) } + | (fxx as t)".gt" { COMPARE (floatop t f32_gt f64_gt) } + | (fxx as t)".ge" { COMPARE (floatop t f32_ge f64_ge) } - | "i32.wrap/i64" { CONVERT (fun e -> I32_wrap_i64 e) } - | "i64.extend_s/i32" { CONVERT (fun e -> I64_extend_s_i32 e) } - | "i64.extend_u/i32" { CONVERT (fun e -> I64_extend_u_i32 e) } - | "f32.demote/f64" { CONVERT (fun e -> F32_demote_f64 e) } - | "f64.promote/f32" { CONVERT (fun e -> F64_promote_f32 e) } + | "i32.wrap/i64" { CONVERT i32_wrap_i64 } + | "i64.extend_s/i32" { CONVERT i64_extend_s_i32 } + | "i64.extend_u/i32" { CONVERT i64_extend_u_i32 } + | "f32.demote/f64" { CONVERT f32_demote_f64 } + | "f64.promote/f32" { CONVERT f64_promote_f32 } | (ixx as t)".trunc_s/f32" - { CONVERT (fun e -> intop t (I32_trunc_s_f32 e) (I64_trunc_s_f32 e)) } + { CONVERT (intop t i32_trunc_s_f32 i64_trunc_s_f32) } | (ixx as t)".trunc_u/f32" - { CONVERT (fun e -> intop t (I32_trunc_u_f32 e) (I64_trunc_u_f32 e)) } + { CONVERT (intop t i32_trunc_u_f32 i64_trunc_u_f32) } | (ixx as t)".trunc_s/f64" - { CONVERT (fun e -> intop t (I32_trunc_s_f64 e) (I64_trunc_s_f64 e)) } + { CONVERT (intop t i32_trunc_s_f64 i64_trunc_s_f64) } | (ixx as t)".trunc_u/f64" - { CONVERT (fun e -> intop t (I32_trunc_u_f64 e) (I64_trunc_u_f64 e)) } + { CONVERT (intop t i32_trunc_u_f64 i64_trunc_u_f64) } | (fxx as t)".convert_s/i32" - { CONVERT (fun e -> floatop t (F32_convert_s_i32 e) (F64_convert_s_i32 e)) } + { CONVERT (floatop t f32_convert_s_i32 f64_convert_s_i32) } | (fxx as t)".convert_u/i32" - { CONVERT (fun e -> floatop t (F32_convert_u_i32 e) (F64_convert_u_i32 e)) } + { CONVERT (floatop t f32_convert_u_i32 f64_convert_u_i32) } | (fxx as t)".convert_s/i64" - { CONVERT (fun e -> floatop t (F32_convert_s_i64 e) (F64_convert_s_i64 e)) } + { CONVERT (floatop t f32_convert_s_i64 f64_convert_s_i64) } | (fxx as t)".convert_u/i64" - { CONVERT (fun e -> floatop t (F32_convert_u_i64 e) (F64_convert_u_i64 e)) } - | "f32.reinterpret/i32" { CONVERT (fun e -> F32_reinterpret_i32 e) } - | "f64.reinterpret/i64" { CONVERT (fun e -> F64_reinterpret_i64 e) } - | "i32.reinterpret/f32" { CONVERT (fun e -> I32_reinterpret_f32 e) } - | "i64.reinterpret/f64" { CONVERT (fun e -> I64_reinterpret_f64 e) } + { CONVERT (floatop t f32_convert_u_i64 f64_convert_u_i64) } + | "f32.reinterpret/i32" { CONVERT f32_reinterpret_i32 } + | "f64.reinterpret/i64" { CONVERT f64_reinterpret_i64 } + | "i32.reinterpret/f32" { CONVERT i32_reinterpret_f32 } + | "i64.reinterpret/f64" { CONVERT i64_reinterpret_f64 } | "current_memory" { CURRENT_MEMORY } | "grow_memory" { GROW_MEMORY } @@ -368,6 +296,7 @@ rule token = parse | "memory" { MEMORY } | "elem" { ELEM } | "data" { DATA } + | "offset" { OFFSET } | "import" { IMPORT } | "export" { EXPORT } diff --git a/ml-proto/host/main.ml b/ml-proto/host/main.ml index f71199bab4..f34e601589 100644 --- a/ml-proto/host/main.ml +++ b/ml-proto/host/main.ml @@ -1,5 +1,5 @@ let name = "Wasm-" ^ Printf.sprintf "0x%02lx" Encode.version -let version = "0.4" +let version = "0.5" let configure () = Import.register "spectest" Spectest.lookup; diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 9b403a90d7..5c9d1a6e63 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -1,8 +1,8 @@ %{ open Source open Types -open Kernel open Ast +open Operators open Script @@ -10,7 +10,9 @@ open Script let error at msg = raise (Script.Syntax (at, msg)) -let parse_error msg = error Source.no_region msg +let parse_error msg = + error Source.no_region + (if msg = "syntax error" then "unexpected token" else msg) (* Position handling *) @@ -51,15 +53,15 @@ let int64 s at = module VarMap = Map.Make(String) -type space = {mutable map : int VarMap.t; mutable count : int} -let empty () = {map = VarMap.empty; count = 0} +type space = {mutable map : int32 VarMap.t; mutable count : int32} +let empty () = {map = VarMap.empty; count = 0l} -type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} +type types = {mutable tmap : int32 VarMap.t; mutable tlist : Types.func_type list} let empty_types () = {tmap = VarMap.empty; tlist = []} type context = { types : types; tables : space; memories : space; - funcs : space; locals : space; globals : space; labels : int VarMap.t } + funcs : space; locals : space; globals : space; labels : int32 VarMap.t } let empty_context () = { types = empty_types (); tables = empty (); memories = empty (); @@ -92,7 +94,11 @@ let anon_module () = None let bind_type c x ty = if VarMap.mem x.it c.types.tmap then error x.at ("duplicate type " ^ x.it); - c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap; + c.types.tmap <- + VarMap.add x.it (Lib.List32.length c.types.tlist) c.types.tmap; + c.types.tlist <- c.types.tlist @ [ty] + +let anon_type c ty = c.types.tlist <- c.types.tlist @ [ty] let anon_type c ty = @@ -102,7 +108,9 @@ let bind category space x = if VarMap.mem x.it space.map then error x.at ("duplicate " ^ category ^ " " ^ x.it); space.map <- VarMap.add x.it space.count space.map; - space.count <- space.count + 1 + space.count <- Int32.add space.count 1l; + if space.count = 0l then + error x.at ("too many " ^ category ^ " bindings") let bind_func c x = bind "function" c.funcs x let bind_local c x = bind "local" c.locals x @@ -110,45 +118,51 @@ let bind_global c x = bind "global" c.globals x let bind_table c x = bind "table" c.tables x let bind_memory c x = bind "memory" c.memories x let bind_label c x = - {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} + {c with labels = VarMap.add x.it 0l (VarMap.map (Int32.add 1l) c.labels)} -let anon space n = space.count <- space.count + n +let anon_type c ty = + c.types.tlist <- c.types.tlist @ [ty] + +let anon category space n = + space.count <- Int32.add space.count n; + if I32.lt_u space.count n then + error no_region ("too many " ^ category ^ " bindings") -let anon_func c = anon c.funcs 1 -let anon_locals c ts = anon c.locals (List.length ts) -let anon_global c = anon c.globals 1 -let anon_table c = anon c.tables 1 -let anon_memory c = anon c.memories 1 -let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} +let anon_func c = anon "function" c.funcs 1l +let anon_locals c ts = anon "local" c.locals (Lib.List32.length ts) +let anon_global c = anon "global" c.globals 1l +let anon_table c = anon "table" c.tables 1l +let anon_memory c = anon "memory" c.memories 1l +let anon_label c = {c with labels = VarMap.map (Int32.add 1l) c.labels} -let empty_type = {ins = []; out = None} +let empty_type = FuncType ([], []) let explicit_sig c var t at = let x = var c type_ in if - x.it < List.length c.types.tlist && + x.it < Lib.List32.length c.types.tlist && t <> empty_type && - t <> List.nth c.types.tlist x.it + t <> Lib.List32.nth c.types.tlist x.it then error at "signature mismatch"; x let inline_type c t at = match Lib.List.index_of t c.types.tlist with - | None -> let i = List.length c.types.tlist in anon_type c t; i @@ at - | Some i -> i @@ at + | None -> let i = Lib.List32.length c.types.tlist in anon_type c t; i @@ at + | Some i -> Int32.of_int i @@ at %} %token NAT INT FLOAT TEXT VAR VALUE_TYPE ANYFUNC MUT LPAR RPAR -%token NOP DROP BLOCK IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE +%token NOP DROP BLOCK END IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE %token CALL CALL_INDIRECT RETURN %token GET_LOCAL SET_LOCAL TEE_LOCAL GET_GLOBAL SET_GLOBAL -%token LOAD STORE OFFSET ALIGN +%token LOAD STORE OFFSET_EQ_NAT ALIGN_EQ_NAT %token CONST UNARY BINARY COMPARE CONVERT %token UNREACHABLE CURRENT_MEMORY GROW_MEMORY %token FUNC START TYPE PARAM RESULT LOCAL GLOBAL -%token MODULE TABLE ELEM MEMORY DATA IMPORT EXPORT TABLE +%token MODULE TABLE ELEM MEMORY DATA OFFSET IMPORT EXPORT TABLE %token REGISTER INVOKE GET %token ASSERT_INVALID ASSERT_UNLINKABLE %token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP @@ -161,16 +175,16 @@ let inline_type c t at = %token TEXT %token VAR %token VALUE_TYPE -%token Ast.expr' * Values.value> CONST -%token Ast.expr'> UNARY -%token Ast.expr'> BINARY -%token Ast.expr'> TEST -%token Ast.expr'> COMPARE -%token Ast.expr'> CONVERT -%token Ast.expr'> LOAD -%token Ast.expr'> STORE -%token OFFSET -%token ALIGN +%token Ast.instr' * Values.value> CONST +%token UNARY +%token BINARY +%token TEST +%token COMPARE +%token CONVERT +%token Memory.offset -> Ast.instr'> LOAD +%token Memory.offset -> Ast.instr'> STORE +%token OFFSET_EQ_NAT +%token ALIGN_EQ_NAT %nonassoc LOW %nonassoc VAR @@ -210,14 +224,16 @@ func_type : ; func_sig : - | /* empty */ { {ins = []; out = None} } - | LPAR RESULT VALUE_TYPE RPAR func_sig - { if $5.out <> None then error (at ()) "multiple return types"; - {$5 with out = Some $3} } + | /* empty */ + { FuncType ([], []) } + | LPAR RESULT value_type_list RPAR func_sig + { let FuncType (ins, out) = $5 in + if ins <> [] then error (at ()) "result before parameter"; + FuncType (ins, $3 @ out) } | LPAR PARAM value_type_list RPAR func_sig - { {$5 with ins = $3 @ $5.ins} } + { let FuncType (ins, out) = $5 in FuncType ($3 @ ins, out) } | LPAR PARAM bind_var VALUE_TYPE RPAR func_sig /* Sugar */ - { {$6 with ins = $4 :: $6.ins} } + { let FuncType (ins, out) = $6 in FuncType ($4 :: ins, out) } ; table_sig : @@ -228,8 +244,7 @@ memory_sig : ; limits : | NAT { {min = int32 $1 (ati 1); max = None} } - | NAT NAT - { {min = int32 $1 (ati 1); max = Some (int32 $2 (ati 2))} } + | NAT NAT { {min = int32 $1 (ati 1); max = Some (int32 $2 (ati 2))} } ; type_use : @@ -239,6 +254,10 @@ type_use : /* Expressions */ +nat : + | NAT { int_of_string $1 } +; + literal : | NAT { $1 @@ at () } | INT { $1 @@ at () } @@ -246,7 +265,7 @@ literal : ; var : - | NAT { let at = at () in fun c lookup -> int $1 at @@ at } + | NAT { let at = at () in fun c lookup -> int32 $1 at @@ at } | VAR { let at = at () in fun c lookup -> lookup c ($1 @@ at) @@ at } ; var_list : @@ -264,77 +283,110 @@ bind_var : labeling_opt : | /* empty */ %prec LOW { fun c -> anon_label c } - | labeling { $1 } -; -labeling : | bind_var { fun c -> bind_label c $1 } ; -offset : +offset_opt : | /* empty */ { 0L } - | OFFSET { $1 } + | OFFSET_EQ_NAT { $1 } ; -align : +align_opt : | /* empty */ { None } - | ALIGN { Some $1 } -; - -expr : - | LPAR expr1 RPAR { let at = at () in fun c -> $2 c @@ at } -; -expr1 : - | NOP { fun c -> Nop } - | UNREACHABLE { fun c -> Unreachable } - | DROP expr { fun c -> Drop ($2 c) } - | BLOCK labeling_opt expr_list { fun c -> let c' = $2 c in Block ($3 c') } - | LOOP labeling_opt expr_list - { fun c -> let c' = anon_label c in let c'' = $2 c' in Loop ($3 c'') } - | LOOP labeling labeling expr_list - { fun c -> let c' = $2 c in let c'' = $3 c' in Loop ($4 c'') } - | BR var expr_opt { fun c -> Br ($2 c label, $3 c) } - | BR_IF var expr { fun c -> Br_if ($2 c label, None, $3 c) } - | BR_IF var expr expr { fun c -> Br_if ($2 c label, Some ($3 c), $4 c) } - | BR_TABLE var var_list expr - { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - Br_table (xs, x, None, $4 c) } - | BR_TABLE var var_list expr expr + | ALIGN_EQ_NAT { Some $1 } +; + +instr : + | plain_instr { let at = at () in fun c -> [$1 c @@ at] } + | ctrl_instr { let at = at () in fun c -> [$1 c @@ at] } + | expr { $1 } /* Sugar */ +; +plain_instr : + | UNREACHABLE { fun c -> unreachable } + | NOP { fun c -> nop } + | DROP { fun c -> drop } + | SELECT { fun c -> select } + | BR nat var { fun c -> br $2 ($3 c label) } + | BR_IF nat var { fun c -> br_if $2 ($3 c label) } + | BR_TABLE var /*nat*/ var var_list + { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in + (* TODO: remove hack once arities are gone *) + let n = $2 c (fun _ -> error x.at "syntax error") in + br_table (Int32.to_int n.it) xs x } + | RETURN { fun c -> return } + | CALL var { fun c -> call ($2 c func) } + | CALL_INDIRECT var { fun c -> call_indirect ($2 c type_) } + | GET_LOCAL var { fun c -> get_local ($2 c local) } + | SET_LOCAL var { fun c -> set_local ($2 c local) } + | TEE_LOCAL var { fun c -> tee_local ($2 c local) } + | GET_GLOBAL var { fun c -> get_global ($2 c global) } + | SET_GLOBAL var { fun c -> set_global ($2 c global) } + | LOAD offset_opt align_opt { fun c -> $1 $3 $2 } + | STORE offset_opt align_opt { fun c -> $1 $3 $2 } + | CONST literal { fun c -> fst (literal $1 $2) } + | UNARY { fun c -> $1 } + | BINARY { fun c -> $1 } + | TEST { fun c -> $1 } + | COMPARE { fun c -> $1 } + | CONVERT { fun c -> $1 } + | CURRENT_MEMORY { fun c -> current_memory } + | GROW_MEMORY { fun c -> grow_memory } +; +ctrl_instr : + | BLOCK labeling_opt instr_list END + { fun c -> let c' = $2 c in block ($3 c') } + | LOOP labeling_opt instr_list END + { fun c -> let c' = $2 c in loop ($3 c') } + | IF labeling_opt instr_list END + { fun c -> let c' = $2 c in if_ ($3 c') [] } + | IF labeling_opt instr_list ELSE labeling_opt instr_list END + { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) } +; + +expr : /* Sugar */ + | LPAR expr1 RPAR + { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } +; +expr1 : /* Sugar */ + | plain_instr expr_list { fun c -> snd ($2 c), $1 c } + /* TODO: remove special-casing of branches here once arities are gone */ + | BR var expr_list { fun c -> let n, es = $3 c in es, br n ($2 c label) } + | BR_IF var expr expr_list + { fun c -> + let es1 = $3 c and n, es2 = $4 c in es1 @ es2, br_if n ($2 c label) } + | BR_TABLE var var_list expr expr_list { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - Br_table (xs, x, Some ($4 c), $5 c) } - | RETURN expr_opt { fun c -> Return ($2 c) } - | IF expr expr { fun c -> let c' = anon_label c in If ($2 c, [$3 c'], []) } + let es1 = $4 c and n, es2 = $5 c in es1 @ es2, br_table n xs x } + | BLOCK labeling_opt instr_list + { fun c -> let c' = $2 c in [], block ($3 c') } + | LOOP labeling_opt instr_list + { fun c -> let c' = $2 c in [], loop ($3 c') } + | IF expr expr { fun c -> let c' = anon_label c in $2 c, if_ ($3 c') [] } | IF expr expr expr - { fun c -> let c' = anon_label c in If ($2 c, [$3 c'], [$4 c']) } - | IF expr LPAR THEN labeling_opt expr_list RPAR - { fun c -> let c' = $5 c in If ($2 c, $6 c', []) } - | IF expr LPAR THEN labeling_opt expr_list RPAR LPAR ELSE labeling_opt expr_list RPAR - { fun c -> let c1 = $5 c in let c2 = $10 c in If ($2 c, $6 c1, $11 c2) } - | SELECT expr expr expr { fun c -> Select ($2 c, $3 c, $4 c) } - | CALL var expr_list { fun c -> Call ($2 c func, $3 c) } - | CALL_INDIRECT var expr expr_list - { fun c -> Call_indirect ($2 c type_, $3 c, $4 c) } - | GET_LOCAL var { fun c -> Get_local ($2 c local) } - | SET_LOCAL var expr { fun c -> Set_local ($2 c local, $3 c) } - | TEE_LOCAL var expr { fun c -> Tee_local ($2 c local, $3 c) } - | GET_GLOBAL var { fun c -> Get_global ($2 c global) } - | SET_GLOBAL var expr { fun c -> Set_global ($2 c global, $3 c) } - | LOAD offset align expr { fun c -> $1 ($2, $3, $4 c) } - | STORE offset align expr expr { fun c -> $1 ($2, $3, $4 c, $5 c) } - | CONST literal { fun c -> fst (literal $1 $2) } - | UNARY expr { fun c -> $1 ($2 c) } - | BINARY expr expr { fun c -> $1 ($2 c, $3 c) } - | TEST expr { fun c -> $1 ($2 c) } - | COMPARE expr expr { fun c -> $1 ($2 c, $3 c) } - | CONVERT expr { fun c -> $1 ($2 c) } - | CURRENT_MEMORY { fun c -> Current_memory } - | GROW_MEMORY expr { fun c -> Grow_memory ($2 c) } -; -expr_opt : - | /* empty */ { fun c -> None } - | expr { fun c -> Some ($1 c) } + { fun c -> let c' = anon_label c in $2 c, if_ ($3 c') ($4 c') } + | IF expr LPAR THEN labeling_opt instr_list RPAR + { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] } + | IF expr LPAR THEN labeling_opt instr_list RPAR LPAR + ELSE labeling_opt instr_list RPAR + { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) } + | IF LPAR THEN labeling_opt instr_list RPAR + { fun c -> let c' = $4 c in [], if_ ($5 c') [] } + | IF LPAR THEN labeling_opt instr_list RPAR + LPAR ELSE labeling_opt instr_list RPAR + { fun c -> let c1 = $4 c in let c2 = $9 c in [], if_ ($5 c1) ($10 c2) } +; + +instr_list : + | /* empty */ { fun c -> [] } + | instr instr_list { fun c -> $1 c @ $2 c } ; expr_list : - | /* empty */ { fun c -> [] } - | expr expr_list { fun c -> $1 c :: $2 c } + | /* empty */ { fun c -> 0, [] } + | expr expr_list + { fun c -> let es1 = $1 c and n, es2 = $2 c in n + 1, es1 @ es2 } +; + +const_expr : + | instr_list { let at = at () in fun c -> $1 c @@ at } ; @@ -342,22 +394,21 @@ expr_list : func_fields : | func_body { $1 } - | LPAR RESULT VALUE_TYPE RPAR func_body - { if (fst $5).out <> None then error (at ()) "multiple return types"; - {(fst $5) with out = Some $3}, - fun c -> (snd $5) c } + | LPAR RESULT value_type_list RPAR func_body + { let FuncType (ins, out) = fst $5 in + FuncType (ins, $3 @ out), fun c -> snd $5 c } | LPAR PARAM value_type_list RPAR func_fields - { {(fst $5) with ins = $3 @ (fst $5).ins}, - fun c -> anon_locals c $3; (snd $5) c } + { let FuncType (ins, out) = fst $5 in + FuncType ($3 @ ins, out), fun c -> anon_locals c $3; (snd $5) c } | LPAR PARAM bind_var VALUE_TYPE RPAR func_fields /* Sugar */ - { {(fst $6) with ins = $4 :: (fst $6).ins}, - fun c -> bind_local c $3; (snd $6) c } + { let FuncType (ins, out) = fst $6 in + FuncType ($4 :: ins, out), fun c -> bind_local c $3; (snd $6) c } ; func_body : - | expr_list + | instr_list { empty_type, fun c -> let c' = anon_label c in - {ftype = -1 @@ at(); locals = []; body = $1 c'} } + {ftype = -1l @@ at(); locals = []; body = $1 c'} } | LPAR LOCAL value_type_list RPAR func_body { fst $5, fun c -> anon_locals c $3; let f = (snd $5) c in @@ -374,7 +425,7 @@ func : let t = explicit_sig c $5 (fst $6) at in (fun () -> {(snd $6 (enter_func c)) with ftype = t} @@ at), $4 FuncExport c.funcs.count c } - /* Need to duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ + /* Duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ | LPAR FUNC bind_var_opt type_use func_fields RPAR { let at = at () in fun c -> $3 c anon_func bind_func; @@ -387,7 +438,7 @@ func : let t = inline_type c (fst $5) at in (fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at), $4 FuncExport c.funcs.count c } - /* Need to duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ + /* Duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ | LPAR FUNC bind_var_opt func_fields RPAR /* Sugar */ { let at = at () in fun c -> $3 c anon_func bind_func; @@ -399,13 +450,18 @@ func : /* Tables, Memories & Globals */ +offset : + | LPAR OFFSET const_expr RPAR { $3 } + | expr { let at = at () in fun c -> $1 c @@ at } /* Sugar */ +; + elem : - | LPAR ELEM var expr var_list RPAR + | LPAR ELEM var offset var_list RPAR { let at = at () in fun c -> {index = $3 c table; offset = $4 c; init = $5 c func} @@ at } - | LPAR ELEM expr var_list RPAR /* Sugar */ + | LPAR ELEM offset var_list RPAR /* Sugar */ { let at = at () in - fun c -> {index = 0 @@ at; offset = $3 c; init = $4 c func} @@ at } + fun c -> {index = 0l @@ at; offset = $3 c; init = $4 c func} @@ at } ; table : @@ -413,22 +469,24 @@ table : { let at = at () in fun c -> $3 c anon_table bind_table; {ttype = $5} @@ at, [], $4 TableExport c.tables.count c } - | LPAR TABLE bind_var_opt inline_export_opt elem_type LPAR ELEM var_list RPAR RPAR /* Sugar */ + | LPAR TABLE bind_var_opt inline_export_opt elem_type + LPAR ELEM var_list RPAR RPAR /* Sugar */ { let at = at () in - fun c -> $3 c anon_table bind_table; + fun c -> let i = c.tables.count in $3 c anon_table bind_table; let init = $8 c func in let size = Int32.of_int (List.length init) in {ttype = TableType ({min = size; max = Some size}, $5)} @@ at, - [{index = c.tables.count - 1 @@ at; offset = I32_const (0l @@ at) @@ at; init} @@ at], + [{index = i @@ at; + offset = [i32_const (0l @@ at) @@ at] @@ at; init} @@ at], $4 TableExport c.tables.count c } ; data : - | LPAR DATA var expr text_list RPAR + | LPAR DATA var offset text_list RPAR { let at = at () in fun c -> {index = $3 c memory; offset = $4 c; init = $5} @@ at } - | LPAR DATA expr text_list RPAR /* Sugar */ + | LPAR DATA offset text_list RPAR /* Sugar */ { let at = at () in - fun c -> {index = 0 @@ at; offset = $3 c; init = $4} @@ at } + fun c -> {index = 0l @@ at; offset = $3 c; init = $4} @@ at } ; memory : @@ -436,31 +494,34 @@ memory : { let at = at () in fun c -> $3 c anon_memory bind_memory; {mtype = $5} @@ at, [], $4 MemoryExport c.memories.count c } - | LPAR MEMORY bind_var_opt inline_export LPAR DATA text_list RPAR RPAR /* Sugar */ + | LPAR MEMORY bind_var_opt inline_export LPAR DATA text_list RPAR RPAR + /* Sugar */ { let at = at () in - fun c -> $3 c anon_memory bind_memory; + fun c -> let i = c.memories.count in $3 c anon_memory bind_memory; let size = Int32.(div (add (of_int (String.length $7)) 65535l) 65536l) in {mtype = MemoryType {min = size; max = Some size}} @@ at, - [{index = c.memories.count - 1 @@ at; offset = I32_const (0l @@ at) @@ at; init = $7} @@ at], + [{index = i @@ at; + offset = [i32_const (0l @@ at) @@ at] @@ at; init = $7} @@ at], $4 MemoryExport c.memories.count c } - /* Need to duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ + /* Duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ | LPAR MEMORY bind_var_opt LPAR DATA text_list RPAR RPAR /* Sugar */ { let at = at () in - fun c -> $3 c anon_memory bind_memory; + fun c -> let i = c.memories.count in $3 c anon_memory bind_memory; let size = Int32.(div (add (of_int (String.length $6)) 65535l) 65536l) in {mtype = MemoryType {min = size; max = Some size}} @@ at, - [{index = c.memories.count - 1 @@ at; offset = I32_const (0l @@ at) @@ at; init = $6} @@ at], + [{index = i @@ at; + offset = [i32_const (0l @@ at) @@ at] @@ at; init = $6} @@ at], [] } ; global : - | LPAR GLOBAL bind_var_opt inline_export global_type expr RPAR + | LPAR GLOBAL bind_var_opt inline_export global_type const_expr RPAR { let at = at () in fun c -> $3 c anon_global bind_global; (fun () -> {gtype = $5; value = $6 c} @@ at), $4 GlobalExport c.globals.count c } - /* Need to duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ - | LPAR GLOBAL bind_var_opt global_type expr RPAR + /* Duplicate above for empty inline_export_opt to avoid LR(1) conflict. */ + | LPAR GLOBAL bind_var_opt global_type const_expr RPAR { let at = at () in fun c -> $3 c anon_global bind_global; (fun () -> {gtype = $4; value = $5 c} @@ at), [] } @@ -532,7 +593,8 @@ inline_export_opt : inline_export : | LPAR EXPORT TEXT RPAR { let at = at () in - fun k count c -> [{name = $3; ekind = k @@ at; item = count - 1 @@ at} @@ at] } + fun k count c -> + [{name = $3; ekind = k @@ at; item = Int32.sub count 1l @@ at} @@ at] } ; @@ -633,7 +695,7 @@ cmd : { AssertInvalid (snd $3, $4) @@ at () } | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR { AssertUnlinkable (snd $3, $4) @@ at () } - | LPAR ASSERT_RETURN action const_opt RPAR { AssertReturn ($3, $4) @@ at () } + | LPAR ASSERT_RETURN action const_list RPAR { AssertReturn ($3, $4) @@ at () } | LPAR ASSERT_RETURN_NAN action RPAR { AssertReturnNaN $3 @@ at () } | LPAR ASSERT_TRAP action TEXT RPAR { AssertTrap ($3, $4) @@ at () } | LPAR INPUT TEXT RPAR { Input $3 @@ at () } @@ -648,10 +710,6 @@ cmd_list : const : | LPAR CONST literal RPAR { snd (literal $2 $3) @@ ati 3 } ; -const_opt : - | /* empty */ { None } - | const { Some $1 } -; const_list : | /* empty */ { [] } | const const_list { $1 :: $2 } diff --git a/ml-proto/host/prettyprint.ml b/ml-proto/host/prettyprint.ml new file mode 100644 index 0000000000..a5db1ec8a5 --- /dev/null +++ b/ml-proto/host/prettyprint.ml @@ -0,0 +1,124 @@ +open Format +open Source +open Ast +open Values + +let list_of_opt = function + | None -> [] + | Some x -> [x] + +let var x = string_of_int x.it + +let memop op = "..." +let extop op = "..." +let wrapop op = "..." +let unop op = "unary" +let binop op = "binary" +let selop op = "select" +let relop op = "compare" +let cvtop op = "convert" + +let hostop = function + | MemorySize -> "memory_size" + | GrowMemory -> "grow_memory" + | HasFeature s -> "has_feature \"" ^ String.escaped s ^ "\"" + +let literal v = + (match v.it with + | Int32 _ -> "i32.const " + | Int64 _ -> "i64.const " + | Float32 _ -> "f32.const " + | Float64 _ -> "f64.const " + ) ^ string_of_value v.it + +let expr e = + match e.it with + | Nop -> "nop", [] + | Unreachable -> "unreachable", [] + | Block es -> "block", es + | Loop e -> "loop", [e] + | Break (x, eo) -> "break " ^ var x, list_of_opt eo + | Br_if (x, eo, e) -> "br_if " ^ var x, list_of_opt eo @ [e] + | If (e1, e2, e3) -> "if", [e1; e2; e3] + | Switch (e, xs, x, es) -> "switch", e::es + | Call (x, es) -> "call " ^ var x, es + | CallImport (x, es) -> "call_import " ^ var x, es + | CallIndirect (x, e, es) -> "call_indirect " ^ var x, e::es + | GetLocal x -> "get_local " ^ var x, [] + | SetLocal (x, e) -> "set_local " ^ var x, [e] + | Load (op, e) -> "load " ^ memop op, [e] + | Store (op, e1, e2) -> "store " ^ memop op, [e1; e2] + | LoadExtend (op, e) -> "load " ^ extop op, [e] + | StoreWrap (op, e1, e2) -> "store " ^ wrapop op, [e1; e2] + | Const lit -> literal lit, [] + | Unary (op, e) -> unop op, [e] + | Binary (op, e1, e2) -> binop op, [e1; e2] + | Select (op, e1, e2, e3) -> selop op, [e1; e2; e3] + | Compare (op, e1, e2) -> relop op, [e1; e2] + | Convert (op, e) -> cvtop op, [e] + | Host (op, es) -> hostop op, es + +type rope = Leaf of string | Concat of rope list +let (^+) s r = Concat [Leaf s; r] +let (+^) r s = Concat [r; Leaf s] + +let rec iter f = function + | Leaf s -> f s + | Concat rs -> List.iter (iter f) rs + +let margin = 80 +let rec pp f off x = + let head, xs = f x in + let lens, rs = List.split (List.map (pp f (off + 2)) xs) in + let len = String.length head + List.length rs + List.fold_left (+) 2 lens in + let sep, fin = + if off + len <= margin then " ", "" + else let indent = String.make off ' ' in "\n " ^ indent, "\n" ^ indent + in len, "(" ^+ head ^+ Concat (List.map (fun r -> sep ^+ r) rs) +^ fin +^ ")" + +let pp_body e = iter print_string (snd (pp expr 0 e)); print_newline () + +(* +let margin = 80 +let rec pp_expr off e = + let head, es = expr e in + let sss, ns = List.split (List.map (pp_expr (off + 2)) es) in + let len = 2 + String.length head + List.length ns + List.fold_left (+) 0 ns in + if off + len <= margin then + "(" :: head :: List.flatten (List.map (fun ss -> " " :: ss) sss) @ [")"], len + else + let indent = String.make off ' ' in + "(" :: head :: List.flatten (List.map (fun ss -> "\n " :: indent :: ss) sss) @ ["\n"; indent; ")"], len + +let pp_body e = List.iter print_string (fst (pp_expr 0 e)); print_newline () +*) + +(* +let margin = 80 +let rec pp_expr off e = + let head, es = expr e in + let ss = List.map (pp_expr (off + 2)) es in + let len = 2 + String.length head + List.length ss + List.fold_left (+) 0 (List.map String.length ss) in + if off + len <= margin then + "(" ^ head ^ String.concat " " (""::ss) ^ ")" + else + let indent = String.make off ' ' in + "(" ^ head ^ String.concat ("\n " ^ indent) (""::ss) ^ "\n" ^ indent ^ ")" + +let pp_body e = print_endline (pp_expr 0 e) +*) + +(* +let rec pp_expr e = + let head, es = expr e in + open_box 2; + print_string "("; + print_string head; + List.iter (fun e -> print_space (); open_box 0; pp_expr e) es; + List.iter (fun e -> close_box ()) es; + close_box (); + print_break 0 0; + print_string ")" + +let pp_body e = pp_expr e; print_newline () +*) diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 021d9ef87a..d96b10fb98 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -1,4 +1,4 @@ -open Kernel +open Ast open Source open Printf open Types @@ -10,7 +10,8 @@ let print_sig prefix i string_of_type t = printf "%s %d : %s\n" prefix i (string_of_type t) let print_func m i f = - print_sig "func" i string_of_func_type (List.nth m.it.types f.it.ftype.it) + let t = Lib.List32.nth m.it.types f.it.ftype.it in + print_sig "func" i string_of_func_type t let print_table m i tab = print_sig "table" i string_of_table_type tab.it.ttype @@ -29,10 +30,10 @@ let print_export m i ex = | TableExport -> "table" | MemoryExport -> "memory" | GlobalExport -> "global" - in printf "export \"%s\" = %s %d\n" name kind item.it + in printf "export \"%s\" = %s %ld\n" name kind item.it let print_start start = - Lib.Option.app (fun x -> printf "start = func %d\n" x.it) start + Lib.Option.app (fun x -> printf "start = func %ld\n" x.it) start let print_module m = (* TODO: more complete print function *) @@ -50,13 +51,10 @@ let print_module_sig m = flush_all () -let print_value vo = - match vo with - | Some v -> - let t = Values.type_of v in - printf "%s : %s\n" - (Values.string_of_value v) (Types.string_of_value_type t); - flush_all () - | None -> - printf "()\n"; - flush_all () +(* Values *) + +let print_result vs = + let ts = List.map Values.type_of vs in + printf "%s : %s\n" + (Values.string_of_values vs) (Types.string_of_value_types ts); + flush_all () diff --git a/ml-proto/host/print.mli b/ml-proto/host/print.mli index 1e2903b036..eb3bb0582e 100644 --- a/ml-proto/host/print.mli +++ b/ml-proto/host/print.mli @@ -1,4 +1,3 @@ -val print_module : Kernel.module_ -> unit -val print_module_sig : Kernel.module_ -> unit -val print_value : Values.value option -> unit - +val print_module : Ast.module_ -> unit +val print_module_sig : Ast.module_ -> unit +val print_result : Values.value list -> unit diff --git a/ml-proto/host/run.ml b/ml-proto/host/run.ml index ea9bc3615d..4596e370c3 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -15,8 +15,8 @@ let dispatch_file_ext on_sexpr on_binary file = (* Input *) let error at category msg = - Script.trace ("Error (" ^ category ^ "): "); - prerr_endline (Source.string_of_region at ^ ": " ^ msg); + Script.trace ("Error: "); + prerr_endline (Source.string_of_region at ^ ": " ^ category ^ ": " ^ msg); false let run_from get_script = @@ -30,10 +30,10 @@ let run_from get_script = | Parse.Syntax (at, msg) -> error at "syntax error" msg | Script.Assert (at, msg) -> error at "assertion failure" msg | Check.Invalid (at, msg) -> error at "invalid module" msg - | Eval.Link (at, msg) -> error at "linking failure" ("link failure: " ^ msg) - | Eval.Trap (at, msg) -> error at "runtime trap" ("trap: " ^ msg) - | Eval.Crash (at, msg) -> error at "runtime crash" ("crash: " ^ msg) - | Import.Unknown (at, msg) -> error at "unknown import" msg + | Import.Unknown (at, msg) -> error at "link failure" msg + | Eval.Link (at, msg) -> error at "link failure" msg + | Eval.Trap (at, msg) -> error at "runtime trap" msg + | Eval.Crash (at, msg) -> error at "runtime crash" msg | Script.IO (at, msg) -> error at "i/o error" msg | Script.Abort _ -> false @@ -118,13 +118,13 @@ let rec run_stdin () = let print_stdout m = Script.trace "Formatting..."; - let sexpr = Arrange.module_ (Desugar.desugar m) in + let sexpr = Arrange.module_ m in Script.trace "Printing..."; Sexpr.output stdout !Flags.width sexpr let create_sexpr_file file m = Script.trace ("Formatting (" ^ file ^ ")..."); - let sexpr = Arrange.module_ (Desugar.desugar m) in + let sexpr = Arrange.module_ m in let oc = open_out file in try Script.trace "Writing..."; diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 1566c8a595..74b1abe05a 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -13,7 +13,7 @@ and definition' = type action = action' Source.phrase and action' = - | Invoke of var option * string * Kernel.literal list + | Invoke of var option * string * Ast.literal list | Get of var option * string type command = command' Source.phrase @@ -23,7 +23,7 @@ and command' = | Action of action | AssertInvalid of definition * string | AssertUnlinkable of definition * string - | AssertReturn of action * Kernel.literal option + | AssertReturn of action * Ast.literal list | AssertReturnNaN of action | AssertTrap of action * string | Input of string @@ -90,7 +90,7 @@ let run_def def = | Textual m -> m | Binary bs -> trace "Decoding..."; - Decode.decode "binary" bs + Decode.decode "binary" bs let run_action act = match act.it with @@ -102,11 +102,12 @@ let run_action act = | Some _ -> Assert.error act.at "export is not a function" | None -> Assert.error act.at "undefined export" ) + | Get (x_opt, name) -> trace ("Getting global \"" ^ name ^ "\"..."); let inst = get_instance x_opt act.at in (match Instance.export inst name with - | Some (ExternalGlobal v) -> Some v + | Some (ExternalGlobal v) -> [v] | Some _ -> Assert.error act.at "export is not a global" | None -> Assert.error act.at "undefined export" ) @@ -115,18 +116,17 @@ let run_cmd cmd = match cmd.it with | Define (x_opt, def) -> let m = run_def def in - let m' = Desugar.desugar m in if not !Flags.unchecked then begin trace "Checking..."; - Check.check_module m'; + Check.check_module m; if !Flags.print_sig then begin trace "Signature:"; - Print.print_module_sig m' + Print.print_module_sig m end end; trace "Initializing..."; - let imports = Import.link m' in - let inst = Eval.init m' imports in + let imports = Import.link m in + let inst = Eval.init m imports in current_module := Some m; current_instance := Some inst; bind modules x_opt m; @@ -139,15 +139,14 @@ let run_cmd cmd = Import.register name (lookup name) | Action act -> - let v = run_action act in - if v <> None then Print.print_value v + let vs = run_action act in + if vs <> [] then Print.print_result vs | AssertInvalid (def, re) -> trace "Asserting invalid..."; (match let m = run_def def in - let m' = Desugar.desugar m in - Check.check_module m' + Check.check_module m with | exception (Decode.Code (_, msg) | Check.Invalid (_, msg)) -> if not (Str.string_match (Str.regexp re) msg 0) then begin @@ -162,11 +161,10 @@ let run_cmd cmd = | AssertUnlinkable (def, re) -> trace "Asserting unlinkable..."; let m = run_def def in - let m' = Desugar.desugar m in - if not !Flags.unchecked then Check.check_module m'; + if not !Flags.unchecked then Check.check_module m; (match - let imports = Import.link m' in - ignore (Eval.init m' imports) + let imports = Import.link m in + ignore (Eval.init m imports) with | exception (Import.Unknown (_, msg) | Eval.Link (_, msg)) -> if not (Str.string_match (Str.regexp re) msg 0) then begin @@ -178,28 +176,28 @@ let run_cmd cmd = Assert.error cmd.at "expected linking error" ) - | AssertReturn (act, expect) -> + | AssertReturn (act, es) -> trace ("Asserting return..."); - let got_v = run_action act in - let expect_v = Lib.Option.map it expect in - if got_v <> expect_v then begin - print_string "Result: "; Print.print_value got_v; - print_string "Expect: "; Print.print_value expect_v; + let got_vs = run_action act in + let expect_vs = List.map it es in + if got_vs <> expect_vs then begin + print_string "Result: "; Print.print_result got_vs; + print_string "Expect: "; Print.print_result expect_vs; Assert.error cmd.at "wrong return value" end | AssertReturnNaN act -> trace ("Asserting return..."); - let got_v = run_action act in + let got_vs = run_action act in if - match got_v with - | Some (Values.Float32 got_f32) -> - got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan - | Some (Values.Float64 got_f64) -> - got_f64 <> F64.pos_nan && got_f64 <> F64.neg_nan + match got_vs with + | [Values.F32 got_f32] -> + got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan + | [Values.F64 got_f64] -> + got_f64 <> F64.pos_nan && got_f64 <> F64.neg_nan | _ -> true then begin - print_string "Result: "; Print.print_value got_v; + print_string "Result: "; Print.print_result got_vs; print_string "Expect: "; print_endline "nan"; Assert.error cmd.at "wrong return value" end @@ -234,19 +232,18 @@ let dry_def def = | Textual m -> m | Binary bs -> trace "Decoding..."; - Decode.decode "binary" bs + Decode.decode "binary" bs let dry_cmd cmd = match cmd.it with | Define (x_opt, def) -> let m = dry_def def in - let m' = Desugar.desugar m in if not !Flags.unchecked then begin trace "Checking..."; - Check.check_module m'; + Check.check_module m; if !Flags.print_sig then begin trace "Signature:"; - Print.print_module_sig m' + Print.print_module_sig m end end; current_module := Some m; diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index e738a3a05c..60e21182bf 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -7,7 +7,7 @@ and definition' = type action = action' Source.phrase and action' = - | Invoke of var option * string * Kernel.literal list + | Invoke of var option * string * Ast.literal list | Get of var option * string type command = command' Source.phrase @@ -17,7 +17,7 @@ and command' = | Action of action | AssertInvalid of definition * string | AssertUnlinkable of definition * string - | AssertReturn of action * Kernel.literal option + | AssertReturn of action * Ast.literal list | AssertReturnNaN of action | AssertTrap of action * string | Input of string diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index f893d490d5..b235e892e1 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -44,7 +44,7 @@ def _runTestFile(self, shortName, fileName, interpreterPath): # Run original file logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.log")) - self._runCommand(("'%s' '%s'") % (interpreterPath, fileName), logPath, expectedExitCode) + self._runCommand(("%s '%s'") % (interpreterPath, fileName), logPath, expectedExitCode) self._compareLog(fileName, logPath) if expectedExitCode != 0: @@ -53,21 +53,21 @@ def _runTestFile(self, shortName, fileName, interpreterPath): # Convert to binary and validate again wasmPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm")) logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.log")) - self._runCommand(("'%s' -d '%s' -o '%s'") % (interpreterPath, fileName, wasmPath)) - self._runCommand(("'%s' -d '%s'") % (interpreterPath, wasmPath), logPath) + self._runCommand(("%s -d '%s' -o '%s'") % (interpreterPath, fileName, wasmPath)) + self._runCommand(("%s -d '%s'") % (interpreterPath, wasmPath), logPath) # Convert back to text and validate again wastPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast")) logPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast.log")) - self._runCommand(("'%s' -d '%s' -o '%s'") % (interpreterPath, wasmPath, wastPath)) - self._runCommand(("'%s' -d '%s' ") % (interpreterPath, wastPath), logPath) + self._runCommand(("%s -d '%s' -o '%s'") % (interpreterPath, wasmPath, wastPath)) + self._runCommand(("%s -d '%s' ") % (interpreterPath, wastPath), logPath) - #return # Convert back to binary once more and compare wasm2Path = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast.wasm")) - self._runCommand(("'%s' -d '%s' -o '%s'") % (interpreterPath, wastPath, wasm2Path)) - self._runCommand(("'%s' -d '%s'") % (interpreterPath, wasm2Path), logPath) - # TODO: Ultimately, the binary should stay the same, but currently desugaring gets in the way. + self._runCommand(("%s -d '%s' -o '%s'") % (interpreterPath, wastPath, wasm2Path)) + self._runCommand(("%s -d '%s'") % (interpreterPath, wasm2Path), logPath) + # TODO: The binary should stay the same, but OCaml's float-string conversions are inaccurate. + # Once we upgrade to OCaml 4.03, use sprintf "%s" for printing floats. # self._compareFile(wasmPath, wasm2Path) def generate_test_case(rec): diff --git a/ml-proto/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml deleted file mode 100644 index 1b021a975d..0000000000 --- a/ml-proto/spec/arithmetic.ml +++ /dev/null @@ -1,293 +0,0 @@ -open Types -open Values - - -(* Runtime type errors *) - -exception TypeError of int * value * value_type - - -(* Value unpacking *) - -let i32_of_value n = - function Int32 i -> i | v -> raise (TypeError (n, v, Int32Type)) - -let i64_of_value n = - function Int64 i -> i | v -> raise (TypeError (n, v, Int64Type)) - -let f32_of_value n = - function Float32 z -> z | v -> raise (TypeError (n, v, Float32Type)) - -let f64_of_value n = - function Float64 z -> z | v -> raise (TypeError (n, v, Float64Type)) - - -(* Int operators *) - -module Int32Op = -struct - open Kernel.I32Op - - let unop op = - let f = match op with - | Clz -> I32.clz - | Ctz -> I32.ctz - | Popcnt -> I32.popcnt - in fun v -> Int32 (f (i32_of_value 1 v)) - - let binop op = - let f = match op with - | Add -> I32.add - | Sub -> I32.sub - | Mul -> I32.mul - | DivS -> I32.div_s - | DivU -> I32.div_u - | RemS -> I32.rem_s - | RemU -> I32.rem_u - | And -> I32.and_ - | Or -> I32.or_ - | Xor -> I32.xor - | Shl -> I32.shl - | ShrU -> I32.shr_u - | ShrS -> I32.shr_s - | Rotl -> I32.rotl - | Rotr -> I32.rotr - in fun v1 v2 -> Int32 (f (i32_of_value 1 v1) (i32_of_value 2 v2)) - - let testop op = - let f = match op with - | Eqz -> I32.eqz - in fun v -> f (i32_of_value 1 v) - - let relop op = - let f = match op with - | Eq -> I32.eq - | Ne -> I32.ne - | LtS -> I32.lt_s - | LtU -> I32.lt_u - | LeS -> I32.le_s - | LeU -> I32.le_u - | GtS -> I32.gt_s - | GtU -> I32.gt_u - | GeS -> I32.ge_s - | GeU -> I32.ge_u - in fun v1 v2 -> f (i32_of_value 1 v1) (i32_of_value 2 v2) - - let cvtop op = - match op with - | WrapInt64 -> - fun v -> Int32 (I32_convert.wrap_i64 (i64_of_value 1 v)) - | TruncSFloat32 -> - fun v -> Int32 (I32_convert.trunc_s_f32 (f32_of_value 1 v)) - | TruncUFloat32 -> - fun v -> Int32 (I32_convert.trunc_u_f32 (f32_of_value 1 v)) - | TruncSFloat64 -> - fun v -> Int32 (I32_convert.trunc_s_f64 (f64_of_value 1 v)) - | TruncUFloat64 -> - fun v -> Int32 (I32_convert.trunc_u_f64 (f64_of_value 1 v)) - | ReinterpretFloat -> - fun v -> Int32 (I32_convert.reinterpret_f32 (f32_of_value 1 v)) - | ExtendSInt32 -> - fun v -> raise (TypeError (1, v, Int32Type)) - | ExtendUInt32 -> - fun v -> raise (TypeError (1, v, Int32Type)) -end - -module Int64Op = -struct - open Kernel.I64Op - - let unop op = - let f = match op with - | Clz -> I64.clz - | Ctz -> I64.ctz - | Popcnt -> I64.popcnt - in fun v -> Int64 (f (i64_of_value 1 v)) - - let binop op = - let f = match op with - | Add -> I64.add - | Sub -> I64.sub - | Mul -> I64.mul - | DivS -> I64.div_s - | DivU -> I64.div_u - | RemS -> I64.rem_s - | RemU -> I64.rem_u - | And -> I64.and_ - | Or -> I64.or_ - | Xor -> I64.xor - | Shl -> I64.shl - | ShrU -> I64.shr_u - | ShrS -> I64.shr_s - | Rotl -> I64.rotl - | Rotr -> I64.rotr - in fun v1 v2 -> Int64 (f (i64_of_value 1 v1) (i64_of_value 2 v2)) - - let testop op = - let f = match op with - | Eqz -> I64.eqz - in fun v -> f (i64_of_value 1 v) - - let relop op = - let f = match op with - | Eq -> I64.eq - | Ne -> I64.ne - | LtS -> I64.lt_s - | LtU -> I64.lt_u - | LeS -> I64.le_s - | LeU -> I64.le_u - | GtS -> I64.gt_s - | GtU -> I64.gt_u - | GeS -> I64.ge_s - | GeU -> I64.ge_u - in fun v1 v2 -> f (i64_of_value 1 v1) (i64_of_value 2 v2) - - let cvtop op = - match op with - | ExtendSInt32 -> - fun v -> Int64 (I64_convert.extend_s_i32 (i32_of_value 1 v)) - | ExtendUInt32 -> - fun v -> Int64 (I64_convert.extend_u_i32 (i32_of_value 1 v)) - | TruncSFloat32 -> - fun v -> Int64 (I64_convert.trunc_s_f32 (f32_of_value 1 v)) - | TruncUFloat32 -> - fun v -> Int64 (I64_convert.trunc_u_f32 (f32_of_value 1 v)) - | TruncSFloat64 -> - fun v -> Int64 (I64_convert.trunc_s_f64 (f64_of_value 1 v)) - | TruncUFloat64 -> - fun v -> Int64 (I64_convert.trunc_u_f64 (f64_of_value 1 v)) - | ReinterpretFloat -> - fun v -> Int64 (I64_convert.reinterpret_f64 (f64_of_value 1 v)) - | WrapInt64 -> - fun v -> raise (TypeError (1, v, Int64Type)) -end - - -(* Float operators *) - -module Float32Op = -struct - open Kernel.F32Op - - let unop op = - let f = match op with - | Neg -> F32.neg - | Abs -> F32.abs - | Sqrt -> F32.sqrt - | Ceil -> F32.ceil - | Floor -> F32.floor - | Trunc -> F32.trunc - | Nearest -> F32.nearest - in fun v -> Float32 (f (f32_of_value 1 v)) - - let binop op = - let f = match op with - | Add -> F32.add - | Sub -> F32.sub - | Mul -> F32.mul - | Div -> F32.div - | Min -> F32.min - | Max -> F32.max - | CopySign -> F32.copysign - in fun v1 v2 -> Float32 (f (f32_of_value 1 v1) (f32_of_value 2 v2)) - - let testop op = assert false - - let relop op = - let f = match op with - | Eq -> F32.eq - | Ne -> F32.ne - | Lt -> F32.lt - | Le -> F32.le - | Gt -> F32.gt - | Ge -> F32.ge - in fun v1 v2 -> f (f32_of_value 1 v1) (f32_of_value 2 v2) - - let cvtop op = - match op with - | DemoteFloat64 -> - fun v -> Float32 (F32_convert.demote_f64 (f64_of_value 1 v)) - | ConvertSInt32 -> - fun v -> Float32 (F32_convert.convert_s_i32 (i32_of_value 1 v)) - | ConvertUInt32 -> - fun v -> Float32 (F32_convert.convert_u_i32 (i32_of_value 1 v)) - | ConvertSInt64 -> - fun v -> Float32 (F32_convert.convert_s_i64 (i64_of_value 1 v)) - | ConvertUInt64 -> - fun v -> Float32 (F32_convert.convert_u_i64 (i64_of_value 1 v)) - | ReinterpretInt -> - fun v -> Float32 (F32_convert.reinterpret_i32 (i32_of_value 1 v)) - | PromoteFloat32 -> - fun v -> raise (TypeError (1, v, Float32Type)) -end - -module Float64Op = -struct - open Kernel.F64Op - - let unop op = - let f = match op with - | Neg -> F64.neg - | Abs -> F64.abs - | Sqrt -> F64.sqrt - | Ceil -> F64.ceil - | Floor -> F64.floor - | Trunc -> F64.trunc - | Nearest -> F64.nearest - in fun v -> Float64 (f (f64_of_value 1 v)) - - let binop op = - let f = match op with - | Add -> F64.add - | Sub -> F64.sub - | Mul -> F64.mul - | Div -> F64.div - | Min -> F64.min - | Max -> F64.max - | CopySign -> F64.copysign - in fun v1 v2 -> Float64 (f (f64_of_value 1 v1) (f64_of_value 2 v2)) - - let testop op = assert false - - let relop op = - let f = match op with - | Eq -> F64.eq - | Ne -> F64.ne - | Lt -> F64.lt - | Le -> F64.le - | Gt -> F64.gt - | Ge -> F64.ge - in fun v1 v2 -> f (f64_of_value 1 v1) (f64_of_value 2 v2) - - let cvtop op = - match op with - | PromoteFloat32 -> - fun v -> Float64 (F64_convert.promote_f32 (f32_of_value 1 v)) - | ConvertSInt32 -> - fun v -> Float64 (F64_convert.convert_s_i32 (i32_of_value 1 v)) - | ConvertUInt32 -> - fun v -> Float64 (F64_convert.convert_u_i32 (i32_of_value 1 v)) - | ConvertSInt64 -> - fun v -> Float64 (F64_convert.convert_s_i64 (i64_of_value 1 v)) - | ConvertUInt64 -> - fun v -> Float64 (F64_convert.convert_u_i64 (i64_of_value 1 v)) - | ReinterpretInt -> - fun v -> Float64 (F64_convert.reinterpret_i64 (i64_of_value 1 v)) - | DemoteFloat64 -> - fun v -> raise (TypeError (1, v, Float64Type)) -end - - -(* Dispatch *) - -let op i32 i64 f32 f64 = function - | Int32 x -> i32 x - | Int64 x -> i64 x - | Float32 x -> f32 x - | Float64 x -> f64 x - -let eval_unop = op Int32Op.unop Int64Op.unop Float32Op.unop Float64Op.unop -let eval_binop = op Int32Op.binop Int64Op.binop Float32Op.binop Float64Op.binop -let eval_testop = op Int32Op.testop Int64Op.testop Float32Op.testop Float64Op.testop -let eval_relop = op Int32Op.relop Int64Op.relop Float32Op.relop Float64Op.relop -let eval_cvtop = op Int32Op.cvtop Int64Op.cvtop Float32Op.cvtop Float64Op.cvtop diff --git a/ml-proto/spec/arithmetic.mli b/ml-proto/spec/arithmetic.mli deleted file mode 100644 index 42d91474b0..0000000000 --- a/ml-proto/spec/arithmetic.mli +++ /dev/null @@ -1,9 +0,0 @@ -open Values - -exception TypeError of int * value * Types.value_type - -val eval_unop : Kernel.unop -> value -> value -val eval_binop : Kernel.binop -> value -> value -> value -val eval_testop : Kernel.testop -> value -> bool -val eval_relop : Kernel.relop -> value -> value -> bool -val eval_cvtop : Kernel.cvtop -> value -> value diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 266800aa1b..c57a37ef07 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -1,239 +1,188 @@ +(* + * Throughout the implementation we use consistent naming conventions for + * syntactic elements, associated with the types defined here and in a few + * other places: + * + * x : var + * v : value + * e : instrr + * f : func + * m : module_ + * + * t : value_type + * s : func_type + * c : context / config + * + * These conventions mostly follow standard practice in language semantics. + *) + +open Types + + +(* Operators *) + +module IntOp = +struct + type unop = Clz | Ctz | Popcnt + type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU + | And | Or | Xor | Shl | ShrS | ShrU | Rotl | Rotr + type testop = Eqz + type relop = Eq | Ne | LtS | LtU | LeS | LeU | GtS | GtU | GeS | GeU + type cvtop = ExtendSI32 | ExtendUI32 | WrapI64 + | TruncSF32 | TruncUF32 | TruncSF64 | TruncUF64 + | ReinterpretFloat +end + +module FloatOp = +struct + type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt + type binop = Add | Sub | Mul | Div | Min | Max | CopySign + type testop + type relop = Eq | Ne | Lt | Le | Gt | Ge + type cvtop = ConvertSI32 | ConvertUI32 | ConvertSI64 | ConvertUI64 + | PromoteF32 | DemoteF64 + | ReinterpretInt +end + +module I32Op = IntOp +module I64Op = IntOp +module F32Op = FloatOp +module F64Op = FloatOp + +type unop = (I32Op.unop, I64Op.unop, F32Op.unop, F64Op.unop) Values.op +type binop = (I32Op.binop, I64Op.binop, F32Op.binop, F64Op.binop) Values.op +type testop = (I32Op.testop, I64Op.testop, F32Op.testop, F64Op.testop) Values.op +type relop = (I32Op.relop, I64Op.relop, F32Op.relop, F64Op.relop) Values.op +type cvtop = (I32Op.cvtop, I64Op.cvtop, F32Op.cvtop, F64Op.cvtop) Values.op + +type 'a memop = + {ty : value_type; align : int; offset : Memory.offset; sz : 'a option} +type loadop = (Memory.mem_size * Memory.extension) memop +type storeop = Memory.mem_size memop + + (* Expressions *) -type var = int Source.phrase - -type expr = expr' Source.phrase -and expr' = - (* Constants *) - | I32_const of I32.t Source.phrase - | I64_const of I64.t Source.phrase - | F32_const of F32.t Source.phrase - | F64_const of F64.t Source.phrase - - (* Control *) - | Nop - | Unreachable - | Drop of expr - | Block of expr list - | Loop of expr list - | Br of var * expr option - | Br_if of var * expr option * expr - | Br_table of var list * var * expr option * expr - | Return of expr option - | If of expr * expr list * expr list - | Select of expr * expr * expr - | Call of var * expr list - | Call_indirect of var * expr * expr list - - (* Variables *) - | Get_local of var - | Set_local of var * expr - | Tee_local of var * expr - | Get_global of var - | Set_global of var * expr - - (* Memory access *) - | I32_load of Memory.offset * int * expr - | I64_load of Memory.offset * int * expr - | F32_load of Memory.offset * int * expr - | F64_load of Memory.offset * int * expr - | I32_store of Memory.offset * int * expr * expr - | I64_store of Memory.offset * int * expr * expr - | F32_store of Memory.offset * int * expr * expr - | F64_store of Memory.offset * int * expr * expr - | I32_load8_s of Memory.offset * int * expr - | I32_load8_u of Memory.offset * int * expr - | I32_load16_s of Memory.offset * int * expr - | I32_load16_u of Memory.offset * int * expr - | I64_load8_s of Memory.offset * int * expr - | I64_load8_u of Memory.offset * int * expr - | I64_load16_s of Memory.offset * int * expr - | I64_load16_u of Memory.offset * int * expr - | I64_load32_s of Memory.offset * int * expr - | I64_load32_u of Memory.offset * int * expr - | I32_store8 of Memory.offset * int * expr * expr - | I32_store16 of Memory.offset * int * expr * expr - | I64_store8 of Memory.offset * int * expr * expr - | I64_store16 of Memory.offset * int * expr * expr - | I64_store32 of Memory.offset * int * expr * expr - - (* Unary arithmetic *) - | I32_clz of expr - | I32_ctz of expr - | I32_popcnt of expr - | I64_clz of expr - | I64_ctz of expr - | I64_popcnt of expr - | F32_neg of expr - | F32_abs of expr - | F32_sqrt of expr - | F32_ceil of expr - | F32_floor of expr - | F32_trunc of expr - | F32_nearest of expr - | F64_neg of expr - | F64_abs of expr - | F64_sqrt of expr - | F64_ceil of expr - | F64_floor of expr - | F64_trunc of expr - | F64_nearest of expr - - (* Binary arithmetic *) - | I32_add of expr * expr - | I32_sub of expr * expr - | I32_mul of expr * expr - | I32_div_s of expr * expr - | I32_div_u of expr * expr - | I32_rem_s of expr * expr - | I32_rem_u of expr * expr - | I32_and of expr * expr - | I32_or of expr * expr - | I32_xor of expr * expr - | I32_shl of expr * expr - | I32_shr_s of expr * expr - | I32_shr_u of expr * expr - | I32_rotl of expr * expr - | I32_rotr of expr * expr - | I64_add of expr * expr - | I64_sub of expr * expr - | I64_mul of expr * expr - | I64_div_s of expr * expr - | I64_div_u of expr * expr - | I64_rem_s of expr * expr - | I64_rem_u of expr * expr - | I64_and of expr * expr - | I64_or of expr * expr - | I64_xor of expr * expr - | I64_shl of expr * expr - | I64_shr_s of expr * expr - | I64_shr_u of expr * expr - | I64_rotl of expr * expr - | I64_rotr of expr * expr - | F32_add of expr * expr - | F32_sub of expr * expr - | F32_mul of expr * expr - | F32_div of expr * expr - | F32_min of expr * expr - | F32_max of expr * expr - | F32_copysign of expr * expr - | F64_add of expr * expr - | F64_sub of expr * expr - | F64_mul of expr * expr - | F64_div of expr * expr - | F64_min of expr * expr - | F64_max of expr * expr - | F64_copysign of expr * expr - - (* Predicates *) - | I32_eqz of expr - | I64_eqz of expr - - (* Comparisons *) - | I32_eq of expr * expr - | I32_ne of expr * expr - | I32_lt_s of expr * expr - | I32_lt_u of expr * expr - | I32_le_s of expr * expr - | I32_le_u of expr * expr - | I32_gt_s of expr * expr - | I32_gt_u of expr * expr - | I32_ge_s of expr * expr - | I32_ge_u of expr * expr - | I64_eq of expr * expr - | I64_ne of expr * expr - | I64_lt_s of expr * expr - | I64_lt_u of expr * expr - | I64_le_s of expr * expr - | I64_le_u of expr * expr - | I64_gt_s of expr * expr - | I64_gt_u of expr * expr - | I64_ge_s of expr * expr - | I64_ge_u of expr * expr - | F32_eq of expr * expr - | F32_ne of expr * expr - | F32_lt of expr * expr - | F32_le of expr * expr - | F32_gt of expr * expr - | F32_ge of expr * expr - | F64_eq of expr * expr - | F64_ne of expr * expr - | F64_lt of expr * expr - | F64_le of expr * expr - | F64_gt of expr * expr - | F64_ge of expr * expr - - (* Conversions *) - | I32_wrap_i64 of expr - | I32_trunc_s_f32 of expr - | I32_trunc_u_f32 of expr - | I32_trunc_s_f64 of expr - | I32_trunc_u_f64 of expr - | I64_extend_s_i32 of expr - | I64_extend_u_i32 of expr - | I64_trunc_s_f32 of expr - | I64_trunc_u_f32 of expr - | I64_trunc_s_f64 of expr - | I64_trunc_u_f64 of expr - | F32_convert_s_i32 of expr - | F32_convert_u_i32 of expr - | F32_convert_s_i64 of expr - | F32_convert_u_i64 of expr - | F32_demote_f64 of expr - | F64_convert_s_i32 of expr - | F64_convert_u_i32 of expr - | F64_convert_s_i64 of expr - | F64_convert_u_i64 of expr - | F64_promote_f32 of expr - | I32_reinterpret_f32 of expr - | I64_reinterpret_f64 of expr - | F32_reinterpret_i32 of expr - | F64_reinterpret_i64 of expr - - (* Host queries *) - | Current_memory - | Grow_memory of expr - - -(* Globals and Functions *) +type var = int32 Source.phrase +type literal = Values.value Source.phrase + +type instr = instr' Source.phrase +and instr' = + | Unreachable (* trap unconditionally *) + | Nop (* do nothing *) + | Drop (* forget a value *) + | Select (* branchless conditional *) + | Block of instr list (* execute in sequence *) + | Loop of instr list (* loop header *) + | Br of int * var (* break to n-th surrounding label *) + | BrIf of int * var (* conditional break *) + | BrTable of int * var list * var (* indexed break *) + | Return (* break from function body *) + | If of instr list * instr list (* conditional *) + | Call of var (* call function *) + | CallIndirect of var (* call function through table *) + | GetLocal of var (* read local variable *) + | SetLocal of var (* write local variable *) + | TeeLocal of var (* write local variable and keep value *) + | GetGlobal of var (* read global variable *) + | SetGlobal of var (* write global variable *) + | Load of loadop (* read memory at address *) + | Store of storeop (* write memory at address *) + | Const of literal (* constant *) + | Unary of unop (* unary numeric operator *) + | Binary of binop (* binary numeric operator *) + | Test of testop (* numeric test *) + | Compare of relop (* numeric comparison *) + | Convert of cvtop (* conversion *) + | CurrentMemory (* size of linear memory *) + | GrowMemory (* grow linear memory *) + + +(* Globals & Functions *) + +type const = instr list Source.phrase type global = global' Source.phrase and global' = { - gtype : Types.global_type; - value : expr; + gtype : global_type; + value : const; } type func = func' Source.phrase and func' = { ftype : var; - locals : Types.value_type list; - body : expr list; + locals : value_type list; + body : instr list; } -(* Modules *) +(* Tables & Memories *) + +type table = table' Source.phrase +and table' = +{ + ttype : table_type; +} + +type memory = memory' Source.phrase +and memory' = +{ + mtype : memory_type; +} type 'data segment = 'data segment' Source.phrase and 'data segment' = { index : var; - offset : expr; + offset : const; init : 'data; } -type module_ = module' Source.phrase -and module' = +type table_segment = var list segment +type memory_segment = string segment + + +(* Modules *) + +type export_kind = export_kind' Source.phrase +and export_kind' = FuncExport | TableExport | MemoryExport | GlobalExport + +type export = export' Source.phrase +and export' = +{ + name : string; + ekind : export_kind; + item : var; +} + +type import_kind = import_kind' Source.phrase +and import_kind' = + | FuncImport of var + | TableImport of table_type + | MemoryImport of memory_type + | GlobalImport of global_type + +type import = import' Source.phrase +and import' = +{ + module_name : string; + item_name : string; + ikind : import_kind; +} + +type module_ = module_' Source.phrase +and module_' = { - types : Types.func_type list; + types : func_type list; globals : global list; - tables : Kernel.table list; - memories : Kernel.memory list; + tables : table list; + memories : memory list; funcs : func list; start : var option; elems : var list segment list; data : string segment list; - imports : Kernel.import list; - exports : Kernel.export list; + imports : import list; + exports : export list; } diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index a3a15893ce..d0fa7179c4 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -1,4 +1,4 @@ -open Kernel +open Ast open Source open Types @@ -11,31 +11,36 @@ exception Invalid = Invalid.Error let error = Invalid.error let require b at s = if not b then error at s +let result_error at r1 r2 = + error at + ("type mismatch: operator requires " ^ string_of_result_type r1 ^ + " but stack has " ^ string_of_result_type r2) + (* Context *) -type expr_type_future = [`Known of expr_type | `SomeUnknown] ref +type op_type = stack_type * result_type type context = { module_ : module_; types : func_type list; funcs : func_type list; - locals : value_type list; - globals : global_type list; - return : expr_type; - labels : expr_type_future list; tables : table_type list; memories : memory_type list; + globals : global_type list; + locals : value_type list; + results : value_type list; + labels : result_type ref list; } -let empty_context m = +let context m = { module_ = m; types = []; funcs = []; tables = []; memories = []; - globals = []; locals = []; return = None; labels = [] } + globals = []; locals = []; results = []; labels = [] } let lookup category list x = - try List.nth list x.it with Failure _ -> - error x.at ("unknown " ^ category ^ " " ^ string_of_int x.it) + try Lib.List32.nth list x.it with Failure _ -> + error x.at ("unknown " ^ category ^ " " ^ Int32.to_string x.it) let type_ c x = lookup "type" c.types x let func c x = lookup "function" c.funcs x @@ -47,23 +52,17 @@ let table c x = lookup "table" c.tables x let memory c x = lookup "memory" c.memories x -(* Type Unification *) +(* Join *) -let string_of_future = function - | `Known et -> string_of_expr_type et - | `SomeUnknown -> "" +let join r1 r2 at = + match r1, r2 with + | Bot, r | r, Bot -> r + | r1, r2 when r1 = r2 -> r1 + | _ -> result_error at r1 r2 -let check_type actual expected at = - if !expected = `SomeUnknown && actual <> None then expected := `Known actual; - require (!expected = `Known actual) at - ("type mismatch: expression has type " ^ string_of_expr_type actual ^ - " but the context requires " ^ string_of_future !expected) - -let some_unknown () = ref `SomeUnknown -let known et = ref (`Known et) -let none = known None -let some t = known (Some t) -let is_some et = !et <> `Known None +let unknown () = ref Bot +let known ts = ref (Stack ts) +let unify v ts at = v := join !v (Stack ts) at (* Type Synthesis *) @@ -75,254 +74,268 @@ let type_testop = Values.type_of let type_relop = Values.type_of let type_cvtop at = function - | Values.Int32 cvtop -> + | Values.I32 cvtop -> let open I32Op in (match cvtop with - | ExtendSInt32 | ExtendUInt32 -> error at "invalid conversion" - | WrapInt64 -> Int64Type - | TruncSFloat32 | TruncUFloat32 | ReinterpretFloat -> Float32Type - | TruncSFloat64 | TruncUFloat64 -> Float64Type - ), Int32Type - | Values.Int64 cvtop -> + | ExtendSI32 | ExtendUI32 -> error at "invalid conversion" + | WrapI64 -> I64Type + | TruncSF32 | TruncUF32 | ReinterpretFloat -> F32Type + | TruncSF64 | TruncUF64 -> F64Type + ), I32Type + | Values.I64 cvtop -> let open I64Op in (match cvtop with - | ExtendSInt32 | ExtendUInt32 -> Int32Type - | WrapInt64 -> error at "invalid conversion" - | TruncSFloat32 | TruncUFloat32 -> Float32Type - | TruncSFloat64 | TruncUFloat64 | ReinterpretFloat -> Float64Type - ), Int64Type - | Values.Float32 cvtop -> + | ExtendSI32 | ExtendUI32 -> I32Type + | WrapI64 -> error at "invalid conversion" + | TruncSF32 | TruncUF32 -> F32Type + | TruncSF64 | TruncUF64 | ReinterpretFloat -> F64Type + ), I64Type + | Values.F32 cvtop -> let open F32Op in (match cvtop with - | ConvertSInt32 | ConvertUInt32 | ReinterpretInt -> Int32Type - | ConvertSInt64 | ConvertUInt64 -> Int64Type - | PromoteFloat32 -> error at "invalid conversion" - | DemoteFloat64 -> Float64Type - ), Float32Type - | Values.Float64 cvtop -> + | ConvertSI32 | ConvertUI32 | ReinterpretInt -> I32Type + | ConvertSI64 | ConvertUI64 -> I64Type + | PromoteF32 -> error at "invalid conversion" + | DemoteF64 -> F64Type + ), F32Type + | Values.F64 cvtop -> let open F64Op in (match cvtop with - | ConvertSInt32 | ConvertUInt32 -> Int32Type - | ConvertSInt64 | ConvertUInt64 | ReinterpretInt -> Int64Type - | PromoteFloat32 -> Float32Type - | DemoteFloat64 -> error at "invalid conversion" - ), Float64Type - -(* - * This function returns a tuple of a func_type and a bool, with the bool - * indicating whether the given function requires a memory declaration to be - * present in the module. - *) -let type_hostop = function - | CurrentMemory -> ({ins = []; out = Some Int32Type}, true) - | GrowMemory -> ({ins = [Int32Type]; out = Some Int32Type}, true) + | ConvertSI32 | ConvertUI32 -> I32Type + | ConvertSI64 | ConvertUI64 | ReinterpretInt -> I64Type + | PromoteF32 -> F32Type + | DemoteF64 -> error at "invalid conversion" + ), F64Type (* Expressions *) +let check_memop (c : context) (memop : 'a memop) get_sz at = + ignore (memory c (0l @@ at)); + require (memop.offset >= 0L) at "negative offset"; + require (memop.offset <= 0xffffffffL) at "offset too large"; + require (Lib.Int.is_power_of_two memop.align) at + "alignment must be a power of two"; + let size = + match get_sz memop.sz with + | None -> size memop.ty + | Some sz -> + require (memop.ty = I64Type || sz <> Memory.Mem32) at + "memory size too big"; + Memory.mem_size sz + in + require (memop.align <= size) at "alignment must not be larger than natural" + +let check_arity n at = + require (n <= 1) at "invalid result arity, larger than 1 is not (yet) allowed" + +let check_result_arity r at = + match r with + | Stack ts -> check_arity (List.length ts) at + | Bot -> () + (* - * check_expr : context -> expr_type_future -> expr -> unit + * check_instr : context -> instr -> stack_type -> unit * * Conventions: * c : context - * e : expr - * eo : expr option + * e : instr + * es : instr list * v : value - * t : value_type - * et : expr_type_future + * t : value_type var + * ts : stack_type *) -let rec check_expr c et e = - match e.it with - | Nop -> - check_type None et e.at +let (-->) ts r = ts, r + +let peek i ts = + try List.nth ts i with Failure _ -> I32Type +let peek_n n ts = + let m = min n (List.length ts) in + Lib.List.take m ts @ Lib.List.make (n - m) I32Type + +let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = + match e.it with | Unreachable -> - () - - | Drop e -> - check_expr c (some_unknown ()) e; - check_type None et e.at - - | Block (es, e) -> - let c' = {c with labels = et :: c.labels} in - List.iter (check_expr c' none) es; - check_expr c' et e - - | Loop e1 -> - let c' = {c with labels = none :: c.labels} in - check_expr c' et e1 - - | Break (x, eo) -> - check_expr_opt c (label c x) eo e.at - - | BreakIf (x, eo, e1) -> - check_expr_opt c (label c x) eo e.at; - check_expr c (some Int32Type) e1; - check_type None et e.at - - | BreakTable (xs, x, eo, e1) -> - List.iter (fun x -> check_expr_opt c (label c x) eo e.at) xs; - check_expr_opt c (label c x) eo e.at; - check_expr c (some Int32Type) e1 - - | If (e1, e2, e3) -> - check_expr c (some Int32Type) e1; - check_expr c et e2; - check_expr c et e3 - - | Select (e1, e2, e3) -> - require (is_some et) e.at "arity mismatch"; - check_expr c et e1; - check_expr c et e2; - check_expr c (some Int32Type) e3 - - | Call (x, es) -> - let {ins; out} = func c x in - check_exprs c ins es e.at; - check_type out et e.at - - | CallIndirect (x, e1, es) -> - let {ins; out} = type_ c x in - ignore (table c (0 @@ e.at)); - check_expr c (some Int32Type) e1; - check_exprs c ins es e.at; - check_type out et e.at + [] --> Bot + + | Nop -> + [] --> Stack [] + + | Drop -> + [peek 0 stack] --> Stack [] + + | Block es -> + let vr = unknown () in + let c' = {c with labels = vr :: c.labels} in + let r = check_block c' es in + check_result_arity r e.at; + [] --> join !vr r e.at + + | Loop es -> + let c' = {c with labels = known [] :: c.labels} in + let r = check_block c' es in + check_result_arity r e.at; + [] --> r + + | Br (n, x) -> + check_arity n e.at; + let ts = peek_n n stack in + unify (label c x) ts e.at; + ts --> Bot + + | BrIf (n, x) -> + check_arity n e.at; + let ts = List.tl (peek_n (n + 1) stack) in + unify (label c x) ts e.at; + (ts @ [I32Type]) --> Stack [] + + | BrTable (n, xs, x) -> + check_arity n e.at; + let ts = List.tl (peek_n (n + 1) stack) in + unify (label c x) ts x.at; + List.iter (fun x' -> unify (label c x') ts x'.at) xs; + (ts @ [I32Type]) --> Bot + + | Return -> + c.results --> Bot + + | If (es1, es2) -> + let vr = unknown () in + let c' = {c with labels = vr :: c.labels} in + let r1 = check_block c' es1 in + let r2 = check_block c' es2 in + let r = join r1 r2 e.at in + check_result_arity r e.at; + [I32Type] --> join !vr r e.at + + | Select -> + let t = peek 1 stack in + [t; t; I32Type] --> Stack [t] + + | Call x -> + let FuncType (ins, out) = func c x in + ins --> Stack out + + | CallIndirect x -> + ignore (table c (0l @@ e.at)); + let FuncType (ins, out) = type_ c x in + (ins @ [I32Type]) --> Stack out | GetLocal x -> - check_type (Some (local c x)) et e.at + [] --> Stack [local c x] - | SetLocal (x, e1) -> - check_expr c (some (local c x)) e1; - check_type None et e.at + | SetLocal x -> + [local c x] --> Stack [] - | TeeLocal (x, e1) -> - check_expr c (some (local c x)) e1; - check_type (Some (local c x)) et e.at + | TeeLocal x -> + [local c x] --> Stack [local c x] | GetGlobal x -> let GlobalType (t, mut) = global c x in - check_type (Some t) et e.at + [] --> Stack [t] - | SetGlobal (x, e1) -> + | SetGlobal x -> let GlobalType (t, mut) = global c x in require (mut = Mutable) x.at "global is immutable"; - check_expr c (some t) e1; - check_type None et e.at - - | Load (memop, e1) -> - check_load c et memop (size memop.ty) e1 e.at + [t] --> Stack [] - | Store (memop, e1, e2) -> - check_store c et memop (size memop.ty) e1 e2 e.at + | Load memop -> + check_memop c memop (Lib.Option.map fst) e.at; + [I32Type] --> Stack [memop.ty] - | LoadExtend (extendop, e1) -> - check_mem_type extendop.memop.ty extendop.sz e.at; - check_load c et extendop.memop (Memory.mem_size extendop.sz) e1 e.at - - | StoreWrap (wrapop, e1, e2) -> - check_mem_type wrapop.memop.ty wrapop.sz e.at; - check_store c et wrapop.memop (Memory.mem_size wrapop.sz) e1 e2 e.at + | Store memop -> + check_memop c memop (fun sz -> sz) e.at; + [I32Type; memop.ty] --> Stack [] | Const v -> - check_literal c et v + let t = type_value v.it in + [] --> Stack [t] - | Unary (unop, e1) -> + | Unary unop -> let t = type_unop unop in - check_expr c (some t) e1; - check_type (Some t) et e.at + [t] --> Stack [t] - | Binary (binop, e1, e2) -> + | Binary binop -> let t = type_binop binop in - check_expr c (some t) e1; - check_expr c (some t) e2; - check_type (Some t) et e.at + [t; t] --> Stack [t] - | Test (testop, e1) -> + | Test testop -> let t = type_testop testop in - check_expr c (some t) e1; - check_type (Some Int32Type) et e.at + [t] --> Stack [I32Type] - | Compare (relop, e1, e2) -> + | Compare relop -> let t = type_relop relop in - check_expr c (some t) e1; - check_expr c (some t) e2; - check_type (Some Int32Type) et e.at - - | Convert (cvtop, e1) -> - let t1, t = type_cvtop e.at cvtop in - check_expr c (some t1) e1; - check_type (Some t) et e.at - - | Host (hostop, es) -> - let {ins; out}, has_mem = type_hostop hostop in - if has_mem then ignore (memory c (0 @@ e.at)); - check_exprs c ins es e.at; - check_type out et e.at - -and check_exprs c ts es at = - require (List.length ts = List.length es) at "arity mismatch"; - let ets = List.map some ts in - List.iter2 (check_expr c) ets es - -and check_expr_opt c et eo at = - match is_some et, eo with - | false, None -> () - | true, Some e -> check_expr c et e - | _ -> error at "arity mismatch" - -and check_literal c et l = - check_type (Some (type_value l.it)) et l.at - -and check_load c et memop mem_size e1 at = - ignore (memory c (0 @@ at)); - check_memop memop mem_size at; - check_expr c (some Int32Type) e1; - check_type (Some memop.ty) et at - -and check_store c et memop mem_size e1 e2 at = - ignore (memory c (0 @@ at)); - check_memop memop mem_size at; - check_expr c (some Int32Type) e1; - check_expr c (some memop.ty) e2; - check_type None et at - -and check_memop memop mem_size at = - require (memop.offset >= 0L) at "negative offset"; - require (memop.offset <= 0xffffffffL) at "offset too large"; - require (Lib.Int.is_power_of_two memop.align) at "alignment must be a power of two"; - require (memop.align <= mem_size) at "alignment must not be larger than natural" - -and check_mem_type ty sz at = - require (ty = Int64Type || sz <> Memory.Mem32) at "memory size too big" - -let check_const c et e = - match e.it with - | Const _ | GetGlobal _ -> check_expr c (some et) e - | _ -> error e.at "constant expression required" - - -(* Functions *) + [t; t] --> Stack [I32Type] + + | Convert cvtop -> + let t1, t2 = type_cvtop e.at cvtop in + [t1] --> Stack [t2] + + | CurrentMemory -> + ignore (memory c (0l @@ e.at)); + [] --> Stack [I32Type] + + | GrowMemory -> + ignore (memory c (0l @@ e.at)); + [I32Type] --> Stack [I32Type] + +and check_block (c : context) (es : instr list) : result_type = + match es with + | [] -> + Stack [] + + | _ -> + let es', e = Lib.List.split_last es in + let r1 = check_block c es' in + match r1 with + | Bot -> Bot + | Stack ts0 -> + let ts2, r2 = check_instr c e (List.rev ts0) in + let n1 = max (List.length ts0 - List.length ts2) 0 in + let ts1 = Lib.List.take n1 ts0 in + let ts2' = Lib.List.drop n1 ts0 in + if ts2 <> ts2' then result_error e.at (Stack ts2) (Stack ts2'); + match r2 with + | Bot -> Bot + | Stack ts3 -> Stack (ts1 @ ts3) + + +(* Functions & Constants *) (* - * check_func : context -> func -> unit - * check_module : context -> module_ -> unit - * * Conventions: * c : context * m : module_ * f : func - * e : expr + * e : instr * v : value * t : value_type * s : func_type *) -let check_func c f = +let check_func (c : context) (f : func) = let {ftype; locals; body} = f.it in - let s = type_ c ftype in - let c' = {c with locals = s.ins @ locals; return = s.out} in - check_expr c' (known s.out) body + let FuncType (ins, out) = type_ c ftype in + check_arity (List.length out) f.at; + let vr = known out in + let c' = {c with locals = ins @ locals; results = out; labels = [vr]} in + let r = check_block c' body in + ignore (join !vr r f.at) + + +let is_const e = + match e.it with + | Const _ | GetGlobal _ -> true + | _ -> false + +let check_const (c : context) (const : const) (t : value_type) = + require (List.for_all is_const const.it) const.at + "constant expression required"; + match check_block c const.it with + | Stack [t'] when t = t' -> () + | r -> result_error const.at (Stack [t]) r (* Tables, Memories, & Globals *) @@ -357,8 +370,8 @@ let check_memory (c : context) (mem : memory) = let check_table_segment c prev_end seg = let {index; offset; init} = seg.it in - check_const c Int32Type offset; - let start = Values.int32_of_value (Eval.const c.module_ offset) in + check_const c offset I32Type; + let start = Values.I32Value.of_value (Eval.const c.module_ offset) in let len = Int32.of_int (List.length init) in let end_ = Int32.add start len in let TableType (lim, _) = table c index in @@ -371,9 +384,9 @@ let check_table_segment c prev_end seg = let check_memory_segment c prev_end seg = let {index; offset; init} = seg.it in - check_const c Int32Type offset; + check_const c offset I32Type; let start = - Int64.of_int32 (Values.int32_of_value (Eval.const c.module_ offset)) in + Int64.of_int32 (Values.I32Value.of_value (Eval.const c.module_ offset)) in let len = Int64.of_int (String.length init) in let end_ = Int64.add start len in let MemoryType lim = memory c index in @@ -387,7 +400,7 @@ let check_memory_segment c prev_end seg = let check_global c glob = let {gtype; value} = glob.it in let GlobalType (t, mut) = gtype in - check_const c t value; + check_const c value t; {c with globals = c.globals @ [gtype]} @@ -395,11 +408,8 @@ let check_global c glob = let check_start c start = Lib.Option.app (fun x -> - let start_type = func c x in - require (start_type.ins = []) x.at - "start function must be nullary"; - require (start_type.out = None) x.at - "start function must not return anything"; + require (func c x = FuncType ([], [])) x.at + "start function must not have parameters or results" ) start let check_import im c = @@ -431,15 +441,15 @@ let check_export c set ex = require (not (NameSet.mem name set)) ex.at "duplicate export name"; NameSet.add name set -let check_module m = +let check_module (m : module_) = let {types; imports; tables; memories; globals; funcs; start; elems; data; exports} = m.it in - let c = List.fold_right check_import imports {(empty_context m) with types} in + let c = List.fold_right check_import imports {(context m) with types} in let c' = { (List.fold_left check_global c globals) with funcs = c.funcs @ List.map (fun f -> type_ c f.it.ftype) funcs; - tables = c.tables @ List.map (fun tab -> tab.it.ttype) tables; + tables = c.tables @ List.map (fun tab -> tab.it.ttype) tables; memories = c.memories @ List.map (fun mem -> mem.it.mtype) memories; } in diff --git a/ml-proto/spec/check.mli b/ml-proto/spec/check.mli index 06b8f0969f..3db17e284d 100644 --- a/ml-proto/spec/check.mli +++ b/ml-proto/spec/check.mli @@ -1,3 +1,3 @@ exception Invalid of Source.region * string -val check_module : Kernel.module_ -> unit (* raise Invalid *) +val check_module : Ast.module_ -> unit (* raise Invalid *) diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 7390015e2f..2433116ba7 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -5,21 +5,18 @@ type stream = name : string; bytes : string; pos : int ref; - len : int } exception EOS -let stream name bs = {name; bytes = bs; pos = ref 0; len = String.length bs} -let substream s end_ = {s with len = end_} +let stream name bs = {name; bytes = bs; pos = ref 0} -let len s = s.len +let len s = String.length s.bytes let pos s = !(s.pos) let eos s = (pos s = len s) let check n s = if pos s + n > len s then raise EOS let skip n s = check n s; s.pos := !(s.pos) + n -let rewind p s = s.pos := p let read s = Char.code (s.bytes.[!(s.pos)]) let peek s = if eos s then None else Some (read s) @@ -80,34 +77,53 @@ let u64 s = let hi = Int64.of_int32 (u32 s) in Int64.(add lo (shift_left hi 32)) -let rec vu64 s = +let rec vuN n s = + require (n > 0) s (pos s) "integer representation too long"; let b = u8 s in + require (n >= 7 || b land 0x7f < 1 lsl n) s (pos s - 1) "integer out of range"; let x = Int64.of_int (b land 0x7f) in - if b land 0x80 = 0 then x - else Int64.(logor x (shift_left (vu64 s) 7)) - (*TODO: check for overflow*) + if b land 0x80 = 0 then x else Int64.(logor x (shift_left (vuN (n - 7) s) 7)) -let rec vs64 s = +let rec vsN n s = + require (n > 0) s (pos s) "integer representation too long"; let b = u8 s in + let mask = (-1 lsl n) land 0x7f in + require (n >= 7 || b land mask = 0 || b land mask = mask) s (pos s - 1) + "integer too large"; let x = Int64.of_int (b land 0x7f) in if b land 0x80 = 0 then (if b land 0x40 = 0 then x else Int64.(logor x (logxor (-1L) 0x7fL))) - else Int64.(logor x (shift_left (vs64 s) 7)) - (*TODO: check for overflow*) - -let vu32 s = Int64.to_int32 (vu64 s) (*TODO:check overflow*) -let vs32 s = Int64.to_int32 (vs64 s) (*TODO:check overflow*) -let vu s = Int64.to_int (vu64 s) (*TODO:check overflow*) + else Int64.(logor x (shift_left (vsN (n - 7) s) 7)) + +let vu1 s = Int64.to_int (vuN 1 s) +let vu7 s = Int64.to_int (vuN 7 s) +let vu32 s = Int64.to_int32 (vuN 32 s) +let vs32 s = Int64.to_int32 (vsN 32 s) +let vu64 s = vuN 64 s +let vs64 s = vsN 64 s let f32 s = F32.of_bits (u32 s) let f64 s = F64.of_bits (u64 s) -let bool s = match get s with 0 | 1 as n -> n <> 0 | _ -> error s (pos s - 1) "invalid boolean" -let string s = let n = vu s in get_string n s +let len32 s = + let pos = pos s in + let n = vu32 s in + if n <= Int32.of_int (len s) then Int32.to_int n else + error s pos "length out of bounds" + +let bool s = (vu1 s = 1) +let string s = let n = len32 s in get_string n s let rec list f n s = if n = 0 then [] else let x = f s in x :: list f (n - 1) s let opt f b s = if b then Some (f s) else None -let vec f s = let n = vu s in list f n s +let vec f s = let n = len32 s in list f n s let vec1 f s = let b = bool s in opt f b s +let sized f s = + let size = len32 s in + let start = pos s in + let x = f size s in + require (pos s = start + size) s start "section size mismatch"; + x + (* Types *) @@ -115,10 +131,10 @@ open Types let value_type s = match u8 s with - | 0x01 -> Int32Type - | 0x02 -> Int64Type - | 0x03 -> Float32Type - | 0x04 -> Float64Type + | 0x01 -> I32Type + | 0x02 -> I64Type + | 0x03 -> F32Type + | 0x04 -> F64Type | _ -> error s (pos s - 1) "invalid value type" let elem_type s = @@ -126,13 +142,37 @@ let elem_type s = | 0x20 -> AnyFuncType | _ -> error s (pos s - 1) "invalid element type" -let expr_type s = vec1 value_type s - let func_type s = expect 0x40 s "invalid function type"; let ins = vec value_type s in - let out = expr_type s in - {ins; out} + let out = vec value_type s in + FuncType (ins, out) + +let limits vu s = + let has_max = bool s in + let min = vu s in + let max = opt vu has_max s in + {min; max} + +let table_type s = + let t = elem_type s in + let lim = limits vu32 s in + TableType (lim, t) + +let memory_type s = + let lim = limits vu32 s in + MemoryType lim + +let mutability s = + match u8 s with + | 0 -> Immutable + | 1 -> Mutable + | _ -> error s (pos s - 1) "invalid mutability" + +let global_type s = + let t = value_type s in + let mut = mutability s in + GlobalType (t, mut) let limits vu s = let has_max = bool s in @@ -161,23 +201,21 @@ let global_type s = GlobalType (t, mut) -(* Decode expressions *) +(* Decode instructions *) -open Kernel open Ast +open Operators let op s = u8 s -let arity s = vu s -let arity1 s = bool s +let arity s = u8 s let memop s = let align = vu32 s in require (I32.lt_u align 32l) s (pos s - 1) "invalid memop flags"; let offset = vu64 s in - offset, 1 lsl Int32.to_int align + 1 lsl Int32.to_int align, offset -let var s = vu s -let var32 s = Int32.to_int (vu32 s) +let var s = vu32 s let rec args n stack s pos = args' n stack [] s pos and args' n stack es s pos = @@ -192,282 +230,247 @@ let args1 b stack s pos = | [e], stack' -> Some e, stack' | _ -> assert false -let rec expr stack s = +let rec instr s = let pos = pos s in - match op s, stack with - | 0x00, es -> - Nop, es - | 0x01, es -> - let es' = expr_block s in - expect 0x0f s "`end` opcode expected"; - Block es', es - | 0x02, es -> - let es' = expr_block s in - expect 0x0f s "`end` opcode expected"; - Loop es', es - | 0x03, e :: es -> - let es1 = expr_block s in + match op s with + | 0x00 -> unreachable + | 0x01 -> + let es' = instr_block s in + expect 0x0f s "END opcode expected"; + block es' + | 0x02 -> + let es' = instr_block s in + expect 0x0f s "END opcode expected"; + loop es' + | 0x03 -> + let es1 = instr_block s in if peek s = Some 0x04 then begin expect 0x04 s "`else` or `end` opcode expected"; - let es2 = expr_block s in - expect 0x0f s "`end` opcode expected"; - If (e, es1, es2), es + let es2 = instr_block s in + expect 0x0f s "END opcode expected"; + if_ es1 es2 end else begin - expect 0x0f s "`end` opcode expected"; - If (e, es1, []), es + expect 0x0f s "END opcode expected"; + if_ es1 [] end - | 0x04, _ -> - error s pos "misplaced `else` opcode" - | 0x05, e3 :: e2 :: e1 :: es -> - Select (e1, e2, e3), es - | 0x06, es -> - let b = arity1 s in - let x = at var s in - let eo, es' = args1 b es s pos in - Br (x, eo), es' - | 0x07, e :: es -> - let b = arity1 s in - let x = at var s in - let eo, es' = args1 b es s pos in - Br_if (x, eo, e), es' - | 0x08, e :: es -> - let b = arity1 s in - let xs = vec (at var) s in - let x = at var s in - let eo, es' = args1 b es s pos in - Br_table (xs, x, eo, e), es' - | 0x09, es -> - let b = arity1 s in - let eo, es' = args1 b es s pos in - Return eo, es' - | 0x0a, es -> - Unreachable, es - | 0x0b, e :: es -> - Drop e, es - | 0x0c | 0x0d | 0x0e as b, _ -> - illegal s pos b - | 0x0f, _ -> - error s pos "misplaced `end` opcode" - - | 0x10, es -> I32_const (at vs32 s), es - | 0x11, es -> I64_const (at vs64 s), es - | 0x12, es -> F32_const (at f32 s), es - | 0x13, es -> F64_const (at f64 s), es - - | 0x14, es -> - let x = at var s in - Get_local x, es - | 0x15, e :: es -> - let x = at var s in - Set_local (x, e), es - - | 0x16, es -> + | 0x04 -> error s pos "misplaced ELSE opcode" + | 0x05 -> select + | 0x06 -> let n = arity s in let x = at var s in - let es1, es' = args n es s pos in - Call (x, es1), es' - | 0x17, es -> + br n x + | 0x07 -> let n = arity s in let x = at var s in - let es1, es' = args (n + 1) es s pos in - Call_indirect (x, List.hd es1, List.tl es1), es' - - | 0x19, e :: es -> - let x = at var s in - Tee_local (x, e), es - - | 0x1c | 0x1d | 0x1e | 0x1f as b, _ -> - illegal s pos b - - | 0x20, e :: es -> let o, a = memop s in I32_load8_s (o, a, e), es - | 0x21, e :: es -> let o, a = memop s in I32_load8_u (o, a, e), es - | 0x22, e :: es -> let o, a = memop s in I32_load16_s (o, a, e), es - | 0x23, e :: es -> let o, a = memop s in I32_load16_u (o, a, e), es - | 0x24, e :: es -> let o, a = memop s in I64_load8_s (o, a, e), es - | 0x25, e :: es -> let o, a = memop s in I64_load8_u (o, a, e), es - | 0x26, e :: es -> let o, a = memop s in I64_load16_s (o, a, e), es - | 0x27, e :: es -> let o, a = memop s in I64_load16_u (o, a, e), es - | 0x28, e :: es -> let o, a = memop s in I64_load32_s (o, a, e), es - | 0x29, e :: es -> let o, a = memop s in I64_load32_u (o, a, e), es - | 0x2a, e :: es -> let o, a = memop s in I32_load (o, a, e), es - | 0x2b, e :: es -> let o, a = memop s in I64_load (o, a, e), es - | 0x2c, e :: es -> let o, a = memop s in F32_load (o, a, e), es - | 0x2d, e :: es -> let o, a = memop s in F64_load (o, a, e), es - - | 0x2e, e2 :: e1 :: es -> let o, a = memop s in I32_store8 (o, a, e1, e2), es - | 0x2f, e2 :: e1 :: es -> let o, a = memop s in I32_store16 (o, a, e1, e2), es - | 0x30, e2 :: e1 :: es -> let o, a = memop s in I64_store8 (o, a, e1, e2), es - | 0x31, e2 :: e1 :: es -> let o, a = memop s in I64_store16 (o, a, e1, e2), es - | 0x32, e2 :: e1 :: es -> let o, a = memop s in I64_store32 (o, a, e1, e2), es - | 0x33, e2 :: e1 :: es -> let o, a = memop s in I32_store (o, a, e1, e2), es - | 0x34, e2 :: e1 :: es -> let o, a = memop s in I64_store (o, a, e1, e2), es - | 0x35, e2 :: e1 :: es -> let o, a = memop s in F32_store (o, a, e1, e2), es - | 0x36, e2 :: e1 :: es -> let o, a = memop s in F64_store (o, a, e1, e2), es - - | 0x37 | 0x38 as b, _ -> illegal s pos b - - | 0x39, e :: es -> Grow_memory e, es - | 0x3a as b, _ -> illegal s pos b - | 0x3b, es -> Current_memory, es - - | 0x3c | 0x3d | 0x3e | 0x3f as b, _ -> illegal s pos b - - | 0x40, e2 :: e1 :: es -> I32_add (e1, e2), es - | 0x41, e2 :: e1 :: es -> I32_sub (e1, e2), es - | 0x42, e2 :: e1 :: es -> I32_mul (e1, e2), es - | 0x43, e2 :: e1 :: es -> I32_div_s (e1, e2), es - | 0x44, e2 :: e1 :: es -> I32_div_u (e1, e2), es - | 0x45, e2 :: e1 :: es -> I32_rem_s (e1, e2), es - | 0x46, e2 :: e1 :: es -> I32_rem_u (e1, e2), es - | 0x47, e2 :: e1 :: es -> I32_and (e1, e2), es - | 0x48, e2 :: e1 :: es -> I32_or (e1, e2), es - | 0x49, e2 :: e1 :: es -> I32_xor (e1, e2), es - | 0x4a, e2 :: e1 :: es -> I32_shl (e1, e2), es - | 0x4b, e2 :: e1 :: es -> I32_shr_u (e1, e2), es - | 0x4c, e2 :: e1 :: es -> I32_shr_s (e1, e2), es - | 0x4d, e2 :: e1 :: es -> I32_eq (e1, e2), es - | 0x4e, e2 :: e1 :: es -> I32_ne (e1, e2), es - | 0x4f, e2 :: e1 :: es -> I32_lt_s (e1, e2), es - | 0x50, e2 :: e1 :: es -> I32_le_s (e1, e2), es - | 0x51, e2 :: e1 :: es -> I32_lt_u (e1, e2), es - | 0x52, e2 :: e1 :: es -> I32_le_u (e1, e2), es - | 0x53, e2 :: e1 :: es -> I32_gt_s (e1, e2), es - | 0x54, e2 :: e1 :: es -> I32_ge_s (e1, e2), es - | 0x55, e2 :: e1 :: es -> I32_gt_u (e1, e2), es - | 0x56, e2 :: e1 :: es -> I32_ge_u (e1, e2), es - | 0x57, e :: es -> I32_clz e, es - | 0x58, e :: es -> I32_ctz e, es - | 0x59, e :: es -> I32_popcnt e, es - | 0x5a, e :: es -> I32_eqz e, es - - | 0x5b, e2 :: e1 :: es -> I64_add (e1, e2), es - | 0x5c, e2 :: e1 :: es -> I64_sub (e1, e2), es - | 0x5d, e2 :: e1 :: es -> I64_mul (e1, e2), es - | 0x5e, e2 :: e1 :: es -> I64_div_s (e1, e2), es - | 0x5f, e2 :: e1 :: es -> I64_div_u (e1, e2), es - | 0x60, e2 :: e1 :: es -> I64_rem_s (e1, e2), es - | 0x61, e2 :: e1 :: es -> I64_rem_u (e1, e2), es - | 0x62, e2 :: e1 :: es -> I64_and (e1, e2), es - | 0x63, e2 :: e1 :: es -> I64_or (e1, e2), es - | 0x64, e2 :: e1 :: es -> I64_xor (e1, e2), es - | 0x65, e2 :: e1 :: es -> I64_shl (e1, e2), es - | 0x66, e2 :: e1 :: es -> I64_shr_u (e1, e2), es - | 0x67, e2 :: e1 :: es -> I64_shr_s (e1, e2), es - | 0x68, e2 :: e1 :: es -> I64_eq (e1, e2), es - | 0x69, e2 :: e1 :: es -> I64_ne (e1, e2), es - | 0x6a, e2 :: e1 :: es -> I64_lt_s (e1, e2), es - | 0x6b, e2 :: e1 :: es -> I64_le_s (e1, e2), es - | 0x6c, e2 :: e1 :: es -> I64_lt_u (e1, e2), es - | 0x6d, e2 :: e1 :: es -> I64_le_u (e1, e2), es - | 0x6e, e2 :: e1 :: es -> I64_gt_s (e1, e2), es - | 0x6f, e2 :: e1 :: es -> I64_ge_s (e1, e2), es - | 0x70, e2 :: e1 :: es -> I64_gt_u (e1, e2), es - | 0x71, e2 :: e1 :: es -> I64_ge_u (e1, e2), es - | 0x72, e :: es -> I64_clz e, es - | 0x73, e :: es -> I64_ctz e, es - | 0x74, e :: es -> I64_popcnt e, es - - | 0x75, e2 :: e1 :: es -> F32_add (e1, e2), es - | 0x76, e2 :: e1 :: es -> F32_sub (e1, e2), es - | 0x77, e2 :: e1 :: es -> F32_mul (e1, e2), es - | 0x78, e2 :: e1 :: es -> F32_div (e1, e2), es - | 0x79, e2 :: e1 :: es -> F32_min (e1, e2), es - | 0x7a, e2 :: e1 :: es -> F32_max (e1, e2), es - | 0x7b, e :: es -> F32_abs e, es - | 0x7c, e :: es -> F32_neg e, es - | 0x7d, e2 :: e1 :: es -> F32_copysign (e1, e2), es - | 0x7e, e :: es -> F32_ceil e, es - | 0x7f, e :: es -> F32_floor e, es - | 0x80, e :: es -> F32_trunc e, es - | 0x81, e :: es -> F32_nearest e, es - | 0x82, e :: es -> F32_sqrt e, es - | 0x83, e2 :: e1 :: es -> F32_eq (e1, e2), es - | 0x84, e2 :: e1 :: es -> F32_ne (e1, e2), es - | 0x85, e2 :: e1 :: es -> F32_lt (e1, e2), es - | 0x86, e2 :: e1 :: es -> F32_le (e1, e2), es - | 0x87, e2 :: e1 :: es -> F32_gt (e1, e2), es - | 0x88, e2 :: e1 :: es -> F32_ge (e1, e2), es - - | 0x89, e2 :: e1 :: es -> F64_add (e1, e2), es - | 0x8a, e2 :: e1 :: es -> F64_sub (e1, e2), es - | 0x8b, e2 :: e1 :: es -> F64_mul (e1, e2), es - | 0x8c, e2 :: e1 :: es -> F64_div (e1, e2), es - | 0x8d, e2 :: e1 :: es -> F64_min (e1, e2), es - | 0x8e, e2 :: e1 :: es -> F64_max (e1, e2), es - | 0x8f, e :: es -> F64_abs e, es - | 0x90, e :: es -> F64_neg e, es - | 0x91, e2 :: e1 :: es -> F64_copysign (e1, e2), es - | 0x92, e :: es -> F64_ceil e, es - | 0x93, e :: es -> F64_floor e, es - | 0x94, e :: es -> F64_trunc e, es - | 0x95, e :: es -> F64_nearest e, es - | 0x96, e :: es -> F64_sqrt e, es - | 0x97, e2 :: e1 :: es -> F64_eq (e1, e2), es - | 0x98, e2 :: e1 :: es -> F64_ne (e1, e2), es - | 0x99, e2 :: e1 :: es -> F64_lt (e1, e2), es - | 0x9a, e2 :: e1 :: es -> F64_le (e1, e2), es - | 0x9b, e2 :: e1 :: es -> F64_gt (e1, e2), es - | 0x9c, e2 :: e1 :: es -> F64_ge (e1, e2), es - - | 0x9d, e :: es -> I32_trunc_s_f32 e, es - | 0x9e, e :: es -> I32_trunc_s_f64 e, es - | 0x9f, e :: es -> I32_trunc_u_f32 e, es - | 0xa0, e :: es -> I32_trunc_u_f64 e, es - | 0xa1, e :: es -> I32_wrap_i64 e, es - | 0xa2, e :: es -> I64_trunc_s_f32 e, es - | 0xa3, e :: es -> I64_trunc_s_f64 e, es - | 0xa4, e :: es -> I64_trunc_u_f32 e, es - | 0xa5, e :: es -> I64_trunc_u_f64 e, es - | 0xa6, e :: es -> I64_extend_s_i32 e, es - | 0xa7, e :: es -> I64_extend_u_i32 e, es - | 0xa8, e :: es -> F32_convert_s_i32 e, es - | 0xa9, e :: es -> F32_convert_u_i32 e, es - | 0xaa, e :: es -> F32_convert_s_i64 e, es - | 0xab, e :: es -> F32_convert_u_i64 e, es - | 0xac, e :: es -> F32_demote_f64 e, es - | 0xad, e :: es -> F32_reinterpret_i32 e, es - | 0xae, e :: es -> F64_convert_s_i32 e, es - | 0xaf, e :: es -> F64_convert_u_i32 e, es - | 0xb0, e :: es -> F64_convert_s_i64 e, es - | 0xb1, e :: es -> F64_convert_u_i64 e, es - | 0xb2, e :: es -> F64_promote_f32 e, es - | 0xb3, e :: es -> F64_reinterpret_i64 e, es - | 0xb4, e :: es -> I32_reinterpret_f32 e, es - | 0xb5, e :: es -> I64_reinterpret_f64 e, es - - | 0xb6, e2 :: e1 :: es -> I32_rotl (e1, e2), es - | 0xb7, e2 :: e1 :: es -> I32_rotr (e1, e2), es - | 0xb8, e2 :: e1 :: es -> I64_rotl (e1, e2), es - | 0xb9, e2 :: e1 :: es -> I64_rotr (e1, e2), es - | 0xba, e :: es -> I64_eqz e, es - - | 0xbb, es -> - let x = at var s in - Get_global x, es - | 0xbc, e :: es -> + br_if n x + | 0x08 -> + let n = arity s in + let xs = vec (at var) s in let x = at var s in - Set_global (x, e), es - - | b, _ when b > 0xbc -> illegal s pos b - - | b, _ -> error s pos "too few operands for operator" - -and expr_block s = List.rev (expr_block' [] s) -and expr_block' stack s = - if eos s then stack else + br_table n xs x + | 0x09 -> return + | 0x0a -> nop + | 0x0b -> drop + | 0x0c | 0x0d | 0x0e as b -> illegal s pos b + | 0x0f -> error s pos "misplaced END opcode" + + | 0x10 -> i32_const (at vs32 s) + | 0x11 -> i64_const (at vs64 s) + | 0x12 -> f32_const (at f32 s) + | 0x13 -> f64_const (at f64 s) + + | 0x14 -> get_local (at var s) + | 0x15 -> set_local (at var s) + + | 0x16 -> call (at var s) + | 0x17 -> call_indirect (at var s) + + | 0x19 -> tee_local (at var s) + + | 0x1a | 0x1b | 0x1c | 0x1d | 0x1e | 0x1f as b -> illegal s pos b + + | 0x20 -> let a, o = memop s in i32_load8_s a o + | 0x21 -> let a, o = memop s in i32_load8_u a o + | 0x22 -> let a, o = memop s in i32_load16_s a o + | 0x23 -> let a, o = memop s in i32_load16_u a o + | 0x24 -> let a, o = memop s in i64_load8_s a o + | 0x25 -> let a, o = memop s in i64_load8_u a o + | 0x26 -> let a, o = memop s in i64_load16_s a o + | 0x27 -> let a, o = memop s in i64_load16_u a o + | 0x28 -> let a, o = memop s in i64_load32_s a o + | 0x29 -> let a, o = memop s in i64_load32_u a o + | 0x2a -> let a, o = memop s in i32_load a o + | 0x2b -> let a, o = memop s in i64_load a o + | 0x2c -> let a, o = memop s in f32_load a o + | 0x2d -> let a, o = memop s in f64_load a o + + | 0x2e -> let a, o = memop s in i32_store8 a o + | 0x2f -> let a, o = memop s in i32_store16 a o + | 0x30 -> let a, o = memop s in i64_store8 a o + | 0x31 -> let a, o = memop s in i64_store16 a o + | 0x32 -> let a, o = memop s in i64_store32 a o + | 0x33 -> let a, o = memop s in i32_store a o + | 0x34 -> let a, o = memop s in i64_store a o + | 0x35 -> let a, o = memop s in f32_store a o + | 0x36 -> let a, o = memop s in f64_store a o + + | 0x37 | 0x38 as b -> illegal s pos b + + | 0x39 -> grow_memory + | 0x3a as b -> illegal s pos b + | 0x3b -> current_memory + + | 0x3c | 0x3d | 0x3e | 0x3f as b -> illegal s pos b + + | 0x40 -> i32_add + | 0x41 -> i32_sub + | 0x42 -> i32_mul + | 0x43 -> i32_div_s + | 0x44 -> i32_div_u + | 0x45 -> i32_rem_s + | 0x46 -> i32_rem_u + | 0x47 -> i32_and + | 0x48 -> i32_or + | 0x49 -> i32_xor + | 0x4a -> i32_shl + | 0x4b -> i32_shr_u + | 0x4c -> i32_shr_s + | 0x4d -> i32_eq + | 0x4e -> i32_ne + | 0x4f -> i32_lt_s + | 0x50 -> i32_le_s + | 0x51 -> i32_lt_u + | 0x52 -> i32_le_u + | 0x53 -> i32_gt_s + | 0x54 -> i32_ge_s + | 0x55 -> i32_gt_u + | 0x56 -> i32_ge_u + | 0x57 -> i32_clz + | 0x58 -> i32_ctz + | 0x59 -> i32_popcnt + | 0x5a -> i32_eqz + + | 0x5b -> i64_add + | 0x5c -> i64_sub + | 0x5d -> i64_mul + | 0x5e -> i64_div_s + | 0x5f -> i64_div_u + | 0x60 -> i64_rem_s + | 0x61 -> i64_rem_u + | 0x62 -> i64_and + | 0x63 -> i64_or + | 0x64 -> i64_xor + | 0x65 -> i64_shl + | 0x66 -> i64_shr_u + | 0x67 -> i64_shr_s + | 0x68 -> i64_eq + | 0x69 -> i64_ne + | 0x6a -> i64_lt_s + | 0x6b -> i64_le_s + | 0x6c -> i64_lt_u + | 0x6d -> i64_le_u + | 0x6e -> i64_gt_s + | 0x6f -> i64_ge_s + | 0x70 -> i64_gt_u + | 0x71 -> i64_ge_u + | 0x72 -> i64_clz + | 0x73 -> i64_ctz + | 0x74 -> i64_popcnt + + | 0x75 -> f32_add + | 0x76 -> f32_sub + | 0x77 -> f32_mul + | 0x78 -> f32_div + | 0x79 -> f32_min + | 0x7a -> f32_max + | 0x7b -> f32_abs + | 0x7c -> f32_neg + | 0x7d -> f32_copysign + | 0x7e -> f32_ceil + | 0x7f -> f32_floor + | 0x80 -> f32_trunc + | 0x81 -> f32_nearest + | 0x82 -> f32_sqrt + | 0x83 -> f32_eq + | 0x84 -> f32_ne + | 0x85 -> f32_lt + | 0x86 -> f32_le + | 0x87 -> f32_gt + | 0x88 -> f32_ge + + | 0x89 -> f64_add + | 0x8a -> f64_sub + | 0x8b -> f64_mul + | 0x8c -> f64_div + | 0x8d -> f64_min + | 0x8e -> f64_max + | 0x8f -> f64_abs + | 0x90 -> f64_neg + | 0x91 -> f64_copysign + | 0x92 -> f64_ceil + | 0x93 -> f64_floor + | 0x94 -> f64_trunc + | 0x95 -> f64_nearest + | 0x96 -> f64_sqrt + | 0x97 -> f64_eq + | 0x98 -> f64_ne + | 0x99 -> f64_lt + | 0x9a -> f64_le + | 0x9b -> f64_gt + | 0x9c -> f64_ge + + | 0x9d -> i32_trunc_s_f32 + | 0x9e -> i32_trunc_s_f64 + | 0x9f -> i32_trunc_u_f32 + | 0xa0 -> i32_trunc_u_f64 + | 0xa1 -> i32_wrap_i64 + | 0xa2 -> i64_trunc_s_f32 + | 0xa3 -> i64_trunc_s_f64 + | 0xa4 -> i64_trunc_u_f32 + | 0xa5 -> i64_trunc_u_f64 + | 0xa6 -> i64_extend_s_i32 + | 0xa7 -> i64_extend_u_i32 + | 0xa8 -> f32_convert_s_i32 + | 0xa9 -> f32_convert_u_i32 + | 0xaa -> f32_convert_s_i64 + | 0xab -> f32_convert_u_i64 + | 0xac -> f32_demote_f64 + | 0xad -> f32_reinterpret_i32 + | 0xae -> f64_convert_s_i32 + | 0xaf -> f64_convert_u_i32 + | 0xb0 -> f64_convert_s_i64 + | 0xb1 -> f64_convert_u_i64 + | 0xb2 -> f64_promote_f32 + | 0xb3 -> f64_reinterpret_i64 + | 0xb4 -> i32_reinterpret_f32 + | 0xb5 -> i64_reinterpret_f64 + + | 0xb6 -> i32_rotl + | 0xb7 -> i32_rotr + | 0xb8 -> i64_rotl + | 0xb9 -> i64_rotr + | 0xba -> i64_eqz + + | 0xbb -> get_global (at var s) + | 0xbc -> set_global (at var s) + + | b when b > 0xbc -> illegal s pos b + + | b -> error s pos "too few operands for operator" + +and instr_block s = List.rev (instr_block' s []) +and instr_block' s es = match peek s with - | None | Some (0x04 | 0x0f) -> stack + | None | Some (0x04 | 0x0f) -> es | _ -> let pos = pos s in - let e', stack' = expr stack s in - expr_block' (Source.(e' @@ region s pos pos) :: stack') s + let e' = instr s in + instr_block' s (Source.(e' @@ region s pos pos) :: es) let const s = - match expr_block s with - | [e] -> - expect 0x0f s "`end` opcode expected"; - e - | _ -> error s (pos s) "too many expressions" + let c = at instr_block s in + expect 0x0f s "END opcode expected"; + c (* Sections *) @@ -477,30 +480,31 @@ let trace s name = (name ^ " @ " ^ string_of_int (pos s) ^ " = " ^ string_of_byte (read s)) let id s = - match string s with - | "type" -> `TypeSection - | "import" -> `ImportSection - | "function" -> `FuncSection - | "table" -> `TableSection - | "memory" -> `MemorySection - | "global" -> `GlobalSection - | "export" -> `ExportSection - | "start" -> `StartSection - | "code" -> `CodeSection - | "element" -> `ElemSection - | "data" -> `DataSection - | _ -> `UnknownSection + let bo = peek s in + Lib.Option.map + (function + | 0 -> `UserSection + | 1 -> `TypeSection + | 2 -> `ImportSection + | 3 -> `FuncSection + | 4 -> `TableSection + | 5 -> `MemorySection + | 6 -> `GlobalSection + | 7 -> `ExportSection + | 8 -> `StartSection + | 9 -> `CodeSection + | 10 -> `ElemSection + | 11 -> `DataSection + | _ -> error s (pos s) "invalid section id" + ) bo + +let section_with_size tag f default s = + match id s with + | Some tag' when tag' = tag -> ignore (get s); sized f s + | _ -> default let section tag f default s = - if eos s then default else - let start_pos = pos s in - if id s <> tag then (rewind start_pos s; default) else - let size = vu s in - let content_pos = pos s in - let s' = substream s (content_pos + size) in - let x = f s' in - require (eos s') s' (pos s') "junk at end of section"; - x + section_with_size tag (fun _ -> f) default s (* Type section *) @@ -558,12 +562,9 @@ let memory_section s = (* Global section *) let global s = - let t = global_type s in - let pos = pos s in - let es = expr_block s in - require (List.length es = 1) s pos "single expression expected"; - expect 0x0f s "`end` opcode expected"; - {gtype = t; value = List.hd es} + let gtype = global_type s in + let value = const s in + {gtype; value} let global_section s = section `GlobalSection (vec (at global)) [] s @@ -598,19 +599,18 @@ let start_section s = (* Code section *) let local s = - let n = vu s in + let n = len32 s in let t = value_type s in Lib.List.make n t -let code s = - let size = vu s in - let p = pos s in +let code _ s = let locals = List.flatten (vec local s) in - let body = expr_block (substream s (p + size)) in - {locals; body; ftype = Source.((-1) @@ Source.no_region)} + let body = instr_block s in + expect 0x0f s "END opcode expected"; + {locals; body; ftype = Source.((-1l) @@ Source.no_region)} let code_section s = - section `CodeSection (vec (at code)) [] s + section `CodeSection (vec (at (sized code))) [] s (* Element section *) @@ -637,10 +637,16 @@ let data_section s = section `DataSection (vec (at memory_segment)) [] s -(* Unknown section *) +(* User section *) -let unknown_section s = - section `UnknownSection (fun s -> skip (len s - pos s) s; true) false s +let user size s = + let start = pos s in + let _id = string s in + skip (size - (pos s - start)) s; + true + +let user_section s = + section_with_size `UserSection user false s (* Modules *) @@ -652,31 +658,29 @@ let module_ s = require (magic = 0x6d736100l) s 0 "magic header not detected"; let version = u32 s in require (version = Encode.version) s 4 "unknown binary version"; - iterate unknown_section s; + iterate user_section s; let types = type_section s in - iterate unknown_section s; + iterate user_section s; let imports = import_section s in - iterate unknown_section s; + iterate user_section s; let func_types = func_section s in - iterate unknown_section s; + iterate user_section s; let tables = table_section s in - iterate unknown_section s; + iterate user_section s; let memories = memory_section s in - iterate unknown_section s; + iterate user_section s; let globals = global_section s in - iterate unknown_section s; + iterate user_section s; let exports = export_section s in - iterate unknown_section s; + iterate user_section s; let start = start_section s in - iterate unknown_section s; - let func_bodies = code_section s in - iterate unknown_section s; + iterate user_section s; let elems = elem_section s in - iterate unknown_section s; + iterate user_section s; + let func_bodies = code_section s in + iterate user_section s; let data = data_section s in - iterate unknown_section s; - (*TODO: name section*) - iterate unknown_section s; + iterate user_section s; require (pos s = len s) s (len s) "junk after last section"; require (List.length func_types = List.length func_bodies) s (len s) "function and code section have inconsistent lengths"; diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml deleted file mode 100644 index d7b88195f9..0000000000 --- a/ml-proto/spec/desugar.ml +++ /dev/null @@ -1,321 +0,0 @@ -open Source -open Types -open Values -open Memory -open Kernel - - -(* Labels *) - -let rec relabel f n e = relabel' f n e.it @@ e.at -and relabel' f n = function - | Nop -> Nop - | Unreachable -> Unreachable - | Drop e -> Drop (relabel f n e) - | Block (es, e) -> - Block (List.map (relabel f (n + 1)) es, relabel f (n + 1) e) - | Loop e -> Loop (relabel f (n + 1) e) - | Break (x, eo) -> - Break (relabel_var f n x, Lib.Option.map (relabel f n) eo) - | BreakIf (x, eo, e) -> - BreakIf (relabel_var f n x, Lib.Option.map (relabel f n) eo, relabel f n e) - | BreakTable (xs, x, eo, e) -> - BreakTable - (List.map (relabel_var f n) xs, relabel_var f n x, - Lib.Option.map (relabel f n) eo, relabel f n e) - | If (e1, e2, e3) -> If (relabel f n e1, relabel f n e2, relabel f n e3) - | Select (e1, e2, e3) -> - Select (relabel f n e1, relabel f n e2, relabel f n e3) - | Call (x, es) -> Call (x, List.map (relabel f n) es) - | CallIndirect (x, e, es) -> - CallIndirect (x, relabel f n e, List.map (relabel f n) es) - | GetLocal x -> GetLocal x - | SetLocal (x, e) -> SetLocal (x, relabel f n e) - | TeeLocal (x, e) -> TeeLocal (x, relabel f n e) - | GetGlobal x -> GetGlobal x - | SetGlobal (x, e) -> SetGlobal (x, relabel f n e) - | Load (memop, e) -> Load (memop, relabel f n e) - | Store (memop, e1, e2) -> Store (memop, relabel f n e1, relabel f n e2) - | LoadExtend (extop, e) -> LoadExtend (extop, relabel f n e) - | StoreWrap (wrapop, e1, e2) -> - StoreWrap (wrapop, relabel f n e1, relabel f n e2) - | Const c -> Const c - | Unary (unop, e) -> Unary (unop, relabel f n e) - | Binary (binop, e1, e2) -> Binary (binop, relabel f n e1, relabel f n e2) - | Test (testop, e) -> Test (testop, relabel f n e) - | Compare (relop, e1, e2) -> Compare (relop, relabel f n e1, relabel f n e2) - | Convert (cvtop, e) -> Convert (cvtop, relabel f n e) - | Host (hostop, es) -> Host (hostop, List.map (relabel f n) es) - -and relabel_var f n x = f n x.it @@ x.at - -let label e = relabel (fun n i -> if i < n then i else i + 1) 0 e -let return e = relabel (fun n i -> if i = -1 then n else i) (-1) e - - -(* Expressions *) - -let rec expr e = expr' e.at e.it @@ e.at -and expr' at = function - | Ast.I32_const n -> Const (Int32 n.it @@ n.at) - | Ast.I64_const n -> Const (Int64 n.it @@ n.at) - | Ast.F32_const n -> Const (Float32 n.it @@ n.at) - | Ast.F64_const n -> Const (Float64 n.it @@ n.at) - - | Ast.Nop -> Nop - | Ast.Unreachable -> Unreachable - | Ast.Drop e -> Drop (expr e) - | Ast.Block [] -> Nop - | Ast.Block es -> - let es', e = Lib.List.split_last es in Block (List.map expr es', expr e) - | Ast.Loop es -> Block ([], Loop (block es) @@ at) - | Ast.Br (x, eo) -> Break (x, Lib.Option.map expr eo) - | Ast.Br_if (x, eo, e) -> BreakIf (x, Lib.Option.map expr eo, expr e) - | Ast.Br_table (xs, x, eo, e) -> - BreakTable (xs, x, Lib.Option.map expr eo, expr e) - | Ast.Return eo -> Break (-1 @@ at, Lib.Option.map expr eo) - | Ast.If (e, es1, es2) -> If (expr e, seq es1, seq es2) - | Ast.Select (e1, e2, e3) -> Select (expr e1, expr e2, expr e3) - - | Ast.Call (x, es) -> Call (x, List.map expr es) - | Ast.Call_indirect (x, e, es) -> CallIndirect (x, expr e, List.map expr es) - - | Ast.Get_local x -> GetLocal x - | Ast.Set_local (x, e) -> SetLocal (x, expr e) - | Ast.Tee_local (x, e) -> TeeLocal (x, expr e) - | Ast.Get_global x -> GetGlobal x - | Ast.Set_global (x, e) -> SetGlobal (x, expr e) - - | Ast.I32_load (offset, align, e) -> - Load ({ty = Int32Type; offset; align}, expr e) - | Ast.I64_load (offset, align, e) -> - Load ({ty = Int64Type; offset; align}, expr e) - | Ast.F32_load (offset, align, e) -> - Load ({ty = Float32Type; offset; align}, expr e) - | Ast.F64_load (offset, align, e) -> - Load ({ty = Float64Type; offset; align}, expr e) - | Ast.I32_store (offset, align, e1, e2) -> - Store ({ty = Int32Type; offset; align}, expr e1, expr e2) - | Ast.I64_store (offset, align, e1, e2) -> - Store ({ty = Int64Type; offset; align}, expr e1, expr e2) - | Ast.F32_store (offset, align, e1, e2) -> - Store ({ty = Float32Type; offset; align}, expr e1, expr e2) - | Ast.F64_store (offset, align, e1, e2) -> - Store ({ty = Float64Type; offset; align}, expr e1, expr e2) - | Ast.I32_load8_s (offset, align, e) -> - LoadExtend - ({memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = SX}, expr e) - | Ast.I32_load8_u (offset, align, e) -> - LoadExtend - ({memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = ZX}, expr e) - | Ast.I32_load16_s (offset, align, e) -> - LoadExtend - ({memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = SX}, expr e) - | Ast.I32_load16_u (offset, align, e) -> - LoadExtend - ({memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = ZX}, expr e) - | Ast.I64_load8_s (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = SX}, expr e) - | Ast.I64_load8_u (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = ZX}, expr e) - | Ast.I64_load16_s (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = SX}, expr e) - | Ast.I64_load16_u (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = ZX}, expr e) - | Ast.I64_load32_s (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = SX}, expr e) - | Ast.I64_load32_u (offset, align, e) -> - LoadExtend - ({memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = ZX}, expr e) - | Ast.I32_store8 (offset, align, e1, e2) -> - StoreWrap - ({memop = {ty = Int32Type; offset; align}; sz = Mem8}, expr e1, expr e2) - | Ast.I32_store16 (offset, align, e1, e2) -> - StoreWrap - ({memop = {ty = Int32Type; offset; align}; sz = Mem16}, expr e1, expr e2) - | Ast.I64_store8 (offset, align, e1, e2) -> - StoreWrap - ({memop = {ty = Int64Type; offset; align}; sz = Mem8}, expr e1, expr e2) - | Ast.I64_store16 (offset, align, e1, e2) -> - StoreWrap - ({memop = {ty = Int64Type; offset; align}; sz = Mem16}, expr e1, expr e2) - | Ast.I64_store32 (offset, align, e1, e2) -> - StoreWrap - ({memop = {ty = Int64Type; offset; align}; sz = Mem32}, expr e1, expr e2) - - | Ast.I32_clz e -> Unary (Int32 I32Op.Clz, expr e) - | Ast.I32_ctz e -> Unary (Int32 I32Op.Ctz, expr e) - | Ast.I32_popcnt e -> Unary (Int32 I32Op.Popcnt, expr e) - | Ast.I64_clz e -> Unary (Int64 I64Op.Clz, expr e) - | Ast.I64_ctz e -> Unary (Int64 I64Op.Ctz, expr e) - | Ast.I64_popcnt e -> Unary (Int64 I64Op.Popcnt, expr e) - | Ast.F32_neg e -> Unary (Float32 F32Op.Neg, expr e) - | Ast.F32_abs e -> Unary (Float32 F32Op.Abs, expr e) - | Ast.F32_sqrt e -> Unary (Float32 F32Op.Sqrt, expr e) - | Ast.F32_ceil e -> Unary (Float32 F32Op.Ceil, expr e) - | Ast.F32_floor e -> Unary (Float32 F32Op.Floor, expr e) - | Ast.F32_trunc e -> Unary (Float32 F32Op.Trunc, expr e) - | Ast.F32_nearest e -> Unary (Float32 F32Op.Nearest, expr e) - | Ast.F64_neg e -> Unary (Float64 F64Op.Neg, expr e) - | Ast.F64_abs e -> Unary (Float64 F64Op.Abs, expr e) - | Ast.F64_sqrt e -> Unary (Float64 F64Op.Sqrt, expr e) - | Ast.F64_ceil e -> Unary (Float64 F64Op.Ceil, expr e) - | Ast.F64_floor e -> Unary (Float64 F64Op.Floor, expr e) - | Ast.F64_trunc e -> Unary (Float64 F64Op.Trunc, expr e) - | Ast.F64_nearest e -> Unary (Float64 F64Op.Nearest, expr e) - - | Ast.I32_add (e1, e2) -> Binary (Int32 I32Op.Add, expr e1, expr e2) - | Ast.I32_sub (e1, e2) -> Binary (Int32 I32Op.Sub, expr e1, expr e2) - | Ast.I32_mul (e1, e2) -> Binary (Int32 I32Op.Mul, expr e1, expr e2) - | Ast.I32_div_s (e1, e2) -> Binary (Int32 I32Op.DivS, expr e1, expr e2) - | Ast.I32_div_u (e1, e2) -> Binary (Int32 I32Op.DivU, expr e1, expr e2) - | Ast.I32_rem_s (e1, e2) -> Binary (Int32 I32Op.RemS, expr e1, expr e2) - | Ast.I32_rem_u (e1, e2) -> Binary (Int32 I32Op.RemU, expr e1, expr e2) - | Ast.I32_and (e1, e2) -> Binary (Int32 I32Op.And, expr e1, expr e2) - | Ast.I32_or (e1, e2) -> Binary (Int32 I32Op.Or, expr e1, expr e2) - | Ast.I32_xor (e1, e2) -> Binary (Int32 I32Op.Xor, expr e1, expr e2) - | Ast.I32_shl (e1, e2) -> Binary (Int32 I32Op.Shl, expr e1, expr e2) - | Ast.I32_shr_s (e1, e2) -> Binary (Int32 I32Op.ShrS, expr e1, expr e2) - | Ast.I32_shr_u (e1, e2) -> Binary (Int32 I32Op.ShrU, expr e1, expr e2) - | Ast.I32_rotl (e1, e2) -> Binary (Int32 I32Op.Rotl, expr e1, expr e2) - | Ast.I32_rotr (e1, e2) -> Binary (Int32 I32Op.Rotr, expr e1, expr e2) - | Ast.I64_add (e1, e2) -> Binary (Int64 I64Op.Add, expr e1, expr e2) - | Ast.I64_sub (e1, e2) -> Binary (Int64 I64Op.Sub, expr e1, expr e2) - | Ast.I64_mul (e1, e2) -> Binary (Int64 I64Op.Mul, expr e1, expr e2) - | Ast.I64_div_s (e1, e2) -> Binary (Int64 I64Op.DivS, expr e1, expr e2) - | Ast.I64_div_u (e1, e2) -> Binary (Int64 I64Op.DivU, expr e1, expr e2) - | Ast.I64_rem_s (e1, e2) -> Binary (Int64 I64Op.RemS, expr e1, expr e2) - | Ast.I64_rem_u (e1, e2) -> Binary (Int64 I64Op.RemU, expr e1, expr e2) - | Ast.I64_and (e1, e2) -> Binary (Int64 I64Op.And, expr e1, expr e2) - | Ast.I64_or (e1, e2) -> Binary (Int64 I64Op.Or, expr e1, expr e2) - | Ast.I64_xor (e1, e2) -> Binary (Int64 I64Op.Xor, expr e1, expr e2) - | Ast.I64_shl (e1, e2) -> Binary (Int64 I64Op.Shl, expr e1, expr e2) - | Ast.I64_shr_s (e1, e2) -> Binary (Int64 I64Op.ShrS, expr e1, expr e2) - | Ast.I64_shr_u (e1, e2) -> Binary (Int64 I64Op.ShrU, expr e1, expr e2) - | Ast.I64_rotl (e1, e2) -> Binary (Int64 I64Op.Rotl, expr e1, expr e2) - | Ast.I64_rotr (e1, e2) -> Binary (Int64 I64Op.Rotr, expr e1, expr e2) - | Ast.F32_add (e1, e2) -> Binary (Float32 F32Op.Add, expr e1, expr e2) - | Ast.F32_sub (e1, e2) -> Binary (Float32 F32Op.Sub, expr e1, expr e2) - | Ast.F32_mul (e1, e2) -> Binary (Float32 F32Op.Mul, expr e1, expr e2) - | Ast.F32_div (e1, e2) -> Binary (Float32 F32Op.Div, expr e1, expr e2) - | Ast.F32_min (e1, e2) -> Binary (Float32 F32Op.Min, expr e1, expr e2) - | Ast.F32_max (e1, e2) -> Binary (Float32 F32Op.Max, expr e1, expr e2) - | Ast.F32_copysign (e1, e2) -> - Binary (Float32 F32Op.CopySign, expr e1, expr e2) - | Ast.F64_add (e1, e2) -> Binary (Float64 F64Op.Add, expr e1, expr e2) - | Ast.F64_sub (e1, e2) -> Binary (Float64 F64Op.Sub, expr e1, expr e2) - | Ast.F64_mul (e1, e2) -> Binary (Float64 F64Op.Mul, expr e1, expr e2) - | Ast.F64_div (e1, e2) -> Binary (Float64 F64Op.Div, expr e1, expr e2) - | Ast.F64_min (e1, e2) -> Binary (Float64 F64Op.Min, expr e1, expr e2) - | Ast.F64_max (e1, e2) -> Binary (Float64 F64Op.Max, expr e1, expr e2) - | Ast.F64_copysign (e1, e2) -> - Binary (Float64 F64Op.CopySign, expr e1, expr e2) - - | Ast.I32_eqz e -> Test (Int32 I32Op.Eqz, expr e) - | Ast.I64_eqz e -> Test (Int64 I64Op.Eqz, expr e) - - | Ast.I32_eq (e1, e2) -> Compare (Int32 I32Op.Eq, expr e1, expr e2) - | Ast.I32_ne (e1, e2) -> Compare (Int32 I32Op.Ne, expr e1, expr e2) - | Ast.I32_lt_s (e1, e2) -> Compare (Int32 I32Op.LtS, expr e1, expr e2) - | Ast.I32_lt_u (e1, e2) -> Compare (Int32 I32Op.LtU, expr e1, expr e2) - | Ast.I32_le_s (e1, e2) -> Compare (Int32 I32Op.LeS, expr e1, expr e2) - | Ast.I32_le_u (e1, e2) -> Compare (Int32 I32Op.LeU, expr e1, expr e2) - | Ast.I32_gt_s (e1, e2) -> Compare (Int32 I32Op.GtS, expr e1, expr e2) - | Ast.I32_gt_u (e1, e2) -> Compare (Int32 I32Op.GtU, expr e1, expr e2) - | Ast.I32_ge_s (e1, e2) -> Compare (Int32 I32Op.GeS, expr e1, expr e2) - | Ast.I32_ge_u (e1, e2) -> Compare (Int32 I32Op.GeU, expr e1, expr e2) - | Ast.I64_eq (e1, e2) -> Compare (Int64 I64Op.Eq, expr e1, expr e2) - | Ast.I64_ne (e1, e2) -> Compare (Int64 I64Op.Ne, expr e1, expr e2) - | Ast.I64_lt_s (e1, e2) -> Compare (Int64 I64Op.LtS, expr e1, expr e2) - | Ast.I64_lt_u (e1, e2) -> Compare (Int64 I64Op.LtU, expr e1, expr e2) - | Ast.I64_le_s (e1, e2) -> Compare (Int64 I64Op.LeS, expr e1, expr e2) - | Ast.I64_le_u (e1, e2) -> Compare (Int64 I64Op.LeU, expr e1, expr e2) - | Ast.I64_gt_s (e1, e2) -> Compare (Int64 I64Op.GtS, expr e1, expr e2) - | Ast.I64_gt_u (e1, e2) -> Compare (Int64 I64Op.GtU, expr e1, expr e2) - | Ast.I64_ge_s (e1, e2) -> Compare (Int64 I64Op.GeS, expr e1, expr e2) - | Ast.I64_ge_u (e1, e2) -> Compare (Int64 I64Op.GeU, expr e1, expr e2) - | Ast.F32_eq (e1, e2) -> Compare (Float32 F32Op.Eq, expr e1, expr e2) - | Ast.F32_ne (e1, e2) -> Compare (Float32 F32Op.Ne, expr e1, expr e2) - | Ast.F32_lt (e1, e2) -> Compare (Float32 F32Op.Lt, expr e1, expr e2) - | Ast.F32_le (e1, e2) -> Compare (Float32 F32Op.Le, expr e1, expr e2) - | Ast.F32_gt (e1, e2) -> Compare (Float32 F32Op.Gt, expr e1, expr e2) - | Ast.F32_ge (e1, e2) -> Compare (Float32 F32Op.Ge, expr e1, expr e2) - | Ast.F64_eq (e1, e2) -> Compare (Float64 F64Op.Eq, expr e1, expr e2) - | Ast.F64_ne (e1, e2) -> Compare (Float64 F64Op.Ne, expr e1, expr e2) - | Ast.F64_lt (e1, e2) -> Compare (Float64 F64Op.Lt, expr e1, expr e2) - | Ast.F64_le (e1, e2) -> Compare (Float64 F64Op.Le, expr e1, expr e2) - | Ast.F64_gt (e1, e2) -> Compare (Float64 F64Op.Gt, expr e1, expr e2) - | Ast.F64_ge (e1, e2) -> Compare (Float64 F64Op.Ge, expr e1, expr e2) - - | Ast.I32_wrap_i64 e -> Convert (Int32 I32Op.WrapInt64, expr e) - | Ast.I32_trunc_s_f32 e -> Convert (Int32 I32Op.TruncSFloat32, expr e) - | Ast.I32_trunc_u_f32 e -> Convert (Int32 I32Op.TruncUFloat32, expr e) - | Ast.I32_trunc_s_f64 e -> Convert (Int32 I32Op.TruncSFloat64, expr e) - | Ast.I32_trunc_u_f64 e -> Convert (Int32 I32Op.TruncUFloat64, expr e) - | Ast.I64_extend_s_i32 e -> Convert (Int64 I64Op.ExtendSInt32, expr e) - | Ast.I64_extend_u_i32 e -> Convert (Int64 I64Op.ExtendUInt32, expr e) - | Ast.I64_trunc_s_f32 e -> Convert (Int64 I64Op.TruncSFloat32, expr e) - | Ast.I64_trunc_u_f32 e -> Convert (Int64 I64Op.TruncUFloat32, expr e) - | Ast.I64_trunc_s_f64 e -> Convert (Int64 I64Op.TruncSFloat64, expr e) - | Ast.I64_trunc_u_f64 e -> Convert (Int64 I64Op.TruncUFloat64, expr e) - | Ast.F32_convert_s_i32 e -> Convert (Float32 F32Op.ConvertSInt32, expr e) - | Ast.F32_convert_u_i32 e -> Convert (Float32 F32Op.ConvertUInt32, expr e) - | Ast.F32_convert_s_i64 e -> Convert (Float32 F32Op.ConvertSInt64, expr e) - | Ast.F32_convert_u_i64 e -> Convert (Float32 F32Op.ConvertUInt64, expr e) - | Ast.F32_demote_f64 e -> Convert (Float32 F32Op.DemoteFloat64, expr e) - | Ast.F64_convert_s_i32 e -> Convert (Float64 F64Op.ConvertSInt32, expr e) - | Ast.F64_convert_u_i32 e -> Convert (Float64 F64Op.ConvertUInt32, expr e) - | Ast.F64_convert_s_i64 e -> Convert (Float64 F64Op.ConvertSInt64, expr e) - | Ast.F64_convert_u_i64 e -> Convert (Float64 F64Op.ConvertUInt64, expr e) - | Ast.F64_promote_f32 e -> Convert (Float64 F64Op.PromoteFloat32, expr e) - | Ast.I32_reinterpret_f32 e -> Convert (Int32 I32Op.ReinterpretFloat, expr e) - | Ast.I64_reinterpret_f64 e -> Convert (Int64 I64Op.ReinterpretFloat, expr e) - | Ast.F32_reinterpret_i32 e -> Convert (Float32 F32Op.ReinterpretInt, expr e) - | Ast.F64_reinterpret_i64 e -> Convert (Float64 F64Op.ReinterpretInt, expr e) - - | Ast.Current_memory -> Host (CurrentMemory, []) - | Ast.Grow_memory e -> Host (GrowMemory, [expr e]) - -and seq = function - | [] -> Nop @@ Source.no_region - | es -> - let es', e = Lib.List.split_last es in - Block (List.map expr es', expr e) @@@ List.map Source.at es - -and block = function - | [] -> Nop @@ Source.no_region - | es -> - let es', e = Lib.List.split_last es in - Block (List.map label (List.map expr es'), label (expr e)) - @@@ List.map Source.at es - - -(* Functions and Modules *) - -let rec global g = global' g.it @@ g.at -and global' = function - | {Ast.gtype = t; value = e} -> {gtype = t; value = expr e} - -let rec func f = func' f.it @@ f.at -and func' = function - | {Ast.body = es; ftype; locals} -> {body = return (seq es); ftype; locals} - -let rec segment seg = segment' seg.it @@ seg.at -and segment' = function - | {index; Ast.offset = e; init} -> {index; offset = expr e; init} - -let rec module_ m = module' m.it @@ m.at -and module' = function - | {Ast.funcs = fs; start; globals = gs; memories; types; imports; exports; tables; elems; data} -> - let globals = List.map global gs in - let elems = List.map segment elems in - let funcs = List.map func fs in - let data = List.map segment data in - {funcs; start; globals; memories; types; imports; exports; tables; elems; data} - -let desugar = module_ diff --git a/ml-proto/spec/desugar.mli b/ml-proto/spec/desugar.mli deleted file mode 100644 index b3abdf41e9..0000000000 --- a/ml-proto/spec/desugar.mli +++ /dev/null @@ -1 +0,0 @@ -val desugar : Ast.module_ -> Kernel.module_ diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 9e718dd831..5287343140 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -1,7 +1,7 @@ open Values open Types -open Kernel open Instance +open Ast open Source @@ -13,302 +13,325 @@ module Crash = Error.Make () exception Link = Link.Error exception Trap = Trap.Error -exception Crash = Crash.Error - (* A crash is an execution failure that cannot legally happen in checked - * code; it indicates an internal inconsistency in the spec. *) +exception Crash = Crash.Error (* failure that cannot happen in valid code *) let memory_error at = function | Memory.Bounds -> Trap.error at "out of bounds memory access" | Memory.SizeOverflow -> Trap.error at "memory size overflow" + | Memory.SizeLimit -> Trap.error at "memory size limit reached" + | Memory.Type -> Crash.error at "type mismatch at memory access" | exn -> raise exn -let type_error at v t = - Crash.error at - ("type error, expected " ^ Types.string_of_value_type t ^ - ", got " ^ Types.string_of_value_type (type_of v)) - -let arithmetic_error at at_op1 at_op2 = function - | Arithmetic.TypeError (i, v, t) -> - type_error (if i = 1 then at_op1 else at_op2) v t - | Numerics.IntegerOverflow -> +let numeric_error at = function + | Eval_numeric.TypeError (i, v, t) -> + Crash.error at + ("type error, expected " ^ Types.string_of_value_type t ^ " as operand " ^ + string_of_int i ^ ", got " ^ Types.string_of_value_type (type_of v)) + | Numeric_error.IntegerOverflow -> Trap.error at "integer overflow" - | Numerics.IntegerDivideByZero -> + | Numeric_error.IntegerDivideByZero -> Trap.error at "integer divide by zero" - | Numerics.InvalidConversionToInteger -> + | Numeric_error.InvalidConversionToInteger -> Trap.error at "invalid conversion to integer" | exn -> raise exn (* Configurations *) -type label = value option -> exn +(* + * Execution is defined by how instructions transform a program configuration. + * Configurations are given in the form of evaluation contexts that are split up + * into four parts: + * + * es : instr list - the remaining instructions (in the current block) + * vs : value stack - the operand stack (local to the current block) + * bs : block stack - the control stack (local to the current function call) + * cs : call stack - the activation stack + * + * This organisation allows to easy indexing into the control stack, in + * particular. An instruction may modify each of the three stacks. + * + * Blocks and call frames do not only hold information relevant to the + * respective block or function (such as locals and result arity), they also + * save the previous instruction list, value stack, and for calls, block stack, + * which are restored once the block or function terminates. A real interpreter + * would typically use one contiguous stack for each part and rather save + * only stack heights on block or function entry. Saving the entire stacks + * instead avoids computing stack heights in the semantics. + *) + +type 'a stack = 'a list -type config = -{ - instance : instance; - locals : value ref list; - labels : label list -} +type eval_context = instr list * value stack * block stack * call stack +and call_context = instr list * value stack * block stack +and block_context = instr list * value stack -let empty_config inst = {instance = inst; locals = []; labels = []} +and block = {target : instr list; bcontext : block_context} +and call = {instance : instance; locals : value list; arity : int; + ccontext : call_context} + +let resource_limit = 1000 let lookup category list x = - try List.nth list x.it with Failure _ -> - Crash.error x.at ("undefined " ^ category ^ " " ^ string_of_int x.it) + try Lib.List32.nth list x.it with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) + +let update category list x y = + try Lib.List32.take x.it list @ y :: Lib.List32.drop (Int32.add x.it 1l) list + with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) -let type_ inst x = lookup "type" inst.module_.it.types x -let func c x = lookup "function" c.instance.funcs x -let table c x = lookup "table" c.instance.tables x -let memory c x = lookup "memory" c.instance.memories x -let global c x = lookup "global" c.instance.globals x let local c x = lookup "local" c.locals x -let label c x = lookup "label" c.labels x +let update_local c x v = {c with locals = update "local" c.locals x v} -let elem c x i t at = - match Table.load (table c x) i t with - | Some item -> item +let type_ inst x = lookup "type" inst.module_.it.types x +let func inst x = lookup "function" inst.Instance.funcs x +let table inst x = lookup "table" inst.Instance.tables x +let memory inst x = lookup "memory" inst.Instance.memories x +let global inst x = lookup "global" inst.Instance.globals x + +let elem inst x i t at = + match Table.load (table inst x) i t with + | Some j -> j | None -> Trap.error at ("uninitialized element " ^ Int32.to_string i) | exception Table.Bounds -> Trap.error at ("undefined element " ^ Int32.to_string i) -let func_elem c x i at = - match elem c x i AnyFuncType at with +let func_elem inst x i at = + match elem inst x i AnyFuncType at with | Func f -> f | _ -> Crash.error at ("type mismatch for element " ^ Int32.to_string i) -let func_type_of t at = +let func_type_of t = match t with | AstFunc (inst, f) -> lookup "type" (!inst).module_.it.types f.it.ftype - | HostFunc _ -> Link.error at "invalid use of host function" - -module MakeLabel () = -struct - exception Label of value option - let label v = Label v -end - + | HostFunc (t, _) -> t -(* Type conversions *) +let take n (vs : 'a stack) at = + try Lib.List.take n vs with Failure _ -> + Crash.error at "stack underflow" -let some v at = - match v with - | Some v -> v - | None -> Crash.error at "type error, expression produced no value" - -let int32 v at = - match some v at with - | Int32 i -> i - | v -> type_error at v Int32Type +let drop n (vs : 'a stack) at = + try Lib.List.drop n vs with Failure _ -> + Crash.error at "stack underflow" -let int64 v at = - match some v at with - | Int64 i -> i - | v -> type_error at v Int64Type +let take32 n (vs : 'a stack) at = + try Lib.List32.take n vs with Failure _ -> + Crash.error at "stack underflow" -let address32 v at = - Int64.logand (Int64.of_int32 (int32 v at)) 0xffffffffL +let drop32 n (vs : 'a stack) at = + try Lib.List32.drop n vs with Failure _ -> + Crash.error at "stack underflow" (* Evaluation *) (* * Conventions: - * c : config - * e : expr - * eo : expr option + * e : instr * v : value - * vo : value option + * es : instr list + * vs : value stack + * bs : block stack + * cs : call stack *) -let rec eval_expr (c : config) (e : expr) : value option = - match e.it with - | Nop -> - None +let i32 v at = + match v with + | I32 i -> i + | _ -> Crash.error at "type error: i32 value expected" + +let eval_call (clos : closure) (es, vs, bs, cs : eval_context) at = + if List.length cs = resource_limit then Trap.error at "call stack exhausted"; + let FuncType (ins, out) = func_type_of clos in + let n = List.length ins in + let m = List.length out in + let args, vs' = take n vs at, drop n vs at in + match clos with + | AstFunc (inst, f) -> + let locals = List.rev args @ List.map default_value f.it.locals in + [Block f.it.body @@ f.at], [], [], + {instance = !inst; locals; arity = m; ccontext = es, vs', bs} :: cs + + | HostFunc (t, f) -> + try es, List.rev (f (List.rev args)) @ vs', bs, cs + with Crash (_, msg) -> Crash.error at msg - | Unreachable -> +let eval_instr (e : instr) (es, vs, bs, cs : eval_context) : eval_context = + match e.it, vs, bs, cs with + | Unreachable, _, _, _ -> Trap.error e.at "unreachable executed" - | Drop e -> - ignore (eval_expr c e); - None + | Nop, _, _, _ -> + es, vs, bs, cs + + | Drop, v :: vs', _, _ -> + es, vs', bs, cs + + | Block es', vs, bs, _ -> + es', [], {target = []; bcontext = es, vs} :: bs, cs + + | Loop es', vs, bs, _ -> + es', [], {target = [e]; bcontext = es, vs} :: bs, cs + + | Br (n, x), vs, bs, _ -> + let bs' = drop32 x.it bs e.at in + let b = List.hd (take 1 bs' e.at) in + let es', vs' = b.bcontext in + b.target @ es', take n vs e.at @ vs', drop 1 bs' e.at, cs + + | BrIf (n, x), I32 0l :: vs', _, _ -> + es, drop n vs' e.at, bs, cs + + | BrIf (n, x), I32 i :: vs', _, _ -> + (Br (n, x) @@ e.at) :: es, vs', bs, cs + + | BrTable (n, xs, x), I32 i :: vs', _, _ + when I32.ge_u i (Lib.List32.length xs) -> + (Br (n, x) @@ e.at) :: es, vs', bs, cs + + | BrTable (n, xs, x), I32 i :: vs', _, _ -> + (Br (n, Lib.List32.nth xs i) @@ e.at) :: es, vs', bs, cs + + | Return, vs, _, c :: cs' -> + let es', vs', bs' = c.ccontext in + es', take c.arity vs e.at @ vs', bs', cs' + + | If (es1, es2), I32 0l :: vs', _, _ -> + (Block es2 @@ e.at) :: es, vs', bs, cs + + | If (es1, es2), I32 i :: vs', _, _ -> + (Block es1 @@ e.at) :: es, vs', bs, cs - | Block (es, e) -> - let module L = MakeLabel () in - let c' = {c with labels = L.label :: c.labels} in + | Select, I32 0l :: v2 :: v1 :: vs', _, _ -> + es, v2 :: vs', bs, cs + + | Select, I32 i :: v2 :: v1 :: vs', _, _ -> + es, v1 :: vs', bs, cs + + | Call x, _, _, c :: _ -> + eval_call (func c.instance x) (es, vs, bs, cs) e.at + + | CallIndirect x, I32 i :: vs, _, c :: _ -> + let clos = func_elem c.instance (0l @@ e.at) i e.at in + if type_ c.instance x <> func_type_of clos then + Trap.error e.at "indirect call signature mismatch"; + eval_call clos (es, vs, bs, cs) e.at + + | GetLocal x, vs, _, c :: _ -> + es, (local c x) :: vs, bs, cs + + | SetLocal x, v :: vs', _, c :: cs' -> + es, vs', bs, update_local c x v :: cs' + + | TeeLocal x, v :: vs', _, c :: cs' -> + es, v :: vs', bs, update_local c x v :: cs' + + | GetGlobal x, vs, _, c :: _ -> + es, !(global c.instance x) :: vs, bs, cs + + | SetGlobal x, v :: vs', _, c :: _ -> + global c.instance x := v; + es, vs', bs, cs + + | Load {offset; ty; sz; _}, I32 i :: vs', _, c :: _ -> + let mem = memory c.instance (0l @@ e.at) in + let addr = I64_convert.extend_u_i32 i in + let v = + try + match sz with + | None -> Memory.load mem addr offset ty + | Some (sz, ext) -> Memory.load_packed sz ext mem addr offset ty + with exn -> memory_error e.at exn + in es, v :: vs', bs, cs + + | Store {offset; sz; _}, v :: I32 i :: vs', _, c :: _ -> + let mem = memory c.instance (0l @@ e.at) in + let addr = I64_convert.extend_u_i32 i in (try - List.iter (fun eI -> ignore (eval_expr c' eI)) es; - eval_expr c' e - with L.Label vo -> vo) - - | Loop e1 -> - let module L = MakeLabel () in - let c' = {c with labels = L.label :: c.labels} in - (try eval_expr c' e1 with L.Label _ -> eval_expr c e) - - | Break (x, eo) -> - raise (label c x (eval_expr_opt c eo)) - - | BreakIf (x, eo, e) -> - let v = eval_expr_opt c eo in - let i = int32 (eval_expr c e) e.at in - if i <> 0l then raise (label c x v) else None - - | BreakTable (xs, x, eo, e) -> - let v = eval_expr_opt c eo in - let i = int32 (eval_expr c e) e.at in - if I32.lt_u i (Int32.of_int (List.length xs)) - then raise (label c (List.nth xs (Int32.to_int i)) v) - else raise (label c x v) - - | If (e1, e2, e3) -> - let i = int32 (eval_expr c e1) e1.at in - eval_expr c (if i <> 0l then e2 else e3) - - | Select (e1, e2, e3) -> - let v1 = some (eval_expr c e1) e1.at in - let v2 = some (eval_expr c e2) e2.at in - let cond = int32 (eval_expr c e3) e3.at in - Some (if cond <> 0l then v1 else v2) - - | Call (x, es) -> - let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in - eval_func (func c x) vs e.at - - | CallIndirect (x, e1, es) -> - let i = int32 (eval_expr c e1) e1.at in - let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in - let f = func_elem c (0 @@ e.at) i e1.at in - if type_ c.instance x <> func_type_of f e1.at then - Trap.error e1.at "indirect call signature mismatch"; - eval_func f vs e.at - - | GetLocal x -> - Some !(local c x) - - | SetLocal (x, e1) -> - let v1 = some (eval_expr c e1) e1.at in - local c x := v1; - None - - | TeeLocal (x, e1) -> - let v1 = some (eval_expr c e1) e1.at in - local c x := v1; - Some v1 - - | GetGlobal x -> - Some !(global c x) - - | SetGlobal (x, e1) -> - let v1 = some (eval_expr c e1) e1.at in - global c x := v1; - None - - | Load ({ty; offset; align = _}, e1) -> - let mem = memory c (0 @@ e.at) in - let v1 = address32 (eval_expr c e1) e1.at in - (try Some (Memory.load mem v1 offset ty) - with exn -> memory_error e.at exn) - - | Store ({ty = _; offset; align = _}, e1, e2) -> - let mem = memory c (0 @@ e.at) in - let v1 = address32 (eval_expr c e1) e1.at in - let v2 = some (eval_expr c e2) e2.at in - (try Memory.store mem v1 offset v2 - with exn -> memory_error e.at exn); - None - - | LoadExtend ({memop = {ty; offset; align = _}; sz; ext}, e1) -> - let mem = memory c (0 @@ e.at) in - let v1 = address32 (eval_expr c e1) e1.at in - (try Some (Memory.load_extend mem v1 offset sz ext ty) - with exn -> memory_error e.at exn) - - | StoreWrap ({memop = {ty; offset; align = _}; sz}, e1, e2) -> - let mem = memory c (0 @@ e.at) in - let v1 = address32 (eval_expr c e1) e1.at in - let v2 = some (eval_expr c e2) e2.at in - (try Memory.store_wrap mem v1 offset sz v2 - with exn -> memory_error e.at exn); - None - - | Const v -> - Some v.it - - | Unary (unop, e1) -> - let v1 = some (eval_expr c e1) e1.at in - (try Some (Arithmetic.eval_unop unop v1) - with exn -> arithmetic_error e.at e1.at e1.at exn) - - | Binary (binop, e1, e2) -> - let v1 = some (eval_expr c e1) e1.at in - let v2 = some (eval_expr c e2) e2.at in - (try Some (Arithmetic.eval_binop binop v1 v2) - with exn -> arithmetic_error e.at e1.at e2.at exn) - - | Test (testop, e1) -> - let v1 = some (eval_expr c e1) e1.at in - (try Some (Int32 (if Arithmetic.eval_testop testop v1 then 1l else 0l)) - with exn -> arithmetic_error e.at e1.at e1.at exn) - - | Compare (relop, e1, e2) -> - let v1 = some (eval_expr c e1) e1.at in - let v2 = some (eval_expr c e2) e2.at in - (try Some (Int32 (if Arithmetic.eval_relop relop v1 v2 then 1l else 0l)) - with exn -> arithmetic_error e.at e1.at e2.at exn) - - | Convert (cvtop, e1) -> - let v1 = some (eval_expr c e1) e1.at in - (try Some (Arithmetic.eval_cvtop cvtop v1) - with exn -> arithmetic_error e.at e1.at e1.at exn) - - | Host (hostop, es) -> - let vs = List.map (eval_expr c) es in - eval_hostop c hostop vs e.at - -and eval_expr_opt c = function - | Some e -> eval_expr c e - | None -> None - -and eval_func func vs at = - match func with - | AstFunc (inst, f) -> - if List.length vs <> List.length (func_type_of func at).ins then - Crash.error at "function called with wrong number of arguments"; - let args = List.map ref vs in - let vars = List.map (fun t -> ref (default_value t)) f.it.locals in - let locals = args @ vars in - eval_expr {(empty_config !inst) with locals} f.it.body + match sz with + | None -> Memory.store mem addr offset v + | Some sz -> Memory.store_packed sz mem addr offset v + with exn -> memory_error e.at exn); + es, vs', bs, cs + + | Const v, vs, _, _ -> + es, v.it :: vs, bs, cs + + | Unary unop, v :: vs', _, _ -> + (try es, Eval_numeric.eval_unop unop v :: vs', bs, cs + with exn -> numeric_error e.at exn) - | HostFunc f -> - try f vs with Crash (_, msg) -> Crash.error at msg + | Binary binop, v2 :: v1 :: vs', _, _ -> + (try es, Eval_numeric.eval_binop binop v1 v2 :: vs', bs, cs + with exn -> numeric_error e.at exn) + | Test testop, v :: vs', _, _ -> + (try es, value_of_bool (Eval_numeric.eval_testop testop v) :: vs', bs, cs + with exn -> numeric_error e.at exn) -(* Host operators *) + | Compare relop, v2 :: v1 :: vs', _, _ -> + (try es, value_of_bool (Eval_numeric.eval_relop relop v1 v2) :: vs', bs, cs + with exn -> numeric_error e.at exn) -and eval_hostop c hostop vs at = - match hostop, vs with - | CurrentMemory, [] -> - let mem = memory c (0 @@ at) in - let size = Memory.size mem in - Some (Int32 size) + | Convert cvtop, v :: vs', _, _ -> + (try es, Eval_numeric.eval_cvtop cvtop v :: vs', bs, cs + with exn -> numeric_error e.at exn) - | GrowMemory, [v] -> - let mem = memory c (0 @@ at) in - let delta = int32 v at in + | CurrentMemory, vs, _, c :: _ -> + let mem = memory c.instance (0l @@ e.at) in + es, I32 (Memory.size mem) :: vs, bs, cs + + | GrowMemory, I32 delta :: vs', _, c :: _ -> + let mem = memory c.instance (0l @@ e.at) in let old_size = Memory.size mem in let result = try Memory.grow mem delta; old_size with Memory.SizeOverflow | Memory.SizeLimit | Memory.OutOfMemory -> -1l - in Some (Int32 result) + in es, I32 result :: vs', bs, cs + + | _ -> + Crash.error e.at "missing or ill-typed operand on stack" + +let rec eval_seq (es, vs, bs, cs : eval_context) = + match es, bs, cs with + | e :: es', _, _ -> + eval_seq (eval_instr e (es', vs, bs, cs)) + + | [], b :: bs', _ -> + let es', vs' = b.bcontext in + eval_seq (es', vs @ vs', bs', cs) + + | [], [], c :: cs' -> +(* if List.length vs <> c.arity then + Crash.error no_region "wrong number of values on stack";*) + let es', vs', bs' = c.ccontext in + eval_seq (es', vs @ vs', bs', cs') + + | [], [], [] -> + vs - | _, _ -> - Crash.error at "invalid invocation of host operator" + +(* Functions & Constants *) + +let eval_func (clos : closure) (vs : value list) at : value list = + let FuncType (ins, out) = func_type_of clos in + if List.length vs <> List.length ins then + Crash.error at "wrong number of arguments"; + List.rev (eval_seq (eval_call clos ([], List.rev vs, [], []) at)) + +let eval_const inst const = + let c = {instance = inst; locals = []; arity = 1; ccontext = [], [], []} in + List.hd (eval_seq (const.it, [], [], [c])) + +let const (m : module_) const = + eval_const (instance m) const (* Modules *) -let create_func m f = +let create_closure m f = AstFunc (ref (instance m), f) let create_table tab = @@ -323,30 +346,35 @@ let create_global glob = let {gtype = GlobalType (t, _); _} = glob.it in ref (default_value t) -let init_func c f = - match f with - | AstFunc (inst, _) -> inst := c.instance +let init_closure inst clos = + match clos with + | AstFunc (inst_ref, _) -> inst_ref := inst | _ -> assert false -let check_elem c seg = +let check_elem inst seg = let {init; _} = seg.it in - List.iter (fun x -> ignore (func_type_of (func c x) x.at)) init - -let init_table c seg = + List.iter + (fun x -> + match func inst x with + | AstFunc _ -> () + | HostFunc _ -> Link.error x.at "invalid use of host function" + ) init + +let init_table inst seg = let {index; offset = e; init} = seg.it in - let tab = table c index in - let offset = int32 (eval_expr c e) e.at in - Table.blit tab offset (List.map (fun x -> Some (Func (func c x))) init) + let tab = table inst index in + let offset = i32 (eval_const inst e) e.at in + Table.blit tab offset (List.map (fun x -> Some (Func (func inst x))) init) -let init_memory c seg = +let init_memory inst seg = let {index; offset = e; init} = seg.it in - let mem = memory c index in - let offset = Int64.of_int32 (int32 (eval_expr c e) e.at) in + let mem = memory inst index in + let offset = Int64.of_int32 (i32 (eval_const inst e) e.at) in Memory.blit mem offset init -let init_global c ref glob = +let init_global inst ref glob = let {value = e; _} = glob.it in - ref := some (eval_expr c e) e.at + ref := eval_const inst e let check_limits actual expected at = if I32.lt_u actual.min expected.min then @@ -360,13 +388,10 @@ let check_limits actual expected at = let add_import (ext : extern) (imp : import) (inst : instance) : instance = match ext, imp.it.ikind.it with - | ExternalFunc f, FuncImport x -> - (match f with - | AstFunc _ when func_type_of f x.at <> type_ inst x -> + | ExternalFunc clos, FuncImport x -> + if func_type_of clos <> type_ inst x then Link.error imp.it.ikind.at "type mismatch"; - | _ -> () - ); - {inst with funcs = f :: inst.funcs} + {inst with funcs = clos :: inst.funcs} | ExternalTable tab, TableImport (TableType (lim, _)) -> check_limits (Table.limits tab) lim imp.it.ikind.at; {inst with tables = tab :: inst.tables} @@ -378,14 +403,14 @@ let add_import (ext : extern) (imp : import) (inst : instance) : instance = | _ -> Link.error imp.it.ikind.at "type mismatch" -let add_export c ex map = +let add_export inst ex map = let {name; ekind; item} = ex.it in let ext = match ekind.it with - | FuncExport -> ExternalFunc (func c item) - | TableExport -> ExternalTable (table c item) - | MemoryExport -> ExternalMemory (memory c item) - | GlobalExport -> ExternalGlobal !(global c item) + | FuncExport -> ExternalFunc (func inst item) + | TableExport -> ExternalTable (table inst item) + | MemoryExport -> ExternalMemory (memory inst item) + | GlobalExport -> ExternalGlobal !(global inst item) in ExportMap.add name ext map let init m externals = @@ -394,7 +419,7 @@ let init m externals = exports; elems; data; start } = m.it in assert (List.length externals = List.length imports); (* TODO: better exception? *) - let fs = List.map (create_func m) funcs in + let fs = List.map (create_closure m) funcs in let gs = List.map create_global globals in let inst = List.fold_right2 add_import externals imports @@ -405,18 +430,14 @@ let init m externals = globals = gs; } in - let c = empty_config inst in - List.iter (init_func c) fs; - List.iter (check_elem c) elems; - List.iter (init_table c) elems; - List.iter (init_memory c) data; - List.iter2 (init_global c) gs globals; - Lib.Option.app (fun x -> ignore (eval_func (func c x) [] x.at)) start; - {inst with exports = List.fold_right (add_export c) exports inst.exports} - -let invoke func vs = - (try eval_func func vs no_region + List.iter (init_closure inst) fs; + List.iter (check_elem inst) elems; + List.iter (init_table inst) elems; + List.iter (init_memory inst) data; + List.iter2 (init_global inst) gs globals; + Lib.Option.app (fun x -> ignore (eval_func (func inst x) [] x.at)) start; + {inst with exports = List.fold_right (add_export inst) exports inst.exports} + +let invoke clos vs = + (try eval_func clos vs no_region with Stack_overflow -> Trap.error no_region "call stack exhausted") - -let const m e = - some (eval_expr (empty_config (instance m)) e) e.at diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index 5f85ac72f4..22739d3641 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -5,6 +5,6 @@ exception Link of Source.region * string exception Trap of Source.region * string exception Crash of Source.region * string -val init : Kernel.module_ -> extern list -> instance -val invoke : func -> value list -> value option (* raises Trap *) -val const : Kernel.module_ -> Kernel.expr -> value +val init : Ast.module_ -> extern list -> instance +val invoke : closure -> value list -> value list (* raises Trap *) +val const : Ast.module_ -> Ast.const -> value diff --git a/ml-proto/spec/eval_numeric.ml b/ml-proto/spec/eval_numeric.ml new file mode 100644 index 0000000000..dd40255875 --- /dev/null +++ b/ml-proto/spec/eval_numeric.ml @@ -0,0 +1,197 @@ +open Types +open Values + + +(* Runtime type errors *) + +exception TypeError of int * value * value_type + +let of_arg f n v = + try f v with Value t -> raise (TypeError (n, v, t)) + + +(* Int operators *) + +module IntOp (IXX : Int.S) (Value : ValueType with type t = IXX.t) = +struct + open Ast.IntOp + + let to_value = Value.to_value + let of_value = of_arg Value.of_value + + let unop op = + let f = match op with + | Clz -> IXX.clz + | Ctz -> IXX.ctz + | Popcnt -> IXX.popcnt + in fun v -> to_value (f (of_value 1 v)) + + let binop op = + let f = match op with + | Add -> IXX.add + | Sub -> IXX.sub + | Mul -> IXX.mul + | DivS -> IXX.div_s + | DivU -> IXX.div_u + | RemS -> IXX.rem_s + | RemU -> IXX.rem_u + | And -> IXX.and_ + | Or -> IXX.or_ + | Xor -> IXX.xor + | Shl -> IXX.shl + | ShrU -> IXX.shr_u + | ShrS -> IXX.shr_s + | Rotl -> IXX.rotl + | Rotr -> IXX.rotr + in fun v1 v2 -> to_value (f (of_value 1 v1) (of_value 2 v2)) + + let testop op = + let f = match op with + | Eqz -> IXX.eqz + in fun v -> f (of_value 1 v) + + let relop op = + let f = match op with + | Eq -> IXX.eq + | Ne -> IXX.ne + | LtS -> IXX.lt_s + | LtU -> IXX.lt_u + | LeS -> IXX.le_s + | LeU -> IXX.le_u + | GtS -> IXX.gt_s + | GtU -> IXX.gt_u + | GeS -> IXX.ge_s + | GeU -> IXX.ge_u + in fun v1 v2 -> f (of_value 1 v1) (of_value 2 v2) +end + +module I32Op = IntOp (I32) (Values.I32Value) +module I64Op = IntOp (I64) (Values.I64Value) + + +(* Float operators *) + +module FloatOp (FXX : Float.S) (Value : ValueType with type t = FXX.t) = +struct + open Ast.FloatOp + + let to_value = Value.to_value + let of_value = of_arg Value.of_value + + let unop op = + let f = match op with + | Neg -> FXX.neg + | Abs -> FXX.abs + | Sqrt -> FXX.sqrt + | Ceil -> FXX.ceil + | Floor -> FXX.floor + | Trunc -> FXX.trunc + | Nearest -> FXX.nearest + in fun v -> to_value (f (of_value 1 v)) + + let binop op = + let f = match op with + | Add -> FXX.add + | Sub -> FXX.sub + | Mul -> FXX.mul + | Div -> FXX.div + | Min -> FXX.min + | Max -> FXX.max + | CopySign -> FXX.copysign + in fun v1 v2 -> to_value (f (of_value 1 v1) (of_value 2 v2)) + + let testop op = assert false + + let relop op = + let f = match op with + | Eq -> FXX.eq + | Ne -> FXX.ne + | Lt -> FXX.lt + | Le -> FXX.le + | Gt -> FXX.gt + | Ge -> FXX.ge + in fun v1 v2 -> f (of_value 1 v1) (of_value 2 v2) +end + +module F32Op = FloatOp (F32) (Values.F32Value) +module F64Op = FloatOp (F64) (Values.F64Value) + + +(* Conversion operators *) + +module I32CvtOp = +struct + open Ast.IntOp + + let cvtop op v = + match op with + | WrapI64 -> I32 (I32_convert.wrap_i64 (I64Op.of_value 1 v)) + | TruncSF32 -> I32 (I32_convert.trunc_s_f32 (F32Op.of_value 1 v)) + | TruncUF32 -> I32 (I32_convert.trunc_u_f32 (F32Op.of_value 1 v)) + | TruncSF64 -> I32 (I32_convert.trunc_s_f64 (F64Op.of_value 1 v)) + | TruncUF64 -> I32 (I32_convert.trunc_u_f64 (F64Op.of_value 1 v)) + | ReinterpretFloat -> I32 (I32_convert.reinterpret_f32 (F32Op.of_value 1 v)) + | ExtendSI32 -> raise (TypeError (1, v, I32Type)) + | ExtendUI32 -> raise (TypeError (1, v, I32Type)) +end + +module I64CvtOp = +struct + open Ast.IntOp + + let cvtop op v = + match op with + | ExtendSI32 -> I64 (I64_convert.extend_s_i32 (I32Op.of_value 1 v)) + | ExtendUI32 -> I64 (I64_convert.extend_u_i32 (I32Op.of_value 1 v)) + | TruncSF32 -> I64 (I64_convert.trunc_s_f32 (F32Op.of_value 1 v)) + | TruncUF32 -> I64 (I64_convert.trunc_u_f32 (F32Op.of_value 1 v)) + | TruncSF64 -> I64 (I64_convert.trunc_s_f64 (F64Op.of_value 1 v)) + | TruncUF64 -> I64 (I64_convert.trunc_u_f64 (F64Op.of_value 1 v)) + | ReinterpretFloat -> I64 (I64_convert.reinterpret_f64 (F64Op.of_value 1 v)) + | WrapI64 -> raise (TypeError (1, v, I64Type)) +end + +module F32CvtOp = +struct + open Ast.FloatOp + + let cvtop op v = + match op with + | DemoteF64 -> F32 (F32_convert.demote_f64 (F64Op.of_value 1 v)) + | ConvertSI32 -> F32 (F32_convert.convert_s_i32 (I32Op.of_value 1 v)) + | ConvertUI32 -> F32 (F32_convert.convert_u_i32 (I32Op.of_value 1 v)) + | ConvertSI64 -> F32 (F32_convert.convert_s_i64 (I64Op.of_value 1 v)) + | ConvertUI64 -> F32 (F32_convert.convert_u_i64 (I64Op.of_value 1 v)) + | ReinterpretInt -> F32 (F32_convert.reinterpret_i32 (I32Op.of_value 1 v)) + | PromoteF32 -> raise (TypeError (1, v, F32Type)) +end + +module F64CvtOp = +struct + open Ast.FloatOp + + let cvtop op v = + match op with + | PromoteF32 -> F64 (F64_convert.promote_f32 (F32Op.of_value 1 v)) + | ConvertSI32 -> F64 (F64_convert.convert_s_i32 (I32Op.of_value 1 v)) + | ConvertUI32 -> F64 (F64_convert.convert_u_i32 (I32Op.of_value 1 v)) + | ConvertSI64 -> F64 (F64_convert.convert_s_i64 (I64Op.of_value 1 v)) + | ConvertUI64 -> F64 (F64_convert.convert_u_i64 (I64Op.of_value 1 v)) + | ReinterpretInt -> F64 (F64_convert.reinterpret_i64 (I64Op.of_value 1 v)) + | DemoteF64 -> raise (TypeError (1, v, F64Type)) +end + + +(* Dispatch *) + +let op i32 i64 f32 f64 = function + | I32 x -> i32 x + | I64 x -> i64 x + | F32 x -> f32 x + | F64 x -> f64 x + +let eval_unop = op I32Op.unop I64Op.unop F32Op.unop F64Op.unop +let eval_binop = op I32Op.binop I64Op.binop F32Op.binop F64Op.binop +let eval_testop = op I32Op.testop I64Op.testop F32Op.testop F64Op.testop +let eval_relop = op I32Op.relop I64Op.relop F32Op.relop F64Op.relop +let eval_cvtop = op I32CvtOp.cvtop I64CvtOp.cvtop F32CvtOp.cvtop F64CvtOp.cvtop diff --git a/ml-proto/spec/eval_numeric.mli b/ml-proto/spec/eval_numeric.mli new file mode 100644 index 0000000000..7435b3c6bb --- /dev/null +++ b/ml-proto/spec/eval_numeric.mli @@ -0,0 +1,9 @@ +open Values + +exception TypeError of int * value * Types.value_type + +val eval_unop : Ast.unop -> value -> value +val eval_binop : Ast.binop -> value -> value -> value +val eval_testop : Ast.testop -> value -> bool +val eval_relop : Ast.relop -> value -> value -> bool +val eval_cvtop : Ast.cvtop -> value -> value diff --git a/ml-proto/spec/f32.ml b/ml-proto/spec/f32.ml index 4a8733d142..ae54cf7265 100644 --- a/ml-proto/spec/f32.ml +++ b/ml-proto/spec/f32.ml @@ -3,11 +3,12 @@ * using 64-bit floats, as described in the paper * "When is double rounding innocuous?" by Samuel A. Figueroa. *) -include Float.Make(struct - include Int32 - let pos_nan = 0x7fc00000l - let neg_nan = 0xffc00000l - let bare_nan = 0x7f800000l - let print_nan_significand_digits a = - Printf.sprintf "%lx" (abs (Int32.logxor bare_nan a)) - end) +include Float.Make + (struct + include Int32 + let pos_nan = 0x7fc00000l + let neg_nan = 0xffc00000l + let bare_nan = 0x7f800000l + let print_nan_significand_digits a = + Printf.sprintf "%lx" (abs (Int32.logxor bare_nan a)) + end) diff --git a/ml-proto/spec/f64.ml b/ml-proto/spec/f64.ml index 6aadfc2d63..7ca281d4ac 100644 --- a/ml-proto/spec/f64.ml +++ b/ml-proto/spec/f64.ml @@ -1,8 +1,9 @@ -include Float.Make(struct - include Int64 - let pos_nan = 0x7ff8000000000000L - let neg_nan = 0xfff8000000000000L - let bare_nan = 0x7ff0000000000000L - let print_nan_significand_digits a = - Printf.sprintf "%Lx" (abs (Int64.logxor bare_nan a)) - end) +include Float.Make + (struct + include Int64 + let pos_nan = 0x7ff8000000000000L + let neg_nan = 0xfff8000000000000L + let bare_nan = 0x7ff0000000000000L + let print_nan_significand_digits a = + Printf.sprintf "%Lx" (abs (Int64.logxor bare_nan a)) + end) diff --git a/ml-proto/spec/float.ml b/ml-proto/spec/float.ml index 9a7864c8b9..a2f2f007a6 100644 --- a/ml-proto/spec/float.ml +++ b/ml-proto/spec/float.ml @@ -1,4 +1,4 @@ -module type RepresentationType = +module type RepType = sig type t @@ -56,7 +56,7 @@ sig val zero : t end -module Make(Rep : RepresentationType) : S with type bits = Rep.t = +module Make (Rep : RepType) : S with type bits = Rep.t = struct type t = Rep.t type bits = Rep.t @@ -71,15 +71,13 @@ struct let of_bits x = x let to_bits x = x - let is_nan x = - let xf = Rep.float_of_bits x in xf <> xf + let is_nan x = let xf = Rep.float_of_bits x in xf <> xf (* * When the result of an arithmetic operation is NaN, the most significant * bit of the significand field is set. *) - let canonicalize_nan x = - Rep.logor x Rep.pos_nan + let canonicalize_nan x = Rep.logor x Rep.pos_nan (* * When the result of a binary operation is NaN, the resulting NaN is computed @@ -93,10 +91,10 @@ struct * when neither is NaN, we can nondeterministically pick whether to return * pos_nan or neg_nan. *) - let nan = (if is_nan x then x else - if is_nan y then y else - Rep.pos_nan) in - canonicalize_nan nan + let nan = + if is_nan x then x else + if is_nan y then y else Rep.pos_nan + in canonicalize_nan nan (* * When the result of a unary operation is NaN, the resulting NaN is computed @@ -109,8 +107,7 @@ struct * operand is not NaN, we can nondeterministically pick whether to return * pos_nan or neg_nan. *) - let nan = (if is_nan x then x else - Rep.pos_nan) in + let nan = if is_nan x then x else Rep.pos_nan in canonicalize_nan nan let binary x op y = @@ -153,8 +150,10 @@ struct let d = Pervasives.floor xf in let um = abs_float (xf -. u) in let dm = abs_float (xf -. d) in - let u_or_d = um < dm || - (um = dm && let h = u /. 2. in Pervasives.floor h = h) in + let u_or_d = + um < dm || + um = dm && let h = u /. 2. in Pervasives.floor h = h + in let f = if u_or_d then u else d in let result = of_float f in if is_nan result then determine_unary_nan result else result @@ -165,8 +164,8 @@ struct (* min -0 0 is -0 *) if xf = yf then Rep.logor x y else if xf < yf then x else - if xf > yf then y else - determine_binary_nan x y + if xf > yf then y else + determine_binary_nan x y let max x y = let xf = to_float x in @@ -174,8 +173,8 @@ struct (* max -0 0 is 0 *) if xf = yf then Rep.logand x y else if xf > yf then x else - if xf < yf then y else - determine_binary_nan x y + if xf < yf then y else + determine_binary_nan x y (* abs, neg, and copysign are purely bitwise operations, even on NaN values *) let abs x = @@ -187,35 +186,33 @@ struct let copysign x y = Rep.logor (abs x) (Rep.logand y Rep.min_int) - let eq x y = (to_float x) = (to_float y) - let ne x y = (to_float x) <> (to_float y) - let lt x y = (to_float x) < (to_float y) - let gt x y = (to_float x) > (to_float y) - let le x y = (to_float x) <= (to_float y) - let ge x y = (to_float x) >= (to_float y) + let eq x y = (to_float x = to_float y) + let ne x y = (to_float x <> to_float y) + let lt x y = (to_float x < to_float y) + let gt x y = (to_float x > to_float y) + let le x y = (to_float x <= to_float y) + let ge x y = (to_float x >= to_float y) let of_signless_string x len = - if x <> "nan" && - (len > 6) && - (String.sub x 0 6) = "nan:0x" then - (let s = Rep.of_string (String.sub x 4 (len - 4)) in - if s = Rep.zero then - raise (Failure "nan payload must not be zero") - else if Rep.logand s bare_nan <> Rep.zero then - raise (Failure "nan payload must not overlap with exponent bits") - else if s < Rep.zero then - raise (Failure "nan payload must not overlap with sign bit") - else - Rep.logor s bare_nan) + if x <> "nan" && len > 6 && String.sub x 0 6 = "nan:0x" then + let s = Rep.of_string (String.sub x 4 (len - 4)) in + if s = Rep.zero then + raise (Failure "nan payload must not be zero") + else if Rep.logand s bare_nan <> Rep.zero then + raise (Failure "nan payload must not overlap with exponent bits") + else if s < Rep.zero then + raise (Failure "nan payload must not overlap with sign bit") + else + Rep.logor s bare_nan else (* TODO: OCaml's float_of_string is insufficient *) of_float (float_of_string x) let of_string x = let len = String.length x in - if len > 0 && (String.get x 0) = '-' then + if len > 0 && x.[0] = '-' then neg (of_signless_string (String.sub x 1 (len - 1)) (len - 1)) - else if len > 0 && (String.get x 0) = '+' then + else if len > 0 && x.[0] = '+' then of_signless_string (String.sub x 1 (len - 1)) (len - 1) else of_signless_string x len @@ -224,9 +221,9 @@ struct (if x < Rep.zero then "-" else "") ^ let a = abs x in if is_nan a then - ("nan:0x" ^ Rep.print_nan_significand_digits a) + "nan:0x" ^ Rep.print_nan_significand_digits a else - (* TODO: OCaml's string_of_float is insufficient *) + (* TODO: use sprintf "%h" once we have upgraded to OCaml 4.03 *) string_of_float (to_float a) end diff --git a/ml-proto/spec/i32.ml b/ml-proto/spec/i32.ml index 9d408fd8e3..3b90885fc1 100644 --- a/ml-proto/spec/i32.ml +++ b/ml-proto/spec/i32.ml @@ -1,6 +1,7 @@ (* WebAssembly-compatible i32 implementation *) -include Int.Make(struct - include Int32 - let bitwidth = 32 - end) +include Int.Make + (struct + include Int32 + let bitwidth = 32 + end) diff --git a/ml-proto/spec/i32_convert.ml b/ml-proto/spec/i32_convert.ml index 4ea0c0f772..dd6cbb14f8 100644 --- a/ml-proto/spec/i32_convert.ml +++ b/ml-proto/spec/i32_convert.ml @@ -4,41 +4,41 @@ let wrap_i64 x = Int64.to_int32 x let trunc_s_f32 x = if F32.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F32.to_float x in if xf >= -.(Int32.to_float Int32.min_int) || xf < (Int32.to_float Int32.min_int) then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int32.of_float xf let trunc_u_f32 x = if F32.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F32.to_float x in if xf >= -.(Int32.to_float Int32.min_int) *. 2. || xf <= -1. then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int64.to_int32 (Int64.of_float xf) let trunc_s_f64 x = if F64.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F64.to_float x in if xf >= -.(Int32.to_float Int32.min_int) || xf < (Int32.to_float Int32.min_int) then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int32.of_float xf let trunc_u_f64 x = if F64.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F64.to_float x in if xf >= -.(Int32.to_float Int32.min_int) *. 2. || xf <= -1. then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int64.to_int32 (Int64.of_float xf) diff --git a/ml-proto/spec/i64.ml b/ml-proto/spec/i64.ml index 4597a54346..d44a3e1b08 100644 --- a/ml-proto/spec/i64.ml +++ b/ml-proto/spec/i64.ml @@ -1,6 +1,7 @@ (* WebAssembly-compatible i64 implementation *) -include Int.Make(struct - include Int64 - let bitwidth = 64 - end) +include Int.Make + (struct + include Int64 + let bitwidth = 64 + end) diff --git a/ml-proto/spec/i64_convert.ml b/ml-proto/spec/i64_convert.ml index 0cf32f8c36..a97a8a8a7c 100644 --- a/ml-proto/spec/i64_convert.ml +++ b/ml-proto/spec/i64_convert.ml @@ -6,21 +6,21 @@ let extend_u_i32 x = Int64.logand (Int64.of_int32 x) 0x00000000ffffffffL let trunc_s_f32 x = if F32.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F32.to_float x in if xf >= -.(Int64.to_float Int64.min_int) || xf < (Int64.to_float Int64.min_int) then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int64.of_float xf let trunc_u_f32 x = if F32.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F32.to_float x in if xf >= -.(Int64.to_float Int64.min_int) *. 2. || xf <= -1. then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else if xf >= -.(Int64.to_float Int64.min_int) then Int64.logxor (Int64.of_float (xf -. 9223372036854775808.)) Int64.min_int else @@ -28,21 +28,21 @@ let trunc_u_f32 x = let trunc_s_f64 x = if F64.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F64.to_float x in if xf >= -.(Int64.to_float Int64.min_int) || xf < (Int64.to_float Int64.min_int) then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Int64.of_float xf let trunc_u_f64 x = if F64.ne x x then - raise Numerics.InvalidConversionToInteger + raise Numeric_error.InvalidConversionToInteger else let xf = F64.to_float x in if xf >= -.(Int64.to_float Int64.min_int) *. 2. || xf <= -1. then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else if xf >= -.(Int64.to_float Int64.min_int) then Int64.logxor (Int64.of_float (xf -. 9223372036854775808.)) Int64.min_int else diff --git a/ml-proto/spec/instance.ml b/ml-proto/spec/instance.ml index 3404c7177d..c41fb03598 100644 --- a/ml-proto/spec/instance.ml +++ b/ml-proto/spec/instance.ml @@ -4,27 +4,27 @@ module ExportMap = Map.Make(String) type global = value ref -type func = - | AstFunc of instance ref * Kernel.func - | HostFunc of (value list -> value option) +type closure = + | AstFunc of instance ref * Ast.func + | HostFunc of Types.func_type * (value list -> value list) and extern = - | ExternalFunc of func + | ExternalFunc of closure | ExternalTable of Table.t | ExternalMemory of Memory.t | ExternalGlobal of value and instance = { - module_ : Kernel.module_; - funcs : func list; + module_ : Ast.module_; + funcs : closure list; tables : Table.t list; memories : Memory.t list; globals : global list; exports : extern ExportMap.t; } -exception Func of func +exception Func of closure let instance m = { module_ = m; funcs = []; tables = []; memories = []; globals = []; diff --git a/ml-proto/spec/int.ml b/ml-proto/spec/int.ml index f53a18cc88..7dbb596dd4 100644 --- a/ml-proto/spec/int.ml +++ b/ml-proto/spec/int.ml @@ -1,25 +1,27 @@ -(* WebAssembly-compatible int operations implementation *) - -module type RepresentationType = +module type RepType = sig type t - val add : t -> t -> t - val min_int : t + val zero : t val one : t val minus_one : t + val min_int : t + val neg : t -> t - val shift_left : t -> int -> t - val shift_right : t -> int -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t (* raises Division_by_zero *) + val rem : t -> t -> t (* raises Division_by_zero *) + val logand : t -> t -> t val lognot : t -> t val logor : t -> t -> t val logxor : t -> t -> t - val sub : t -> t -> t - val div : t -> t -> t - val mul : t -> t -> t - val rem : t -> t -> t + val shift_left : t -> int -> t + val shift_right : t -> int -> t val shift_right_logical : t -> int -> t + val of_int : int -> t val to_int : t -> int val to_string : t -> string @@ -40,10 +42,10 @@ sig val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t - val div_s : t -> t -> t - val div_u : t -> t -> t - val rem_s : t -> t -> t - val rem_u : t -> t -> t + val div_s : t -> t -> t (* raises IntegerDivideByZero, IntegerOverflow *) + val div_u : t -> t -> t (* raises IntegerDivideByZero *) + val rem_s : t -> t -> t (* raises IntegerDivideByZero *) + val rem_u : t -> t -> t (* raises IntegerDivideByZero *) val and_ : t -> t -> t val or_ : t -> t -> t val xor : t -> t -> t @@ -72,7 +74,7 @@ sig val to_string : t -> string end -module Make(Rep : RepresentationType) : S with type bits = Rep.t and type t = Rep.t = +module Make (Rep : RepType) : S with type bits = Rep.t and type t = Rep.t = struct (* * Unsigned comparison in terms of signed comparison. @@ -86,15 +88,15 @@ struct * "Unsigned Short Division from Signed Division". *) let divrem_u n d = - if d = Rep.zero then raise Numerics.IntegerDivideByZero else - let t = Rep.shift_right d (Rep.bitwidth - 1) in - let n' = Rep.logand n (Rep.lognot t) in - let q = Rep.shift_left (Rep.div (Rep.shift_right_logical n' 1) d) 1 in - let r = Rep.sub n (Rep.mul q d) in - if cmp_u r (<) d then - q, r - else - Rep.add q Rep.one, Rep.sub r d + if d = Rep.zero then raise Numeric_error.IntegerDivideByZero else + let t = Rep.shift_right d (Rep.bitwidth - 1) in + let n' = Rep.logand n (Rep.lognot t) in + let q = Rep.shift_left (Rep.div (Rep.shift_right_logical n' 1) d) 1 in + let r = Rep.sub n (Rep.mul q d) in + if cmp_u r (<) d then + q, r + else + Rep.add q Rep.one, Rep.sub r d type t = Rep.t type bits = Rep.t @@ -103,8 +105,6 @@ struct let to_bits x = x let zero = Rep.zero - let ten = Rep.of_int 10 - let max_upper, max_lower = divrem_u Rep.minus_one ten (* add, sub, and mul are sign-agnostic and do not trap on overflow. *) let add = Rep.add @@ -114,20 +114,20 @@ struct (* result is truncated toward zero *) let div_s x y = if y = Rep.zero then - raise Numerics.IntegerDivideByZero + raise Numeric_error.IntegerDivideByZero else if x = Rep.min_int && y = Rep.minus_one then - raise Numerics.IntegerOverflow + raise Numeric_error.IntegerOverflow else Rep.div x y - (* result is floored (which is the same as truncating, for unsigned values) *) + (* result is floored (which is the same as truncating for unsigned values) *) let div_u x y = let q, r = divrem_u x y in q (* result has the sign of the dividend *) let rem_s x y = if y = Rep.zero then - raise Numerics.IntegerDivideByZero + raise Numeric_error.IntegerDivideByZero else Rep.rem x y @@ -165,37 +165,34 @@ struct (* clz is defined for all values, including all-zeros. *) let clz x = - Rep.of_int - (let rec loop acc n = - if n = Rep.zero then - Rep.bitwidth - else if and_ n (Rep.shift_left Rep.one (Rep.bitwidth - 1)) <> Rep.zero then - acc - else - loop (1 + acc) (Rep.shift_left n 1) - in loop 0 x) + let rec loop acc n = + if n = Rep.zero then + Rep.bitwidth + else if and_ n (Rep.shift_left Rep.one (Rep.bitwidth - 1)) <> Rep.zero then + acc + else + loop (1 + acc) (Rep.shift_left n 1) + in Rep.of_int (loop 0 x) (* ctz is defined for all values, including all-zeros. *) let ctz x = - Rep.of_int - (let rec loop acc n = - if n = Rep.zero then - Rep.bitwidth - else if and_ n Rep.one = Rep.one then - acc - else - loop (1 + acc) (Rep.shift_right_logical n 1) - in loop 0 x) + let rec loop acc n = + if n = Rep.zero then + Rep.bitwidth + else if and_ n Rep.one = Rep.one then + acc + else + loop (1 + acc) (Rep.shift_right_logical n 1) + in Rep.of_int (loop 0 x) let popcnt x = - Rep.of_int - (let rec loop acc i n = - if n = Rep.zero then - acc - else - let acc' = if and_ n Rep.one = Rep.one then acc + 1 else acc in - loop acc' (i - 1) (Rep.shift_right_logical n 1) - in loop 0 Rep.bitwidth x) + let rec loop acc i n = + if n = Rep.zero then + acc + else + let acc' = if and_ n Rep.one = Rep.one then acc + 1 else acc in + loop acc' (i - 1) (Rep.shift_right_logical n 1) + in Rep.of_int (loop 0 Rep.bitwidth x) let eqz x = x = Rep.zero @@ -210,52 +207,51 @@ struct let ge_s x y = x >= y let ge_u x y = cmp_u x (>=) y - let parse_hexdigit = function + let of_int = Rep.of_int + let to_string = Rep.to_string + + (* String conversion that allows leading signs and unsigned values *) + + let require b = if not b then failwith "of_string" + + let dec_digit = function + | '0' .. '9' as c -> Char.code c - Char.code '0' + | _ -> failwith "of_string" + + let hex_digit = function | '0' .. '9' as c -> Char.code c - Char.code '0' | 'a' .. 'f' as c -> 0xa + Char.code c - Char.code 'a' | 'A' .. 'F' as c -> 0xa + Char.code c - Char.code 'A' | _ -> failwith "of_string" - let parse_decdigit c = - if '0' > c || '9' < c then failwith "of_string"; - Rep.of_int (int_of_char c - Char.code '0') - - let require b = if not b then failwith "of_string" + let ten = Rep.of_int 10 + let max_upper, max_lower = divrem_u Rep.minus_one ten - (* This implementation allows leading signs and unsigned values *) - let of_string x = + let of_string s = let open Rep in - let len = String.length x in + let len = String.length s in let rec parse_hex i num = - if i = len then num - else begin - require (le_u num (shr_u minus_one (of_int 4))); - parse_hex (i + 1) (logor (shift_left num 4) (of_int (parse_hexdigit x.[i]))) - end + if i = len then num else + let digit = of_int (hex_digit s.[i]) in + require (le_u num (shr_u minus_one (of_int 4))); + parse_hex (i + 1) (logor (shift_left num 4) digit) in let rec parse_dec i num = - if i = len then num - else begin - let new_digit = parse_decdigit x.[i] in - require (le_u num max_upper && (num <> max_upper || le_u new_digit max_lower)); - parse_dec (i + 1) (add (mul num ten) new_digit) - end + if i = len then num else + let digit = of_int (dec_digit s.[i]) in + require (lt_u num max_upper || num = max_upper && le_u digit max_lower); + parse_dec (i + 1) (add (mul num ten) digit) in let parse_int i = - if i + 3 <= len && x.[i] = '0' && x.[i + 1] = 'x' then - parse_hex (i + 2) zero - else - parse_dec i zero + if i + 2 <= len && s.[i] = '0' && s.[i + 1] = 'x' + then parse_hex (i + 2) zero + else parse_dec i zero in - match x.[0] with - | '+' -> parse_int 1 - | '-' -> - let y = (parse_int 1) in - require (ge_s (sub y one) minus_one); - neg y - | _ -> parse_int 0 - - let to_string = Rep.to_string - - let of_int = Rep.of_int + match s.[0] with + | '+' -> parse_int 1 + | '-' -> + let n = parse_int 1 in + require (ge_s (sub n one) minus_one); + neg n + | _ -> parse_int 0 end diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml deleted file mode 100644 index accca26cc7..0000000000 --- a/ml-proto/spec/kernel.ml +++ /dev/null @@ -1,190 +0,0 @@ -(* - * Throughout the implementation we use consistent naming conventions for - * syntactic elements, associated with the types defined here and in a few - * other places: - * - * x : var - * v : value - * e : expr - * f : func - * m : module_ - * - * t : value_type - * s : func_type - * c : context / config - * - * These conventions mostly follow standard practice in language semantics. - *) - - -open Types -open Values - - -(* Operators *) - -module IntOp = -struct - type unop = Clz | Ctz | Popcnt - type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU - | And | Or | Xor | Shl | ShrS | ShrU | Rotl | Rotr - type testop = Eqz - type relop = Eq | Ne | LtS | LtU | LeS | LeU | GtS | GtU | GeS | GeU - type cvtop = ExtendSInt32 | ExtendUInt32 | WrapInt64 - | TruncSFloat32 | TruncUFloat32 | TruncSFloat64 | TruncUFloat64 - | ReinterpretFloat -end - -module FloatOp = -struct - type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt - type binop = Add | Sub | Mul | Div | Min | Max | CopySign - type testop - type relop = Eq | Ne | Lt | Le | Gt | Ge - type cvtop = ConvertSInt32 | ConvertUInt32 | ConvertSInt64 | ConvertUInt64 - | PromoteFloat32 | DemoteFloat64 - | ReinterpretInt -end - -module I32Op = IntOp -module I64Op = IntOp -module F32Op = FloatOp -module F64Op = FloatOp - -type unop = (I32Op.unop, I64Op.unop, F32Op.unop, F64Op.unop) op -type binop = (I32Op.binop, I64Op.binop, F32Op.binop, F64Op.binop) op -type testop = (I32Op.testop, I64Op.testop, F32Op.testop, F64Op.testop) op -type relop = (I32Op.relop, I64Op.relop, F32Op.relop, F64Op.relop) op -type cvtop = (I32Op.cvtop, I64Op.cvtop, F32Op.cvtop, F64Op.cvtop) op - -type memop = {ty : value_type; offset : Memory.offset; align : int} -type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} -type wrapop = {memop : memop; sz : Memory.mem_size} -type hostop = - | CurrentMemory (* inquire current size of linear memory *) - | GrowMemory (* grow linear memory *) - - -(* Expressions *) - -type var = int Source.phrase -type literal = value Source.phrase - -type expr = expr' Source.phrase -and expr' = - | Nop (* do nothing *) - | Unreachable (* trap *) - | Drop of expr (* forget a value *) - | Block of expr list * expr (* execute in sequence *) - | Loop of expr (* loop header *) - | Break of var * expr option (* break to n-th surrounding label *) - | BreakIf of var * expr option * expr (* conditional break *) - | BreakTable of var list * var * expr option * expr (* indexed break *) - | If of expr * expr * expr (* conditional *) - | Select of expr * expr * expr (* branchless conditional *) - | Call of var * expr list (* call function *) - | CallIndirect of var * expr * expr list (* call function through table *) - | GetLocal of var (* read local variable *) - | SetLocal of var * expr (* write local variable *) - | TeeLocal of var * expr (* write local variable and keep value *) - | GetGlobal of var (* read global variable *) - | SetGlobal of var * expr (* write global variable *) - | Load of memop * expr (* read memory at address *) - | Store of memop * expr * expr (* write memory at address *) - | LoadExtend of extop * expr (* read memory at address and extend *) - | StoreWrap of wrapop * expr * expr (* wrap and write to memory at address *) - | Const of literal (* constant *) - | Unary of unop * expr (* unary arithmetic operator *) - | Binary of binop * expr * expr (* binary arithmetic operator *) - | Test of testop * expr (* arithmetic test *) - | Compare of relop * expr * expr (* arithmetic comparison *) - | Convert of cvtop * expr (* conversion *) - | Host of hostop * expr list (* host interaction *) - - -(* Globals and Functions *) - -type global = global' Source.phrase -and global' = -{ - gtype : global_type; - value : expr; -} - -type func = func' Source.phrase -and func' = -{ - ftype : var; - locals : value_type list; - body : expr; -} - - -(* Tables & Memories *) - -type table = table' Source.phrase -and table' = -{ - ttype : table_type; -} - -type memory = memory' Source.phrase -and memory' = -{ - mtype : memory_type; -} - -type 'data segment = 'data segment' Source.phrase -and 'data segment' = -{ - index : var; - offset : expr; - init : 'data; -} - -type table_segment = var list segment -type memory_segment = string segment - - -(* Modules *) - -type export_kind = export_kind' Source.phrase -and export_kind' = FuncExport | TableExport | MemoryExport | GlobalExport - -type export = export' Source.phrase -and export' = -{ - name : string; - ekind : export_kind; - item : var; -} - -type import_kind = import_kind' Source.phrase -and import_kind' = - | FuncImport of var - | TableImport of table_type - | MemoryImport of memory_type - | GlobalImport of global_type - -type import = import' Source.phrase -and import' = -{ - module_name : string; - item_name : string; - ikind : import_kind; -} - -type module_ = module_' Source.phrase -and module_' = -{ - types : Types.func_type list; - globals : global list; - tables : table list; - memories : memory list; - funcs : func list; - start : var option; - elems : table_segment list; - data : memory_segment list; - imports : import list; - exports : export list; -} diff --git a/ml-proto/spec/memory.ml b/ml-proto/spec/memory.ml index 45ea4e1b00..2e952d85e5 100644 --- a/ml-proto/spec/memory.ml +++ b/ml-proto/spec/memory.ml @@ -119,18 +119,18 @@ let storen mem n ea v = let load mem a o t = let ea = effective_address a o in match t with - | Int32Type -> Int32 (Int64.to_int32 (loadn mem 4 ea)) - | Int64Type -> Int64 (loadn mem 8 ea) - | Float32Type -> Float32 (F32.of_bits (Int64.to_int32 (loadn mem 4 ea))) - | Float64Type -> Float64 (F64.of_bits (loadn mem 8 ea)) + | I32Type -> I32 (Int64.to_int32 (loadn mem 4 ea)) + | I64Type -> I64 (loadn mem 8 ea) + | F32Type -> F32 (F32.of_bits (Int64.to_int32 (loadn mem 4 ea))) + | F64Type -> F64 (F64.of_bits (loadn mem 8 ea)) let store mem a o v = let ea = effective_address a o in match v with - | Int32 x -> storen mem 4 ea (Int64.of_int32 x) - | Int64 x -> storen mem 8 ea x - | Float32 x -> storen mem 4 ea (Int64.of_int32 (F32.to_bits x)) - | Float64 x -> storen mem 8 ea (F64.to_bits x) + | I32 x -> storen mem 4 ea (Int64.of_int32 x) + | I64 x -> storen mem 8 ea x + | F32 x -> storen mem 4 ea (Int64.of_int32 (F32.to_bits x)) + | F64 x -> storen mem 8 ea (F64.to_bits x) let loadn_sx mem n ea = assert (n > 0 && n <= 8); @@ -138,29 +138,29 @@ let loadn_sx mem n ea = let shift = 64 - (8 * n) in Int64.shift_right (Int64.shift_left v shift) shift -let load_extend mem a o sz ext t = +let load_packed sz ext mem a o t = let ea = effective_address a o in match sz, ext, t with - | Mem8, ZX, Int32Type -> Int32 (Int64.to_int32 (loadn mem 1 ea)) - | Mem8, SX, Int32Type -> Int32 (Int64.to_int32 (loadn_sx mem 1 ea)) - | Mem8, ZX, Int64Type -> Int64 (loadn mem 1 ea) - | Mem8, SX, Int64Type -> Int64 (loadn_sx mem 1 ea) - | Mem16, ZX, Int32Type -> Int32 (Int64.to_int32 (loadn mem 2 ea)) - | Mem16, SX, Int32Type -> Int32 (Int64.to_int32 (loadn_sx mem 2 ea)) - | Mem16, ZX, Int64Type -> Int64 (loadn mem 2 ea) - | Mem16, SX, Int64Type -> Int64 (loadn_sx mem 2 ea) - | Mem32, ZX, Int64Type -> Int64 (loadn mem 4 ea) - | Mem32, SX, Int64Type -> Int64 (loadn_sx mem 4 ea) + | Mem8, ZX, I32Type -> I32 (Int64.to_int32 (loadn mem 1 ea)) + | Mem8, SX, I32Type -> I32 (Int64.to_int32 (loadn_sx mem 1 ea)) + | Mem8, ZX, I64Type -> I64 (loadn mem 1 ea) + | Mem8, SX, I64Type -> I64 (loadn_sx mem 1 ea) + | Mem16, ZX, I32Type -> I32 (Int64.to_int32 (loadn mem 2 ea)) + | Mem16, SX, I32Type -> I32 (Int64.to_int32 (loadn_sx mem 2 ea)) + | Mem16, ZX, I64Type -> I64 (loadn mem 2 ea) + | Mem16, SX, I64Type -> I64 (loadn_sx mem 2 ea) + | Mem32, ZX, I64Type -> I64 (loadn mem 4 ea) + | Mem32, SX, I64Type -> I64 (loadn_sx mem 4 ea) | _ -> raise Type -let store_wrap mem a o sz v = +let store_packed sz mem a o v = let ea = effective_address a o in match sz, v with - | Mem8, Int32 x -> storen mem 1 ea (Int64.of_int32 x) - | Mem8, Int64 x -> storen mem 1 ea x - | Mem16, Int32 x -> storen mem 2 ea (Int64.of_int32 x) - | Mem16, Int64 x -> storen mem 2 ea x - | Mem32, Int64 x -> storen mem 4 ea x + | Mem8, I32 x -> storen mem 1 ea (Int64.of_int32 x) + | Mem8, I64 x -> storen mem 1 ea x + | Mem16, I32 x -> storen mem 2 ea (Int64.of_int32 x) + | Mem16, I64 x -> storen mem 2 ea x + | Mem32, I64 x -> storen mem 4 ea x | _ -> raise Type let blit mem addr data = diff --git a/ml-proto/spec/memory.mli b/ml-proto/spec/memory.mli index 7c446da6c6..c12b367421 100644 --- a/ml-proto/spec/memory.mli +++ b/ml-proto/spec/memory.mli @@ -28,8 +28,8 @@ val grow : memory -> size -> unit (* raise SizeOverflow, OutOfMemory *) val load : memory -> address -> offset -> value_type -> value val store : memory -> address -> offset -> value -> unit -val load_extend : - memory -> address -> offset -> mem_size -> extension -> value_type -> value -val store_wrap : memory -> address -> offset -> mem_size -> value -> unit +val load_packed : + mem_size -> extension -> memory -> address -> offset -> value_type -> value +val store_packed : mem_size -> memory -> address -> offset -> value -> unit val blit : memory -> address -> string -> unit diff --git a/ml-proto/spec/numerics.ml b/ml-proto/spec/numeric_error.ml similarity index 71% rename from ml-proto/spec/numerics.ml rename to ml-proto/spec/numeric_error.ml index 5809362e5d..0dcf7bc19d 100644 --- a/ml-proto/spec/numerics.ml +++ b/ml-proto/spec/numeric_error.ml @@ -1,5 +1,3 @@ -(* WebAssembly numeric utilities *) - exception IntegerOverflow exception IntegerDivideByZero exception InvalidConversionToInteger diff --git a/ml-proto/spec/numerics.mli b/ml-proto/spec/numerics.mli deleted file mode 100644 index 5809362e5d..0000000000 --- a/ml-proto/spec/numerics.mli +++ /dev/null @@ -1,5 +0,0 @@ -(* WebAssembly numeric utilities *) - -exception IntegerOverflow -exception IntegerDivideByZero -exception InvalidConversionToInteger diff --git a/ml-proto/spec/operators.ml b/ml-proto/spec/operators.ml new file mode 100644 index 0000000000..12b9a7d42d --- /dev/null +++ b/ml-proto/spec/operators.ml @@ -0,0 +1,204 @@ +open Source +open Types +open Values +open Memory +open Ast + + +let i32_const n = Const (I32 n.it @@ n.at) +let i64_const n = Const (I64 n.it @@ n.at) +let f32_const n = Const (F32 n.it @@ n.at) +let f64_const n = Const (F64 n.it @@ n.at) + +let unreachable = Unreachable +let nop = Nop +let drop = Drop +let block es = Block es +let loop es = Loop es +let br n x = Br (n, x) +let br_if n x = BrIf (n, x) +let br_table n xs x = BrTable (n, xs, x) +let return = Return +let if_ es1 es2 = If (es1, es2) +let select = Select + +let call x = Call x +let call_indirect x = CallIndirect x + +let get_local x = GetLocal x +let set_local x = SetLocal x +let tee_local x = TeeLocal x +let get_global x = GetGlobal x +let set_global x = SetGlobal x + +let i32_load align offset = Load {ty = I32Type; align; offset; sz = None} +let i64_load align offset = Load {ty = I64Type; align; offset; sz = None} +let f32_load align offset = Load {ty = F32Type; align; offset; sz = None} +let f64_load align offset = Load {ty = F64Type; align; offset; sz = None} +let i32_load8_s align offset = + Load {ty = I32Type; align; offset; sz = Some (Mem8, SX)} +let i32_load8_u align offset = + Load {ty = I32Type; align; offset; sz = Some (Mem8, ZX)} +let i32_load16_s align offset = + Load {ty = I32Type; align; offset; sz = Some (Mem16, SX)} +let i32_load16_u align offset = + Load {ty = I32Type; align; offset; sz = Some (Mem16, ZX)} +let i64_load8_s align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem8, SX)} +let i64_load8_u align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem8, ZX)} +let i64_load16_s align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem16, SX)} +let i64_load16_u align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem16, ZX)} +let i64_load32_s align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem32, SX)} +let i64_load32_u align offset = + Load {ty = I64Type; align; offset; sz = Some (Mem32, ZX)} + +let i32_store align offset = Store {ty = I32Type; align; offset; sz = None} +let i64_store align offset = Store {ty = I64Type; align; offset; sz = None} +let f32_store align offset = Store {ty = F32Type; align; offset; sz = None} +let f64_store align offset = Store {ty = F64Type; align; offset; sz = None} +let i32_store8 align offset = + Store {ty = I32Type; align; offset; sz = Some Mem8} +let i32_store16 align offset = + Store {ty = I32Type; align; offset; sz = Some Mem16} +let i64_store8 align offset = + Store {ty = I64Type; align; offset; sz = Some Mem8} +let i64_store16 align offset = + Store {ty = I64Type; align; offset; sz = Some Mem16} +let i64_store32 align offset = + Store {ty = I64Type; align; offset; sz = Some Mem32} + +let i32_clz = Unary (I32 I32Op.Clz) +let i32_ctz = Unary (I32 I32Op.Ctz) +let i32_popcnt = Unary (I32 I32Op.Popcnt) +let i64_clz = Unary (I64 I64Op.Clz) +let i64_ctz = Unary (I64 I64Op.Ctz) +let i64_popcnt = Unary (I64 I64Op.Popcnt) +let f32_neg = Unary (F32 F32Op.Neg) +let f32_abs = Unary (F32 F32Op.Abs) +let f32_sqrt = Unary (F32 F32Op.Sqrt) +let f32_ceil = Unary (F32 F32Op.Ceil) +let f32_floor = Unary (F32 F32Op.Floor) +let f32_trunc = Unary (F32 F32Op.Trunc) +let f32_nearest = Unary (F32 F32Op.Nearest) +let f64_neg = Unary (F64 F64Op.Neg) +let f64_abs = Unary (F64 F64Op.Abs) +let f64_sqrt = Unary (F64 F64Op.Sqrt) +let f64_ceil = Unary (F64 F64Op.Ceil) +let f64_floor = Unary (F64 F64Op.Floor) +let f64_trunc = Unary (F64 F64Op.Trunc) +let f64_nearest = Unary (F64 F64Op.Nearest) + +let i32_add = Binary (I32 I32Op.Add) +let i32_sub = Binary (I32 I32Op.Sub) +let i32_mul = Binary (I32 I32Op.Mul) +let i32_div_s = Binary (I32 I32Op.DivS) +let i32_div_u = Binary (I32 I32Op.DivU) +let i32_rem_s = Binary (I32 I32Op.RemS) +let i32_rem_u = Binary (I32 I32Op.RemU) +let i32_and = Binary (I32 I32Op.And) +let i32_or = Binary (I32 I32Op.Or) +let i32_xor = Binary (I32 I32Op.Xor) +let i32_shl = Binary (I32 I32Op.Shl) +let i32_shr_s = Binary (I32 I32Op.ShrS) +let i32_shr_u = Binary (I32 I32Op.ShrU) +let i32_rotl = Binary (I32 I32Op.Rotl) +let i32_rotr = Binary (I32 I32Op.Rotr) +let i64_add = Binary (I64 I64Op.Add) +let i64_sub = Binary (I64 I64Op.Sub) +let i64_mul = Binary (I64 I64Op.Mul) +let i64_div_s = Binary (I64 I64Op.DivS) +let i64_div_u = Binary (I64 I64Op.DivU) +let i64_rem_s = Binary (I64 I64Op.RemS) +let i64_rem_u = Binary (I64 I64Op.RemU) +let i64_and = Binary (I64 I64Op.And) +let i64_or = Binary (I64 I64Op.Or) +let i64_xor = Binary (I64 I64Op.Xor) +let i64_shl = Binary (I64 I64Op.Shl) +let i64_shr_s = Binary (I64 I64Op.ShrS) +let i64_shr_u = Binary (I64 I64Op.ShrU) +let i64_rotl = Binary (I64 I64Op.Rotl) +let i64_rotr = Binary (I64 I64Op.Rotr) +let f32_add = Binary (F32 F32Op.Add) +let f32_sub = Binary (F32 F32Op.Sub) +let f32_mul = Binary (F32 F32Op.Mul) +let f32_div = Binary (F32 F32Op.Div) +let f32_min = Binary (F32 F32Op.Min) +let f32_max = Binary (F32 F32Op.Max) +let f32_copysign = Binary (F32 F32Op.CopySign) +let f64_add = Binary (F64 F64Op.Add) +let f64_sub = Binary (F64 F64Op.Sub) +let f64_mul = Binary (F64 F64Op.Mul) +let f64_div = Binary (F64 F64Op.Div) +let f64_min = Binary (F64 F64Op.Min) +let f64_max = Binary (F64 F64Op.Max) +let f64_copysign = Binary (F64 F64Op.CopySign) + +let i32_eqz = Test (I32 I32Op.Eqz) +let i64_eqz = Test (I64 I64Op.Eqz) + +let i32_eq = Compare (I32 I32Op.Eq) +let i32_ne = Compare (I32 I32Op.Ne) +let i32_lt_s = Compare (I32 I32Op.LtS) +let i32_lt_u = Compare (I32 I32Op.LtU) +let i32_le_s = Compare (I32 I32Op.LeS) +let i32_le_u = Compare (I32 I32Op.LeU) +let i32_gt_s = Compare (I32 I32Op.GtS) +let i32_gt_u = Compare (I32 I32Op.GtU) +let i32_ge_s = Compare (I32 I32Op.GeS) +let i32_ge_u = Compare (I32 I32Op.GeU) +let i64_eq = Compare (I64 I64Op.Eq) +let i64_ne = Compare (I64 I64Op.Ne) +let i64_lt_s = Compare (I64 I64Op.LtS) +let i64_lt_u = Compare (I64 I64Op.LtU) +let i64_le_s = Compare (I64 I64Op.LeS) +let i64_le_u = Compare (I64 I64Op.LeU) +let i64_gt_s = Compare (I64 I64Op.GtS) +let i64_gt_u = Compare (I64 I64Op.GtU) +let i64_ge_s = Compare (I64 I64Op.GeS) +let i64_ge_u = Compare (I64 I64Op.GeU) +let f32_eq = Compare (F32 F32Op.Eq) +let f32_ne = Compare (F32 F32Op.Ne) +let f32_lt = Compare (F32 F32Op.Lt) +let f32_le = Compare (F32 F32Op.Le) +let f32_gt = Compare (F32 F32Op.Gt) +let f32_ge = Compare (F32 F32Op.Ge) +let f64_eq = Compare (F64 F64Op.Eq) +let f64_ne = Compare (F64 F64Op.Ne) +let f64_lt = Compare (F64 F64Op.Lt) +let f64_le = Compare (F64 F64Op.Le) +let f64_gt = Compare (F64 F64Op.Gt) +let f64_ge = Compare (F64 F64Op.Ge) + +let i32_wrap_i64 = Convert (I32 I32Op.WrapI64) +let i32_trunc_s_f32 = Convert (I32 I32Op.TruncSF32) +let i32_trunc_u_f32 = Convert (I32 I32Op.TruncUF32) +let i32_trunc_s_f64 = Convert (I32 I32Op.TruncSF64) +let i32_trunc_u_f64 = Convert (I32 I32Op.TruncUF64) +let i64_extend_s_i32 = Convert (I64 I64Op.ExtendSI32) +let i64_extend_u_i32 = Convert (I64 I64Op.ExtendUI32) +let i64_trunc_s_f32 = Convert (I64 I64Op.TruncSF32) +let i64_trunc_u_f32 = Convert (I64 I64Op.TruncUF32) +let i64_trunc_s_f64 = Convert (I64 I64Op.TruncSF64) +let i64_trunc_u_f64 = Convert (I64 I64Op.TruncUF64) +let f32_convert_s_i32 = Convert (F32 F32Op.ConvertSI32) +let f32_convert_u_i32 = Convert (F32 F32Op.ConvertUI32) +let f32_convert_s_i64 = Convert (F32 F32Op.ConvertSI64) +let f32_convert_u_i64 = Convert (F32 F32Op.ConvertUI64) +let f32_demote_f64 = Convert (F32 F32Op.DemoteF64) +let f64_convert_s_i32 = Convert (F64 F64Op.ConvertSI32) +let f64_convert_u_i32 = Convert (F64 F64Op.ConvertUI32) +let f64_convert_s_i64 = Convert (F64 F64Op.ConvertSI64) +let f64_convert_u_i64 = Convert (F64 F64Op.ConvertUI64) +let f64_promote_f32 = Convert (F64 F64Op.PromoteF32) +let i32_reinterpret_f32 = Convert (I32 I32Op.ReinterpretFloat) +let i64_reinterpret_f64 = Convert (I64 I64Op.ReinterpretFloat) +let f32_reinterpret_i32 = Convert (F32 F32Op.ReinterpretInt) +let f64_reinterpret_i64 = Convert (F64 F64Op.ReinterpretInt) + +let current_memory = CurrentMemory +let grow_memory = GrowMemory + diff --git a/ml-proto/spec/table.ml b/ml-proto/spec/table.ml index 8426661852..cb8af681ff 100644 --- a/ml-proto/spec/table.ml +++ b/ml-proto/spec/table.ml @@ -74,5 +74,5 @@ let blit tab offset elems = let data = Array.of_list elems in let base = host_index_of_int32 offset in try - Array.blit data 0 tab.content base (Array.length data) + Array.blit data 0 tab.content base (Array.length data) with Invalid_argument _ -> raise Bounds diff --git a/ml-proto/spec/table.mli b/ml-proto/spec/table.mli index 3b88e3d1be..3b65bf7401 100644 --- a/ml-proto/spec/table.mli +++ b/ml-proto/spec/table.mli @@ -4,7 +4,7 @@ type t = table type size = int32 type index = int32 -type elem = exn option +type elem = exn option (* exn as extensible type *) type elem_type = Types.elem_type type 'a limits = 'a Types.limits diff --git a/ml-proto/spec/types.ml b/ml-proto/spec/types.ml index 8a6b8113a0..4d25595b09 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -1,9 +1,10 @@ (* Types *) -type value_type = Int32Type | Int64Type | Float32Type | Float64Type +type value_type = I32Type | I64Type | F32Type | F64Type type elem_type = AnyFuncType -type expr_type = value_type option -type func_type = {ins : value_type list; out : expr_type} +type stack_type = value_type list +type result_type = Stack of stack_type | Bot +type func_type = FuncType of stack_type * stack_type type 'a limits = {min : 'a; max : 'a option} type mutability = Immutable | Mutable @@ -20,19 +21,19 @@ type external_type = (* Attributes *) let size = function - | Int32Type | Float32Type -> 4 - | Int64Type | Float64Type -> 8 + | I32Type | F32Type -> 4 + | I64Type | F64Type -> 8 (* String conversion *) let string_of_value_type = function - | Int32Type -> "i32" - | Int64Type -> "i64" - | Float32Type -> "f32" - | Float64Type -> "f64" + | I32Type -> "i32" + | I64Type -> "i64" + | F32Type -> "f32" + | F64Type -> "f64" -let string_of_value_type_list = function +let string_of_value_types = function | [t] -> string_of_value_type t | ts -> "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" @@ -53,9 +54,12 @@ let string_of_global_type = function | GlobalType (t, Immutable) -> string_of_value_type t | GlobalType (t, Mutable) -> "(mut " ^ string_of_value_type t ^ ")" -let string_of_expr_type = function - | None -> "()" - | Some t -> string_of_value_type t +let string_of_stack_type ts = + "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" -let string_of_func_type {ins; out} = - string_of_value_type_list ins ^ " -> " ^ string_of_expr_type out +let string_of_result_type = function + | Stack ts -> string_of_stack_type ts + | Bot -> "_|_" + +let string_of_func_type (FuncType (ins, out)) = + string_of_stack_type ins ^ " -> " ^ string_of_stack_type out diff --git a/ml-proto/spec/values.ml b/ml-proto/spec/values.ml index aa6440670b..f31e424d48 100644 --- a/ml-proto/spec/values.ml +++ b/ml-proto/spec/values.ml @@ -4,7 +4,7 @@ open Types (* Values and operators *) type ('i32, 'i64, 'f32, 'f64) op = - Int32 of 'i32 | Int64 of 'i64 | Float32 of 'f32 | Float64 of 'f64 + I32 of 'i32 | I64 of 'i64 | F32 of 'f32 | F64 of 'f64 type value = (I32.t, I64.t, F32.t, F64.t) op @@ -12,36 +12,69 @@ type value = (I32.t, I64.t, F32.t, F64.t) op (* Typing *) let type_of = function - | Int32 _ -> Int32Type - | Int64 _ -> Int64Type - | Float32 _ -> Float32Type - | Float64 _ -> Float64Type + | I32 _ -> I32Type + | I64 _ -> I64Type + | F32 _ -> F32Type + | F64 _ -> F64Type let default_value = function - | Int32Type -> Int32 I32.zero - | Int64Type -> Int64 I64.zero - | Float32Type -> Float32 F32.zero - | Float64Type -> Float64 F64.zero + | I32Type -> I32 I32.zero + | I64Type -> I64 I64.zero + | F32Type -> F32 F32.zero + | F64Type -> F64 F64.zero -(* String conversion *) +(* Conversion *) + +let value_of_bool b = I32 (if b then 1l else 0l) let string_of_value = function - | Int32 i -> I32.to_string i - | Int64 i -> I64.to_string i - | Float32 z -> F32.to_string z - | Float64 z -> F64.to_string z + | I32 i -> I32.to_string i + | I64 i -> I64.to_string i + | F32 z -> F32.to_string z + | F64 z -> F64.to_string z let string_of_values = function | [v] -> string_of_value v | vs -> "(" ^ String.concat " " (List.map string_of_value vs) ^ ")" -(* TODO(stack): merge this with stack branch's additions *) -let int32_of_value = function - | Int32 n -> n - | _ -> raise (Invalid_argument "int32_of_value") +(* Injection & projection *) + +exception Value of value_type + +module type ValueType = +sig + type t + val to_value : t -> value + val of_value : value -> t (* raise Value *) +end + +module I32Value = +struct + type t = I32.t + let to_value i = I32 i + let of_value = function I32 i -> i | _ -> raise (Value I32Type) +end + +module I64Value = +struct + type t = I64.t + let to_value i = I64 i + let of_value = function I64 i -> i | _ -> raise (Value I64Type) +end + +module F32Value = +struct + type t = F32.t + let to_value i = F32 i + let of_value = function F32 z -> z | _ -> raise (Value F32Type) +end + +module F64Value = +struct + type t = F64.t + let to_value i = F64 i + let of_value = function F64 z -> z | _ -> raise (Value F64Type) +end -let int64_of_value = function - | Int64 n -> n - | _ -> raise (Invalid_argument "int64_of_value") diff --git a/ml-proto/test/block.wast b/ml-proto/test/block.wast index c134062bb9..763c693f45 100644 --- a/ml-proto/test/block.wast +++ b/ml-proto/test/block.wast @@ -143,16 +143,16 @@ ) (assert_invalid - (module (func $type-first-num-vs-void (result i32) - (block (i32.const 7) (nop) (i32.const 8)) + (module (func $type-binary (result i64) + (block (i64.const 1) (i64.const 2)) i64.add )) - "type mismatch" + "invalid result arity" ) (assert_invalid - (module (func $type-mid-num-vs-void (result i32) - (block (nop) (i32.const 7) (nop) (i32.const 8)) + (module (func $type-binary-with-nop (result i32) + (block (nop) (i32.const 7) (nop) (i32.const 8)) i32.add )) - "type mismatch" + "invalid result arity" ) (assert_invalid @@ -173,6 +173,7 @@ )) "type mismatch" ) +(; TODO(stack): Should these become legal? (assert_invalid (module (func $type-value-num-vs-void-after-break (block (br 0) (i32.const 1)) @@ -191,43 +192,44 @@ )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-last-void-vs-empty (block (br 0 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-num-vs-empty (block (br 0 (i32.const 66))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-empty-vs-num (result i32) (block (br 0)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-void-vs-empty (block (br 0 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-num-vs-empty (block (br 0 (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-empty-vs-num (result i32) (block (br 0) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid @@ -254,6 +256,7 @@ )) "type mismatch" ) +(; TODO(stack): Should these become legal? (assert_invalid (module (func $type-break-second-void-vs-num (result i32) (block (br 0 (i32.const 1)) (br 0 (nop))) @@ -266,24 +269,25 @@ )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-nested-void-vs-empty (block (block (br 1 (nop))) (br 0)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-num-vs-empty (block (block (br 1 (i32.const 1))) (br 0)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-empty-vs-num (result i32) (block (block (br 1)) (br 0 (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid @@ -303,7 +307,7 @@ (module (func $type-break-operand-empty-vs-num (result i32) (i32.ctz (block (br 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid @@ -318,3 +322,4 @@ )) "type mismatch" ) + diff --git a/ml-proto/test/br.wast b/ml-proto/test/br.wast index 0fa70eb12e..833341d94b 100644 --- a/ml-proto/test/br.wast +++ b/ml-proto/test/br.wast @@ -356,26 +356,28 @@ (module (func $type-arg-empty-vs-num (result i32) (block (br 0) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-arg-void-vs-empty (block (br 0 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-arg-num-vs-empty (block (br 0 (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) +(; TODO(stack): Should this become legal? (assert_invalid (module (func $type-arg-poly-vs-empty (block (br 0 (unreachable))) )) - "arity mismatch" + "type mismatch" ) +;) (assert_invalid (module (func $type-arg-void-vs-num (result i32) @@ -390,6 +392,19 @@ "type mismatch" ) +(assert_invalid + (module (func $type-binary (result i64) + (block (i64.const 1) (i64.const 2) br 2 0) i64.add + )) + "invalid result arity" +) +(assert_invalid + (module (func $type-binary-with-nop (result i32) + (block (nop) (i32.const 7) (nop) (i32.const 8) br 2 0) i32.add + )) + "invalid result arity" +) + (assert_invalid (module (func $unbound-label (br 1))) "unknown label" @@ -399,6 +414,6 @@ "unknown label" ) (assert_invalid - (module (func $large-label (br 0x100000001))) + (module (func $large-label (br 0x10000001))) "unknown label" ) diff --git a/ml-proto/test/br_if.wast b/ml-proto/test/br_if.wast index 0676831bd9..44a0636fea 100644 --- a/ml-proto/test/br_if.wast +++ b/ml-proto/test/br_if.wast @@ -198,50 +198,52 @@ (module (func $type-false-arg-empty-vs-num (result i32) (block (br_if 0 (i32.const 0)) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-true-arg-empty-vs-num (result i32) (block (br_if 0 (i32.const 1)) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-false-arg-void-vs-empty (block (br_if 0 (nop) (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-true-arg-void-vs-empty (block (br_if 0 (nop) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-false-arg-num-vs-empty (block (br_if 0 (i32.const 0) (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-true-arg-num-vs-empty (block (br_if 0 (i32.const 0) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) +(; TODO(stack): Should these become legal? (assert_invalid (module (func $type-false-arg-poly-vs-empty (block (br_if 0 (unreachable) (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-true-arg-poly-vs-empty (block (br_if 0 (unreachable) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) +;) (assert_invalid (module (func $type-false-arg-void-vs-num (result i32) @@ -293,6 +295,21 @@ "type mismatch" ) +(assert_invalid + (module (func $type-binary (result i64) + (block (i64.const 1) (i64.const 2) (i64.const 3) br_if 2 0) + i64.add + )) + "invalid result arity" +) +(assert_invalid + (module (func $type-binary-with-nop (result i32) + (block (nop) (i32.const 7) (nop) (i32.const 8) (i64.const 3) br_if 2 0) + i32.add + )) + "invalid result arity" +) + (assert_invalid (module (func $unbound-label (br_if 1 (i32.const 1)))) "unknown label" @@ -302,7 +319,7 @@ "unknown label" ) (assert_invalid - (module (func $large-label (br_if 0x100000001 (i32.const 1)))) + (module (func $large-label (br_if 0x10000001 (i32.const 1)))) "unknown label" ) diff --git a/ml-proto/test/br_table.wast b/ml-proto/test/br_table.wast index 2dcab6bb82..104ddecb2d 100644 --- a/ml-proto/test/br_table.wast +++ b/ml-proto/test/br_table.wast @@ -1273,26 +1273,28 @@ (module (func $type-arg-empty-vs-num (result i32) (block (br_table 0 (i32.const 1)) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-arg-void-vs-empty (block (br_table 0 (nop) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-arg-num-vs-empty (block (br_table 0 (i32.const 0) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) +(; TODO(stack): Should this become legal? (assert_invalid (module (func $type-arg-poly-vs-empty (block (br_table 0 (unreachable) (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) +;) (assert_invalid (module (func $type-arg-void-vs-num (result i32) @@ -1332,6 +1334,21 @@ "type mismatch" ) +(assert_invalid + (module (func $type-binary (result i64) + (block (i64.const 1) (i64.const 2) (i64.const 3) br_table 2 0 0) + i64.add + )) + "invalid result arity" +) +(assert_invalid + (module (func $type-binary-with-nop (result i32) + (block (nop) (i32.const 7) (nop) (i32.const 8) (i64.const 3) br_table 2 0) + i32.add + )) + "invalid result arity" +) + (assert_invalid (module (func $unbound-label (block (br_table 2 1 (i32.const 1))) @@ -1346,7 +1363,7 @@ ) (assert_invalid (module (func $large-label - (block (br_table 0 0x100000001 0 (i32.const 1))) + (block (br_table 0 0x10000001 0 (i32.const 1))) )) "unknown label" ) @@ -1365,7 +1382,7 @@ ) (assert_invalid (module (func $large-label-default - (block (br_table 0 0 0x100000001 (i32.const 1))) + (block (br_table 0 0 0x10000001 (i32.const 1))) )) "unknown label" ) diff --git a/ml-proto/test/break-drop.wast b/ml-proto/test/break-drop.wast index 5493e2b3af..a09f27148e 100644 --- a/ml-proto/test/break-drop.wast +++ b/ml-proto/test/break-drop.wast @@ -10,16 +10,16 @@ (assert_invalid (module (func (block (br 0 (nop))))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func (block (br_if 0 (nop) (i32.const 0))))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func (block (br_table 0 (nop) (i32.const 0))))) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/call.wast b/ml-proto/test/call.wast index dde2f949f9..548b473a4c 100644 --- a/ml-proto/test/call.wast +++ b/ml-proto/test/call.wast @@ -167,50 +167,36 @@ (func $arity-0-vs-1 (call 1)) (func (param i32)) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $arity-0-vs-2 (call 1)) (func (param f64 i32)) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $arity-1-vs-0 (call 1 (i32.const 1))) (func) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $arity-2-vs-0 (call 1 (f64.const 2) (i32.const 1))) (func) ) - "arity mismatch" + "type mismatch" ) -(assert_invalid - (module - (func $arity-nop-first (call 1 (nop) (i32.const 1) (i32.const 2))) - (func (param i32 i32)) - ) - "arity mismatch" -) -(assert_invalid - (module - (func $arity-nop-mid (call 1 (i32.const 1) (nop) (i32.const 2))) - (func (param i32 i32)) - ) - "arity mismatch" -) -(assert_invalid - (module - (func $arity-nop-last (call 1 (i32.const 1) (i32.const 2) (nop))) - (func (param i32 i32)) - ) - "arity mismatch" +;; TODO(stack): move these elsewhere +(module + (func (param i32 i32)) + (func $arity-nop-first (call 0 (nop) (i32.const 1) (i32.const 2))) + (func $arity-nop-mid (call 0 (i32.const 1) (nop) (i32.const 2))) + (func $arity-nop-last (call 0 (i32.const 1) (i32.const 2) (nop))) ) (assert_invalid @@ -250,6 +236,6 @@ "unknown function" ) (assert_invalid - (module (func $large-func (call 10001232130000))) + (module (func $large-func (call 1012321300))) "unknown function" ) diff --git a/ml-proto/test/call_indirect.wast b/ml-proto/test/call_indirect.wast index 6d2dc46b82..74afe2f2af 100644 --- a/ml-proto/test/call_indirect.wast +++ b/ml-proto/test/call_indirect.wast @@ -60,43 +60,43 @@ (func (export "type-f64") (result f64) (call_indirect $out-f64 (i32.const 3))) (func (export "type-index") (result i64) - (call_indirect $over-i64 (i32.const 5) (i64.const 100)) + (call_indirect $over-i64 (i64.const 100) (i32.const 5)) ) (func (export "type-first-i32") (result i32) - (call_indirect $over-i32 (i32.const 4) (i32.const 32)) + (call_indirect $over-i32 (i32.const 32) (i32.const 4)) ) (func (export "type-first-i64") (result i64) - (call_indirect $over-i64 (i32.const 5) (i64.const 64)) + (call_indirect $over-i64 (i64.const 64) (i32.const 5)) ) (func (export "type-first-f32") (result f32) - (call_indirect $over-f32 (i32.const 6) (f32.const 1.32)) + (call_indirect $over-f32 (f32.const 1.32) (i32.const 6)) ) (func (export "type-first-f64") (result f64) - (call_indirect $over-f64 (i32.const 7) (f64.const 1.64)) + (call_indirect $over-f64 (f64.const 1.64) (i32.const 7)) ) (func (export "type-second-i32") (result i32) - (call_indirect $f32-i32 (i32.const 8) (f32.const 32.1) (i32.const 32)) + (call_indirect $f32-i32 (f32.const 32.1) (i32.const 32) (i32.const 8)) ) (func (export "type-second-i64") (result i64) - (call_indirect $i32-i64 (i32.const 9) (i32.const 32) (i64.const 64)) + (call_indirect $i32-i64 (i32.const 32) (i64.const 64) (i32.const 9)) ) (func (export "type-second-f32") (result f32) - (call_indirect $f64-f32 (i32.const 10) (f64.const 64) (f32.const 32)) + (call_indirect $f64-f32 (f64.const 64) (f32.const 32) (i32.const 10)) ) (func (export "type-second-f64") (result f64) - (call_indirect $i64-f64 (i32.const 11) (i64.const 64) (f64.const 64.1)) + (call_indirect $i64-f64 (i64.const 64) (f64.const 64.1) (i32.const 11)) ) ;; Dispatch (func (export "dispatch") (param i32 i64) (result i64) - (call_indirect $over-i64 (get_local 0) (get_local 1)) + (call_indirect $over-i64 (get_local 1) (get_local 0)) ) (func (export "dispatch-structural") (param i32) (result i64) - (call_indirect $over-i64-duplicate (get_local 0) (i64.const 9)) + (call_indirect $over-i64-duplicate (i64.const 9) (get_local 0)) ) ;; Recursion @@ -106,8 +106,9 @@ (i64.const 1) (i64.mul (get_local 0) - (call_indirect $over-i64 (i32.const 12) + (call_indirect $over-i64 (i64.sub (get_local 0) (i64.const 1)) + (i32.const 12) ) ) ) @@ -117,11 +118,13 @@ (if (i64.le_u (get_local 0) (i64.const 1)) (i64.const 1) (i64.add - (call_indirect $over-i64 (i32.const 13) + (call_indirect $over-i64 (i64.sub (get_local 0) (i64.const 2)) + (i32.const 13) ) - (call_indirect $over-i64 (i32.const 13) + (call_indirect $over-i64 (i64.sub (get_local 0) (i64.const 1)) + (i32.const 13) ) ) ) @@ -130,16 +133,18 @@ (func $even (export "even") (param i32) (result i32) (if (i32.eqz (get_local 0)) (i32.const 44) - (call_indirect $over-i32 (i32.const 15) + (call_indirect $over-i32 (i32.sub (get_local 0) (i32.const 1)) + (i32.const 15) ) ) ) (func $odd (export "odd") (param i32) (result i32) (if (i32.eqz (get_local 0)) (i32.const 99) - (call_indirect $over-i32 (i32.const 14) + (call_indirect $over-i32 (i32.sub (get_local 0) (i32.const 1)) + (i32.const 14) ) ) ) @@ -251,7 +256,7 @@ (table 0 anyfunc) (func $arity-0-vs-1 (call_indirect 0 (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module @@ -259,63 +264,47 @@ (table 0 anyfunc) (func $arity-0-vs-2 (call_indirect 0 (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (type (func)) (table 0 anyfunc) - (func $arity-1-vs-0 (call_indirect 0 (i32.const 0) (i32.const 1))) + (func $arity-1-vs-0 (call_indirect 0 (i32.const 1) (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (type (func)) (table 0 anyfunc) (func $arity-2-vs-0 - (call_indirect 0 (i32.const 0) (f64.const 2) (i32.const 1)) + (call_indirect 0 (f64.const 2) (i32.const 1) (i32.const 0)) ) ) - "arity mismatch" + "type mismatch" ) -(assert_invalid - (module - (type (func (param i32 i32))) - (table 0 anyfunc) - (func $arity-nop-first - (call_indirect 0 (i32.const 0) (nop) (i32.const 1) (i32.const 2)) - ) +;; TODO(stack): move these elsewhere +(module + (type (func (param i32 i32))) + (table 0 anyfunc) + (func $arity-nop-first + (call_indirect 0 (nop) (i32.const 1) (i32.const 2) (i32.const 0)) ) - "arity mismatch" -) -(assert_invalid - (module - (type (func (param i32 i32))) - (table 0 anyfunc) - (func $arity-nop-mid - (call_indirect 0 (i32.const 0) (i32.const 1) (nop) (i32.const 2)) - ) + (func $arity-nop-mid + (call_indirect 0 (i32.const 1) (nop) (i32.const 2) (i32.const 0)) ) - "arity mismatch" -) -(assert_invalid - (module - (type (func (param i32 i32))) - (table 0 anyfunc) - (func $arity-nop-last - (call_indirect 0 (i32.const 0) (i32.const 1) (i32.const 2) (nop)) - ) + (func $arity-nop-last + (call_indirect 0 (i32.const 1) (i32.const 2) (nop) (i32.const 0)) ) - "arity mismatch" ) (assert_invalid (module (type (func (param i32))) (table 0 anyfunc) - (func $type-func-void-vs-i32 (call_indirect 0 (nop) (i32.const 1))) + (func $type-func-void-vs-i32 (call_indirect 0 (i32.const 1) (nop))) ) "type mismatch" ) @@ -323,7 +312,7 @@ (module (type (func (param i32))) (table 0 anyfunc) - (func $type-func-num-vs-i32 (call_indirect 0 (i64.const 1) (i32.const 0))) + (func $type-func-num-vs-i32 (call_indirect 0 (i32.const 0) (i64.const 1))) ) "type mismatch" ) @@ -333,7 +322,7 @@ (type (func (param i32 i32))) (table 0 anyfunc) (func $type-first-void-vs-num - (call_indirect 0 (i32.const 0) (nop) (i32.const 1)) + (call_indirect 0 (nop) (i32.const 1) (i32.const 0)) ) ) "type mismatch" @@ -343,7 +332,7 @@ (type (func (param i32 i32))) (table 0 anyfunc) (func $type-second-void-vs-num - (call_indirect 0 (i32.const 0) (i32.const 1) (nop)) + (call_indirect 0 (i32.const 1) (nop) (i32.const 0)) ) ) "type mismatch" @@ -353,7 +342,7 @@ (type (func (param i32 f64))) (table 0 anyfunc) (func $type-first-num-vs-num - (call_indirect 0 (i32.const 0) (f64.const 1) (i32.const 1)) + (call_indirect 0 (f64.const 1) (i32.const 1) (i32.const 0)) ) ) "type mismatch" @@ -363,7 +352,7 @@ (type (func (param f64 i32))) (table 0 anyfunc) (func $type-second-num-vs-num - (call_indirect 0 (i32.const 0) (i32.const 1) (f64.const 1)) + (call_indirect 0 (i32.const 1) (f64.const 1) (i32.const 0)) ) ) "type mismatch" @@ -382,7 +371,7 @@ (assert_invalid (module (table 0 anyfunc) - (func $large-type (call_indirect 10001232130000 (i32.const 0))) + (func $large-type (call_indirect 1012321300 (i32.const 0))) ) "unknown type" ) diff --git a/ml-proto/test/expected-output/if_label_scope.fail.wast.log b/ml-proto/test/expected-output/if_label_scope.fail.wast.log index bc4b19aa32..4fa590d00c 100644 --- a/ml-proto/test/expected-output/if_label_scope.fail.wast.log +++ b/ml-proto/test/expected-output/if_label_scope.fail.wast.log @@ -1 +1 @@ -test/if_label_scope.fail.wast:6.19-6.21: unknown label $l +test/if_label_scope.fail.wast:6.19-6.21: syntax error: unknown label $l diff --git a/ml-proto/test/fac.wast b/ml-proto/test/fac.wast index 4a97ba5557..445dcfb012 100644 --- a/ml-proto/test/fac.wast +++ b/ml-proto/test/fac.wast @@ -23,42 +23,46 @@ (local i64 i64) (set_local 1 (get_local 0)) (set_local 2 (i64.const 1)) - (loop - (if - (i64.eq (get_local 1) (i64.const 0)) - (br 2) - (block - (set_local 2 (i64.mul (get_local 1) (get_local 2))) - (set_local 1 (i64.sub (get_local 1) (i64.const 1))) + (block + (loop + (if + (i64.eq (get_local 1) (i64.const 0)) + (br 2) + (block + (set_local 2 (i64.mul (get_local 1) (get_local 2))) + (set_local 1 (i64.sub (get_local 1) (i64.const 1))) + ) ) + (br 0) ) - (br 0) ) (get_local 2) ) ;; Iterative factorial named - (func $fac-iter-named (export "fac-iter-named") (param $n i64) (result i64) + (func (export "fac-iter-named") (param $n i64) (result i64) (local $i i64) (local $res i64) (set_local $i (get_local $n)) (set_local $res (i64.const 1)) - (loop $done $loop - (if - (i64.eq (get_local $i) (i64.const 0)) - (br $done) - (block - (set_local $res (i64.mul (get_local $i) (get_local $res))) - (set_local $i (i64.sub (get_local $i) (i64.const 1))) + (block $done + (loop $loop + (if + (i64.eq (get_local $i) (i64.const 0)) + (br $done) + (block + (set_local $res (i64.mul (get_local $i) (get_local $res))) + (set_local $i (i64.sub (get_local $i) (i64.const 1))) + ) ) + (br $loop) ) - (br $loop) ) (get_local $res) ) ;; Optimized factorial. - (func (export "fac-optimised") (param i64) (result i64) + (func (export "fac-opt") (param i64) (result i64) (local i64) (set_local 1 (i64.const 1)) (block @@ -77,5 +81,5 @@ (assert_return (invoke "fac-iter" (i64.const 25)) (i64.const 7034535277573963776)) (assert_return (invoke "fac-rec-named" (i64.const 25)) (i64.const 7034535277573963776)) (assert_return (invoke "fac-iter-named" (i64.const 25)) (i64.const 7034535277573963776)) -(assert_return (invoke "fac-optimised" (i64.const 25)) (i64.const 7034535277573963776)) +(assert_return (invoke "fac-opt" (i64.const 25)) (i64.const 7034535277573963776)) (assert_trap (invoke "fac-rec" (i64.const 1073741824)) "call stack exhausted") diff --git a/ml-proto/test/float_exprs.wast b/ml-proto/test/float_exprs.wast index fc4a2a5b63..f00d25ca52 100644 --- a/ml-proto/test/float_exprs.wast +++ b/ml-proto/test/float_exprs.wast @@ -736,10 +736,15 @@ (func (export "run") (param $n i32) (param $z f32) (local $i i32) - (loop $exit $cont - (f32.store (get_local $i) (f32.div (f32.load (get_local $i)) (get_local $z))) - (set_local $i (i32.add (get_local $i) (i32.const 4))) - (br_if $cont (i32.lt_u (get_local $i) (get_local $n))) + (block $exit + (loop $cont + (f32.store + (get_local $i) + (f32.div (f32.load (get_local $i)) (get_local $z)) + ) + (set_local $i (i32.add (get_local $i) (i32.const 4))) + (br_if $cont (i32.lt_u (get_local $i) (get_local $n))) + ) ) ) @@ -766,10 +771,15 @@ (func (export "run") (param $n i32) (param $z f64) (local $i i32) - (loop $exit $cont - (f64.store (get_local $i) (f64.div (f64.load (get_local $i)) (get_local $z))) - (set_local $i (i32.add (get_local $i) (i32.const 8))) - (br_if $cont (i32.lt_u (get_local $i) (get_local $n))) + (block $exit + (loop $cont + (f64.store + (get_local $i) + (f64.div (f64.load (get_local $i)) (get_local $z)) + ) + (set_local $i (i32.add (get_local $i) (i32.const 8))) + (br_if $cont (i32.lt_u (get_local $i) (get_local $n))) + ) ) ) @@ -1306,22 +1316,41 @@ (local $sum f32) (local $c f32) (local $t f32) - (loop $exit $top - (set_local $t (f32.sub (f32.sub (tee_local $sum (f32.add (get_local $c) (tee_local $t (f32.sub (f32.load (get_local $p)) (get_local $t))))) (get_local $c)) (get_local $t))) - (set_local $p (i32.add (get_local $p) (i32.const 4))) - (set_local $c (get_local $sum)) - (br_if $top (tee_local $n (i32.add (get_local $n) (i32.const -1)))) + (block $exit + (loop $top + (set_local $t + (f32.sub + (f32.sub + (tee_local $sum + (f32.add + (get_local $c) + (tee_local $t + (f32.sub (f32.load (get_local $p)) (get_local $t)) + ) + ) + ) + (get_local $c) + ) + (get_local $t) + ) + ) + (set_local $p (i32.add (get_local $p) (i32.const 4))) + (set_local $c (get_local $sum)) + (br_if $top (tee_local $n (i32.add (get_local $n) (i32.const -1)))) + ) ) (get_local $sum) ) (func (export "f32.plain_sum") (param $p i32) (param $n i32) (result f32) (local $sum f32) - (loop $exit $top - (set_local $sum (f32.add (get_local $sum) (f32.load (get_local $p)))) - (set_local $p (i32.add (get_local $p) (i32.const 4))) - (set_local $n (i32.add (get_local $n) (i32.const -1))) - (br_if $top (get_local $n)) + (block $exit + (loop $top + (set_local $sum (f32.add (get_local $sum) (f32.load (get_local $p)))) + (set_local $p (i32.add (get_local $p) (i32.const 4))) + (set_local $n (i32.add (get_local $n) (i32.const -1))) + (br_if $top (get_local $n)) + ) ) (get_local $sum) ) @@ -1338,22 +1367,41 @@ (local $sum f64) (local $c f64) (local $t f64) - (loop $exit $top - (set_local $t (f64.sub (f64.sub (tee_local $sum (f64.add (get_local $c) (tee_local $t (f64.sub (f64.load (get_local $p)) (get_local $t))))) (get_local $c)) (get_local $t))) - (set_local $p (i32.add (get_local $p) (i32.const 8))) - (set_local $c (get_local $sum)) - (br_if $top (tee_local $n (i32.add (get_local $n) (i32.const -1)))) + (block $exit + (loop $top + (set_local $t + (f64.sub + (f64.sub + (tee_local $sum + (f64.add + (get_local $c) + (tee_local $t + (f64.sub (f64.load (get_local $p)) (get_local $t)) + ) + ) + ) + (get_local $c) + ) + (get_local $t) + ) + ) + (set_local $p (i32.add (get_local $p) (i32.const 8))) + (set_local $c (get_local $sum)) + (br_if $top (tee_local $n (i32.add (get_local $n) (i32.const -1)))) + ) ) (get_local $sum) ) (func (export "f64.plain_sum") (param $p i32) (param $n i32) (result f64) (local $sum f64) - (loop $exit $top - (set_local $sum (f64.add (get_local $sum) (f64.load (get_local $p)))) - (set_local $p (i32.add (get_local $p) (i32.const 8))) - (set_local $n (i32.add (get_local $n) (i32.const -1))) - (br_if $top (get_local $n)) + (block $exit + (loop $top + (set_local $sum (f64.add (get_local $sum) (f64.load (get_local $p)))) + (set_local $p (i32.add (get_local $p) (i32.const 8))) + (set_local $n (i32.add (get_local $n) (i32.const -1))) + (br_if $top (get_local $n)) + ) ) (get_local $sum) ) diff --git a/ml-proto/test/func.wast b/ml-proto/test/func.wast index c00d6c8be8..a9fadbac8a 100644 --- a/ml-proto/test/func.wast +++ b/ml-proto/test/func.wast @@ -13,6 +13,7 @@ (func $h (export "g")) (func (local)) + (func (local) (local)) (func (local i32)) (func (local $x i32)) (func (local i32 f64 i64)) @@ -20,6 +21,7 @@ (func (local i32 f32) (local $x i64) (local) (local i32 f64)) (func (param)) + (func (param) (param)) (func (param i32)) (func (param $x i32)) (func (param i32 f64 i64)) @@ -168,17 +170,20 @@ (func (export "signature-implicit-reused") ;; The implicit index 16 in this test depends on the function and ;; type definitions, and may need adapting if they change. - (call_indirect 16 (i32.const 0) + (call_indirect 16 (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f32.const 0) (i32.const 0) + (i32.const 0) ) - (call_indirect 16 (i32.const 2) + (call_indirect 16 (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f32.const 0) (i32.const 0) + (i32.const 2) ) - (call_indirect 16 (i32.const 3) + (call_indirect 16 (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f32.const 0) (i32.const 0) + (i32.const 3) ) ) @@ -187,9 +192,10 @@ ) (func (export "signature-implicit-duplicate") - (call_indirect $complex-sig-duplicate (i32.const 0) + (call_indirect $complex-sig-duplicate (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f64.const 0) (i64.const 0) (f32.const 0) (i32.const 0) + (i32.const 0) ) ) ) @@ -335,6 +341,19 @@ ;; Invalid typing of result +(assert_invalid + (module (func $type-multiple-result (result i32 i32) (unreachable))) + "invalid result arity" +) +(assert_invalid + (module + (type (func (result i32 i32))) + (func $type-multiple-result (type 0) (unreachable)) + ) + "invalid result arity" +) + + (assert_invalid (module (func $type-empty-i32 (result i32))) "type mismatch" @@ -370,6 +389,8 @@ )) "type mismatch" ) + +(; TODO(stack): Should these become legal? (assert_invalid (module (func $type-value-void-vs-num-after-return (result i32) (return (i32.const 1)) (nop) @@ -392,26 +413,19 @@ (module (func $type-value-num-vs-num-after-break (result i32) (br 0 (i32.const 1)) (f32.const 0) )) - "type mismatch" -) - -(assert_invalid - (module (func $type-return-last-void-vs-enpty - (return (nop)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-return-last-num-vs-enpty - (return (i32.const 0)) - )) "arity mismatch" ) +;) + +;; TODO(stack): move these somewhere else +(module (func $type-return-void-vs-enpty (return (nop)))) +(module (func $type-return-num-vs-enpty (return (i32.const 0)))) + (assert_invalid (module (func $type-return-last-empty-vs-num (result i32) (return) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-return-last-void-vs-num (result i32) @@ -425,23 +439,12 @@ )) "type mismatch" ) -(assert_invalid - (module (func $type-return-void-vs-empty - (return (nop)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-return-num-vs-empty - (return (i32.const 0)) - )) - "arity mismatch" -) + (assert_invalid (module (func $type-return-empty-vs-num (result i32) (return) (i32.const 1) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-return-void-vs-num (result i32) @@ -461,30 +464,32 @@ )) "type mismatch" ) +(; TODO(stack): Should this become legal? (assert_invalid (module (func $type-return-second-num-vs-num (result i32) (return (i32.const 1)) (return (f64.const 1)) )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-last-void-vs-empty (br 0 (nop)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-num-vs-empty (br 0 (i32.const 0)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-empty-vs-num (result i32) (br 0) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-void-vs-num (result i32) @@ -502,19 +507,19 @@ (module (func $type-break-void-vs-empty (br 0 (i64.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-num-vs-empty (br 0 (i64.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-empty-vs-num (result i32) (br 0) (i32.const 1) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-void-vs-num (result i32) @@ -534,18 +539,20 @@ )) "type mismatch" ) +(; TODO(stack): Should this become legal? (assert_invalid (module (func $type-break-second-num-vs-num (result i32) (br 0 (i32.const 1)) (br 0 (f64.const 1)) )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-nested-empty-vs-num (result i32) (block (br 1)) (br 0 (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-void-vs-num (result i32) diff --git a/ml-proto/test/labels.wast b/ml-proto/test/labels.wast index b661f08adb..2428bd5a97 100644 --- a/ml-proto/test/labels.wast +++ b/ml-proto/test/labels.wast @@ -9,60 +9,67 @@ (func (export "loop1") (result i32) (local $i i32) (set_local $i (i32.const 0)) - (loop $exit $cont - (set_local $i (i32.add (get_local $i) (i32.const 1))) - (if (i32.eq (get_local $i) (i32.const 5)) - (br $exit (get_local $i)) + (block $exit + (loop $cont + (set_local $i (i32.add (get_local $i) (i32.const 1))) + (if (i32.eq (get_local $i) (i32.const 5)) + (br $exit (get_local $i)) + ) + (br $cont) ) - (br $cont) ) ) (func (export "loop2") (result i32) (local $i i32) (set_local $i (i32.const 0)) - (loop $exit $cont - (set_local $i (i32.add (get_local $i) (i32.const 1))) - (if (i32.eq (get_local $i) (i32.const 5)) + (block $exit + (loop $cont + (set_local $i (i32.add (get_local $i) (i32.const 1))) + (if (i32.eq (get_local $i) (i32.const 5)) + (br $cont) + ) + (if (i32.eq (get_local $i) (i32.const 8)) + (br $exit (get_local $i)) + ) + (set_local $i (i32.add (get_local $i) (i32.const 1))) (br $cont) ) - (if (i32.eq (get_local $i) (i32.const 8)) - (br $exit (get_local $i)) - ) - (set_local $i (i32.add (get_local $i) (i32.const 1))) - (br $cont) ) ) (func (export "loop3") (result i32) (local $i i32) (set_local $i (i32.const 0)) - (loop $exit $cont - (set_local $i (i32.add (get_local $i) (i32.const 1))) - (if (i32.eq (get_local $i) (i32.const 5)) - (br $exit (get_local $i)) + (block $exit + (loop $cont + (set_local $i (i32.add (get_local $i) (i32.const 1))) + (if (i32.eq (get_local $i) (i32.const 5)) + (br $exit (get_local $i)) + ) + (get_local $i) ) - (get_local $i) ) ) (func (export "loop4") (param $max i32) (result i32) (local $i i32) (set_local $i (i32.const 1)) - (loop $exit $cont - (set_local $i (i32.add (get_local $i) (get_local $i))) - (if (i32.gt_u (get_local $i) (get_local $max)) - (br $exit (get_local $i)) + (block $exit + (loop $cont + (set_local $i (i32.add (get_local $i) (get_local $i))) + (if (i32.gt_u (get_local $i) (get_local $max)) + (br $exit (get_local $i)) + ) + (br $cont) ) - (br $cont) ) ) (func (export "loop5") (result i32) - (i32.add (loop $l0 $l1 - (i32.const 1) - ) - (i32.const 1) + (i32.add + (loop $l (i32.const 1)) + (i32.const 1) ) ) @@ -290,7 +297,7 @@ ) (assert_invalid (module (func (block $l (f32.neg (br_if $l (f32.const 0) (i32.const 1)))))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module diff --git a/ml-proto/test/left-to-right.wast b/ml-proto/test/left-to-right.wast index e94add1f05..4a30929f5d 100644 --- a/ml-proto/test/left-to-right.wast +++ b/ml-proto/test/left-to-right.wast @@ -56,9 +56,10 @@ (func $f64_another (result f64) (call $bump) (i32.store8 (i32.const 8) (i32.const 3)) (f64.const 1)) (func $f64_callee (result i32) (call $bump) (i32.store8 (i32.const 8) (i32.const 4)) (i32.const 6)) (func $f64_bool (result i32) (call $bump) (i32.store8 (i32.const 8) (i32.const 5)) (i32.const 0)) - (func $i32_dummy (param i32 i32)) (func $i64_dummy (param i64 i64)) - (func $f32_dummy (param f32 f32)) (func $f64_dummy (param f64 f64)) - + (func $i32_dummy (param i32 i32)) + (func $i64_dummy (param i64 i64)) + (func $f32_dummy (param f32 f32)) + (func $f64_dummy (param f64 f64)) (func (export "i32_add") (result i32) (call $reset) (drop (i32.add (call $i32_left) (call $i32_right))) (call $get)) (func (export "i32_sub") (result i32) (call $reset) (drop (i32.sub (call $i32_left) (call $i32_right))) (call $get)) @@ -87,7 +88,7 @@ (func (export "i32_store8") (result i32) (call $reset) (i32.store8 (call $i32_left) (call $i32_right)) (call $get)) (func (export "i32_store16") (result i32) (call $reset) (i32.store16 (call $i32_left) (call $i32_right)) (call $get)) (func (export "i32_call") (result i32) (call $reset) (call $i32_dummy (call $i32_left) (call $i32_right)) (call $get)) - (func (export "i32_call_indirect") (result i32) (call $reset) (drop (call_indirect $i32_T (call $i32_callee) (call $i32_right) (call $i32_another))) (call $get)) + (func (export "i32_call_indirect") (result i32) (call $reset) (drop (call_indirect $i32_T (call $i32_left) (call $i32_right) (call $i32_callee))) (call $get)) (func (export "i32_select") (result i32) (call $reset) (drop (select (call $i32_left) (call $i32_right) (call $i32_bool))) (call $get)) (func (export "i64_add") (result i32) (call $reset) (drop (i64.add (call $i64_left) (call $i64_right))) (call $get)) @@ -118,7 +119,7 @@ (func (export "i64_store16") (result i32) (call $reset) (i64.store16 (call $i32_left) (call $i64_right)) (call $get)) (func (export "i64_store32") (result i32) (call $reset) (i64.store32 (call $i32_left) (call $i64_right)) (call $get)) (func (export "i64_call") (result i32) (call $reset) (call $i64_dummy (call $i64_left) (call $i64_right)) (call $get)) - (func (export "i64_call_indirect") (result i32) (call $reset) (drop (call_indirect $i64_T (call $i64_callee) (call $i64_right) (call $i64_another))) (call $get)) + (func (export "i64_call_indirect") (result i32) (call $reset) (drop (call_indirect $i64_T (call $i64_left) (call $i64_right) (call $i64_callee))) (call $get)) (func (export "i64_select") (result i32) (call $reset) (drop (select (call $i64_left) (call $i64_right) (call $i64_bool))) (call $get)) (func (export "f32_add") (result i32) (call $reset) (drop (f32.add (call $f32_left) (call $f32_right))) (call $get)) @@ -136,7 +137,7 @@ (func (export "f32_max") (result i32) (call $reset) (drop (f32.max (call $f32_left) (call $f32_right))) (call $get)) (func (export "f32_store") (result i32) (call $reset) (f32.store (call $i32_left) (call $f32_right)) (call $get)) (func (export "f32_call") (result i32) (call $reset) (call $f32_dummy (call $f32_left) (call $f32_right)) (call $get)) - (func (export "f32_call_indirect") (result i32) (call $reset) (drop (call_indirect $f32_T (call $f32_callee) (call $f32_right) (call $f32_another))) (call $get)) + (func (export "f32_call_indirect") (result i32) (call $reset) (drop (call_indirect $f32_T (call $f32_left) (call $f32_right) (call $f32_callee))) (call $get)) (func (export "f32_select") (result i32) (call $reset) (drop (select (call $f32_left) (call $f32_right) (call $f32_bool))) (call $get)) (func (export "f64_add") (result i32) (call $reset) (drop (f64.add (call $f64_left) (call $f64_right))) (call $get)) @@ -154,7 +155,7 @@ (func (export "f64_max") (result i32) (call $reset) (drop (f64.max (call $f64_left) (call $f64_right))) (call $get)) (func (export "f64_store") (result i32) (call $reset) (f64.store (call $i32_left) (call $f64_right)) (call $get)) (func (export "f64_call") (result i32) (call $reset) (call $f64_dummy (call $f64_left) (call $f64_right)) (call $get)) - (func (export "f64_call_indirect") (result i32) (call $reset) (drop (call_indirect $f64_T (call $f64_callee) (call $f64_right) (call $f64_another))) (call $get)) + (func (export "f64_call_indirect") (result i32) (call $reset) (drop (call_indirect $f64_T (call $f64_left) (call $f64_right) (call $f64_callee))) (call $get)) (func (export "f64_select") (result i32) (call $reset) (drop (select (call $f64_left) (call $f64_right) (call $f64_bool))) (call $get)) (func (export "br_if") (result i32) @@ -205,8 +206,8 @@ (assert_return (invoke "i32_store16") (i32.const 0x0102)) (assert_return (invoke "i64_store16") (i32.const 0x0102)) (assert_return (invoke "i64_store32") (i32.const 0x0102)) (assert_return (invoke "i32_call") (i32.const 0x0102)) (assert_return (invoke "i64_call") (i32.const 0x0102)) -(assert_return (invoke "i32_call_indirect") (i32.const 0x040203)) -(assert_return (invoke "i64_call_indirect") (i32.const 0x040203)) +(assert_return (invoke "i32_call_indirect") (i32.const 0x010204)) +(assert_return (invoke "i64_call_indirect") (i32.const 0x010204)) (assert_return (invoke "i32_select") (i32.const 0x010205)) (assert_return (invoke "i64_select") (i32.const 0x010205)) (assert_return (invoke "f32_add") (i32.const 0x0102)) (assert_return (invoke "f64_add") (i32.const 0x0102)) @@ -224,8 +225,8 @@ (assert_return (invoke "f32_max") (i32.const 0x0102)) (assert_return (invoke "f64_max") (i32.const 0x0102)) (assert_return (invoke "f32_store") (i32.const 0x0102)) (assert_return (invoke "f64_store") (i32.const 0x0102)) (assert_return (invoke "f32_call") (i32.const 0x0102)) (assert_return (invoke "f64_call") (i32.const 0x0102)) -(assert_return (invoke "f32_call_indirect") (i32.const 0x040203)) -(assert_return (invoke "f64_call_indirect") (i32.const 0x040203)) +(assert_return (invoke "f32_call_indirect") (i32.const 0x010204)) +(assert_return (invoke "f64_call_indirect") (i32.const 0x010204)) (assert_return (invoke "f32_select") (i32.const 0x010205)) (assert_return (invoke "f64_select") (i32.const 0x010205)) (assert_return (invoke "br_if") (i32.const 0x0102)) diff --git a/ml-proto/test/loop.wast b/ml-proto/test/loop.wast index d994b19d6f..3ca568bb09 100644 --- a/ml-proto/test/loop.wast +++ b/ml-proto/test/loop.wast @@ -48,55 +48,59 @@ ) (func (export "break-bare") (result i32) - (loop (br 1) (br 0) (unreachable)) - (loop (br_if 1 (i32.const 1)) (unreachable)) - (loop (br_table 1 (i32.const 0)) (unreachable)) - (loop (br_table 1 1 1 (i32.const 1)) (unreachable)) + (block (loop (br 1) (br 0) (unreachable))) + (block (loop (br_if 1 (i32.const 1)) (unreachable))) + (block (loop (br_table 1 (i32.const 0)) (unreachable))) + (block (loop (br_table 1 1 1 (i32.const 1)) (unreachable))) (i32.const 19) ) (func (export "break-value") (result i32) - (loop (br 1 (i32.const 18)) (br 0) (i32.const 19)) + (block (loop (br 1 (i32.const 18)) (br 0) (i32.const 19))) ) (func (export "break-repeated") (result i32) - (loop - (br 1 (i32.const 18)) - (br 1 (i32.const 19)) - (br_if 1 (i32.const 20) (i32.const 0)) - (br_if 1 (i32.const 20) (i32.const 1)) - (br 1 (i32.const 21)) - (br_table 1 (i32.const 22) (i32.const 0)) - (br_table 1 1 1 (i32.const 23) (i32.const 1)) - (i32.const 21) + (block + (loop + (br 1 (i32.const 18)) + (br 1 (i32.const 19)) + (br_if 1 (i32.const 20) (i32.const 0)) + (br_if 1 (i32.const 20) (i32.const 1)) + (br 1 (i32.const 21)) + (br_table 1 (i32.const 22) (i32.const 0)) + (br_table 1 1 1 (i32.const 23) (i32.const 1)) + (i32.const 21) + ) ) ) (func (export "break-inner") (result i32) (local i32) (set_local 0 (i32.const 0)) - (set_local 0 (i32.add (get_local 0) (loop (block (br 2 (i32.const 0x1)))))) - (set_local 0 (i32.add (get_local 0) (loop (loop (br 3 (i32.const 0x2)))))) - (set_local 0 (i32.add (get_local 0) (loop (loop (br 1 (i32.const 0x4)))))) - (set_local 0 (i32.add (get_local 0) (loop (i32.ctz (br 1 (i32.const 0x8)))))) - (set_local 0 (i32.add (get_local 0) (loop (i32.ctz (loop (br 3 (i32.const 0x10))))))) + (set_local 0 (i32.add (get_local 0) (block (loop (block (br 2 (i32.const 0x1))))))) + (set_local 0 (i32.add (get_local 0) (block (loop (loop (br 2 (i32.const 0x2))))))) + (set_local 0 (i32.add (get_local 0) (block (loop (block (loop (br 1 (i32.const 0x4)))))))) + (set_local 0 (i32.add (get_local 0) (block (loop (i32.ctz (br 1 (i32.const 0x8))))))) + (set_local 0 (i32.add (get_local 0) (block (loop (i32.ctz (loop (br 2 (i32.const 0x10)))))))) (get_local 0) ) (func (export "cont-inner") (result i32) (local i32) (set_local 0 (i32.const 0)) - (set_local 0 (i32.add (get_local 0) (loop (loop (br 2))))) + (set_local 0 (i32.add (get_local 0) (loop (loop (br 1))))) (set_local 0 (i32.add (get_local 0) (loop (i32.ctz (br 0))))) - (set_local 0 (i32.add (get_local 0) (loop (i32.ctz (loop (br 2)))))) + (set_local 0 (i32.add (get_local 0) (loop (i32.ctz (loop (br 1)))))) (get_local 0) ) (func $fx (export "effects") (result i32) (local i32) - (loop - (set_local 0 (i32.const 1)) - (set_local 0 (i32.mul (get_local 0) (i32.const 3))) - (set_local 0 (i32.sub (get_local 0) (i32.const 5))) - (set_local 0 (i32.mul (get_local 0) (i32.const 7))) - (br 1) - (set_local 0 (i32.mul (get_local 0) (i32.const 100))) + (block + (loop + (set_local 0 (i32.const 1)) + (set_local 0 (i32.mul (get_local 0) (i32.const 3))) + (set_local 0 (i32.sub (get_local 0) (i32.const 5))) + (set_local 0 (i32.mul (get_local 0) (i32.const 7))) + (br 1) + (set_local 0 (i32.mul (get_local 0) (i32.const 100))) + ) ) (i32.eq (get_local 0) (i32.const -14)) ) @@ -104,11 +108,13 @@ (func (export "while") (param i64) (result i64) (local i64) (set_local 1 (i64.const 1)) - (loop - (br_if 1 (i64.eqz (get_local 0))) - (set_local 1 (i64.mul (get_local 0) (get_local 1))) - (set_local 0 (i64.sub (get_local 0) (i64.const 1))) - (br 0) + (block + (loop + (br_if 1 (i64.eqz (get_local 0))) + (set_local 1 (i64.mul (get_local 0) (get_local 1))) + (set_local 0 (i64.sub (get_local 0) (i64.const 1))) + (br 0) + ) ) (get_local 1) ) @@ -117,30 +123,36 @@ (local i64 i64) (set_local 1 (i64.const 1)) (set_local 2 (i64.const 2)) - (loop - (br_if 1 (i64.gt_u (get_local 2) (get_local 0))) - (set_local 1 (i64.mul (get_local 1) (get_local 2))) - (set_local 2 (i64.add (get_local 2) (i64.const 1))) - (br 0) + (block + (loop + (br_if 1 (i64.gt_u (get_local 2) (get_local 0))) + (set_local 1 (i64.mul (get_local 1) (get_local 2))) + (set_local 2 (i64.add (get_local 2) (i64.const 1))) + (br 0) + ) ) (get_local 1) ) (func (export "nesting") (param f32 f32) (result f32) (local f32 f32) - (loop - (br_if 1 (f32.eq (get_local 0) (f32.const 0))) - (set_local 2 (get_local 1)) + (block (loop - (br_if 1 (f32.eq (get_local 2) (f32.const 0))) - (br_if 3 (f32.lt (get_local 2) (f32.const 0))) - (set_local 3 (f32.add (get_local 3) (get_local 2))) - (set_local 2 (f32.sub (get_local 2) (f32.const 2))) + (br_if 1 (f32.eq (get_local 0) (f32.const 0))) + (set_local 2 (get_local 1)) + (block + (loop + (br_if 1 (f32.eq (get_local 2) (f32.const 0))) + (br_if 3 (f32.lt (get_local 2) (f32.const 0))) + (set_local 3 (f32.add (get_local 3) (get_local 2))) + (set_local 2 (f32.sub (get_local 2) (f32.const 2))) + (br 0) + ) + ) + (set_local 3 (f32.div (get_local 3) (get_local 0))) + (set_local 0 (f32.sub (get_local 0) (f32.const 1))) (br 0) ) - (set_local 3 (f32.div (get_local 3) (get_local 0))) - (set_local 0 (f32.sub (get_local 0) (f32.const 1))) - (br 0) ) (get_local 3) ) @@ -213,183 +225,81 @@ ) (assert_invalid - (module (func $type-value-void-vs-num (result i32) - (loop (nop)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-value-num-vs-num (result i32) - (loop (f32.const 0)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-value-void-vs-num-after-break (result i32) - (loop (br 1 (i32.const 1)) (nop)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-value-num-vs-num-after-break (result i32) - (loop (br 1 (i32.const 1)) (f32.const 0)) - )) - "type mismatch" -) - -(assert_invalid - (module (func $type-break-last-void-vs-empty - (loop (br 1 (nop))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-last-num-vs-empty - (loop (br 1 (i32.const 0))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-last-empty-vs-num (result i32) - (loop (br 1)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-last-void-vs-num (result i32) - (loop (br 1 (nop))) - )) - "type mismatch" -) - -(assert_invalid - (module (func $type-break-void-vs-empty - (loop (br 1 (nop))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-num-vs-empty - (loop (br 1 (i32.const 0))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-empty-vs-num (result i32) - (loop (br 1) (i32.const 1)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-void-vs-num (result i32) - (loop (br 1 (nop)) (i32.const 1)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-num-vs-num (result i32) - (loop (br 1 (i64.const 1)) (i32.const 1)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-first-num-vs-num (result i32) - (loop (br 1 (i64.const 1)) (br 1 (i32.const 1))) + (module (func $type-binary (result i64) + (loop (i64.const 1) (i64.const 2)) i64.add )) - "type mismatch" + "invalid result arity" ) (assert_invalid - (module (func $type-break-second-num-vs-num (result i32) - (loop (br 1 (i32.const 1)) (br 1 (f64.const 1))) + (module (func $type-binary-with-nop (result i32) + (loop (nop) (i32.const 7) (nop) (i32.const 8)) i32.add )) - "type mismatch" + "invalid result arity" ) (assert_invalid - (module (func $type-break-nested-void-vs-empty - (loop (loop (br 3 (nop))) (br 1)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-nested-num-vs-empty - (loop (loop (br 3 (i32.const 1))) (br 1)) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-nested-empty-vs-num (result i32) - (loop (loop (br 3)) (br 1 (i32.const 1))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-nested-void-vs-num (result i32) - (loop (loop (br 3 (nop))) (br 1 (i32.const 1))) + (module (func $type-value-void-vs-num (result i32) + (loop (nop)) )) "type mismatch" ) (assert_invalid - (module (func $type-break-nested-num-vs-num (result i32) - (loop (loop (br 3 (i64.const 1))) (br 1 (i32.const 1))) + (module (func $type-value-num-vs-num (result i32) + (loop (f32.const 0)) )) "type mismatch" ) +(; TODO(stack): Should these become legal? (assert_invalid - (module (func $type-break-operand-empty-vs-num (result i32) - (i32.ctz (loop (br 1))) - )) - "arity mismatch" -) -(assert_invalid - (module (func $type-break-operand-void-vs-num (result i32) - (i32.ctz (loop (br 1 (nop)))) + (module (func $type-value-void-vs-num-after-break (result i32) + (loop (br 1 (i32.const 1)) (nop)) )) "type mismatch" ) (assert_invalid - (module (func $type-break-operand-num-vs-num (result i32) - (i64.ctz (loop (br 1 (i64.const 9)))) + (module (func $type-value-num-vs-num-after-break (result i32) + (loop (br 1 (i32.const 1)) (f32.const 0)) )) "type mismatch" ) +;) (assert_invalid (module (func $type-cont-last-void-vs-empty (result i32) (loop (br 0 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-cont-last-num-vs-empty (result i32) (loop (br 0 (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-cont-void-vs-empty (result i32) (loop (br 0 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid - (module (func $type-break-num-vs-empty (result i32) + (module (func $type-cont-num-vs-empty (result i32) (loop (br 0 (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-cont-nested-void-vs-empty - (loop (loop (br 2 (nop))) (br 1)) + (block (loop (loop (br 0 (nop))) (br 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-cont-nested-num-vs-empty - (loop (loop (br 2 (i32.const 1))) (br 1)) + (block (loop (loop (br 0 (i32.const 1))) (br 1))) )) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/memory.wast b/ml-proto/test/memory.wast index 9f9b6dfb7e..0fde16811a 100644 --- a/ml-proto/test/memory.wast +++ b/ml-proto/test/memory.wast @@ -173,20 +173,22 @@ (func (export "aligned") (result i32) (local i32 i32 i32) (set_local 0 (i32.const 10)) - (loop - (if - (i32.eq (get_local 0) (i32.const 0)) - (br 2) - ) - (set_local 2 (i32.mul (get_local 0) (i32.const 4))) - (i32.store (get_local 2) (get_local 0)) - (set_local 1 (i32.load (get_local 2))) - (if - (i32.ne (get_local 0) (get_local 1)) - (return (i32.const 0)) + (block + (loop + (if + (i32.eq (get_local 0) (i32.const 0)) + (br 2) + ) + (set_local 2 (i32.mul (get_local 0) (i32.const 4))) + (i32.store (get_local 2) (get_local 0)) + (set_local 1 (i32.load (get_local 2))) + (if + (i32.ne (get_local 0) (get_local 1)) + (return (i32.const 0)) + ) + (set_local 0 (i32.sub (get_local 0) (i32.const 1))) + (br 0) ) - (set_local 0 (i32.sub (get_local 0) (i32.const 1))) - (br 0) ) (i32.const 1) ) @@ -195,20 +197,22 @@ (func (export "unaligned") (result i32) (local i32 f64 f64) (set_local 0 (i32.const 10)) - (loop - (if - (i32.eq (get_local 0) (i32.const 0)) - (br 2) - ) - (set_local 2 (f64.convert_s/i32 (get_local 0))) - (f64.store align=1 (get_local 0) (get_local 2)) - (set_local 1 (f64.load align=1 (get_local 0))) - (if - (f64.ne (get_local 2) (get_local 1)) - (return (i32.const 0)) + (block + (loop + (if + (i32.eq (get_local 0) (i32.const 0)) + (br 2) + ) + (set_local 2 (f64.convert_s/i32 (get_local 0))) + (f64.store align=1 (get_local 0) (get_local 2)) + (set_local 1 (f64.load align=1 (get_local 0))) + (if + (f64.ne (get_local 2) (get_local 1)) + (return (i32.const 0)) + ) + (set_local 0 (i32.sub (get_local 0) (i32.const 1))) + (br 0) ) - (set_local 0 (i32.sub (get_local 0) (i32.const 1))) - (br 0) ) (i32.const 1) ) diff --git a/ml-proto/test/names.wast b/ml-proto/test/names.wast index 924dca303d..07b4deb58e 100644 --- a/ml-proto/test/names.wast +++ b/ml-proto/test/names.wast @@ -62,7 +62,7 @@ (assert_return (invoke "if") (f32.const 0x2.03p+2)) (module - ;; Test that we can use indices instead of names to reference imports, + ;; Test that we can use indices instead of names to reference imports, ;; exports, functions and parameters. (import "spectest" "print" (func (param i32))) (func (import "spectest" "print") (param i32)) diff --git a/ml-proto/test/nop.wast b/ml-proto/test/nop.wast index 7968322f44..d6e485c019 100644 --- a/ml-proto/test/nop.wast +++ b/ml-proto/test/nop.wast @@ -1,7 +1,12 @@ ;; Test `nop` operator. (module + ;; Auxiliary definitions (func $dummy) + (func $3-ary (param i32 i32 i32) (result i32) + get_local 0 get_local 1 get_local 2 i32.sub i32.add + ) + (memory 1) (func (export "as-func-first") (result i32) (nop) (i32.const 1) @@ -9,8 +14,32 @@ (func (export "as-func-mid") (result i32) (call $dummy) (nop) (i32.const 2) ) - (func (export "as-func-last") - (call $dummy) (nop) + (func (export "as-func-last") (result i32) + (call $dummy) (i32.const 3) (nop) + ) + (func (export "as-func-everywhere") (result i32) + (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop) + ) + + (func (export "as-drop-last") (param i32) + (get_local 0) (nop) (drop) + ) + (func (export "as-drop-everywhere") (param i32) + (nop) (nop) (get_local 0) (nop) (nop) (drop) + ) + + (func (export "as-select-mid1") (param i32) (result i32) + (get_local 0) (nop) (get_local 0) (get_local 0) (select) + ) + (func (export "as-select-mid2") (param i32) (result i32) + (get_local 0) (get_local 0) (nop) (get_local 0) (select) + ) + (func (export "as-select-last") (param i32) (result i32) + (get_local 0) (get_local 0) (get_local 0) (nop) (select) + ) + (func (export "as-select-everywhere") (param i32) (result i32) + (nop) (get_local 0) (nop) (nop) (get_local 0) + (nop) (nop) (get_local 0) (nop) (nop) (select) ) (func (export "as-block-first") (result i32) @@ -19,8 +48,11 @@ (func (export "as-block-mid") (result i32) (block (call $dummy) (nop) (i32.const 2)) ) - (func (export "as-block-last") - (block (nop) (call $dummy) (nop)) + (func (export "as-block-last") (result i32) + (block (nop) (call $dummy) (i32.const 3) (nop)) + ) + (func (export "as-block-everywhere") (result i32) + (block (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop)) ) (func (export "as-loop-first") (result i32) @@ -29,35 +61,188 @@ (func (export "as-loop-mid") (result i32) (loop (call $dummy) (nop) (i32.const 2)) ) - (func (export "as-loop-last") - (loop (call $dummy) (nop)) + (func (export "as-loop-last") (result i32) + (loop (call $dummy) (i32.const 3) (nop)) + ) + (func (export "as-loop-everywhere") (result i32) + (loop (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop)) ) + (func (export "as-if-condition") (param i32) + (get_local 0) (nop) (if (then (call $dummy))) + ) (func (export "as-if-then") (param i32) - (block (if (get_local 0) (nop) (call $dummy))) + (if (get_local 0) (nop) (call $dummy)) ) (func (export "as-if-else") (param i32) - (block (if (get_local 0) (call $dummy) (nop))) + (if (get_local 0) (call $dummy) (nop)) + ) + + (func (export "as-br-last") (param i32) (result i32) + (block (get_local 0) (nop) (br 1 0)) + ) + (func (export "as-br-everywhere") (param i32) (result i32) + (block (nop) (nop) (get_local 0) (nop) (nop) (br 1 0)) + ) + + (func (export "as-br_if-mid") (param i32) (result i32) + (block (get_local 0) (nop) (get_local 0) (br_if 1 0) (i32.const 0)) + ) + (func (export "as-br_if-last") (param i32) (result i32) + (block (get_local 0) (get_local 0) (nop) (br_if 1 0) (i32.const 0)) + ) + (func (export "as-br_if-everywhere") (param i32) (result i32) + (block + (nop) (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) + (br_if 1 0) + (i32.const 0) + ) + ) + + (func (export "as-br_table-mid") (param i32) (result i32) + (block (get_local 0) (nop) (get_local 0) (br_table 1 0 0)) + ) + (func (export "as-br_table-last") (param i32) (result i32) + (block (get_local 0) (get_local 0) (nop) (br_table 1 0 0)) + ) + (func (export "as-br_table-everywhere") (param i32) (result i32) + (block + (nop) (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) + (br_table 1 0 0) + ) + ) + + (func (export "as-return-last") (param i32) (result i32) + (get_local 0) (nop) (return) + ) + (func (export "as-return-everywhere") (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) (return) + ) + + (func (export "as-call-mid1") (param i32 i32 i32) (result i32) + (get_local 0) (nop) (get_local 1) (get_local 2) (call $3-ary) + ) + (func (export "as-call-mid2") (param i32 i32 i32) (result i32) + (get_local 0) (get_local 1) (nop) (get_local 2) (call $3-ary) + ) + (func (export "as-call-last") (param i32 i32 i32) (result i32) + (get_local 0) (get_local 1) (get_local 2) (nop) (call $3-ary) + ) + (func (export "as-call-everywhere") (param i32 i32 i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) (get_local 1) + (nop) (nop) (get_local 2) (nop) (nop) (call $3-ary) + ) + + ;; TODO(stack): call_indirect, *_local, load*, store* + + (func (export "as-unary-last") (param i32) (result i32) + (get_local 0) (nop) (i32.ctz) + ) + (func (export "as-unary-everywhere") (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) (i32.ctz) + ) + + (func (export "as-binary-mid") (param i32) (result i32) + (get_local 0) (nop) (get_local 0) (i32.add) + ) + (func (export "as-binary-last") (param i32) (result i32) + (get_local 0) (get_local 0) (nop) (i32.add) + ) + (func (export "as-binary-everywhere") (param i32) (result i32) + (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) (i32.add) + ) + + (func (export "as-test-last") (param i32) (result i32) + (get_local 0) (nop) (i32.eqz) + ) + (func (export "as-test-everywhere") (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) i32.eqz + ) + + (func (export "as-compare-mid") (param i32) (result i32) + (get_local 0) (nop) (get_local 0) (i32.ne) + ) + (func (export "as-compare-last") (param i32) (result i32) + (get_local 0) (get_local 0) (nop) (i32.lt_u) + ) + (func (export "as-compare-everywhere") (param i32) (result i32) + (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) (i32.le_s) + ) + + (func (export "as-grow_memory-last") (param i32) (result i32) + (get_local 0) (nop) (grow_memory) + ) + (func (export "as-grow_memory-everywhere") (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) (grow_memory) ) ) (assert_return (invoke "as-func-first") (i32.const 1)) (assert_return (invoke "as-func-mid") (i32.const 2)) -(assert_return (invoke "as-func-last")) +(assert_return (invoke "as-func-last") (i32.const 3)) +(assert_return (invoke "as-func-everywhere") (i32.const 4)) + +(assert_return (invoke "as-drop-last" (i32.const 0))) +(assert_return (invoke "as-drop-everywhere" (i32.const 0))) + +(assert_return (invoke "as-select-mid1" (i32.const 3)) (i32.const 3)) +(assert_return (invoke "as-select-mid2" (i32.const 3)) (i32.const 3)) +(assert_return (invoke "as-select-last" (i32.const 3)) (i32.const 3)) +(assert_return (invoke "as-select-everywhere" (i32.const 3)) (i32.const 3)) (assert_return (invoke "as-block-first") (i32.const 2)) (assert_return (invoke "as-block-mid") (i32.const 2)) -(assert_return (invoke "as-block-last")) +(assert_return (invoke "as-block-last") (i32.const 3)) +(assert_return (invoke "as-block-everywhere") (i32.const 4)) (assert_return (invoke "as-loop-first") (i32.const 2)) (assert_return (invoke "as-loop-mid") (i32.const 2)) -(assert_return (invoke "as-loop-last")) +(assert_return (invoke "as-loop-last") (i32.const 3)) +(assert_return (invoke "as-loop-everywhere") (i32.const 4)) +(assert_return (invoke "as-if-condition" (i32.const 0))) +(assert_return (invoke "as-if-condition" (i32.const -1))) (assert_return (invoke "as-if-then" (i32.const 0))) (assert_return (invoke "as-if-then" (i32.const 4))) (assert_return (invoke "as-if-else" (i32.const 0))) (assert_return (invoke "as-if-else" (i32.const 3))) +(assert_return (invoke "as-br-last" (i32.const 6)) (i32.const 6)) +(assert_return (invoke "as-br-everywhere" (i32.const 7)) (i32.const 7)) + +(assert_return (invoke "as-br_if-mid" (i32.const 5)) (i32.const 5)) +(assert_return (invoke "as-br_if-last" (i32.const 6)) (i32.const 6)) +(assert_return (invoke "as-br_if-everywhere" (i32.const 7)) (i32.const 7)) + +(assert_return (invoke "as-br_table-mid" (i32.const 5)) (i32.const 5)) +(assert_return (invoke "as-br_table-last" (i32.const 6)) (i32.const 6)) +(assert_return (invoke "as-br_table-everywhere" (i32.const 7)) (i32.const 7)) + +(assert_return (invoke "as-return-last" (i32.const 6)) (i32.const 6)) +(assert_return (invoke "as-return-everywhere" (i32.const 7)) (i32.const 7)) + +(assert_return (invoke "as-call-mid1" (i32.const 3) (i32.const 1) (i32.const 2)) (i32.const 2)) +(assert_return (invoke "as-call-mid2" (i32.const 0) (i32.const 3) (i32.const 1)) (i32.const 2)) +(assert_return (invoke "as-call-last" (i32.const 10) (i32.const 9) (i32.const -1)) (i32.const 20)) +(assert_return (invoke "as-call-everywhere" (i32.const 2) (i32.const 1) (i32.const 5)) (i32.const -2)) + +(assert_return (invoke "as-unary-last" (i32.const 30)) (i32.const 1)) +(assert_return (invoke "as-unary-everywhere" (i32.const 12)) (i32.const 2)) + +(assert_return (invoke "as-binary-mid" (i32.const 3)) (i32.const 6)) +(assert_return (invoke "as-binary-last" (i32.const 3)) (i32.const 6)) +(assert_return (invoke "as-binary-everywhere" (i32.const 3)) (i32.const 6)) + +(assert_return (invoke "as-test-last" (i32.const 0)) (i32.const 1)) +(assert_return (invoke "as-test-everywhere" (i32.const 0)) (i32.const 1)) + +(assert_return (invoke "as-compare-mid" (i32.const 3)) (i32.const 0)) +(assert_return (invoke "as-compare-last" (i32.const 3)) (i32.const 0)) +(assert_return (invoke "as-compare-everywhere" (i32.const 3)) (i32.const 1)) + +(assert_return (invoke "as-grow_memory-last" (i32.const 2)) (i32.const 1)) +(assert_return (invoke "as-grow_memory-everywhere" (i32.const 12)) (i32.const 3)) + (assert_invalid (module (func $type-i32 (result i32) (nop))) "type mismatch" diff --git a/ml-proto/test/return.wast b/ml-proto/test/return.wast index f701416238..c4b5366684 100644 --- a/ml-proto/test/return.wast +++ b/ml-proto/test/return.wast @@ -10,7 +10,7 @@ (func (export "type-f64") (drop (f64.neg (return)))) (func (export "nullary") (return)) - (func (export "unary") (result f64) (return (f64.const 3.1))) + (func (export "unary") (result f64) (return (f64.const 3))) (func (export "as-func-first") (result i32) (return (i32.const 1)) (i32.const 2) @@ -185,7 +185,7 @@ (assert_return (invoke "type-f64")) (assert_return (invoke "nullary")) -(assert_return (invoke "unary") (f64.const 3.1)) +(assert_return (invoke "unary") (f64.const 3)) (assert_return (invoke "as-func-first") (i32.const 1)) (assert_return (invoke "as-func-mid") (i32.const 2)) @@ -258,17 +258,13 @@ (assert_return (invoke "as-grow_memory-size") (i32.const 40)) -(assert_invalid - (module (func $type-value-void-vs-empty (return (nop)))) - "arity mismatch" -) -(assert_invalid - (module (func $type-value-num-vs-empty (return (i32.const 0)))) - "arity mismatch" -) +;; TODO(stack): move these somewhere else +(module (func $type-value-void-vs-empty (return (nop)))) +(module (func $type-value-num-vs-empty (return (i32.const 0)))) + (assert_invalid (module (func $type-value-empty-vs-num (result f64) (return))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-value-void-vs-num (result f64) (return (nop)))) diff --git a/ml-proto/test/select.wast b/ml-proto/test/select.wast index f77b88f023..a2406017f3 100644 --- a/ml-proto/test/select.wast +++ b/ml-proto/test/select.wast @@ -53,5 +53,5 @@ (assert_invalid (module (func $arity-0 (select (nop) (nop) (i32.const 1)))) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/stack.wast b/ml-proto/test/stack.wast new file mode 100644 index 0000000000..1cf5ea2b01 --- /dev/null +++ b/ml-proto/test/stack.wast @@ -0,0 +1,133 @@ +(module + (func (export "fac-expr") (param $n i64) (result i64) + (local $i i64) + (local $res i64) + (set_local $i (get_local $n)) + (set_local $res (i64.const 1)) + (block $done + (loop $loop + (if + (i64.eq (get_local $i) (i64.const 0)) + (br $done) + (block + (set_local $res (i64.mul (get_local $i) (get_local $res))) + (set_local $i (i64.sub (get_local $i) (i64.const 1))) + ) + ) + (br $loop) + ) + ) + (get_local $res) + ) + + (func (export "fac-stack") (param $n i64) (result i64) + (local $i i64) + (local $res i64) + (get_local $n) + (set_local $i) + (i64.const 1) + (set_local $res) + (block $done + (loop $loop + (get_local $i) + (i64.const 0) + (i64.eq) + (if + (then (br 0 $done)) + (else + (get_local $i) + (get_local $res) + (i64.mul) + (set_local $res) + (get_local $i) + (i64.const 1) + (i64.sub) + (set_local $i) + ) + ) + (br 0 $loop) + ) + ) + (get_local $res) + ) + + (func (export "fac-stack-raw") (param $n i64) (result i64) + (local $i i64) + (local $res i64) + get_local $n + set_local $i + i64.const 1 + set_local $res + block $done + loop $loop + get_local $i + i64.const 0 + i64.eq + if + br 0 $done + else + get_local $i + get_local $res + i64.mul + set_local $res + get_local $i + i64.const 1 + i64.sub + set_local $i + end + br 0 $loop + end + end + get_local $res + ) + + (func (export "fac-mixed") (param $n i64) (result i64) + (local $i i64) + (local $res i64) + (set_local $i (get_local $n)) + (set_local $res (i64.const 1)) + (block $done + (loop $loop + (i64.eq (get_local $i) (i64.const 0)) + (if + (then (br 0 $done)) + (else + (i64.mul (get_local $i) (get_local $res)) + (set_local $res) + (i64.sub (get_local $i) (i64.const 1)) + (set_local $i) + ) + ) + (br $loop) + ) + ) + (get_local $res) + ) + + (func (export "fac-mixed-raw") (param $n i64) (result i64) + (local $i i64) + (local $res i64) + (set_local $i (get_local $n)) + (set_local $res (i64.const 1)) + block $done + loop $loop + (i64.eq (get_local $i) (i64.const 0)) + if + br 0 $done + else + (i64.mul (get_local $i) (get_local $res)) + set_local $res + (i64.sub (get_local $i) (i64.const 1)) + set_local $i + end + br 0 $loop + end + end + get_local $res + ) +) + +(assert_return (invoke "fac-expr" (i64.const 25)) (i64.const 7034535277573963776)) +(assert_return (invoke "fac-stack" (i64.const 25)) (i64.const 7034535277573963776)) +(assert_return (invoke "fac-mixed" (i64.const 25)) (i64.const 7034535277573963776)) + diff --git a/ml-proto/test/start.wast b/ml-proto/test/start.wast index faaf104f4b..a20c449be9 100644 --- a/ml-proto/test/start.wast +++ b/ml-proto/test/start.wast @@ -1,20 +1,20 @@ (assert_invalid (module (func) (start 1)) - "unknown function 1" + "unknown function" ) (assert_invalid (module (func $main (result i32) (return (i32.const 0))) (start $main) ) - "start function must not return anything" + "start function" ) (assert_invalid (module (func $main (param $a i32)) (start $main) ) - "start function must be nullary" + "start function" ) (module (memory (data "A")) diff --git a/ml-proto/test/store_retval.wast b/ml-proto/test/store_retval.wast index 3f4579cd9e..fdbfe3f0e0 100644 --- a/ml-proto/test/store_retval.wast +++ b/ml-proto/test/store_retval.wast @@ -2,56 +2,56 @@ (assert_invalid (module (func (param i32) (result i32) (set_local 0 (i32.const 1)))) - "type mismatch: expression has type () but the context requires i32" + "type mismatch" ) (assert_invalid (module (func (param i64) (result i64) (set_local 0 (i64.const 1)))) - "type mismatch: expression has type () but the context requires i64" + "type mismatch" ) (assert_invalid (module (func (param f32) (result f32) (set_local 0 (f32.const 1)))) - "type mismatch: expression has type () but the context requires f32" + "type mismatch" ) (assert_invalid (module (func (param f64) (result f64) (set_local 0 (f64.const 1)))) - "type mismatch: expression has type () but the context requires f64" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i32) (result i32) (i32.store (i32.const 0) (i32.const 1)))) - "type mismatch: expression has type () but the context requires i32" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i64) (result i64) (i64.store (i32.const 0) (i64.const 1)))) - "type mismatch: expression has type () but the context requires i64" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param f32) (result f32) (f32.store (i32.const 0) (f32.const 1)))) - "type mismatch: expression has type () but the context requires f32" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param f64) (result f64) (f64.store (i32.const 0) (f64.const 1)))) - "type mismatch: expression has type () but the context requires f64" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i32) (result i32) (i32.store8 (i32.const 0) (i32.const 1)))) - "type mismatch: expression has type () but the context requires i32" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i32) (result i32) (i32.store16 (i32.const 0) (i32.const 1)))) - "type mismatch: expression has type () but the context requires i32" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i64) (result i64) (i64.store8 (i32.const 0) (i64.const 1)))) - "type mismatch: expression has type () but the context requires i64" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i64) (result i64) (i64.store16 (i32.const 0) (i64.const 1)))) - "type mismatch: expression has type () but the context requires i64" + "type mismatch" ) (assert_invalid (module (memory 1) (func (param i64) (result i64) (i64.store32 (i32.const 0) (i64.const 1)))) - "type mismatch: expression has type () but the context requires i64" + "type mismatch" ) diff --git a/ml-proto/test/typecheck.wast b/ml-proto/test/typecheck.wast index ef7e9e9cd7..c165b01991 100644 --- a/ml-proto/test/typecheck.wast +++ b/ml-proto/test/typecheck.wast @@ -1,6 +1,231 @@ +;; TODO: move all tests in this file to appropriate operator-specific files. + ;; at least one valid module is required for the testing framework (module) +(assert_invalid + (module (func $type-unary-operand-missing + i32.eqz drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-unary-operand-missing-in-block + (i32.const 0) + block i32.eqz drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-unary-operand-missing-in-loop + (i32.const 0) + loop i32.eqz drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-unary-operand-missing-in-if + (i32.const 0) (i32.const 0) + if i32.eqz drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-unary-operand-missing-in-else + (i32.const 0) (i32.const 0) + if (i32.const 0) else i32.eqz end drop + )) + "type mismatch" +) + +(assert_invalid + (module (func $type-binary-1st-operand-missing + i32.add drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-2nd-operand-missing + (i32.const 0) i32.add drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-1st-operand-missing-in-block + (i32.const 0) (i32.const 0) + block i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-2nd-operand-missing-in-block + (i32.const 0) + block (i32.const 0) i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-1st-operand-missing-in-loop + (i32.const 0) (i32.const 0) + loop i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-2nd-operand-missing-in-loop + (i32.const 0) + loop (i32.const 0) i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-1st-operand-missing-in-if + (i32.const 0) (i32.const 0) (i32.const 0) + if i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-2nd-operand-missing-in-if + (i32.const 0) (i32.const 0) + if (i32.const 0) i32.add drop end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-1st-operand-missing-in-else + (i32.const 0) (i32.const 0) (i32.const 0) + if (i32.const 0) (i32.const 0) else i32.add (i32.const 0) end + drop drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-binary-2nd-operand-missing-in-else + (i32.const 0) (i32.const 0) + if (i32.const 0) (i32.const 0) else i32.add end + drop + )) + "type mismatch" +) + +(assert_invalid + (module (func $type-if-operand-missing + if end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-if-operand-missing-in-block + (i32.const 0) + block if end end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-if-operand-missing-in-loop + (i32.const 0) + loop if end end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-if-operand-missing-in-if + (i32.const 0) (i32.const 0) + if if end end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-if-operand-missing-in-else + (i32.const 0) (i32.const 0) + if (i32.const 0) else if end (i32.const 0) end + drop + )) + "type mismatch" +) + +(assert_invalid + (module (func $type-br-operand-missing + block br 1 0 end + i32.eqz drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-br-operand-missing-in-block + (i32.const 0) + block br 1 0 end + i32.eqz drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-br-operand-missing-in-loop + (i32.const 0) + loop br 1 0 end + i32.eqz drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-br-operand-missing-in-if + block + (i32.const 0) (i32.const 0) + if br 1 0 end + end + i32.eqz drop + )) + "type mismatch" +) +(assert_invalid + (module (func $type-br-operand-missing-in-else + block + (i32.const 0) (i32.const 0) + if (i32.const 0) else br 1 0 end + end + i32.eqz drop + )) + "type mismatch" +) + +(assert_invalid + (module (func $type-return-operand-missing (result i32) + return + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-block (result i32) + (i32.const 0) + block return end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-loop (result i32) + (i32.const 0) + loop return end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-if (result i32) + (i32.const 0) (i32.const 0) + if return end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-else (result i32) + (i32.const 0) (i32.const 0) + if (i32.const 0) else return end drop + )) + "type mismatch" +) + +;; TODO(stack): more of the above + ;; if condition (assert_invalid (module (func (if (f32.const 0) (nop) (nop)))) "type mismatch") diff --git a/ml-proto/test/unreachable.wast b/ml-proto/test/unreachable.wast index 07e1808d8a..97baf9985e 100644 --- a/ml-proto/test/unreachable.wast +++ b/ml-proto/test/unreachable.wast @@ -49,7 +49,7 @@ (loop (nop) (call $dummy) (unreachable)) ) (func (export "as-loop-broke") (result i32) - (loop (call $dummy) (br 1 (i32.const 1)) (unreachable)) + (block (loop (call $dummy) (br 1 (i32.const 1)) (unreachable))) ) (func (export "as-br-value") (result i32) diff --git a/ml-proto/winmake.bat b/ml-proto/winmake.bat index 49c1fcc0d1..78bf04c71d 100644 --- a/ml-proto/winmake.bat +++ b/ml-proto/winmake.bat @@ -1,86 +1,92 @@ rem Auto-generated from Makefile! set NAME=wasm if '%1' neq '' set NAME=%1 -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/float.cmo spec/float.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/numerics.cmi spec/numerics.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/int.cmo spec/int.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/i32.cmo spec/i32.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/f32.cmo spec/f32.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/f64.cmo spec/f64.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/i64.cmo spec/i64.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/types.cmo spec/types.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/values.cmo spec/values.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/memory.cmi spec/memory.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/numeric_error.cmo spec/numeric_error.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/int.cmo spec/int.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/i32.cmo spec/i32.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/float.cmo spec/float.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/types.cmo spec/types.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/f32.cmo spec/f32.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/f64.cmo spec/f64.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/i64.cmo spec/i64.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/values.cmo spec/values.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/memory.cmi spec/memory.mli ocamlc.opt -c -bin-annot -I given -I spec -I host -I host/import -o given/source.cmi given/source.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/kernel.cmo spec/kernel.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/ast.cmo spec/ast.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/table.cmi spec/table.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/instance.cmo spec/instance.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/eval.cmi spec/eval.mli -ocamlc.opt -c -bin-annot -I given -I spec -I host -I host/import -o given/lib.cmi given/lib.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/ast.cmo spec/ast.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/table.cmi spec/table.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/instance.cmo spec/instance.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/eval.cmi spec/eval.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/print.cmi host/print.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/encode.cmi host/encode.mli -ocamlc.opt -c -bin-annot -I host/import -I spec -I host -I given -o host/import/env.cmo host/import/env.ml +ocamlc.opt -c -bin-annot -I host/import -I spec -I given -I host -o host/import/env.cmo host/import/env.ml ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/flags.cmo host/flags.ml ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/import.cmi host/import.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/run.cmi host/run.mli -ocamlc.opt -c -bin-annot -I host/import -I spec -I host -I given -o host/import/spectest.cmo host/import/spectest.ml +ocamlc.opt -c -bin-annot -I host/import -I spec -I given -I host -o host/import/spectest.cmo host/import/spectest.ml ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/main.cmo host/main.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/main.d.cmo host/main.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/error.cmi spec/error.mli +ocamlc.opt -c -bin-annot -I given -I spec -I host -I host/import -o given/lib.cmi given/lib.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/error.cmi spec/error.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/sexpr.cmi host/sexpr.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/script.cmi host/script.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/arrange.cmi host/arrange.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/check.cmi spec/check.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/decode.cmi spec/decode.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/desugar.cmi spec/desugar.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/check.cmi spec/check.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/decode.cmi spec/decode.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/parse.cmi host/parse.mli ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/encode.d.cmo host/encode.ml -ocamlc.opt -c -g -bin-annot -I host/import -I spec -I host -I given -o host/import/env.d.cmo host/import/env.ml +ocamlc.opt -c -g -bin-annot -I host/import -I spec -I given -I host -o host/import/env.d.cmo host/import/env.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/flags.d.cmo host/flags.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/import.d.cmo host/import.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/run.d.cmo host/run.ml -ocamlc.opt -c -g -bin-annot -I host/import -I spec -I host -I given -o host/import/spectest.d.cmo host/import/spectest.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/ast.d.cmo spec/ast.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/f32.d.cmo spec/f32.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/f64.d.cmo spec/f64.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/i32.d.cmo spec/i32.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/kernel.d.cmo spec/kernel.ml +ocamlc.opt -c -g -bin-annot -I host/import -I spec -I given -I host -o host/import/spectest.d.cmo host/import/spectest.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/ast.d.cmo spec/ast.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/f32.d.cmo spec/f32.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/f64.d.cmo spec/f64.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/i32.d.cmo spec/i32.ml ocamlc.opt -c -g -bin-annot -I given -I spec -I host -I host/import -o given/lib.d.cmo given/lib.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/memory.d.cmo spec/memory.ml ocamlc.opt -c -g -bin-annot -I given -I spec -I host -I host/import -o given/source.d.cmo given/source.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/types.d.cmo spec/types.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/i64.d.cmo spec/i64.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/memory.d.cmo spec/memory.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/float.d.cmo spec/float.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/int.d.cmo spec/int.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/numerics.d.cmo spec/numerics.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/values.d.cmo spec/values.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/arithmetic.cmi spec/arithmetic.mli -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/eval.d.cmo spec/eval.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/instance.d.cmo spec/instance.ml -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/f32_convert.cmi spec/f32_convert.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/f64_convert.cmi spec/f64_convert.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/i32_convert.cmi spec/i32_convert.mli -ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/i64_convert.cmi spec/i64_convert.mli -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/arithmetic.d.cmo spec/arithmetic.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/error.d.cmo spec/error.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/table.d.cmo spec/table.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/f32_convert.d.cmo spec/f32_convert.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/f64_convert.d.cmo spec/f64_convert.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/i32_convert.d.cmo spec/i32_convert.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/i64_convert.d.cmo spec/i64_convert.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/types.d.cmo spec/types.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/values.d.cmo spec/values.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/i64.d.cmo spec/i64.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/float.d.cmo spec/float.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/int.d.cmo spec/int.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/numeric_error.d.cmo spec/numeric_error.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/eval_numeric.cmi spec/eval_numeric.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/i64_convert.cmi spec/i64_convert.mli +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/eval.d.cmo spec/eval.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/instance.d.cmo spec/instance.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/f32_convert.cmi spec/f32_convert.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/f64_convert.cmi spec/f64_convert.mli +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/i32_convert.cmi spec/i32_convert.mli +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/error.d.cmo spec/error.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/eval_numeric.d.cmo spec/eval_numeric.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/i64_convert.d.cmo spec/i64_convert.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/table.d.cmo spec/table.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/f32_convert.d.cmo spec/f32_convert.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/f64_convert.d.cmo spec/f64_convert.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/i32_convert.d.cmo spec/i32_convert.ml +ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/operators.cmo spec/operators.ml ocamlyacc host/parser.mly ++ ocamlyacc host/parser.mly +1 reduce/reduce conflict. ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/parser.cmi host/parser.mli ocamlc.opt -c -bin-annot -I host -I spec -I given -I host/import -o host/lexer.cmi host/lexer.mli ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/arrange.d.cmo host/arrange.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/check.d.cmo spec/check.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/decode.d.cmo spec/decode.ml -ocamlc.opt -c -g -bin-annot -I spec -I host -I given -I host/import -o spec/desugar.d.cmo spec/desugar.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/check.d.cmo spec/check.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/decode.d.cmo spec/decode.ml ++ ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/decode.d.cmo spec/decode.ml +File "spec/decode.ml", line 645, characters 2-31: +Warning 5: this function application is partial, +maybe some arguments are missing. +File "spec/decode.ml", line 644, characters 6-8: +Warning 26: unused variable id. ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/parse.d.cmo host/parse.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/script.d.cmo host/script.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/sexpr.d.cmo host/sexpr.ml +ocamlc.opt -c -g -bin-annot -I spec -I given -I host -I host/import -o spec/operators.d.cmo spec/operators.ml ocamllex.opt -q host/lexer.mll ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/lexer.d.cmo host/lexer.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/parser.d.cmo host/parser.ml ocamlc.opt -c -g -bin-annot -I host -I spec -I given -I host/import -o host/print.d.cmo host/print.ml -ocamlc.opt str.cma bigarray.cma -g given/lib.d.cmo given/source.d.cmo spec/float.d.cmo spec/f32.d.cmo spec/f64.d.cmo spec/numerics.d.cmo spec/int.d.cmo spec/i32.d.cmo spec/i64.d.cmo spec/types.d.cmo spec/values.d.cmo spec/memory.d.cmo spec/kernel.d.cmo spec/ast.d.cmo host/encode.d.cmo host/flags.d.cmo spec/error.d.cmo spec/table.d.cmo spec/instance.d.cmo host/import.d.cmo spec/i32_convert.d.cmo spec/f32_convert.d.cmo spec/i64_convert.d.cmo spec/f64_convert.d.cmo spec/arithmetic.d.cmo spec/eval.d.cmo host/import/env.d.cmo host/print.d.cmo host/import/spectest.d.cmo host/sexpr.d.cmo host/arrange.d.cmo spec/check.d.cmo spec/decode.d.cmo spec/desugar.d.cmo host/script.d.cmo host/parser.d.cmo host/lexer.d.cmo host/parse.d.cmo host/run.d.cmo host/main.d.cmo -o %NAME% +ocamlc.opt str.cma bigarray.cma -g given/lib.d.cmo given/source.d.cmo spec/float.d.cmo spec/f32.d.cmo spec/f64.d.cmo spec/numeric_error.d.cmo spec/int.d.cmo spec/i32.d.cmo spec/i64.d.cmo spec/types.d.cmo spec/values.d.cmo spec/memory.d.cmo spec/ast.d.cmo host/encode.d.cmo host/flags.d.cmo spec/error.d.cmo spec/table.d.cmo spec/instance.d.cmo host/import.d.cmo spec/i32_convert.d.cmo spec/f32_convert.d.cmo spec/i64_convert.d.cmo spec/f64_convert.d.cmo spec/eval_numeric.d.cmo spec/eval.d.cmo host/import/env.d.cmo host/print.d.cmo host/import/spectest.d.cmo host/sexpr.d.cmo host/arrange.d.cmo spec/check.d.cmo spec/operators.d.cmo spec/decode.d.cmo host/script.d.cmo host/parser.d.cmo host/lexer.d.cmo host/parse.d.cmo host/run.d.cmo host/main.d.cmo -o %NAME%