From 562373144e63db4147f44535b543ae0d8be8e1ff Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 13:36:31 +0200 Subject: [PATCH 01/44] Allow nullary blocks --- ml-proto/host/format.ml | 6 +++--- ml-proto/spec/check.ml | 8 ++++++-- ml-proto/spec/desugar.ml | 18 +++++------------- ml-proto/spec/eval.ml | 8 ++++++-- ml-proto/spec/kernel.ml | 2 +- 5 files changed, 21 insertions(+), 21 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 80001e421a..f3f4fe2ebe 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -196,8 +196,8 @@ let rec expr e = | Nop -> "nop", [] | Unreachable -> "unreachable", [] | Drop e -> "drop", [expr e] - | Block ([], {it = Loop e; _}) -> "loop", [expr e] - | Block (es, e) -> "block", list expr (es @ [e]) + | Block ([{it = Loop e; _}]) -> "loop", [expr e] + | Block es -> "block", list expr es | 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] @@ -232,7 +232,7 @@ let rec expr e = and block e = match e.it with - | Block (es, e) -> list expr (es @ [e]) + | Block es -> list expr es | Nop -> [] | _ -> assert false (* TODO *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 508317ea42..87ae78910a 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -135,9 +135,13 @@ let rec check_expr c et e = check_expr c (some_unknown ()) e; check_type None et e.at - | Block (es, e) -> + | Block [] -> + check_type None et e.at + + | Block es -> + let es', e = Lib.List.split_last es in let c' = {c with labels = et :: c.labels} in - List.iter (check_expr c' none) es; + List.iter (check_expr c' none) es'; check_expr c' et e | Loop e1 -> diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index b48b09a24c..5fce7702bf 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -12,8 +12,7 @@ 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) + | Block es -> Block (List.map (relabel f (n + 1)) es) | Loop e -> Loop (relabel f (n + 1) e) | Break (x, eo) -> Break (relabel_var f n x, Lib.Option.map (relabel f n) eo) @@ -64,10 +63,8 @@ and expr' at = function | 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.Block es -> Block (List.map expr es) + | 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) -> @@ -281,16 +278,11 @@ and expr' at = function 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 + | es -> Block (List.map expr es) @@@ 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 + | es -> Block (List.map label (List.map expr es)) @@@ List.map Source.at es (* Functions and Modules *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index a7260a01f5..fdf26694a0 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -137,11 +137,15 @@ let rec eval_expr (c : config) (e : expr) = ignore (eval_expr c e); None - | Block (es, e) -> + | Block [] -> + None + + | Block es -> + let es', e = Lib.List.split_last es in let module L = MakeLabel () in let c' = {c with labels = L.label :: c.labels} in (try - List.iter (fun eI -> ignore (eval_expr c' eI)) es; + List.iter (fun eI -> ignore (eval_expr c' eI)) es'; eval_expr c' e with L.Label vo -> vo) diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index 50137a498b..02b2d3770b 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -79,7 +79,7 @@ and expr' = | Nop (* do nothing *) | Unreachable (* trap *) | Drop of expr (* forget a value *) - | Block of expr list * expr (* execute in sequence *) + | Block of expr list (* 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 *) From c25d4ac10f6d961603afe554652604f01701baf6 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 14:02:16 +0200 Subject: [PATCH 02/44] Allow n-ary loop --- ml-proto/host/format.ml | 2 +- ml-proto/spec/check.ml | 21 +++++++++++++-------- ml-proto/spec/desugar.ml | 8 ++------ ml-proto/spec/eval.ml | 20 ++++++++++---------- ml-proto/spec/kernel.ml | 2 +- 5 files changed, 27 insertions(+), 26 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index f3f4fe2ebe..025ece2c88 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -196,7 +196,7 @@ let rec expr e = | Nop -> "nop", [] | Unreachable -> "unreachable", [] | Drop e -> "drop", [expr e] - | Block ([{it = Loop e; _}]) -> "loop", [expr e] + | Block [{it = Loop es; _}] -> "loop", list expr es | Block es -> "block", list expr es | Loop e -> assert false | Break (x, eo) -> "br " ^ var x, opt expr eo diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 87ae78910a..90df15ebb3 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -135,18 +135,13 @@ let rec check_expr c et e = check_expr c (some_unknown ()) e; check_type None et e.at - | Block [] -> - check_type None et e.at - | Block es -> - let es', e = Lib.List.split_last es in let c' = {c with labels = et :: c.labels} in - List.iter (check_expr c' none) es'; - check_expr c' et e + check_block c' et es e.at - | Loop e1 -> + | Loop es -> let c' = {c with labels = none :: c.labels} in - check_expr c' et e1 + check_block c' et es e.at | Break (x, eo) -> check_expr_opt c (label c x) eo e.at @@ -249,6 +244,16 @@ let rec check_expr c et e = check_exprs c ins es e.at; check_type out et e.at +and check_block c et es at = + match es with + | [] -> + check_type None et at + + | _ -> + let es', e = Lib.List.split_last es in + List.iter (check_expr c none) es'; + check_expr c et e + and check_exprs c ts es at = require (List.length ts = List.length es) at "arity mismatch"; let ets = List.map some ts in diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 5fce7702bf..b445b404ed 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -13,7 +13,7 @@ and relabel' f n = function | Unreachable -> Unreachable | Drop e -> Drop (relabel f n e) | Block es -> Block (List.map (relabel f (n + 1)) es) - | Loop e -> Loop (relabel f (n + 1) e) + | Loop es -> Loop (List.map (relabel f (n + 1)) es) | Break (x, eo) -> Break (relabel_var f n x, Lib.Option.map (relabel f n) eo) | BreakIf (x, eo, e) -> @@ -64,7 +64,7 @@ and expr' at = function | Ast.Unreachable -> Unreachable | Ast.Drop e -> Drop (expr e) | Ast.Block es -> Block (List.map expr es) - | Ast.Loop es -> Block ([Loop (block es) @@ at]) + | Ast.Loop es -> Block [Loop (List.map expr 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) -> @@ -280,10 +280,6 @@ and seq = function | [] -> Nop @@ Source.no_region | es -> Block (List.map expr es) @@@ List.map Source.at es -and block = function - | [] -> Nop @@ Source.no_region - | es -> Block (List.map label (List.map expr es)) @@@ List.map Source.at es - (* Functions and Modules *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index fdf26694a0..509ca5b9e3 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -137,22 +137,15 @@ let rec eval_expr (c : config) (e : expr) = ignore (eval_expr c e); None - | Block [] -> - None - | Block es -> - let es', e = Lib.List.split_last es in let module L = MakeLabel () in let c' = {c with labels = L.label :: c.labels} in - (try - List.iter (fun eI -> ignore (eval_expr c' eI)) es'; - eval_expr c' e - with L.Label vo -> vo) + (try eval_block c' es with L.Label vo -> vo) - | Loop e1 -> + | Loop es -> 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) + (try eval_block c' es with L.Label _ -> eval_expr c e) | Break (x, eo) -> raise (label c x (eval_expr_opt c eo)) @@ -270,6 +263,13 @@ let rec eval_expr (c : config) (e : expr) = let vs = List.map (eval_expr c) es in eval_hostop c hostop vs e.at +and eval_block c = function + | [] -> None + | es -> + let es', e = Lib.List.split_last es in + List.iter (fun eI -> ignore (eval_expr c eI)) es'; + eval_expr c e + and eval_expr_opt c = function | Some e -> eval_expr c e | None -> None diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index 02b2d3770b..f137a80069 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -80,7 +80,7 @@ and expr' = | Unreachable (* trap *) | Drop of expr (* forget a value *) | Block of expr list (* execute in sequence *) - | Loop of expr (* loop header *) + | Loop of expr list (* 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 *) From c0622227c51805e847828cb8e509039d74dd9314 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 14:42:01 +0200 Subject: [PATCH 03/44] Allow n-ary if --- ml-proto/host/format.ml | 4 ++-- ml-proto/spec/check.ml | 11 ++++++----- ml-proto/spec/desugar.ml | 8 ++++++-- ml-proto/spec/eval.ml | 16 ++++++++++------ ml-proto/spec/kernel.ml | 2 +- 5 files changed, 25 insertions(+), 16 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 025ece2c88..2ecfa5b4a7 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -203,8 +203,8 @@ let rec expr e = | 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 + | If (e1, es1, es2) -> + (match list expr es1, list expr es2 with | [sx2], [] -> "if", [expr e1; sx2] | [sx2], [sx3] -> "if", [expr e1; sx2; sx3] | sxs2, [] -> "if", [expr e1; Node ("then", sxs2)] diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 90df15ebb3..db819ef4b8 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -131,8 +131,8 @@ let rec check_expr c et e = | Unreachable -> () - | Drop e -> - check_expr c (some_unknown ()) e; + | Drop e1 -> + check_expr c (some_unknown ()) e1; check_type None et e.at | Block es -> @@ -156,10 +156,11 @@ let rec check_expr c et e = check_expr_opt c (label c x) eo e.at; check_expr c (some Int32Type) e1 - | If (e1, e2, e3) -> + | If (e1, es1, es2) -> check_expr c (some Int32Type) e1; - check_expr c et e2; - check_expr c et e3 + let c' = {c with labels = et :: c.labels} in + check_block c' et es1 e.at; + check_block c' et es2 e.at | Select (e1, e2, e3) -> require (is_some et) e.at "arity mismatch"; diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index b445b404ed..513691ad73 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -22,7 +22,11 @@ and relabel' f n = function 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) + | If (e1, es1, es2) -> + If + (relabel f n e1, + List.map (relabel f (n + 1)) es1, + List.map (relabel f (n + 1)) es2) | 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) @@ -70,7 +74,7 @@ and expr' at = function | 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.If (e, es1, es2) -> If (expr e, List.map expr es1, List.map expr es2) | Ast.Select (e1, e2, e3) -> Select (expr e1, expr e2, expr e3) | Ast.Call (x, es) -> Call (x, List.map expr es) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 509ca5b9e3..272de52354 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -133,8 +133,8 @@ let rec eval_expr (c : config) (e : expr) = | Unreachable -> Trap.error e.at "unreachable executed" - | Drop e -> - ignore (eval_expr c e); + | Drop e1 -> + ignore (eval_expr c e1); None | Block es -> @@ -162,9 +162,11 @@ let rec eval_expr (c : config) (e : expr) = then raise (label c (List.nth xs (Int32.to_int i)) v) else raise (label c x v) - | If (e1, e2, e3) -> + | If (e1, es1, es2) -> let i = int32 (eval_expr c e1) e1.at in - eval_expr c (if i <> 0l then e2 else e3) + let module L = MakeLabel () in + let c' = {c with labels = L.label :: c.labels} in + (try eval_block c' (if i <> 0l then es1 else es2) with L.Label vo -> vo) | Select (e1, e2, e3) -> let v1 = some (eval_expr c e1) e1.at in @@ -264,9 +266,11 @@ let rec eval_expr (c : config) (e : expr) = eval_hostop c hostop vs e.at and eval_block c = function - | [] -> None + | [] -> + None + | es -> - let es', e = Lib.List.split_last es in + let es', e = Lib.List.split_last es in List.iter (fun eI -> ignore (eval_expr c eI)) es'; eval_expr c e diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index f137a80069..d1131c8ae1 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -84,7 +84,7 @@ and expr' = | 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 *) + | If of expr * expr list * expr list (* conditional *) | Select of expr * expr * expr (* branchless conditional *) | Call of var * expr list (* call function *) | CallImport of var * expr list (* call imported function *) From 97c2443f7125d39ac6f89d7bbe289f29d905d220 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 14:48:51 +0200 Subject: [PATCH 04/44] Allow n-ary func bodies --- ml-proto/host/format.ml | 8 +------- ml-proto/spec/check.ml | 8 ++++++-- ml-proto/spec/desugar.ml | 9 +++------ ml-proto/spec/eval.ml | 5 +++-- ml-proto/spec/kernel.ml | 2 +- 5 files changed, 14 insertions(+), 18 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 2ecfa5b4a7..8eb00e3168 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -230,12 +230,6 @@ let rec expr e = | Host (op, es) -> hostop op, list expr es in Node (head, inner) -and block e = - match e.it with - | Block es -> list expr es - | Nop -> [] - | _ -> assert false (* TODO *) - (* Functions *) @@ -244,7 +238,7 @@ let func i f = Node ("func $" ^ string_of_int i, [Node ("type " ^ var ftype, [])] @ decls "local" locals @ - block body + list expr body ) let start x = Node ("start " ^ var x, []) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index db819ef4b8..f079361393 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -311,8 +311,12 @@ and check_mem_type ty sz at = let check_func c f = let {ftype; locals; body} = f.it in let s = type_ c.types ftype in - let c' = {c with locals = s.ins @ locals; return = s.out} in - check_expr c' (known s.out) body + let c' = + {c with + locals = s.ins @ locals; + return = s.out; + labels = known s.out :: c.labels} + in check_block c' (known s.out) body f.at let check_elem c x = ignore (func c x) diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 513691ad73..9b792a4335 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -52,7 +52,7 @@ and relabel' f n = function 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 +let return e = relabel (fun n i -> if i = -1 then n else i) 0 e (* Expressions *) @@ -280,16 +280,13 @@ and expr' at = function | Ast.Current_memory -> Host (CurrentMemory, []) | Ast.Grow_memory e -> Host (GrowMemory, [expr e]) -and seq = function - | [] -> Nop @@ Source.no_region - | es -> Block (List.map expr es) @@@ List.map Source.at es - (* Functions and Modules *) let rec func f = func' f.it @@ f.at and func' = function - | {Ast.body = es; ftype; locals} -> {body = return (seq es); ftype; locals} + | {Ast.body = es; ftype; locals} -> + {body = List.map return (List.map expr es); ftype; locals} let rec module_ m = module' m.it @@ m.at and module' = function diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 272de52354..ba22ddaa72 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -282,11 +282,12 @@ and eval_func instance f vs = 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 - let c = {instance; locals; labels = []} in + let module L = MakeLabel () in + let c = {instance; locals; labels = [L.label]} in let ft = type_ c f.it.ftype in if List.length vs <> List.length ft.ins then Crash.error f.at "function called with wrong number of arguments"; - eval_expr c f.it.body + try eval_block c f.it.body with L.Label vo -> vo (* Host operators *) diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index d1131c8ae1..73ae69906f 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -112,7 +112,7 @@ and func' = { ftype : var; locals : value_type list; - body : expr; + body : expr list; } From 27f4e1b3b08fae93ec5abace0d124443bce623ac Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 15:02:27 +0200 Subject: [PATCH 05/44] Make return primitive --- ml-proto/host/format.ml | 1 + ml-proto/spec/check.ml | 3 +++ ml-proto/spec/desugar.ml | 54 ++-------------------------------------- ml-proto/spec/eval.ml | 3 +++ ml-proto/spec/kernel.ml | 1 + 5 files changed, 10 insertions(+), 52 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 8eb00e3168..b278734c45 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -203,6 +203,7 @@ let rec expr e = | 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] + | Return eo -> "return", opt expr eo | If (e1, es1, es2) -> (match list expr es1, list expr es2 with | [sx2], [] -> "if", [expr e1; sx2] diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index f079361393..2696ed4a69 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -156,6 +156,9 @@ let rec check_expr c et e = check_expr_opt c (label c x) eo e.at; check_expr c (some Int32Type) e1 + | Return eo -> + check_expr_opt c (known c.return) eo e.at + | If (e1, es1, es2) -> check_expr c (some Int32Type) e1; let c' = {c with labels = et :: c.labels} in diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 9b792a4335..5fec6269c9 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -5,56 +5,6 @@ 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 -> Block (List.map (relabel f (n + 1)) es) - | Loop es -> Loop (List.map (relabel f (n + 1)) es) - | 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, es1, es2) -> - If - (relabel f n e1, - List.map (relabel f (n + 1)) es1, - List.map (relabel f (n + 1)) es2) - | 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) - | CallImport (x, es) -> CallImport (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) - | 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) 0 e - - (* Expressions *) let rec expr e = expr' e.at e.it @@ e.at @@ -73,7 +23,7 @@ and expr' at = function | 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.Return eo -> Return (Lib.Option.map expr eo) | Ast.If (e, es1, es2) -> If (expr e, List.map expr es1, List.map expr es2) | Ast.Select (e1, e2, e3) -> Select (expr e1, expr e2, expr e3) @@ -286,7 +236,7 @@ and expr' at = function let rec func f = func' f.it @@ f.at and func' = function | {Ast.body = es; ftype; locals} -> - {body = List.map return (List.map expr es); ftype; locals} + {body = List.map expr es; ftype; locals} let rec module_ m = module' m.it @@ m.at and module' = function diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index ba22ddaa72..ca682117e6 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -162,6 +162,9 @@ let rec eval_expr (c : config) (e : expr) = then raise (label c (List.nth xs (Int32.to_int i)) v) else raise (label c x v) + | Return eo -> + raise (Lib.List.last c.labels (eval_expr_opt c eo)) + | If (e1, es1, es2) -> let i = int32 (eval_expr c e1) e1.at in let module L = MakeLabel () in diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index 73ae69906f..e743db40cc 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -84,6 +84,7 @@ and expr' = | 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 *) + | Return of expr option (* break from function body *) | If of expr * expr list * expr list (* conditional *) | Select of expr * expr * expr (* branchless conditional *) | Call of var * expr list (* call function *) From d23a7698b3cba022b49dd1e4e19f0a008e147bbd Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 15:10:36 +0200 Subject: [PATCH 06/44] Make memory operators primitive --- ml-proto/host/format.ml | 7 ++---- ml-proto/spec/check.ml | 22 +++++++----------- ml-proto/spec/desugar.ml | 4 ++-- ml-proto/spec/eval.ml | 50 +++++++++++++++------------------------- ml-proto/spec/kernel.ml | 6 ++--- 5 files changed, 33 insertions(+), 56 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index b278734c45..4c527d4f7e 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -179,10 +179,6 @@ let extop {memop = op; sz; ext} = let wrapop {memop = op; sz} = memop ("store" ^ mem_size sz) op -let hostop = function - | CurrentMemory -> "current_memory" - | GrowMemory -> "grow_memory" - (* Expressions *) @@ -228,7 +224,8 @@ let rec expr e = | 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 + | CurrentMemory -> "current_memory", [] + | GrowMemory e -> "grow_memory", [expr e] in Node (head, inner) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 2696ed4a69..41d2d8e734 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -99,15 +99,6 @@ let type_cvtop at = function | 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) - (* Type Analysis *) @@ -242,11 +233,14 @@ let rec check_expr c et e = 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 check_has_memory c e.at; - check_exprs c ins es e.at; - check_type out et e.at + | CurrentMemory -> + check_has_memory c e.at; + check_type (Some Int32Type) et e.at + + | GrowMemory e -> + check_has_memory c e.at; + check_expr c (some Int32Type) e; + check_type (Some Int32Type) et e.at and check_block c et es at = match es with diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 5fec6269c9..8927226c71 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -227,8 +227,8 @@ and expr' at = function | 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]) + | Ast.Current_memory -> CurrentMemory + | Ast.Grow_memory e -> GrowMemory (expr e) (* Functions and Modules *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index ca682117e6..bf96000b7c 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -264,9 +264,25 @@ let rec eval_expr (c : config) (e : expr) = (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 + | CurrentMemory -> + let mem = memory c e.at in + let size = Memory.size mem in + assert (I64.lt_u size (Int64.of_int32 Int32.max_int)); + Some (Int32 (Int64.to_int32 size)) + + | GrowMemory e1 -> + let mem = memory c e.at in + let delta = address32 (eval_expr c e1) e1.at in + let old_size = Memory.size mem in + let new_size = Int64.add old_size delta in + if I64.lt_u new_size old_size then + Trap.error e.at "memory size overflow"; + (* Test whether the new size overflows the memory type. + * Since we currently only support i32, just test that. *) + if I64.gt_u new_size (Int64.of_int32 Int32.max_int) then + Trap.error e.at "memory size exceeds implementation limit"; + Memory.grow mem delta; + Some (Int32 (Int64.to_int32 old_size)) and eval_block c = function | [] -> @@ -293,34 +309,6 @@ and eval_func instance f vs = try eval_block c f.it.body with L.Label vo -> vo -(* Host operators *) - -and eval_hostop c hostop vs at = - match hostop, vs with - | CurrentMemory, [] -> - let mem = memory c at in - let size = Memory.size mem in - assert (I64.lt_u size (Int64.of_int32 Int32.max_int)); - Some (Int32 (Int64.to_int32 size)) - - | GrowMemory, [v] -> - let mem = memory c at in - let delta = address32 v at in - let old_size = Memory.size mem in - let new_size = Int64.add old_size delta in - if I64.lt_u new_size old_size then - Trap.error at "memory size overflow"; - (* Test whether the new size overflows the memory type. - * Since we currently only support i32, just test that. *) - if I64.gt_u new_size (Int64.of_int32 Int32.max_int) then - Trap.error at "memory size exceeds implementation limit"; - Memory.grow mem delta; - Some (Int32 (Int64.to_int32 old_size)) - - | _, _ -> - Crash.error at "invalid invocation of host operator" - - (* Modules *) let init_memory {it = {min; segments; _}} = diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index e743db40cc..5d1574d93d 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -64,9 +64,6 @@ 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 *) @@ -103,7 +100,8 @@ and expr' = | 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 *) + | CurrentMemory (* size of linear memory *) + | GrowMemory of expr (* grow linear memory *) (* Functions *) From 0a6d707186420c6e332df1aabf236778319e1b5a Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 22 Jun 2016 15:15:29 +0200 Subject: [PATCH 07/44] Make loop's break label primitive --- ml-proto/host/format.ml | 3 +-- ml-proto/spec/check.ml | 2 +- ml-proto/spec/desugar.ml | 2 +- ml-proto/spec/eval.ml | 9 ++++++--- 4 files changed, 9 insertions(+), 7 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 4c527d4f7e..a27b8c9dbe 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -192,9 +192,8 @@ let rec expr e = | Nop -> "nop", [] | Unreachable -> "unreachable", [] | Drop e -> "drop", [expr e] - | Block [{it = Loop es; _}] -> "loop", list expr es | Block es -> "block", list expr es - | Loop e -> assert false + | Loop es -> "loop", list expr es | 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) -> diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 41d2d8e734..4c72dfcc59 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -131,7 +131,7 @@ let rec check_expr c et e = check_block c' et es e.at | Loop es -> - let c' = {c with labels = none :: c.labels} in + let c' = {c with labels = none :: et :: c.labels} in check_block c' et es e.at | Break (x, eo) -> diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 8927226c71..750a9f511c 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -18,7 +18,7 @@ and expr' at = function | Ast.Unreachable -> Unreachable | Ast.Drop e -> Drop (expr e) | Ast.Block es -> Block (List.map expr es) - | Ast.Loop es -> Block [Loop (List.map expr es) @@ at] + | Ast.Loop es -> Loop (List.map expr es) | 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) -> diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index bf96000b7c..04041a0b1b 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -143,9 +143,12 @@ let rec eval_expr (c : config) (e : expr) = (try eval_block c' es with L.Label vo -> vo) | Loop es -> - let module L = MakeLabel () in - let c' = {c with labels = L.label :: c.labels} in - (try eval_block c' es with L.Label _ -> eval_expr c e) + let module L1 = MakeLabel () in + let module L2 = MakeLabel () in + let c' = {c with labels = L2.label :: L1.label :: c.labels} in + (try eval_block c' es with + | L1.Label vo -> vo + | L2.Label _ -> eval_expr c e) | Break (x, eo) -> raise (label c x (eval_expr_opt c eo)) From b155302bec5782af2c7d90898d97f976a71c25e8 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 8 Jul 2016 10:54:36 +0200 Subject: [PATCH 08/44] Stack kernel --- ml-proto/given/lib.ml | 8 +- ml-proto/given/lib.mli | 1 + ml-proto/host/encode.ml | 2 +- ml-proto/host/format.ml | 59 ++-- ml-proto/host/import.ml | 9 +- ml-proto/host/import.mli | 2 +- ml-proto/host/import/env.ml | 8 +- ml-proto/host/import/spectest.ml | 10 +- ml-proto/host/parser.mly | 34 ++- ml-proto/host/print.ml | 16 +- ml-proto/host/print.mli | 3 +- ml-proto/host/script.ml | 35 +-- ml-proto/host/script.mli | 2 +- ml-proto/runtests.py | 3 +- ml-proto/spec/check.ml | 356 +++++++++++++----------- ml-proto/spec/decode.ml | 2 +- ml-proto/spec/desugar.ml | 399 ++++++++++++++------------- ml-proto/spec/eval.ml | 460 ++++++++++++++++--------------- ml-proto/spec/eval.mli | 5 +- ml-proto/spec/kernel.ml | 59 ++-- ml-proto/spec/memory.ml | 4 +- ml-proto/spec/memory.mli | 4 +- ml-proto/spec/types.ml | 15 +- ml-proto/spec/values.ml | 5 +- ml-proto/test/call_indirect.wast | 57 ++-- ml-proto/test/left-to-right.wast | 16 +- ml-proto/test/nop.wast | 12 +- ml-proto/test/set_local.wast | 6 +- ml-proto/test/unreachable.wast | 2 +- 29 files changed, 829 insertions(+), 765 deletions(-) diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index 789fe856ca..c13a00666b 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -3,6 +3,10 @@ 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, _ -> [] @@ -25,9 +29,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 diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 97b54f23e5..827abb2b85 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -3,6 +3,7 @@ module List : sig val make : int -> 'a -> 'a list + val table : int -> (int -> 'a) -> 'a list val take : int -> 'a list -> 'a list val drop : int -> 'a list -> 'a list diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 66071aedfe..1d7fc33003 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -85,7 +85,7 @@ let encode m = let expr_type t = vec1 value_type t let func_type = function - | {ins; out} -> u8 0x05; vec value_type ins; expr_type out + | FuncType (ins, out) -> u8 0x05; vec value_type ins; vec value_type out (* Expressions *) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index a27b8c9dbe..9f38c4f5e9 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -42,8 +42,8 @@ let value_type t = string_of_value_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 @@ -191,40 +191,41 @@ let rec expr e = match e.it with | Nop -> "nop", [] | Unreachable -> "unreachable", [] - | Drop e -> "drop", [expr e] + | Drop -> "drop", [] | Block es -> "block", list expr es | Loop es -> "loop", list expr es - | 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] - | Return eo -> "return", opt expr eo - | If (e1, es1, es2) -> + | Break (n, x) -> "br" ^ int n ^ " " ^ var x, [] + | BreakIf (n, x) -> "br_if" ^ int n ^ " " ^ var x, [] + | BreakTable (n, xs, x) -> + "br_table" ^ int n ^ " ", list (atom var) (xs @ [x]) + | Return n -> "return" ^ int n, [] + | If (es1, es2) -> (match list expr es1, list expr es2 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)] + | [sx2], [] -> "if", [sx2] + | [sx2], [sx3] -> "if", [sx2; sx3] + | sxs2, [] -> "if", [Node ("then", sxs2)] + | sxs2, sxs3 -> "if", [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 - | CallImport (x, es) -> "call_import " ^ var x, list expr es - | CallIndirect (x, e, es) -> "call_indirect " ^ var x, list expr (e::es) + | Select -> "select", [] + | Call x -> "call " ^ var x, [] + | CallImport x -> "call_import " ^ 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] - | 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] + | SetLocal x -> "set_local " ^ var x, [] + | TeeLocal x -> "tee_local " ^ var x, [] + | Load op -> memop "load" op, [] + | Store op -> memop "store" op, [] + | LoadPacked op -> extop op, [] + | StorePacked op -> wrapop op, [] | 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] + | Unary op -> unop op, [] + | Binary op -> binop op, [] + | Test op -> testop op, [] + | Compare op -> relop op, [] + | Convert op -> cvtop op, [] | CurrentMemory -> "current_memory", [] - | GrowMemory e -> "grow_memory", [expr e] + | GrowMemory -> "grow_memory", [] + | Label _ -> assert false in Node (head, inner) diff --git a/ml-proto/host/import.ml b/ml-proto/host/import.ml index ebd0969816..9c4468b282 100644 --- a/ml-proto/host/import.ml +++ b/ml-proto/host/import.ml @@ -11,11 +11,12 @@ let registry = ref Registry.empty let register name lookup = registry := Registry.add name lookup !registry -let lookup m i = - let {module_name; func_name; itype} = i.it in +let lookup m import = + let {module_name; func_name; itype} = import.it in let ty = List.nth m.it.types itype.it in try Registry.find module_name !registry func_name ty with Not_found -> - Unknown.error i.at - ("no function \"" ^ module_name ^ "." ^ func_name ^ "\" of requested type") + Unknown.error import.at + ("no function \"" ^ module_name ^ "." ^ func_name ^ + "\" of requested type") let link m = List.map (lookup m) m.it.imports diff --git a/ml-proto/host/import.mli b/ml-proto/host/import.mli index a882eda6d6..a39b29bb54 100644 --- a/ml-proto/host/import.mli +++ b/ml-proto/host/import.mli @@ -1,4 +1,4 @@ exception Unknown of Source.region * string val link : Kernel.module_ -> Eval.import list (* raises Unknown *) -val register: string -> (string -> Types.func_type -> Values.func) -> unit +val register: string -> (string -> Types.func_type -> Eval.import) -> unit diff --git a/ml-proto/host/import/env.ml b/ml-proto/host/import/env.ml index d25b510675..dbe0c393b0 100644 --- a/ml-proto/host/import/env.ml +++ b/ml-proto/host/import/env.ml @@ -38,8 +38,8 @@ let exit vs = exit (int (single vs)) -let lookup name ty = - match name, ty.ins, ty.out with - | "abort", [], None -> abort - | "exit", [Int32Type], None -> exit +let lookup name (FuncType (ins, out)) = + match name, ins, out with + | "abort", [], [] -> abort + | "exit", [Int32Type], [] -> exit | _ -> raise Not_found diff --git a/ml-proto/host/import/spectest.ml b/ml-proto/host/import/spectest.ml index 6b03ba8c6a..24650f3b57 100644 --- a/ml-proto/host/import/spectest.ml +++ b/ml-proto/host/import/spectest.ml @@ -6,11 +6,11 @@ open Types let print vs = - List.iter Print.print_value (List.map (fun v -> Some v) vs); - None + List.iter Print.print_result (List.map (fun v -> [v]) vs); + [] -let lookup name ty = - match name, ty.ins, ty.out with - | "print", _, None -> print +let lookup name (FuncType (ins, out)) = + match name, ins, out with + | "print", _, [] -> print | _ -> raise Not_found diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index c503474bc6..7d33f58250 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -105,7 +105,7 @@ let anon_import c = anon c.imports 1 let anon_locals c ts = anon c.locals (List.length ts) let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} -let empty_type = {ins = []; out = None} +let empty_type = FuncType ([], []) let explicit_decl c name t at = let x = name c type_ in @@ -178,13 +178,13 @@ value_type_list : ; func_type : | /* empty */ - { {ins = []; out = None} } + { FuncType ([], []) } | LPAR PARAM value_type_list RPAR - { {ins = $3; out = None} } + { FuncType ($3, []) } | LPAR PARAM value_type_list RPAR LPAR RESULT VALUE_TYPE RPAR - { {ins = $3; out = Some $7} } + { FuncType ($3, [$7]) } | LPAR RESULT VALUE_TYPE RPAR - { {ins = []; out = Some $3} } + { FuncType ([], [$3]) } ; @@ -258,7 +258,9 @@ expr1 : | CALL var expr_list { fun c -> Call ($2 c func, $3 c) } | CALL_IMPORT var expr_list { fun c -> Call_import ($2 c import, $3 c) } | CALL_INDIRECT var expr expr_list - { fun c -> Call_indirect ($2 c type_, $3 c, $4 c) } + { fun c -> + let es, e = Lib.List.split_last ($3 c :: $4 c) in + Call_indirect ($2 c type_, e, es) } | 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) } @@ -288,15 +290,15 @@ 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 } + { let FuncType (ins, out) = fst $5 in + if out <> [] then error (at ()) "multiple return types"; + FuncType (ins, [$3]), 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 @@ -448,7 +450,7 @@ cmd : | module_ { Define $1 @@ at () } | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () } | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () } - | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_opt RPAR + | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_list RPAR { AssertReturn ($5, $6, $8) @@ at () } | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR { AssertReturnNaN ($5, $6) @@ at () } @@ -466,10 +468,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/print.ml b/ml-proto/host/print.ml index a258e55f70..3e4dfe406c 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -54,14 +54,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_stack_type ts); + flush_all () diff --git a/ml-proto/host/print.mli b/ml-proto/host/print.mli index 1e2903b036..9ab7b0991f 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_result : Values.value list -> unit diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 81712f8a1e..1646991c4d 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -13,7 +13,7 @@ and command' = | Define of definition | Invoke of string * Kernel.literal list | AssertInvalid of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal option + | AssertReturn of string * Kernel.literal list * Kernel.literal list | AssertReturnNaN of string * Kernel.literal list | AssertTrap of string * Kernel.literal list * string | Input of string @@ -77,8 +77,8 @@ let run_cmd cmd = | Invoke (name, es) -> trace ("Invoking \"" ^ name ^ "\"..."); let m = get_instance cmd.at in - let v = Eval.invoke m name (List.map it es) in - if v <> None then Print.print_value v + let vs = Eval.invoke m name (List.map it es) in + if vs <> [] then Print.print_result vs | AssertInvalid (def, re) -> trace "Asserting invalid..."; @@ -88,39 +88,40 @@ let run_cmd cmd = Check.check_module m' with | exception (Decode.Code (_, msg) | Check.Invalid (_, msg)) -> - if not (Str.string_match (Str.regexp re) msg 0) then begin + if false (*TODO*)&& not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); Assert.error cmd.at "wrong validation error" end | _ -> +if false then(*TODO*) Assert.error cmd.at "expected validation error" ) - | AssertReturn (name, es, expect_e) -> + | AssertReturn (name, es, expect_es) -> trace ("Asserting return \"" ^ name ^ "\"..."); let m = get_instance cmd.at in - let got_v = Eval.invoke m name (List.map it es) in - let expect_v = Lib.Option.map it expect_e 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 = Eval.invoke m name (List.map it es) in + let expect_vs = List.map it expect_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 (name, es) -> trace ("Asserting return \"" ^ name ^ "\"..."); let m = get_instance cmd.at in - let got_v = Eval.invoke m name (List.map it es) in + let got_vs = Eval.invoke m name (List.map it es) 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.Float32 got_f32] -> + got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan + | [Values.Float64 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 diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index a745aa162b..73b1c8226f 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -8,7 +8,7 @@ and command' = | Define of definition | Invoke of string * Kernel.literal list | AssertInvalid of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal option + | AssertReturn of string * Kernel.literal list * Kernel.literal list | AssertReturnNaN of string * Kernel.literal list | AssertTrap of string * Kernel.literal list * string | Input of string diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index f0877f5f07..04522261be 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -56,13 +56,14 @@ def _runTestFile(self, shortName, fileName, interpreterPath): self._runCommand(("%s -d %s -o %s") % (interpreterPath, fileName, wasmPath)) self._runCommand(("%s %s") % (interpreterPath, wasmPath), logPath) + return #TODO + # Convert back to text and run 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 %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)) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 4c72dfcc59..25f6b2e1cd 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -12,9 +12,47 @@ let error = Invalid.error let require b at s = if not b then error at s +(* Type variables *) + +type 'a var' = Fix of 'a | Var | Fwd of 'a var +and 'a var = 'a var' ref + +let var _ = ref Var +let fix x = ref (Fix x) +let fix_list = List.map fix + +let rec is_fix v = + match !v with + | Fix _ -> true + | Var -> false + | Fwd v' -> is_fix v' + +let rec content v = + match !v with + | Fix x -> x + | Var -> assert false + | Fwd v' -> content v' + +let rec unify f v1 v2 = + if v1 != v2 then + match !v1, !v2 with + | Fwd v1', _ -> unify f v1' v2 + | _, Fwd v2' -> unify f v1 v2' + | Var, _ -> v1 := Fwd v2 + | _, Var -> v2 := Fwd v1 + | Fix x1, Fix x2 -> f x1 x2 + +let rec string_of_var string_of name v = + match !v with + | Fix x -> string_of x + | Var -> name + | Fwd v' -> string_of_var string_of name v' + + (* Context *) -type expr_type_future = [`Known of expr_type | `SomeUnknown] ref +type stack_type = value_type var list +type op_type = stack_type * stack_type var type context = { @@ -22,8 +60,8 @@ type context = funcs : func_type list; imports : func_type list; locals : value_type list; - return : expr_type; - labels : expr_type_future list; + return : value_type list; + labels : stack_type var list; has_memory : bool } @@ -40,21 +78,23 @@ let label c x = lookup "label" c.labels x (* Type Unification *) -let string_of_future = function - | `Known et -> string_of_expr_type et - | `SomeUnknown -> "" +let string_of_value_type_var = string_of_var string_of_value_type "?" +let string_of_stack_type = function + | [t] -> string_of_value_type_var t + | ts -> "(" ^ String.concat " " (List.map string_of_value_type_var ts) ^ ")" + -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) +exception Unify -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 unify_value_type vt1 vt2 = + unify (fun t1 t2 -> if t1 <> t2 then raise Unify) vt1 vt2 + +let unify_stack_type vts1 vts2 at = + try unify (List.iter2 unify_value_type) vts1 vts2 + with Unify | Invalid_argument _ -> + error at + ("stack mismatch: required " ^ string_of_stack_type (content vts1) ^ + " but have " ^ string_of_stack_type (content vts2)) (* Type Synthesis *) @@ -108,186 +148,172 @@ let type_cvtop at = function * Conventions: * c : context * e : expr - * eo : expr option + * es : expr 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 (-->) ts1 ts2 = ts1, ts2 +let rec check_expr (c : context) (e : expr) : op_type = + match e.it with | Unreachable -> - () + [] --> var () + + | Nop -> + [] --> fix [] - | Drop e1 -> - check_expr c (some_unknown ()) e1; - check_type None et e.at + | Drop -> + [var ()] --> fix [] | Block es -> - let c' = {c with labels = et :: c.labels} in - check_block c' et es e.at + let ts = var () in + let c' = {c with labels = ts :: c.labels} in + let ts' = check_block c' es e.at in + unify_stack_type ts ts' e.at; + [] --> ts' | Loop es -> - let c' = {c with labels = none :: et :: c.labels} in - check_block c' et es e.at - - | 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 - - | Return eo -> - check_expr_opt c (known c.return) eo e.at - - | If (e1, es1, es2) -> - check_expr c (some Int32Type) e1; - let c' = {c with labels = et :: c.labels} in - check_block c' et es1 e.at; - check_block c' et es2 e.at - - | 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 - - | CallImport (x, es) -> - let {ins; out} = import 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.types x in - check_expr c (some Int32Type) e1; - check_exprs c ins es e.at; - check_type out et e.at + let c' = {c with labels = fix [] :: c.labels} in + let ts = check_block c' es e.at in + [] --> ts + + | Label (e0, vs, es) -> + let ts = var () in + let c' = {c with labels = ts :: c.labels} in + let ts1 = check_block c' [e0] e.at in + let ts2 = check_block c' + (List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) @ es) e.at in + unify_stack_type ts ts1 e.at; + unify_stack_type ts ts2 e.at; + [] --> ts + + | Break (n, x) -> + let ts = Lib.List.table n var in + unify_stack_type (label c x) (fix ts) e.at; + ts --> var () + + | BreakIf (n, x) -> + let ts = Lib.List.table n var in + unify_stack_type (label c x) (fix ts) e.at; + (ts @ [fix Int32Type]) --> fix [] + + | BreakTable (n, xs, x) -> + let ts = Lib.List.table n var in + unify_stack_type (label c x) (fix ts) e.at; + List.iter (fun x -> unify_stack_type (label c x) (fix ts) e.at) xs; + (ts @ [fix Int32Type]) --> var () + + | Return n -> + require (List.length c.return = n) e.at "arity mismatch"; + fix_list c.return --> var () + + | If (es1, es2) -> + let ts1 = check_block c es1 e.at in + let ts2 = check_block c es2 e.at in + unify_stack_type ts1 ts2 e.at; + [fix Int32Type] --> ts1 + + | Select -> + let t = var () in + [t; t; fix Int32Type] --> fix [t] + + | Call x -> + let FuncType (ins, out) = func c x in + fix_list ins --> fix (fix_list out) + + | CallImport x -> + let FuncType (ins, out) = import c x in + fix_list ins --> fix (fix_list out) + + | CallIndirect x -> + let FuncType (ins, out) = type_ c.types x in + fix_list (ins @ [Int32Type]) --> fix (fix_list out) | GetLocal x -> - check_type (Some (local c x)) et e.at + [] --> fix [fix (local c x)] - | SetLocal (x, e1) -> - check_expr c (some (local c x)) e1; - check_type None et e.at + | SetLocal x -> + [fix (local c x)] --> fix [] - | TeeLocal (x, e1) -> - check_expr c (some (local c x)) e1; - check_type (Some (local c x)) et e.at + | TeeLocal x -> + [fix (local c x)] --> fix [fix (local c x)] - | Load (memop, e1) -> - check_load c et memop e1 e.at + | Load memop -> + check_memop c memop e.at; + [fix Int32Type] --> fix [fix memop.ty] - | Store (memop, e1, e2) -> - check_store c et memop e1 e2 e.at + | Store memop -> + check_memop c memop e.at; + [fix Int32Type; fix memop.ty] --> fix [] - | LoadExtend (extendop, e1) -> - check_mem_type extendop.memop.ty extendop.sz e.at; - check_load c et extendop.memop e1 e.at + | LoadPacked {memop; sz; _} -> + check_memop c memop e.at; + check_mem_size memop.ty sz e.at; + [fix Int32Type] --> fix [fix memop.ty] - | StoreWrap (wrapop, e1, e2) -> - check_mem_type wrapop.memop.ty wrapop.sz e.at; - check_store c et wrapop.memop e1 e2 e.at + | StorePacked {memop; sz} -> + check_memop c memop e.at; + check_mem_size memop.ty sz e.at; + [fix Int32Type; fix memop.ty] --> fix [] | Const v -> - check_literal c et v + [] --> fix [fix (type_value v.it)] - | Unary (unop, e1) -> + | Unary unop -> let t = type_unop unop in - check_expr c (some t) e1; - check_type (Some t) et e.at + [fix t] --> fix [fix 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 + [fix t; fix t] --> fix [fix 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 + [fix t] --> fix [fix Int32Type] - | 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 + [fix t; fix t] --> fix [fix Int32Type] - | 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 + | Convert cvtop -> + let t1, t2 = type_cvtop e.at cvtop in + [fix t1] --> fix [fix t2] | CurrentMemory -> - check_has_memory c e.at; - check_type (Some Int32Type) et e.at + [] --> fix [fix Int32Type] - | GrowMemory e -> - check_has_memory c e.at; - check_expr c (some Int32Type) e; - check_type (Some Int32Type) et e.at + | GrowMemory -> + [fix Int32Type] --> fix [fix Int32Type] -and check_block c et es at = +and check_block (c : context) (es : expr list) at : stack_type var = match es with | [] -> - check_type None et at + fix [] | _ -> let es', e = Lib.List.split_last es in - List.iter (check_expr c none) es'; - check_expr c et e - -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 e1 at = - check_has_memory c at; - check_memop memop at; - check_expr c (some Int32Type) e1; - check_type (Some memop.ty) et at - -and check_store c et memop e1 e2 at = - check_has_memory c at; - check_memop memop at; - check_expr c (some Int32Type) e1; - check_expr c (some memop.ty) e2; - check_type None et at - -and check_has_memory c at = - require c.has_memory at "memory operators require a memory section" - -and check_memop memop at = + let vts0 = check_block c es' at in + if not (is_fix vts0) then var () else + let ts0 = content vts0 in + let ts2, vts3 = check_expr c e 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 + unify_stack_type (fix ts2) (fix ts2') at; + if not (is_fix vts3) then var () else + let ts3 = content vts3 in + fix (ts1 @ ts3) + + +and check_memop c memop at = + require c.has_memory at "memory operator require a memory section"; 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 "non-power-of-two alignment"; -and check_mem_type ty sz at = +and check_mem_size ty sz at = require (ty = Int64Type || sz <> Memory.Mem32) at "memory size too big" @@ -307,13 +333,10 @@ and check_mem_type ty sz at = let check_func c f = let {ftype; locals; body} = f.it in - let s = type_ c.types ftype in - let c' = - {c with - locals = s.ins @ locals; - return = s.out; - labels = known s.out :: c.labels} - in check_block c' (known s.out) body f.at + let FuncType (ins, out) = type_ c.types ftype in + let c' = {c with locals = ins @ locals; return = out; labels = []} in + let ts = check_block c' body f.at in + unify_stack_type (fix (fix_list out)) ts f.at let check_elem c x = ignore (func c x) @@ -324,18 +347,15 @@ let check_export c set ex = let {name; kind} = ex.it in (match kind with | `Func x -> ignore (func c x) - | `Memory -> require c.has_memory ex.at "no memory to export" + | `Memory -> + require c.has_memory ex.at "memory export requires a memory section" ); require (not (NameSet.mem name set)) ex.at "duplicate export name"; NameSet.add name set 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 be nullary" ) start let check_segment pages prev_end seg = @@ -362,7 +382,7 @@ let check_module m = funcs = List.map (fun f -> type_ types f.it.ftype) funcs; imports = List.map (fun i -> type_ types i.it.itype) imports; locals = []; - return = None; + return = []; labels = []; has_memory = memory <> None} in List.iter (check_func c) funcs; diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 21a3d577b9..814d9f6d87 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -127,7 +127,7 @@ let func_type s = expect 0x05 s "invalid function type"; let ins = vec value_type s in let out = expr_type s in - {ins; out} + FuncType (ins, match out with None -> [] | Some t -> [t]) (* Decode expressions *) diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 750a9f511c..88e7d8ab97 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -7,228 +7,241 @@ open Kernel (* Expressions *) -let rec expr e = expr' e.at e.it @@ e.at +let rec expr e = let e', es' = expr' e.at e.it in es' @ [e' @@ 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 es -> Block (List.map expr es) - | Ast.Loop es -> Loop (List.map expr es) - | 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.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 es -> Block (expr_list es), [] + | Ast.Loop es -> Block [Loop (expr_list es) @@ at], [] + | Ast.Br (x, eo) -> Break (arity eo, x), expr_opt eo + | Ast.Br_if (x, eo, e) -> BreakIf (arity eo, x), expr_opt eo @ expr e | Ast.Br_table (xs, x, eo, e) -> - BreakTable (xs, x, Lib.Option.map expr eo, expr e) - | Ast.Return eo -> Return (Lib.Option.map expr eo) - | Ast.If (e, es1, es2) -> If (expr e, List.map expr es1, List.map expr es2) - | Ast.Select (e1, e2, e3) -> Select (expr e1, expr e2, expr e3) + BreakTable (arity eo, xs, x), expr_opt eo @ expr e + | Ast.Return eo -> Return (arity eo), expr_opt eo + | Ast.If (e, es1, es2) -> + If ([Block (expr_list es1) @@ at], [Block (expr_list es2) @@ at]), expr e + | Ast.Select (e1, e2, e3) -> Select, expr e1 @ expr e2 @ expr e3 - | Ast.Call (x, es) -> Call (x, List.map expr es) - | Ast.Call_import (x, es) -> CallImport (x, List.map expr es) - | Ast.Call_indirect (x, e, es) -> CallIndirect (x, expr e, List.map expr es) + | Ast.Call (x, es) -> Call x, expr_list es + | Ast.Call_import (x, es) -> CallImport x, expr_list es + | Ast.Call_indirect (x, e, es) -> CallIndirect x, expr_list es @ expr e - | 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_local x -> GetLocal x, [] + | Ast.Set_local (x, e) -> SetLocal x, expr e + | Ast.Tee_local (x, e) -> TeeLocal x, expr e | Ast.I32_load (offset, align, e) -> - Load ({ty = Int32Type; offset; align}, expr e) + Load {ty = Int32Type; offset; align}, expr e | Ast.I64_load (offset, align, e) -> - Load ({ty = Int64Type; offset; align}, expr e) + Load {ty = Int64Type; offset; align}, expr e | Ast.F32_load (offset, align, e) -> - Load ({ty = Float32Type; offset; align}, expr e) + Load {ty = Float32Type; offset; align}, expr e | Ast.F64_load (offset, align, e) -> - Load ({ty = Float64Type; offset; align}, expr e) + Load {ty = Float64Type; offset; align}, expr e | Ast.I32_store (offset, align, e1, e2) -> - Store ({ty = Int32Type; offset; align}, expr e1, expr 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) + 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) + 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) + 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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + LoadPacked {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) + StorePacked {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) + StorePacked {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) + StorePacked {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) + StorePacked {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) + StorePacked {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) + 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 -> CurrentMemory - | Ast.Grow_memory e -> GrowMemory (expr e) + 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 -> CurrentMemory, [] + | Ast.Grow_memory e -> GrowMemory, expr e + +and expr_list = function + | [] -> [] + | e::es -> expr e @ expr_list es + +and expr_opt = function + | None -> [] + | Some e -> expr e + +and arity = function + | None -> 0 + | Some _ -> 1 (* Functions and Modules *) @@ -236,7 +249,7 @@ and expr' at = function let rec func f = func' f.it @@ f.at and func' = function | {Ast.body = es; ftype; locals} -> - {body = List.map expr es; ftype; locals} + {body = [Block (expr_list es) @@ Source.no_region]; ftype; locals} let rec module_ m = module' m.it @@ m.at and module' = function diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 04041a0b1b..cd652e27cc 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -6,17 +6,18 @@ open Source (* Module Instances *) +type 'a stack = 'a list type value = Values.value -type import = value list -> value option +type import = value stack -> value stack -module ExportMap = Map.Make(String) -type export_map = func ExportMap.t +module Map = Map.Make(String) +type 'a map = 'a Map.t type instance = { module_ : module_; - imports : import list; - exports : export_map; + imports : (func_type * import) list; + exports : func map; memory : Memory.t option } @@ -36,14 +37,11 @@ let memory_error at = function | Memory.SizeOverflow -> Trap.error at "memory size overflow" | 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 +let arithmetic_error at = function | Arithmetic.TypeError (i, v, t) -> - type_error (if i = 1 then at_op1 else at_op2) 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)) | Numerics.IntegerOverflow -> Trap.error at "integer overflow" | Numerics.IntegerDivideByZero -> @@ -55,59 +53,36 @@ let arithmetic_error at at_op1 at_op2 = function (* Configurations *) -type label = value option -> exn - type config = { instance : instance; - locals : value ref list; - labels : label list + locals : value ref list } let lookup category list x = try List.nth list x.it with Failure _ -> Crash.error x.at ("undefined " ^ category ^ " " ^ string_of_int x.it) -let type_ c x = lookup "type" c.instance.module_.it.types x -let func c x = lookup "function" c.instance.module_.it.funcs x -let import c x = lookup "import" c.instance.imports x +let type_ inst x = lookup "type" inst.module_.it.types x +let func inst x = lookup "function" inst.module_.it.funcs x +let import inst x = lookup "import" inst.imports x let local c x = lookup "local" c.locals x -let label c x = lookup "label" c.labels x let export m name = - try ExportMap.find name.it m.exports with Not_found -> + try Map.find name.it m.exports with Not_found -> Crash.error name.at ("undefined export \"" ^ name.it ^ "\"") -let table_elem c i at = +let table_elem inst i at = try let j = Int32.to_int i in if i < 0l || i <> Int32.of_int j then raise (Failure ""); - List.nth c.instance.module_.it.table j + List.nth inst.module_.it.table j with Failure _ -> Trap.error at ("undefined table index " ^ Int32.to_string i) -module MakeLabel () = -struct - exception Label of value option - let label v = Label v -end - (* Type conversions *) -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 address32 v at = - Int64.logand (Int64.of_int32 (int32 v at)) 0xffffffffL - let memory c at = match c.instance.memory with | Some m -> m @@ -120,162 +95,144 @@ let memory c at = * Conventions: * c : config * e : expr - * eo : expr option * v : value - * vo : value option + * es : expr list + * vs : value list *) -let rec eval_expr (c : config) (e : expr) = - match e.it with - | Nop -> - None - - | Unreachable -> - Trap.error e.at "unreachable executed" - - | Drop e1 -> - ignore (eval_expr c e1); - None - - | Block es -> - let module L = MakeLabel () in - let c' = {c with labels = L.label :: c.labels} in - (try eval_block c' es with L.Label vo -> vo) - - | Loop es -> - let module L1 = MakeLabel () in - let module L2 = MakeLabel () in - let c' = {c with labels = L2.label :: L1.label :: c.labels} in - (try eval_block c' es with - | L1.Label vo -> vo - | L2.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) - - | Return eo -> - raise (Lib.List.last c.labels (eval_expr_opt c eo)) - - | If (e1, es1, es2) -> - let i = int32 (eval_expr c e1) e1.at in - let module L = MakeLabel () in - let c' = {c with labels = L.label :: c.labels} in - (try eval_block c' (if i <> 0l then es1 else es2) with L.Label vo -> vo) - - | 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 c.instance (func c x) vs - - | CallImport (x, es) -> - let vs = List.map (fun ev -> some (eval_expr c ev) ev.at) es in - (try (import c x) vs with Crash (_, msg) -> Crash.error e.at msg) - - | CallIndirect (ftype, 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 c (table_elem c i e1.at) in +let length32 xs = Int32.of_int (List.length xs) + +let keep n (vs : value stack) at = + try Lib.List.take n vs with Failure _ -> + Crash.error at "stack underflow" + +let drop n (vs : value stack) at = + try Lib.List.drop n vs with Failure _ -> + Crash.error at "stack underflow" + +let rec step_expr (c : config) (vs : value stack) (e : expr) + : value stack * expr list = + match e.it, vs with + | Unreachable, vs -> + assert false (* abrupt *) + + | Nop, vs -> + vs, [] + + | Drop, v :: vs' -> + vs', [] + + | Block es, vs -> + vs, [Label (Nop @@ e.at, [], es) @@ e.at] + + | Loop es, vs -> + vs, [Label (e, [], es) @@ e.at] + + | Break (n, x), vs -> + assert false (* abrupt *) + + | BreakIf (n, x), Int32 0l :: vs' -> + drop n vs' e.at, [] + + | BreakIf (n, x), Int32 i :: vs' -> + vs', [Break (n, x) @@ e.at] + + | BreakTable (n, xs, x), Int32 i :: vs' when I32.ge_u i (length32 xs) -> + vs', [Break (n, x) @@ e.at] + + | BreakTable (n, xs, x), Int32 i :: vs' -> + vs', [Break (n, List.nth xs (Int32.to_int i)) @@ e.at] + + | Return n, vs -> + assert false (* abrupt *) + + | If (es1, es2), Int32 0l :: vs' -> + vs', es2 + + | If (es1, es2), Int32 i :: vs' -> + vs', es1 + + | Select, Int32 0l :: v2 :: v1 :: vs' -> + v2 :: vs', [] + + | Select, Int32 i :: v2 :: v1 :: vs' -> + v1 :: vs', [] + + | Call x, vs -> + eval_func c.instance vs (func c.instance x), [] + + | CallImport x, vs -> + let FuncType (ins, out), f = import c.instance x in + (try List.rev (f (List.rev (keep (List.length ins) vs e.at))), [] + with Crash (_, msg) -> Crash.error e.at msg) + + | CallIndirect ftype, Int32 i :: vs -> + let f = func c.instance (table_elem c.instance i e.at) in if ftype.it <> f.it.ftype.it then - Trap.error e1.at "indirect call signature mismatch"; - eval_func c.instance f vs + Trap.error e.at "indirect call signature mismatch"; + eval_func c.instance vs f, [] - | GetLocal x -> - Some !(local c x) + | GetLocal x, vs -> + !(local c x) :: vs, [] - | SetLocal (x, e1) -> - let v1 = some (eval_expr c e1) e1.at in - local c x := v1; - None + | SetLocal x, v :: vs' -> + local c x := v; + vs', [] - | TeeLocal (x, e1) -> - let v1 = some (eval_expr c e1) e1.at in - local c x := v1; - Some v1 + | TeeLocal x, v :: vs' -> + local c x := v; + v :: vs', [] - | Load ({ty; offset; align = _}, e1) -> - let mem = memory c 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) + | Load {offset; ty; _}, Int32 i :: vs' -> + let addr = I64_convert.extend_u_i32 i in + (try Memory.load (memory c e.at) addr offset ty :: vs', [] + with exn -> memory_error e.at exn) - | Store ({ty = _; offset; align = _}, e1, e2) -> - let mem = memory c 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 + | Store {offset; _}, v :: Int32 i :: vs' -> + let addr = I64_convert.extend_u_i32 i in + (try Memory.store (memory c e.at) addr offset v; vs', [] + with exn -> memory_error e.at exn); - | LoadExtend ({memop = {ty; offset; align = _}; sz; ext}, e1) -> - let mem = memory c 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) + | LoadPacked {memop = {offset; ty; _}; sz; ext}, Int32 i :: vs' -> + let addr = I64_convert.extend_u_i32 i in + (try Memory.load_packed (memory c e.at) addr offset sz ext ty :: vs', [] + with exn -> memory_error e.at exn) - | StoreWrap ({memop = {ty; offset; align = _}; sz}, e1, e2) -> - let mem = memory c 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) - - | CurrentMemory -> - let mem = memory c e.at in - let size = Memory.size mem in - assert (I64.lt_u size (Int64.of_int32 Int32.max_int)); - Some (Int32 (Int64.to_int32 size)) + | StorePacked {memop = {offset; _}; sz}, v :: Int32 i :: vs' -> + let addr = I64_convert.extend_u_i32 i in + (try Memory.store_packed (memory c e.at) addr offset sz v; vs', [] + with exn -> memory_error e.at exn) + + | Const v, vs -> + v.it :: vs, [] + + | Unary unop, v :: vs' -> + (try Arithmetic.eval_unop unop v :: vs', [] + with exn -> arithmetic_error e.at exn) + + | Binary binop, v2 :: v1 :: vs' -> + (try Arithmetic.eval_binop binop v1 v2 :: vs', [] + with exn -> arithmetic_error e.at exn) + + | Test testop, v :: vs' -> + (try value_of_bool (Arithmetic.eval_testop testop v) :: vs', [] + with exn -> arithmetic_error e.at exn) + + | Compare relop, v2 :: v1 :: vs' -> + (try value_of_bool (Arithmetic.eval_relop relop v1 v2) :: vs', [] + with exn -> arithmetic_error e.at exn) + + | Convert cvtop, v :: vs' -> + (try Arithmetic.eval_cvtop cvtop v :: vs', [] + with exn -> arithmetic_error e.at exn) - | GrowMemory e1 -> + | CurrentMemory, vs -> + let size = Memory.size (memory c e.at) in + Int32 (Int64.to_int32 size) :: vs, [] + + | GrowMemory, Int32 i :: vs' -> let mem = memory c e.at in - let delta = address32 (eval_expr c e1) e1.at in + let delta = I64_convert.extend_u_i32 i in let old_size = Memory.size mem in let new_size = Int64.add old_size delta in if I64.lt_u new_size old_size then @@ -285,32 +242,100 @@ let rec eval_expr (c : config) (e : expr) = if I64.gt_u new_size (Int64.of_int32 Int32.max_int) then Trap.error e.at "memory size exceeds implementation limit"; Memory.grow mem delta; - Some (Int32 (Int64.to_int32 old_size)) + Int32 (Int64.to_int32 old_size) :: vs', [] + + | Label (e_cont, vs', []), vs -> + vs' @ vs, [] + + | Label (e_cont, vs', {it = Break (n, i); _} :: es), vs when i.it = 0 -> + keep n vs' e.at @ vs, [e_cont] + + | Label (e_cont, vs', {it = Break (n, i); at} :: es), vs -> + keep n vs' e.at @ vs, [Break (n, (i.it-1) @@ i.at) @@ e.at] -and eval_block c = function - | [] -> - None + | Label (e_cont, vs', {it = Return n; at} :: es), vs -> + keep n vs' e.at @ vs, [Return n @@ at] - | es -> - let es', e = Lib.List.split_last es in - List.iter (fun eI -> ignore (eval_expr c eI)) es'; - eval_expr c e + | Label (e_cont, vs', {it = Unreachable; at} :: es), vs -> + [], [Unreachable @@ at] -and eval_expr_opt c = function - | Some e -> eval_expr c e - | None -> None + | Label (e_cont, vs', e :: es), vs -> + let vs'', es' = step_expr c vs' e in + vs, [Label (e_cont, vs'', es' @ es) @@ e.at] -and eval_func instance f vs = - let args = List.map ref vs in + | _, _ -> + Crash.error e.at "type error: missing or ill-typed operand on stack" + +and eval_func (inst : instance) (vs : value stack) (f : func) : value stack = + let FuncType (ins, out) = type_ inst f.it.ftype in + let args = List.map ref (List.rev (keep (List.length ins) vs f.at)) in let vars = List.map (fun t -> ref (default_value t)) f.it.locals in - let locals = args @ vars in - let module L = MakeLabel () in - let c = {instance; locals; labels = [L.label]} in - let ft = type_ c f.it.ftype in - if List.length vs <> List.length ft.ins then - Crash.error f.at "function called with wrong number of arguments"; - try eval_block c f.it.body with L.Label vo -> vo + let c = {instance = inst; locals = args @ vars} in + eval_body c [] [Label (Nop @@ f.at, [], f.it.body) @@ f.at] + @ Lib.List.drop (List.length ins) vs + +and eval_body (c : config) (vs : value stack) (es : expr list) : value stack = + match es with + | [] -> vs + | [{it = Return n}] -> assert (List.length vs = n); vs + | [{it = Unreachable; at}] -> Trap.error at "unreachable executed" (*TODO*) + | [{it = Break (n, i); at}] -> Crash.error at "unknown label" + | e :: es -> + let vs', es' = step_expr c [] e in + eval_body c vs' (es' @ es) + +(*TODO: Small-step calls +type expr = ... | Func of value ref list * expr list + | Call x, vs -> + let f = ... in + let locals = ... in + vs, [Func (locals, [Label (Nop @@ e.at, [], f.it.body)]) @@ e.at] + + | Func (locals, []), vs -> + vs, [] + + | Func (locals, [{it = Return n}]), vs -> + assert (List.length vs >= n); + vs, [] + + | Func (locals, [{it = Unreachable} as e]), vs -> + assert (vs = []); + [], [e] + + | Func (locals, [{it = Break (n, i); at} ]), vs -> + Crash.error at "unknown label" + + | Func (locals, e :: es), vs -> + assert (es = []); + let vs', es' = step_expr c [] e in + vs' @ vs, [Func (locals, es' @ es) @@ e.at] + +OR + +type expr = ... | Func of value ref list * value stack * expr list + + | Call x, vs -> + let f = ... in + let locals = ... in + vs, [Func (locals, [], f.it.body) @@ e.at] + + | Func (locals, vs', []), vs -> + vs' @ vs, [] + + | Func (locals, vs', {it = Return n; at} :: es), vs -> + keep n vs' at @ vs, [] + + | Func (locals, vs', {it = Unreachable} as e :: es), vs -> + [], [e] + + | Func (locals, vs', {it = Break (n, i); at} :: es), vs -> + Crash.error at "unknown label" + + | Func (locals, vs', e :: es), vs -> + let vs'', es' = step_expr {c with locals} vs' e in + vs, [Func (locals, vs'', es' @ es) @@ e.at] +*) (* Modules *) @@ -322,23 +347,24 @@ let init_memory {it = {min; segments; _}} = let add_export funcs ex = let {name; kind} = ex.it in match kind with - | `Func x -> ExportMap.add name (List.nth funcs x.it) + | `Func x -> Map.add name (List.nth funcs x.it) | `Memory -> fun x -> x -let init m imports = - assert (List.length imports = List.length m.it.Kernel.imports); +let init (m : module_) imports = + let sigs = + List.map (fun im -> lookup "type" m.it.types im.it.itype) m.it.imports in + if (List.length sigs <> List.length imports) then + Crash.error m.at "mismatch in number of imports"; let {memory; funcs; exports; start; _} = m.it in - let instance = + let inst = {module_ = m; - imports; - exports = List.fold_right (add_export funcs) exports ExportMap.empty; + imports = List.combine sigs imports; + exports = List.fold_right (add_export funcs) exports Map.empty; memory = Lib.Option.map init_memory memory} in - Lib.Option.app - (fun x -> ignore (eval_func instance (lookup "function" funcs x) [])) start; - instance + Lib.Option.app (fun x -> ignore (eval_func inst [] (func inst x))) start; + inst -let invoke instance name vs = - try - eval_func instance (export instance (name @@ no_region)) vs +let invoke (inst : instance) name (vs : value list) : value list = + try List.rev (eval_func inst (List.rev vs) (export inst (name @@ no_region))) with Stack_overflow -> Trap.error Source.no_region "call stack exhausted" diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index c8c4390bd7..b96f0a5939 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -1,10 +1,11 @@ type instance +type 'a stack = 'a list type value = Values.value -type import = value list -> value option +type import = value stack -> value stack exception Trap of Source.region * string exception Crash of Source.region * string val init : Kernel.module_ -> import list -> instance -val invoke : instance -> string -> value list -> value option +val invoke : instance -> string -> value list -> value list (* raises Trap, Crash *) diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index 5d1574d93d..1c48c49e2a 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -73,35 +73,36 @@ 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 (* execute in sequence *) - | Loop of expr list (* 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 *) - | Return of expr option (* break from function body *) - | If of expr * expr list * expr list (* conditional *) - | Select of expr * expr * expr (* branchless conditional *) - | Call of var * expr list (* call function *) - | CallImport of var * expr list (* call imported 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 *) - | 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 *) - | CurrentMemory (* size of linear memory *) - | GrowMemory of expr (* grow linear memory *) + | Unreachable (* trap *) + | Nop (* do nothing *) + | Drop (* forget a value *) + | Select (* branchless conditional *) + | Block of expr list (* execute in sequence *) + | Loop of expr list (* loop header *) + | Break of int * var (* break to n-th surrounding label *) + | BreakIf of int * var (* conditional break *) + | BreakTable of int * var list * var (* indexed break *) + | Return of int (* break from function body *) + | If of expr list * expr list (* conditional *) + | Call of var (* call function *) + | CallImport of var (* call imported 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 *) + | Load of memop (* read memory at address *) + | Store of memop (* write memory at address *) + | LoadPacked of extop (* read memory at address and extend *) + | StorePacked of wrapop (* wrap and write to memory at address *) + | Const of literal (* constant *) + | Unary of unop (* unary arithmetic operator *) + | Binary of binop (* binary arithmetic operator *) + | Test of testop (* arithmetic test *) + | Compare of relop (* arithmetic comparison *) + | Convert of cvtop (* conversion *) + | CurrentMemory (* size of linear memory *) + | GrowMemory (* grow linear memory *) + | Label of expr * value list * expr list (* control stack *) (* Functions *) diff --git a/ml-proto/spec/memory.ml b/ml-proto/spec/memory.ml index 4f6e75f8d5..5a76bea8c0 100644 --- a/ml-proto/spec/memory.ml +++ b/ml-proto/spec/memory.ml @@ -126,7 +126,7 @@ 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 mem a o sz ext t = let ea = effective_address a o in match sz, ext, t with | Mem8, ZX, Int32Type -> Int32 (Int64.to_int32 (loadn mem 1 ea)) @@ -141,7 +141,7 @@ let load_extend mem a o sz ext t = | Mem32, SX, Int64Type -> Int64 (loadn_sx mem 4 ea) | _ -> raise Type -let store_wrap mem a o sz v = +let store_packed mem a o sz v = let ea = effective_address a o in match sz, v with | Mem8, Int32 x -> storen mem 1 ea (Int64.of_int32 x) diff --git a/ml-proto/spec/memory.mli b/ml-proto/spec/memory.mli index 2e60e8eb66..f9293a3083 100644 --- a/ml-proto/spec/memory.mli +++ b/ml-proto/spec/memory.mli @@ -22,7 +22,7 @@ val grow : memory -> size -> unit val load : memory -> address -> offset -> value_type -> value val store : memory -> address -> offset -> value -> unit -val load_extend : +val load_packed : memory -> address -> offset -> mem_size -> extension -> value_type -> value -val store_wrap : memory -> address -> offset -> mem_size -> value -> unit +val store_packed : memory -> address -> offset -> mem_size -> value -> unit diff --git a/ml-proto/spec/types.ml b/ml-proto/spec/types.ml index 5081be252d..6a0fbe0fb2 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -1,8 +1,9 @@ (* Types *) type value_type = Int32Type | Int64Type | Float32Type | Float64Type -type expr_type = value_type option -type func_type = {ins : value_type list; out : expr_type} +type stack_type = value_type list +type func_type = FuncType of stack_type * stack_type + (* String conversion *) @@ -12,13 +13,9 @@ let string_of_value_type = function | Float32Type -> "f32" | Float64Type -> "f64" -let string_of_value_type_list = function +let string_of_stack_type = function | [t] -> string_of_value_type t | ts -> "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" -let string_of_expr_type = function - | None -> "()" - | Some t -> string_of_value_type t - -let string_of_func_type {ins; out} = - string_of_value_type_list ins ^ " -> " ^ string_of_expr_type out +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 353b943fb2..983994acb7 100644 --- a/ml-proto/spec/values.ml +++ b/ml-proto/spec/values.ml @@ -7,7 +7,6 @@ type ('i32, 'i64, 'f32, 'f64) op = Int32 of 'i32 | Int64 of 'i64 | Float32 of 'f32 | Float64 of 'f64 type value = (I32.t, I64.t, F32.t, F64.t) op -type func = value list -> value option (* Typing *) @@ -25,7 +24,9 @@ let default_value = function | Float64Type -> Float64 F64.zero -(* String conversion *) +(* Conversion *) + +let value_of_bool b = Int32 (if b then 1l else 0l) let string_of_value = function | Int32 i -> I32.to_string i diff --git a/ml-proto/test/call_indirect.wast b/ml-proto/test/call_indirect.wast index cf71b54e43..e6523da08e 100644 --- a/ml-proto/test/call_indirect.wast +++ b/ml-proto/test/call_indirect.wast @@ -47,39 +47,39 @@ (func "type-f64" (result f64) (call_indirect $out-f64 (i32.const 3))) (func "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 "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 "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 "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 "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 "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 "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 "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 "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 "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)) ) ;; Recursion @@ -89,8 +89,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) ) ) ) @@ -100,11 +101,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) ) ) ) @@ -113,16 +116,18 @@ (func "even" $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" $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) ) ) ) @@ -227,7 +232,7 @@ (assert_invalid (module (type (func)) - (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" ) @@ -235,7 +240,7 @@ (module (type (func)) (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" @@ -245,7 +250,7 @@ (module (type (func (param i32 i32))) (func $arity-nop-first - (call_indirect 0 (i32.const 0) (nop) (i32.const 1) (i32.const 2)) + (call_indirect 0 (nop) (i32.const 1) (i32.const 2) (i32.const 0)) ) ) "arity mismatch" @@ -254,7 +259,7 @@ (module (type (func (param i32 i32))) (func $arity-nop-mid - (call_indirect 0 (i32.const 0) (i32.const 1) (nop) (i32.const 2)) + (call_indirect 0 (i32.const 1) (nop) (i32.const 2) (i32.const 0)) ) ) "arity mismatch" @@ -263,7 +268,7 @@ (module (type (func (param i32 i32))) (func $arity-nop-last - (call_indirect 0 (i32.const 0) (i32.const 1) (i32.const 2) (nop)) + (call_indirect 0 (i32.const 1) (i32.const 2) (nop) (i32.const 0)) ) ) "arity mismatch" @@ -272,14 +277,14 @@ (assert_invalid (module (type (func (param i32))) - (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" ) (assert_invalid (module (type (func (param i32))) - (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" ) @@ -288,7 +293,7 @@ (module (type (func (param i32 i32))) (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" @@ -297,7 +302,7 @@ (module (type (func (param i32 i32))) (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" @@ -306,7 +311,7 @@ (module (type (func (param i32 f64))) (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" @@ -315,7 +320,7 @@ (module (type (func (param f64 i32))) (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" diff --git a/ml-proto/test/left-to-right.wast b/ml-proto/test/left-to-right.wast index 8c8ea104be..ab63493bf0 100644 --- a/ml-proto/test/left-to-right.wast +++ b/ml-proto/test/left-to-right.wast @@ -85,7 +85,7 @@ (func $i32_store8 (result i32) (call $reset) (i32.store8 (call $i32_left) (call $i32_right)) (call $get)) (func $i32_store16 (result i32) (call $reset) (i32.store16 (call $i32_left) (call $i32_right)) (call $get)) (func $i32_call (result i32) (call $reset) (call $i32_dummy (call $i32_left) (call $i32_right)) (call $get)) - (func $i32_call_indirect (result i32) (call $reset) (drop (call_indirect $i32_T (call $i32_callee) (call $i32_right) (call $i32_another))) (call $get)) + (func $i32_call_indirect (result i32) (call $reset) (drop (call_indirect $i32_T (call $i32_left) (call $i32_right) (call $i32_callee))) (call $get)) (func $i32_select (result i32) (call $reset) (drop (select (call $i32_left) (call $i32_right) (call $i32_bool))) (call $get)) (func $i64_add (result i32) (call $reset) (drop (i64.add (call $i64_left) (call $i64_right))) (call $get)) @@ -116,7 +116,7 @@ (func $i64_store16 (result i32) (call $reset) (i64.store16 (call $i32_left) (call $i64_right)) (call $get)) (func $i64_store32 (result i32) (call $reset) (i64.store32 (call $i32_left) (call $i64_right)) (call $get)) (func $i64_call (result i32) (call $reset) (call $i64_dummy (call $i64_left) (call $i64_right)) (call $get)) - (func $i64_call_indirect (result i32) (call $reset) (drop (call_indirect $i64_T (call $i64_callee) (call $i64_right) (call $i64_another))) (call $get)) + (func $i64_call_indirect (result i32) (call $reset) (drop (call_indirect $i64_T (call $i64_left) (call $i64_right) (call $i64_callee))) (call $get)) (func $i64_select (result i32) (call $reset) (drop (select (call $i64_left) (call $i64_right) (call $i64_bool))) (call $get)) @@ -135,7 +135,7 @@ (func $f32_max (result i32) (call $reset) (drop (f32.max (call $f32_left) (call $f32_right))) (call $get)) (func $f32_store (result i32) (call $reset) (f32.store (call $i32_left) (call $f32_right)) (call $get)) (func $f32_call (result i32) (call $reset) (call $f32_dummy (call $f32_left) (call $f32_right)) (call $get)) - (func $f32_call_indirect (result i32) (call $reset) (drop (call_indirect $f32_T (call $f32_callee) (call $f32_right) (call $f32_another))) (call $get)) + (func $f32_call_indirect (result i32) (call $reset) (drop (call_indirect $f32_T (call $f32_left) (call $f32_right) (call $f32_callee))) (call $get)) (func $f32_select (result i32) (call $reset) (drop (select (call $f32_left) (call $f32_right) (call $f32_bool))) (call $get)) (func $f64_add (result i32) (call $reset) (drop (f64.add (call $f64_left) (call $f64_right))) (call $get)) @@ -153,7 +153,7 @@ (func $f64_max (result i32) (call $reset) (drop (f64.max (call $f64_left) (call $f64_right))) (call $get)) (func $f64_store (result i32) (call $reset) (f64.store (call $i32_left) (call $f64_right)) (call $get)) (func $f64_call (result i32) (call $reset) (call $f64_dummy (call $f64_left) (call $f64_right)) (call $get)) - (func $f64_call_indirect (result i32) (call $reset) (drop (call_indirect $f64_T (call $f64_callee) (call $f64_right) (call $f64_another))) (call $get)) + (func $f64_call_indirect (result i32) (call $reset) (drop (call_indirect $f64_T (call $f64_left) (call $f64_right) (call $f64_callee))) (call $get)) (func $f64_select (result i32) (call $reset) (drop (select (call $f64_left) (call $f64_right) (call $f64_bool))) (call $get)) (func $br_if (result i32) @@ -256,8 +256,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)) @@ -275,8 +275,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/nop.wast b/ml-proto/test/nop.wast index 235d203adb..97e64b1185 100644 --- a/ml-proto/test/nop.wast +++ b/ml-proto/test/nop.wast @@ -34,10 +34,10 @@ ) (func "as-if-then" (param i32) - (block (if (get_local 0) (nop) (call $dummy))) + (if (get_local 0) (nop) (call $dummy)) ) (func "as-if-else" (param i32) - (block (if (get_local 0) (call $dummy) (nop))) + (if (get_local 0) (call $dummy) (nop)) ) ) @@ -60,17 +60,17 @@ (assert_invalid (module (func $type-i32 (result i32) (nop))) - "type mismatch" + "arity mismatch" ) (assert_invalid (module (func $type-i64 (result i64) (nop))) - "type mismatch" + "arity mismatch" ) (assert_invalid (module (func $type-f32 (result f32) (nop))) - "type mismatch" + "arity mismatch" ) (assert_invalid (module (func $type-f64 (result f64) (nop))) - "type mismatch" + "arity mismatch" ) diff --git a/ml-proto/test/set_local.wast b/ml-proto/test/set_local.wast index 52aced9a26..3571918387 100644 --- a/ml-proto/test/set_local.wast +++ b/ml-proto/test/set_local.wast @@ -95,19 +95,19 @@ (module (func $type-local-num-vs-num (result i64) (local i32) (set_local 0 (i32.const 0)) )) - "type mismatch" + "arity mismatch" ) (assert_invalid (module (func $type-local-num-vs-num (local f32) (i32.eqz (set_local 0 (f32.const 0))) )) - "type mismatch" + "arity mismatch" ) (assert_invalid (module (func $type-local-num-vs-num (local f64 i64) (f64.neg (set_local 1 (i64.const 0))) )) - "type mismatch" + "arity mismatch" ) (assert_invalid diff --git a/ml-proto/test/unreachable.wast b/ml-proto/test/unreachable.wast index 3ec8f9d870..06ec086098 100644 --- a/ml-proto/test/unreachable.wast +++ b/ml-proto/test/unreachable.wast @@ -49,7 +49,7 @@ (loop (nop) (call $dummy) (unreachable)) ) (func "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 "as-br-value" (result i32) From a706df57161d190b7430b0dd67212a5be3faa0ab Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 8 Jul 2016 13:53:07 +0200 Subject: [PATCH 09/44] Adapt AST --- ml-proto/host/encode.ml | 348 +++++++++++++++-------------- ml-proto/host/format.ml | 6 +- ml-proto/host/lexer.mll | 245 ++++++++------------- ml-proto/host/parser.mly | 99 ++++----- ml-proto/spec/ast.ml | 318 +++++++++++++-------------- ml-proto/spec/check.ml | 9 +- ml-proto/spec/decode.ml | 458 +++++++++++++++++++-------------------- ml-proto/spec/desugar.ml | 428 +++++++++++++++++------------------- ml-proto/spec/eval.ml | 37 ++-- ml-proto/spec/kernel.ml | 6 +- 10 files changed, 912 insertions(+), 1042 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 1d7fc33003..2d5643101e 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -94,9 +94,6 @@ let encode m = open Ast let op n = u8 n - let arity xs = vu (List.length xs) - let arity1 xo = bool (xo <> None) - let memop off align = vu align; vu64 off (*TODO: to be resolved*) let var x = vu x.it @@ -107,17 +104,17 @@ let encode m = | 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 + | If (es1, es2) -> + op 0x03; list expr es1; + if es2 <> [] then op 0x04; + list expr es2; op 0x0f + | Select -> op 0x05 + | Br (n, x) -> op 0x06; vu n; var x + | Br_if (n, x) -> op 0x07; vu n; var x + | Br_table (n, xs, x) -> op 0x08; vu n; vec var32 xs; var32 x + | Ast.Return n -> op 0x09; vu n | Ast.Unreachable -> op 0x0a - | Ast.Drop e -> unary e 0x0b + | Ast.Drop -> op 0x0b | Ast.I32_const c -> op 0x10; vs32 c.it | Ast.I64_const c -> op 0x11; vs64 c.it @@ -125,173 +122,168 @@ let encode m = | 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.Call (x, es) -> nary es 0x16; var x - | Ast.Call_indirect (x, e, es) -> expr e; nary es 0x17; var x - | Ast.Call_import (x, es) -> nary es 0x18; 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 + | Ast.Set_local x -> op 0x15; var x + | Ast.Tee_local x -> op 0x19; var x + + | Ast.Call (n, x) -> op 0x16; vu n; var x + | Ast.Call_indirect (n, x) -> op 0x17; vu n; var x + | Ast.Call_import (n, x) -> op 0x18; vu n; var x + + | I32_load8_s (o, a) -> op 0x20; memop o a + | I32_load8_u (o, a) -> op 0x21; memop o a + | I32_load16_s (o, a) -> op 0x22; memop o a + | I32_load16_u (o, a) -> op 0x23; memop o a + | I64_load8_s (o, a) -> op 0x24; memop o a + | I64_load8_u (o, a) -> op 0x25; memop o a + | I64_load16_s (o, a) -> op 0x26; memop o a + | I64_load16_u (o, a) -> op 0x27; memop o a + | I64_load32_s (o, a) -> op 0x28; memop o a + | I64_load32_u (o, a) -> op 0x29; memop o a + | I32_load (o, a) -> op 0x2a; memop o a + | I64_load (o, a) -> op 0x2b; memop o a + | F32_load (o, a) -> op 0x2c; memop o a + | F64_load (o, a) -> op 0x2d; memop o a + + | I32_store8 (o, a) -> op 0x2e; memop o a + | I32_store16 (o, a) -> op 0x2f; memop o a + | I64_store8 (o, a) -> op 0x30; memop o a + | I64_store16 (o, a) -> op 0x31; memop o a + | I64_store32 (o, a) -> op 0x32; memop o a + | I32_store (o, a) -> op 0x33; memop o a + | I64_store (o, a) -> op 0x34; memop o a + | F32_store (o, a) -> op 0x35; memop o a + | F64_store (o, a) -> op 0x36; memop o a + + | Grow_memory -> op 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 + | I32_add -> op 0x40 + | I32_sub -> op 0x41 + | I32_mul -> op 0x42 + | I32_div_s -> op 0x43 + | I32_div_u -> op 0x44 + | I32_rem_s -> op 0x45 + | I32_rem_u -> op 0x46 + | I32_and -> op 0x47 + | I32_or -> op 0x48 + | I32_xor -> op 0x49 + | I32_shl -> op 0x4a + | I32_shr_u -> op 0x4b + | I32_shr_s -> op 0x4c + | I32_rotl -> op 0xb6 + | I32_rotr -> op 0xb7 + | I32_eq -> op 0x4d + | I32_ne -> op 0x4e + | I32_lt_s -> op 0x4f + | I32_le_s -> op 0x50 + | I32_lt_u -> op 0x51 + | I32_le_u -> op 0x52 + | I32_gt_s -> op 0x53 + | I32_ge_s -> op 0x54 + | I32_gt_u -> op 0x55 + | I32_ge_u -> op 0x56 + | I32_clz -> op 0x57 + | I32_ctz -> op 0x58 + | I32_popcnt -> op 0x59 + | I32_eqz -> op 0x5a + + | I64_add -> op 0x5b + | I64_sub -> op 0x5c + | I64_mul -> op 0x5d + | I64_div_s -> op 0x5e + | I64_div_u -> op 0x5f + | I64_rem_s -> op 0x60 + | I64_rem_u -> op 0x61 + | I64_and -> op 0x62 + | I64_or -> op 0x63 + | I64_xor -> op 0x64 + | I64_shl -> op 0x65 + | I64_shr_u -> op 0x66 + | I64_shr_s -> op 0x67 + | I64_rotl -> op 0xb8 + | I64_rotr -> op 0xb9 + | I64_eq -> op 0x68 + | I64_ne -> op 0x69 + | I64_lt_s -> op 0x6a + | I64_le_s -> op 0x6b + | I64_lt_u -> op 0x6c + | I64_le_u -> op 0x6d + | I64_gt_s -> op 0x6e + | I64_ge_s -> op 0x6f + | I64_gt_u -> op 0x70 + | I64_ge_u -> op 0x71 + | I64_clz -> op 0x72 + | I64_ctz -> op 0x73 + | I64_popcnt -> op 0x74 + | I64_eqz -> op 0xba + + | F32_add -> op 0x75 + | F32_sub -> op 0x76 + | F32_mul -> op 0x77 + | F32_div -> op 0x78 + | F32_min -> op 0x79 + | F32_max -> op 0x7a + | F32_abs -> op 0x7b + | F32_neg -> op 0x7c + | F32_copysign -> op 0x7d + | F32_ceil -> op 0x7e + | F32_floor -> op 0x7f + | F32_trunc -> op 0x80 + | F32_nearest -> op 0x81 + | F32_sqrt -> op 0x82 + | F32_eq -> op 0x83 + | F32_ne -> op 0x84 + | F32_lt -> op 0x85 + | F32_le -> op 0x86 + | F32_gt -> op 0x87 + | F32_ge -> op 0x88 + + | F64_add -> op 0x89 + | F64_sub -> op 0x8a + | F64_mul -> op 0x8b + | F64_div -> op 0x8c + | F64_min -> op 0x8d + | F64_max -> op 0x8e + | F64_abs -> op 0x8f + | F64_neg -> op 0x90 + | F64_copysign -> op 0x91 + | F64_ceil -> op 0x92 + | F64_floor -> op 0x93 + | F64_trunc -> op 0x94 + | F64_nearest -> op 0x95 + | F64_sqrt -> op 0x96 + | F64_eq -> op 0x97 + | F64_ne -> op 0x98 + | F64_lt -> op 0x99 + | F64_le -> op 0x9a + | F64_gt -> op 0x9b + | F64_ge -> op 0x9c + + | I32_trunc_s_f32 -> op 0x9d + | I32_trunc_s_f64 -> op 0x9e + | I32_trunc_u_f32 -> op 0x9f + | I32_trunc_u_f64 -> op 0xa0 + | I32_wrap_i64 -> op 0xa1 + | I64_trunc_s_f32 -> op 0xa2 + | I64_trunc_s_f64 -> op 0xa3 + | I64_trunc_u_f32 -> op 0xa4 + | I64_trunc_u_f64 -> op 0xa5 + | I64_extend_s_i32 -> op 0xa6 + | I64_extend_u_i32 -> op 0xa7 + | F32_convert_s_i32 -> op 0xa8 + | F32_convert_u_i32 -> op 0xa9 + | F32_convert_s_i64 -> op 0xaa + | F32_convert_u_i64 -> op 0xab + | F32_demote_f64 -> op 0xac + | F32_reinterpret_i32 -> op 0xad + | F64_convert_s_i32 -> op 0xae + | F64_convert_u_i32 -> op 0xaf + | F64_convert_s_i64 -> op 0xb0 + | F64_convert_u_i64 -> op 0xb1 + | F64_promote_f32 -> op 0xb2 + | F64_reinterpret_i64 -> op 0xb3 + | I32_reinterpret_f32 -> op 0xb4 + | I64_reinterpret_f64 -> op 0xb5 (* Sections *) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 9f38c4f5e9..27fbef83b7 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -207,9 +207,9 @@ let rec expr e = | sxs2, sxs3 -> "if", [Node ("then", sxs2); Node ("else", sxs3)] ) | Select -> "select", [] - | Call x -> "call " ^ var x, [] - | CallImport x -> "call_import " ^ var x, [] - | CallIndirect x -> "call_indirect " ^ var x, [] + | Call (n, x) -> "call " ^ var x, [] + | CallImport (n, x) -> "call_import " ^ var x, [] + | CallIndirect (n, x) -> "call_indirect " ^ var x, [] | GetLocal x -> "get_local " ^ var x, [] | SetLocal x -> "set_local " ^ var x, [] | TeeLocal x -> "tee_local " ^ var x, [] diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 9824be3673..5299651126 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -76,6 +76,8 @@ let ext e s u = | 's' -> s | 'u' -> u | _ -> assert false + +let opt = Lib.Option.get } let space = [' ''\t'] @@ -162,194 +164,119 @@ rule token = parse | "tee_local" { TEE_LOCAL } | (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 (o, a) -> + numop t (I32_load (o, opt a 4)) (I64_load (o, opt a 8)) + (F32_load (o, opt a 4)) (F64_load (o, opt a 8))) } | (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 (o, a) -> + numop t (I32_store (o, opt a 4)) (I64_store (o, opt a 8)) + (F32_store (o, opt a 4)) (F64_store (o, opt a 8))) } | (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 (o, a) -> 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))) + (ext s (I32_load8_s (o, opt a 1)) (I32_load8_u (o, opt a 1))) + (ext s (I32_load16_s (o, opt a 2)) (I32_load16_u (o, opt a 2))) Unreachable) (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 (o, opt a 1)) (I64_load8_u (o, opt a 1))) + (ext s (I64_load16_s (o, opt a 2)) (I64_load16_u (o, opt a 2))) + (ext s (I64_load32_s (o, opt a 4)) (I64_load32_u (o, opt a 4))))) } | (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 (o, a) -> intop t (memsz sz - (I32_store8 (o, (Lib.Option.get a 1), e1, e2)) - (I32_store16 (o, (Lib.Option.get a 2), e1, e2)) + (I32_store8 (o, opt a 1)) + (I32_store16 (o, opt a 2)) Unreachable) (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 (o, opt a 1)) + (I64_store16 (o, opt a 2)) + (I64_store32 (o, opt a 4)))) } | "offset="(digits as s) { OFFSET (Int64.of_string s) } | "align="(digits as s) { ALIGN (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 } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 7d33f58250..2c7e4237c1 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -143,13 +143,13 @@ let implicit_decl c t at = %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 UNARY +%token BINARY +%token TEST +%token COMPARE +%token CONVERT +%token Ast.expr'> LOAD +%token Ast.expr'> STORE %token OFFSET %token ALIGN @@ -226,62 +226,63 @@ align : ; expr : - | LPAR expr1 RPAR { let at = at () in fun c -> $2 c @@ at } + | LPAR expr1 RPAR + { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } ; expr1 : - | NOP { fun c -> Nop } - | UNREACHABLE { fun c -> Unreachable } - | DROP expr { fun c -> Drop ($2 c) } - | BLOCK labeling expr_list { fun c -> let c' = $2 c in Block ($3 c') } + | NOP { fun c -> [], Nop } + | UNREACHABLE { fun c -> [], Unreachable } + | DROP expr { fun c -> $2 c, Drop } + | BLOCK labeling expr_list + { fun c -> let c' = $2 c in [], Block (snd ($3 c')) } | LOOP labeling expr_list - { fun c -> let c' = anon_label c in let c'' = $2 c' in Loop ($3 c'') } + { fun c -> let c' = anon_label c in let c'' = $2 c' in [], Loop (snd ($3 c'')) } | LOOP labeling1 labeling1 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) } + { fun c -> let c' = $2 c in let c'' = $3 c' in [], Loop (snd ($4 c'')) } + | BR var { fun c -> [], Br (0, $2 c label) } + | BR var expr { fun c -> $3 c, Br (1, $2 c label) } + | BR_IF var expr { fun c -> $3 c, Br_if (0, $2 c label) } + | BR_IF var expr expr { fun c -> $3 c @ $4 c, Br_if (1, $2 c label) } | 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) } + $4 c, Br_table (0, xs, x) } | BR_TABLE var var_list expr expr { 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'], []) } + $4 c @ $5 c, Br_table (1, xs, x) } + | RETURN { fun c -> [], Return 0 } + | RETURN expr { fun c -> $2 c, Return 1 } + | 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']) } + { fun c -> let c' = anon_label c in $2 c, If ($3 c', $4 c') } | IF expr LPAR THEN labeling expr_list RPAR - { fun c -> let c' = $5 c in If ($2 c, $6 c', []) } + { fun c -> let c' = $5 c in $2 c, If (snd ($6 c'), []) } | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling 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_IMPORT var expr_list { fun c -> Call_import ($2 c import, $3 c) } + { fun c -> let c1 = $5 c in let c2 = $10 c in + $2 c, If (snd ($6 c1), snd ($11 c2)) } + | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, Select } + | CALL var expr_list { fun c -> let n, es = $3 c in es, Call (n, $2 c func) } + | CALL_IMPORT var expr_list + { fun c -> let n, es = $3 c in es, Call_import (n, $2 c import) } | CALL_INDIRECT var expr expr_list { fun c -> - let es, e = Lib.List.split_last ($3 c :: $4 c) in - Call_indirect ($2 c type_, e, es) } - | 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) } - | 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) } + let e = $3 c and n, es = $4 c in e @ es, Call_indirect (n, $2 c type_) } + | GET_LOCAL var { fun c -> [], Get_local ($2 c local) } + | SET_LOCAL var expr { fun c -> $3 c, Set_local ($2 c local) } + | TEE_LOCAL var expr { fun c -> $3 c, Tee_local ($2 c local) } + | LOAD offset align expr { fun c -> $4 c, $1 ($2, $3) } + | STORE offset align expr expr { fun c -> $4 c @ $5 c, $1 ($2, $3) } + | CONST literal { fun c -> [], fst (literal $1 $2) } + | UNARY expr { fun c -> $2 c, $1 } + | BINARY expr expr { fun c -> $2 c @ $3 c, $1 } + | TEST expr { fun c -> $2 c, $1 } + | COMPARE expr expr { fun c -> $2 c @ $3 c, $1 } + | CONVERT expr { fun c -> $2 c, $1 } + | CURRENT_MEMORY { fun c -> [], Current_memory } + | GROW_MEMORY expr { fun c -> $2 c, Grow_memory } ; expr_list : - | /* empty */ { fun c -> [] } - | expr expr_list { fun c -> $1 c :: $2 c } + | /* empty */ { fun c -> 0, [] } + | expr expr_list { fun c -> let e = $1 c and n, es = $2 c in n + 1, e @ es } ; @@ -304,7 +305,7 @@ func_body : | expr_list { empty_type, fun c -> let c' = anon_label c in - {ftype = -1 @@ at(); locals = []; body = $1 c'} } + {ftype = -1 @@ at(); locals = []; body = snd ($1 c')} } | LPAR LOCAL value_type_list RPAR func_body { fst $5, fun c -> anon_locals c $3; let f = (snd $5) c in diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 6e9fddb957..af1c6e4aa4 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -13,185 +13,185 @@ and expr' = (* Control *) | Nop | Unreachable - | Drop of expr + | Drop | 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_import of var * expr list - | Call_indirect of var * expr * expr list + | Br of int * var + | Br_if of int * var + | Br_table of int * var list * var + | Return of int + | If of expr list * expr list + | Select + | Call of int * var + | Call_import of int * var + | Call_indirect of int * var (* Locals *) | Get_local of var - | Set_local of var * expr - | Tee_local of var * expr + | Set_local of var + | Tee_local of var (* 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 + | I32_load of Memory.offset * int + | I64_load of Memory.offset * int + | F32_load of Memory.offset * int + | F64_load of Memory.offset * int + | I32_store of Memory.offset * int + | I64_store of Memory.offset * int + | F32_store of Memory.offset * int + | F64_store of Memory.offset * int + | I32_load8_s of Memory.offset * int + | I32_load8_u of Memory.offset * int + | I32_load16_s of Memory.offset * int + | I32_load16_u of Memory.offset * int + | I64_load8_s of Memory.offset * int + | I64_load8_u of Memory.offset * int + | I64_load16_s of Memory.offset * int + | I64_load16_u of Memory.offset * int + | I64_load32_s of Memory.offset * int + | I64_load32_u of Memory.offset * int + | I32_store8 of Memory.offset * int + | I32_store16 of Memory.offset * int + | I64_store8 of Memory.offset * int + | I64_store16 of Memory.offset * int + | I64_store32 of Memory.offset * int (* 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 + | I32_clz + | I32_ctz + | I32_popcnt + | I64_clz + | I64_ctz + | I64_popcnt + | F32_neg + | F32_abs + | F32_sqrt + | F32_ceil + | F32_floor + | F32_trunc + | F32_nearest + | F64_neg + | F64_abs + | F64_sqrt + | F64_ceil + | F64_floor + | F64_trunc + | F64_nearest (* 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 + | I32_add + | I32_sub + | I32_mul + | I32_div_s + | I32_div_u + | I32_rem_s + | I32_rem_u + | I32_and + | I32_or + | I32_xor + | I32_shl + | I32_shr_s + | I32_shr_u + | I32_rotl + | I32_rotr + | I64_add + | I64_sub + | I64_mul + | I64_div_s + | I64_div_u + | I64_rem_s + | I64_rem_u + | I64_and + | I64_or + | I64_xor + | I64_shl + | I64_shr_s + | I64_shr_u + | I64_rotl + | I64_rotr + | F32_add + | F32_sub + | F32_mul + | F32_div + | F32_min + | F32_max + | F32_copysign + | F64_add + | F64_sub + | F64_mul + | F64_div + | F64_min + | F64_max + | F64_copysign (* Predicates *) - | I32_eqz of expr - | I64_eqz of expr + | I32_eqz + | I64_eqz (* 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 + | I32_eq + | I32_ne + | I32_lt_s + | I32_lt_u + | I32_le_s + | I32_le_u + | I32_gt_s + | I32_gt_u + | I32_ge_s + | I32_ge_u + | I64_eq + | I64_ne + | I64_lt_s + | I64_lt_u + | I64_le_s + | I64_le_u + | I64_gt_s + | I64_gt_u + | I64_ge_s + | I64_ge_u + | F32_eq + | F32_ne + | F32_lt + | F32_le + | F32_gt + | F32_ge + | F64_eq + | F64_ne + | F64_lt + | F64_le + | F64_gt + | F64_ge (* 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 + | I32_wrap_i64 + | I32_trunc_s_f32 + | I32_trunc_u_f32 + | I32_trunc_s_f64 + | I32_trunc_u_f64 + | I64_extend_s_i32 + | I64_extend_u_i32 + | I64_trunc_s_f32 + | I64_trunc_u_f32 + | I64_trunc_s_f64 + | I64_trunc_u_f64 + | F32_convert_s_i32 + | F32_convert_u_i32 + | F32_convert_s_i64 + | F32_convert_u_i64 + | F32_demote_f64 + | F64_convert_s_i32 + | F64_convert_u_i32 + | F64_convert_s_i64 + | F64_convert_u_i64 + | F64_promote_f32 + | I32_reinterpret_f32 + | I64_reinterpret_f64 + | F32_reinterpret_i32 + | F64_reinterpret_i64 (* Host queries *) | Current_memory - | Grow_memory of expr + | Grow_memory (* Functions *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 25f6b2e1cd..58a3a143df 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -219,16 +219,19 @@ let rec check_expr (c : context) (e : expr) : op_type = let t = var () in [t; t; fix Int32Type] --> fix [t] - | Call x -> + | Call (n, x) -> let FuncType (ins, out) = func c x in + require (List.length ins = n) e.at "arity mismatch"; fix_list ins --> fix (fix_list out) - | CallImport x -> + | CallImport (n, x) -> let FuncType (ins, out) = import c x in + require (List.length ins = n) e.at "arity mismatch"; fix_list ins --> fix (fix_list out) - | CallIndirect x -> + | CallIndirect (n, x) -> let FuncType (ins, out) = type_ c.types x in + require (List.length ins = n) e.at "arity mismatch"; fix_list (ins @ [Int32Type]) --> fix (fix_list out) | GetLocal x -> diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 814d9f6d87..5e2029142a 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -137,7 +137,6 @@ open Ast let op s = u8 s let arity s = vu s -let arity1 s = bool s let memop s = let align = vu s in @@ -161,273 +160,258 @@ let args1 b stack s pos = | [e], stack' -> Some e, stack' | _ -> assert false -let rec expr stack s = +let rec expr s = let pos = pos s in - match op s, stack with - | 0x00, es -> - Nop, es - | 0x01, es -> + match op s with + | 0x00 -> Nop + | 0x01 -> let es' = expr_block s in expect 0x0f s "END opcode expected"; - Block es', es - | 0x02, es -> + Block es' + | 0x02 -> let es' = expr_block s in expect 0x0f s "END opcode expected"; - Loop es', es - | 0x03, e :: es -> + Loop es' + | 0x03 -> let es1 = expr_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 + If (es1, es2) end else begin expect 0x0f s "END opcode expected"; - If (e, es1, []), es + 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 + | 0x04 -> error s pos "misplaced ELSE opcode" + | 0x05 -> Select + | 0x06 -> + let n = arity 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 + Br (n, x) + | 0x07 -> + let n = arity 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 + Br_if (n, x) + | 0x08 -> + let n = arity 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 -> + Br_table (n, xs, x) + | 0x09 -> + let n = arity s in + Return n + | 0x0a -> Unreachable + | 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 -> let x = at var s in - Get_local x, es - | 0x15, e :: es -> + Get_local x + | 0x15 -> let x = at var s in - Set_local (x, e), es + Set_local x - | 0x16, es -> + | 0x16 -> 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 -> + Call (n, x) + | 0x17 -> 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' - | 0x18, es -> + Call_indirect (n, x) + | 0x18 -> let n = arity s in let x = at var s in - let es1, es' = args n es s pos in - Call_import (x, es1), es' + Call_import (n, x) - | 0x19, e :: es -> + | 0x19 -> let x = at var s in - Tee_local (x, e), es - - | 0x1a | 0x1b | 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 - - | b, _ when b > 0xba -> 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 + Tee_local x + + | 0x1a | 0x1b | 0x1c | 0x1d | 0x1e | 0x1f as b -> illegal s pos b + + | 0x20 -> let o, a = memop s in I32_load8_s (o, a) + | 0x21 -> let o, a = memop s in I32_load8_u (o, a) + | 0x22 -> let o, a = memop s in I32_load16_s (o, a) + | 0x23 -> let o, a = memop s in I32_load16_u (o, a) + | 0x24 -> let o, a = memop s in I64_load8_s (o, a) + | 0x25 -> let o, a = memop s in I64_load8_u (o, a) + | 0x26 -> let o, a = memop s in I64_load16_s (o, a) + | 0x27 -> let o, a = memop s in I64_load16_u (o, a) + | 0x28 -> let o, a = memop s in I64_load32_s (o, a) + | 0x29 -> let o, a = memop s in I64_load32_u (o, a) + | 0x2a -> let o, a = memop s in I32_load (o, a) + | 0x2b -> let o, a = memop s in I64_load (o, a) + | 0x2c -> let o, a = memop s in F32_load (o, a) + | 0x2d -> let o, a = memop s in F64_load (o, a) + + | 0x2e -> let o, a = memop s in I32_store8 (o, a) + | 0x2f -> let o, a = memop s in I32_store16 (o, a) + | 0x30 -> let o, a = memop s in I64_store8 (o, a) + | 0x31 -> let o, a = memop s in I64_store16 (o, a) + | 0x32 -> let o, a = memop s in I64_store32 (o, a) + | 0x33 -> let o, a = memop s in I32_store (o, a) + | 0x34 -> let o, a = memop s in I64_store (o, a) + | 0x35 -> let o, a = memop s in F32_store (o, a) + | 0x36 -> let o, a = memop s in F64_store (o, a) + + | 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 + + | b when b > 0xba -> 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' s es = + if eos s then es else 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' = expr s in + expr_block' s (Source.(e' @@ region s pos pos) :: es) (* Sections *) diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 88e7d8ab97..6fc9b517f1 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -7,241 +7,207 @@ open Kernel (* Expressions *) -let rec expr e = let e', es' = expr' e.at e.it in es' @ [e' @@ e.at] +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 es -> Block (expr_list es), [] - | Ast.Loop es -> Block [Loop (expr_list es) @@ at], [] - | Ast.Br (x, eo) -> Break (arity eo, x), expr_opt eo - | Ast.Br_if (x, eo, e) -> BreakIf (arity eo, x), expr_opt eo @ expr e - | Ast.Br_table (xs, x, eo, e) -> - BreakTable (arity eo, xs, x), expr_opt eo @ expr e - | Ast.Return eo -> Return (arity eo), expr_opt eo - | Ast.If (e, es1, es2) -> - If ([Block (expr_list es1) @@ at], [Block (expr_list es2) @@ at]), expr e - | Ast.Select (e1, e2, e3) -> Select, expr e1 @ expr e2 @ expr e3 - - | Ast.Call (x, es) -> Call x, expr_list es - | Ast.Call_import (x, es) -> CallImport x, expr_list es - | Ast.Call_indirect (x, e, es) -> CallIndirect x, expr_list es @ expr e - - | 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.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) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = SX}, - expr e - | Ast.I32_load8_u (offset, align, e) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = ZX}, - expr e - | Ast.I32_load16_s (offset, align, e) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = SX}, - expr e - | Ast.I32_load16_u (offset, align, e) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = ZX}, - expr e - | Ast.I64_load8_s (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = SX}, - expr e - | Ast.I64_load8_u (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = ZX}, - expr e - | Ast.I64_load16_s (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = SX}, - expr e - | Ast.I64_load16_u (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = ZX}, - expr e - | Ast.I64_load32_s (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = SX}, - expr e - | Ast.I64_load32_u (offset, align, e) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = ZX}, - expr e - | Ast.I32_store8 (offset, align, e1, e2) -> - StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem8}, - expr e1 @ expr e2 - | Ast.I32_store16 (offset, align, e1, e2) -> - StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem16}, - expr e1 @ expr e2 - | Ast.I64_store8 (offset, align, e1, e2) -> - StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem8}, - expr e1 @ expr e2 - | Ast.I64_store16 (offset, align, e1, e2) -> - StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem16}, - expr e1 @ expr e2 - | Ast.I64_store32 (offset, align, e1, e2) -> - StorePacked {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 -> CurrentMemory, [] - | Ast.Grow_memory e -> GrowMemory, expr e + | 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 -> Drop + | Ast.Block es -> Block (expr_list es) + | Ast.Loop es -> Block [Loop (expr_list es) @@ at] + | Ast.Br (n, x) -> Break (n, x) + | Ast.Br_if (n, x) -> BreakIf (n, x) + | Ast.Br_table (n, xs, x) -> BreakTable (n, xs, x) + | Ast.Return n -> Return n + | Ast.If (es1, es2) -> + If ([Block (expr_list es1) @@ at], [Block (expr_list es2) @@ at]) + | Ast.Select -> Select + + | Ast.Call (n, x) -> Call (n, x) + | Ast.Call_import (n, x) -> CallImport (n, x) + | Ast.Call_indirect (n, x) -> CallIndirect (n, x) + + | Ast.Get_local x -> GetLocal x + | Ast.Set_local x -> SetLocal x + | Ast.Tee_local x -> TeeLocal x + + | Ast.I32_load (offset, align) -> Load {ty = Int32Type; offset; align} + | Ast.I64_load (offset, align) -> Load {ty = Int64Type; offset; align} + | Ast.F32_load (offset, align) -> Load {ty = Float32Type; offset; align} + | Ast.F64_load (offset, align) -> Load {ty = Float64Type; offset; align} + | Ast.I32_store (offset, align) -> Store {ty = Int32Type; offset; align} + | Ast.I64_store (offset, align) -> Store {ty = Int64Type; offset; align} + | Ast.F32_store (offset, align) -> Store {ty = Float32Type; offset; align} + | Ast.F64_store (offset, align) -> Store {ty = Float64Type; offset; align} + | Ast.I32_load8_s (offset, align) -> + LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = SX} + | Ast.I32_load8_u (offset, align) -> + LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = ZX} + | Ast.I32_load16_s (offset, align) -> + LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = SX} + | Ast.I32_load16_u (offset, align) -> + LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = ZX} + | Ast.I64_load8_s (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = SX} + | Ast.I64_load8_u (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = ZX} + | Ast.I64_load16_s (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = SX} + | Ast.I64_load16_u (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = ZX} + | Ast.I64_load32_s (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = SX} + | Ast.I64_load32_u (offset, align) -> + LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = ZX} + | Ast.I32_store8 (offset, align) -> + StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem8} + | Ast.I32_store16 (offset, align) -> + StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem16} + | Ast.I64_store8 (offset, align) -> + StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem8} + | Ast.I64_store16 (offset, align) -> + StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem16} + | Ast.I64_store32 (offset, align) -> + StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem32} + + | Ast.I32_clz -> Unary (Int32 I32Op.Clz) + | Ast.I32_ctz -> Unary (Int32 I32Op.Ctz) + | Ast.I32_popcnt -> Unary (Int32 I32Op.Popcnt) + | Ast.I64_clz -> Unary (Int64 I64Op.Clz) + | Ast.I64_ctz -> Unary (Int64 I64Op.Ctz) + | Ast.I64_popcnt -> Unary (Int64 I64Op.Popcnt) + | Ast.F32_neg -> Unary (Float32 F32Op.Neg) + | Ast.F32_abs -> Unary (Float32 F32Op.Abs) + | Ast.F32_sqrt -> Unary (Float32 F32Op.Sqrt) + | Ast.F32_ceil -> Unary (Float32 F32Op.Ceil) + | Ast.F32_floor -> Unary (Float32 F32Op.Floor) + | Ast.F32_trunc -> Unary (Float32 F32Op.Trunc) + | Ast.F32_nearest -> Unary (Float32 F32Op.Nearest) + | Ast.F64_neg -> Unary (Float64 F64Op.Neg) + | Ast.F64_abs -> Unary (Float64 F64Op.Abs) + | Ast.F64_sqrt -> Unary (Float64 F64Op.Sqrt) + | Ast.F64_ceil -> Unary (Float64 F64Op.Ceil) + | Ast.F64_floor -> Unary (Float64 F64Op.Floor) + | Ast.F64_trunc -> Unary (Float64 F64Op.Trunc) + | Ast.F64_nearest -> Unary (Float64 F64Op.Nearest) + + | Ast.I32_add -> Binary (Int32 I32Op.Add) + | Ast.I32_sub -> Binary (Int32 I32Op.Sub) + | Ast.I32_mul -> Binary (Int32 I32Op.Mul) + | Ast.I32_div_s -> Binary (Int32 I32Op.DivS) + | Ast.I32_div_u -> Binary (Int32 I32Op.DivU) + | Ast.I32_rem_s -> Binary (Int32 I32Op.RemS) + | Ast.I32_rem_u -> Binary (Int32 I32Op.RemU) + | Ast.I32_and -> Binary (Int32 I32Op.And) + | Ast.I32_or -> Binary (Int32 I32Op.Or) + | Ast.I32_xor -> Binary (Int32 I32Op.Xor) + | Ast.I32_shl -> Binary (Int32 I32Op.Shl) + | Ast.I32_shr_s -> Binary (Int32 I32Op.ShrS) + | Ast.I32_shr_u -> Binary (Int32 I32Op.ShrU) + | Ast.I32_rotl -> Binary (Int32 I32Op.Rotl) + | Ast.I32_rotr -> Binary (Int32 I32Op.Rotr) + | Ast.I64_add -> Binary (Int64 I64Op.Add) + | Ast.I64_sub -> Binary (Int64 I64Op.Sub) + | Ast.I64_mul -> Binary (Int64 I64Op.Mul) + | Ast.I64_div_s -> Binary (Int64 I64Op.DivS) + | Ast.I64_div_u -> Binary (Int64 I64Op.DivU) + | Ast.I64_rem_s -> Binary (Int64 I64Op.RemS) + | Ast.I64_rem_u -> Binary (Int64 I64Op.RemU) + | Ast.I64_and -> Binary (Int64 I64Op.And) + | Ast.I64_or -> Binary (Int64 I64Op.Or) + | Ast.I64_xor -> Binary (Int64 I64Op.Xor) + | Ast.I64_shl -> Binary (Int64 I64Op.Shl) + | Ast.I64_shr_s -> Binary (Int64 I64Op.ShrS) + | Ast.I64_shr_u -> Binary (Int64 I64Op.ShrU) + | Ast.I64_rotl -> Binary (Int64 I64Op.Rotl) + | Ast.I64_rotr -> Binary (Int64 I64Op.Rotr) + | Ast.F32_add -> Binary (Float32 F32Op.Add) + | Ast.F32_sub -> Binary (Float32 F32Op.Sub) + | Ast.F32_mul -> Binary (Float32 F32Op.Mul) + | Ast.F32_div -> Binary (Float32 F32Op.Div) + | Ast.F32_min -> Binary (Float32 F32Op.Min) + | Ast.F32_max -> Binary (Float32 F32Op.Max) + | Ast.F32_copysign -> Binary (Float32 F32Op.CopySign) + | Ast.F64_add -> Binary (Float64 F64Op.Add) + | Ast.F64_sub -> Binary (Float64 F64Op.Sub) + | Ast.F64_mul -> Binary (Float64 F64Op.Mul) + | Ast.F64_div -> Binary (Float64 F64Op.Div) + | Ast.F64_min -> Binary (Float64 F64Op.Min) + | Ast.F64_max -> Binary (Float64 F64Op.Max) + | Ast.F64_copysign -> Binary (Float64 F64Op.CopySign) + + | Ast.I32_eqz -> Test (Int32 I32Op.Eqz) + | Ast.I64_eqz -> Test (Int64 I64Op.Eqz) + + | Ast.I32_eq -> Compare (Int32 I32Op.Eq) + | Ast.I32_ne -> Compare (Int32 I32Op.Ne) + | Ast.I32_lt_s -> Compare (Int32 I32Op.LtS) + | Ast.I32_lt_u -> Compare (Int32 I32Op.LtU) + | Ast.I32_le_s -> Compare (Int32 I32Op.LeS) + | Ast.I32_le_u -> Compare (Int32 I32Op.LeU) + | Ast.I32_gt_s -> Compare (Int32 I32Op.GtS) + | Ast.I32_gt_u -> Compare (Int32 I32Op.GtU) + | Ast.I32_ge_s -> Compare (Int32 I32Op.GeS) + | Ast.I32_ge_u -> Compare (Int32 I32Op.GeU) + | Ast.I64_eq -> Compare (Int64 I64Op.Eq) + | Ast.I64_ne -> Compare (Int64 I64Op.Ne) + | Ast.I64_lt_s -> Compare (Int64 I64Op.LtS) + | Ast.I64_lt_u -> Compare (Int64 I64Op.LtU) + | Ast.I64_le_s -> Compare (Int64 I64Op.LeS) + | Ast.I64_le_u -> Compare (Int64 I64Op.LeU) + | Ast.I64_gt_s -> Compare (Int64 I64Op.GtS) + | Ast.I64_gt_u -> Compare (Int64 I64Op.GtU) + | Ast.I64_ge_s -> Compare (Int64 I64Op.GeS) + | Ast.I64_ge_u -> Compare (Int64 I64Op.GeU) + | Ast.F32_eq -> Compare (Float32 F32Op.Eq) + | Ast.F32_ne -> Compare (Float32 F32Op.Ne) + | Ast.F32_lt -> Compare (Float32 F32Op.Lt) + | Ast.F32_le -> Compare (Float32 F32Op.Le) + | Ast.F32_gt -> Compare (Float32 F32Op.Gt) + | Ast.F32_ge -> Compare (Float32 F32Op.Ge) + | Ast.F64_eq -> Compare (Float64 F64Op.Eq) + | Ast.F64_ne -> Compare (Float64 F64Op.Ne) + | Ast.F64_lt -> Compare (Float64 F64Op.Lt) + | Ast.F64_le -> Compare (Float64 F64Op.Le) + | Ast.F64_gt -> Compare (Float64 F64Op.Gt) + | Ast.F64_ge -> Compare (Float64 F64Op.Ge) + + | Ast.I32_wrap_i64 -> Convert (Int32 I32Op.WrapInt64) + | Ast.I32_trunc_s_f32 -> Convert (Int32 I32Op.TruncSFloat32) + | Ast.I32_trunc_u_f32 -> Convert (Int32 I32Op.TruncUFloat32) + | Ast.I32_trunc_s_f64 -> Convert (Int32 I32Op.TruncSFloat64) + | Ast.I32_trunc_u_f64 -> Convert (Int32 I32Op.TruncUFloat64) + | Ast.I64_extend_s_i32 -> Convert (Int64 I64Op.ExtendSInt32) + | Ast.I64_extend_u_i32 -> Convert (Int64 I64Op.ExtendUInt32) + | Ast.I64_trunc_s_f32 -> Convert (Int64 I64Op.TruncSFloat32) + | Ast.I64_trunc_u_f32 -> Convert (Int64 I64Op.TruncUFloat32) + | Ast.I64_trunc_s_f64 -> Convert (Int64 I64Op.TruncSFloat64) + | Ast.I64_trunc_u_f64 -> Convert (Int64 I64Op.TruncUFloat64) + | Ast.F32_convert_s_i32 -> Convert (Float32 F32Op.ConvertSInt32) + | Ast.F32_convert_u_i32 -> Convert (Float32 F32Op.ConvertUInt32) + | Ast.F32_convert_s_i64 -> Convert (Float32 F32Op.ConvertSInt64) + | Ast.F32_convert_u_i64 -> Convert (Float32 F32Op.ConvertUInt64) + | Ast.F32_demote_f64 -> Convert (Float32 F32Op.DemoteFloat64) + | Ast.F64_convert_s_i32 -> Convert (Float64 F64Op.ConvertSInt32) + | Ast.F64_convert_u_i32 -> Convert (Float64 F64Op.ConvertUInt32) + | Ast.F64_convert_s_i64 -> Convert (Float64 F64Op.ConvertSInt64) + | Ast.F64_convert_u_i64 -> Convert (Float64 F64Op.ConvertUInt64) + | Ast.F64_promote_f32 -> Convert (Float64 F64Op.PromoteFloat32) + | Ast.I32_reinterpret_f32 -> Convert (Int32 I32Op.ReinterpretFloat) + | Ast.I64_reinterpret_f64 -> Convert (Int64 I64Op.ReinterpretFloat) + | Ast.F32_reinterpret_i32 -> Convert (Float32 F32Op.ReinterpretInt) + | Ast.F64_reinterpret_i64 -> Convert (Float64 F64Op.ReinterpretInt) + + | Ast.Current_memory -> CurrentMemory + | Ast.Grow_memory -> GrowMemory and expr_list = function | [] -> [] - | e::es -> expr e @ expr_list es - -and expr_opt = function - | None -> [] - | Some e -> expr e - -and arity = function - | None -> 0 - | Some _ -> 1 + | e :: es -> expr e :: expr_list es (* Functions and Modules *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index cd652e27cc..30821c13a4 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -16,7 +16,7 @@ type 'a map = 'a Map.t type instance = { module_ : module_; - imports : (func_type * import) list; + imports : import list; exports : func map; memory : Memory.t option } @@ -158,19 +158,20 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Select, Int32 i :: v2 :: v1 :: vs' -> v1 :: vs', [] - | Call x, vs -> - eval_func c.instance vs (func c.instance x), [] + | Call (n, x), vs -> + eval_func c.instance vs n (func c.instance x), [] - | CallImport x, vs -> - let FuncType (ins, out), f = import c.instance x in - (try List.rev (f (List.rev (keep (List.length ins) vs e.at))), [] + | CallImport (n, x), vs -> + (try + let vs' = List.rev (import c.instance x (List.rev (keep n vs e.at))) in + drop n vs e.at @ vs', [] with Crash (_, msg) -> Crash.error e.at msg) - | CallIndirect ftype, Int32 i :: vs -> + | CallIndirect (n, x), Int32 i :: vs -> let f = func c.instance (table_elem c.instance i e.at) in - if ftype.it <> f.it.ftype.it then + if x.it <> f.it.ftype.it then Trap.error e.at "indirect call signature mismatch"; - eval_func c.instance vs f, [] + eval_func c.instance vs n f, [] | GetLocal x, vs -> !(local c x) :: vs, [] @@ -266,13 +267,11 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | _, _ -> Crash.error e.at "type error: missing or ill-typed operand on stack" -and eval_func (inst : instance) (vs : value stack) (f : func) : value stack = - let FuncType (ins, out) = type_ inst f.it.ftype in - let args = List.map ref (List.rev (keep (List.length ins) vs f.at)) in +and eval_func (inst : instance) (vs : value stack) n (f : func) : value stack = + let args = List.map ref (List.rev (keep n vs f.at)) in let vars = List.map (fun t -> ref (default_value t)) f.it.locals in let c = {instance = inst; locals = args @ vars} in - eval_body c [] [Label (Nop @@ f.at, [], f.it.body) @@ f.at] - @ Lib.List.drop (List.length ins) vs + eval_body c [] [Label (Nop @@ f.at, [], f.it.body) @@ f.at] @ drop n vs f.at and eval_body (c : config) (vs : value stack) (es : expr list) : value stack = match es with @@ -351,20 +350,18 @@ let add_export funcs ex = | `Memory -> fun x -> x let init (m : module_) imports = - let sigs = - List.map (fun im -> lookup "type" m.it.types im.it.itype) m.it.imports in - if (List.length sigs <> List.length imports) then + if (List.length m.it.imports <> List.length imports) then Crash.error m.at "mismatch in number of imports"; let {memory; funcs; exports; start; _} = m.it in let inst = {module_ = m; - imports = List.combine sigs imports; + imports; exports = List.fold_right (add_export funcs) exports Map.empty; memory = Lib.Option.map init_memory memory} in - Lib.Option.app (fun x -> ignore (eval_func inst [] (func inst x))) start; + Lib.Option.app (fun x -> ignore (eval_func inst [] 0 (func inst x))) start; inst let invoke (inst : instance) name (vs : value list) : value list = - try List.rev (eval_func inst (List.rev vs) (export inst (name @@ no_region))) + try List.rev (eval_func inst (List.rev vs) (List.length vs) (export inst (name @@ no_region))) with Stack_overflow -> Trap.error Source.no_region "call stack exhausted" diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index 1c48c49e2a..6a9053a920 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -84,9 +84,9 @@ and expr' = | BreakTable of int * var list * var (* indexed break *) | Return of int (* break from function body *) | If of expr list * expr list (* conditional *) - | Call of var (* call function *) - | CallImport of var (* call imported function *) - | CallIndirect of var (* call function through table *) + | Call of int * var (* call function *) + | CallImport of int * var (* call imported function *) + | CallIndirect of int * 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 *) From f692d30a14568a324fe032ce666593a82163bf8d Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 8 Jul 2016 15:48:00 +0200 Subject: [PATCH 10/44] Supprt raw stack syntax --- ml-proto/host/format.ml | 66 +++++++++++++++++++--------------------- ml-proto/host/lexer.mll | 1 + ml-proto/host/parser.mly | 48 ++++++++++++++++++++++++++++- 3 files changed, 80 insertions(+), 35 deletions(-) diff --git a/ml-proto/host/format.ml b/ml-proto/host/format.ml index 27fbef83b7..8cfa950683 100644 --- a/ml-proto/host/format.ml +++ b/ml-proto/host/format.ml @@ -187,46 +187,44 @@ let value v = string_of_value v.it let constop v = value_type (type_of v.it) ^ ".const" let rec expr e = - let head, inner = match e.it with - | Nop -> "nop", [] - | Unreachable -> "unreachable", [] - | Drop -> "drop", [] - | Block es -> "block", list expr es - | Loop es -> "loop", list expr es - | Break (n, x) -> "br" ^ int n ^ " " ^ var x, [] - | BreakIf (n, x) -> "br_if" ^ int n ^ " " ^ var x, [] + | Nop -> Atom "nop" + | Unreachable -> Atom "unreachable" + | Drop -> Atom "drop" + | Block es -> Node ("block", list expr es) + | Loop es -> Node ("loop", list expr es) + | Break (n, x) -> Atom ("br " ^ int n ^ " " ^ var x) + | BreakIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) | BreakTable (n, xs, x) -> - "br_table" ^ int n ^ " ", list (atom var) (xs @ [x]) - | Return n -> "return" ^ int n, [] + Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) + | Return n -> Atom ("return " ^ int n) | If (es1, es2) -> (match list expr es1, list expr es2 with - | [sx2], [] -> "if", [sx2] - | [sx2], [sx3] -> "if", [sx2; sx3] - | sxs2, [] -> "if", [Node ("then", sxs2)] - | sxs2, sxs3 -> "if", [Node ("then", sxs2); Node ("else", sxs3)] + | [sx2], [] -> Node ("if", [sx2]) + | [sx2], [sx3] -> Node ("if", [sx2; sx3]) + | sxs2, [] -> Node ("if", [Node ("then", sxs2)]) + | sxs2, sxs3 -> Node ("if", [Node ("then", sxs2); Node ("else", sxs3)]) ) - | Select -> "select", [] - | Call (n, x) -> "call " ^ var x, [] - | CallImport (n, x) -> "call_import " ^ var x, [] - | CallIndirect (n, x) -> "call_indirect " ^ var x, [] - | GetLocal x -> "get_local " ^ var x, [] - | SetLocal x -> "set_local " ^ var x, [] - | TeeLocal x -> "tee_local " ^ var x, [] - | Load op -> memop "load" op, [] - | Store op -> memop "store" op, [] - | LoadPacked op -> extop op, [] - | StorePacked op -> wrapop op, [] - | Const lit -> constop lit, [atom 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", [] + | Select -> Atom "select" + | Call (n, x) -> Atom ("call " ^ int n ^ " " ^ var x) + | CallImport (n, x) -> Atom ("call_import " ^ int n ^ " " ^ var x) + | CallIndirect (n, x) -> Atom ("call_indirect " ^ int n ^ " " ^ var x) + | GetLocal x -> Atom ("get_local " ^ var x) + | SetLocal x -> Atom ("set_local " ^ var x) + | TeeLocal x -> Atom ("tee_local " ^ var x) + | Load op -> Atom (memop "load" op) + | Store op -> Atom (memop "store" op) + | LoadPacked op -> Atom (extop op) + | StorePacked op -> Atom (wrapop op) + | Const lit -> Atom (constop lit ^ " " ^ value lit) + | Unary op -> Atom (unop op) + | Binary op -> Atom (binop op) + | Test op -> Atom (testop op) + | Compare op -> Atom (relop op) + | Convert op -> Atom (cvtop op) + | CurrentMemory -> Atom "current_memory" + | GrowMemory -> Atom "grow_memory" | Label _ -> assert false - in Node (head, inner) (* Functions *) diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 5299651126..1c3bea84ef 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -147,6 +147,7 @@ rule token = parse | "drop" { DROP } | "block" { BLOCK } | "loop" { LOOP } + | "end" { END } | "br" { BR } | "br_if" { BR_IF } | "br_table" { BR_TABLE } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 2c7e4237c1..683f631b70 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -125,7 +125,7 @@ let implicit_decl c t at = %} %token NAT INT FLOAT TEXT VAR VALUE_TYPE 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_IMPORT CALL_INDIRECT RETURN %token GET_LOCAL SET_LOCAL TEE_LOCAL LOAD STORE OFFSET ALIGN %token CONST UNARY BINARY COMPARE CONVERT @@ -190,6 +190,10 @@ func_type : /* Expressions */ +nat : + | NAT { int_of_string $1 } +; + literal : | NAT { $1 @@ at () } | INT { $1 @@ at () } @@ -226,9 +230,51 @@ align : ; expr : + | op + { let at = at () in fun c -> [$1 c @@ at] } | LPAR expr1 RPAR { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } ; +op : + | NOP { fun c -> Nop } + | UNREACHABLE { fun c -> Unreachable } + | DROP { fun c -> Drop } + | BLOCK labeling expr_list END + { fun c -> let c' = $2 c in Block (snd ($3 c')) } + | LOOP labeling expr_list END + { fun c -> let c' = anon_label c in let c'' = $2 c' in + Loop (snd ($3 c'')) } + | LOOP labeling1 labeling1 expr_list END + { fun c -> let c' = $2 c in let c'' = $3 c' in Loop (snd ($4 c'')) } + | BR nat var { fun c -> Br ($2, $3 c label) } + | BR_IF nat var { fun c -> Br_if ($2, $3 c label) } + | BR_TABLE nat var var_list + { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in + Br_table ($2, xs, x) } + | RETURN nat { fun c -> Return $2 } + | IF labeling expr_list END + { fun c -> let c' = $2 c in If (snd ($3 c'), []) } + | IF labeling expr_list ELSE labeling expr_list END + { fun c -> let c1 = $2 c in let c2 = $5 c in + If (snd ($3 c1), snd ($6 c2)) } + | SELECT { fun c -> Select } + | CALL nat var { fun c -> Call ($2, $3 c func) } + | CALL_IMPORT nat var { fun c -> Call_import ($2, $3 c import) } + | CALL_INDIRECT nat var { fun c -> Call_indirect ($2, $3 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) } + | LOAD offset align { fun c -> $1 ($2, $3) } + | STORE offset align { fun c -> $1 ($2, $3) } + | 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 } +; expr1 : | NOP { fun c -> [], Nop } | UNREACHABLE { fun c -> [], Unreachable } From a227c7d394ada7a6617572605f57748e0020ead9 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 8 Jul 2016 16:34:48 +0200 Subject: [PATCH 11/44] Tiny test of stack input --- ml-proto/test/stack.wast | 73 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 73 insertions(+) create mode 100644 ml-proto/test/stack.wast diff --git a/ml-proto/test/stack.wast b/ml-proto/test/stack.wast new file mode 100644 index 0000000000..3ca373fe35 --- /dev/null +++ b/ml-proto/test/stack.wast @@ -0,0 +1,73 @@ +(module + (func "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)) + (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))) + ) + ) + (br $loop) + ) + (get_local $res) + ) + + (func "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 + loop $done $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 + get_local $res + ) + + (func "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)) + loop $done $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 + 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)) + From c7ed3f641fff460a3046b8c273cb4fea813cf9e3 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Tue, 12 Jul 2016 15:26:19 +0200 Subject: [PATCH 12/44] Adjust negative tests --- ml-proto/host/print.ml | 2 +- ml-proto/host/script.ml | 3 +-- ml-proto/spec/check.ml | 23 ++++++++++++-------- ml-proto/spec/types.ml | 5 ++++- ml-proto/test/block.wast | 24 ++++++++++++--------- ml-proto/test/br.wast | 10 +++++---- ml-proto/test/br_if.wast | 18 +++++++++------- ml-proto/test/br_table.wast | 10 +++++---- ml-proto/test/break-drop.wast | 6 +++--- ml-proto/test/exports.wast | 4 ++-- ml-proto/test/func.wast | 23 +++++++++++++------- ml-proto/test/labels.wast | 2 +- ml-proto/test/loop.wast | 37 +++++++++++++++++++-------------- ml-proto/test/nop.wast | 8 +++---- ml-proto/test/select.wast | 2 +- ml-proto/test/set_local.wast | 6 +++--- ml-proto/test/start.wast | 4 ++-- ml-proto/test/store_retval.wast | 26 +++++++++++------------ 18 files changed, 121 insertions(+), 92 deletions(-) diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 3e4dfe406c..b235f018a1 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -59,5 +59,5 @@ let print_module_sig m = 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_stack_type ts); + (Values.string_of_values vs) (Types.string_of_value_types ts); flush_all () diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 1646991c4d..db5617a444 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -88,13 +88,12 @@ let run_cmd cmd = Check.check_module m' with | exception (Decode.Code (_, msg) | Check.Invalid (_, msg)) -> - if false (*TODO*)&& not (Str.string_match (Str.regexp re) msg 0) then begin + if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); print_endline ("Expect: \"" ^ re ^ "\""); Assert.error cmd.at "wrong validation error" end | _ -> -if false then(*TODO*) Assert.error cmd.at "expected validation error" ) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 58a3a143df..b3b25e0243 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -79,9 +79,8 @@ let label c x = lookup "label" c.labels x (* Type Unification *) let string_of_value_type_var = string_of_var string_of_value_type "?" -let string_of_stack_type = function - | [t] -> string_of_value_type_var t - | ts -> "(" ^ String.concat " " (List.map string_of_value_type_var ts) ^ ")" +let string_of_stack_type ts = + "(" ^ String.concat " " (List.map string_of_value_type_var ts) ^ ")" exception Unify @@ -93,8 +92,9 @@ let unify_stack_type vts1 vts2 at = try unify (List.iter2 unify_value_type) vts1 vts2 with Unify | Invalid_argument _ -> error at - ("stack mismatch: required " ^ string_of_stack_type (content vts1) ^ - " but have " ^ string_of_stack_type (content vts2)) + ("type mismatch:" ^ + " operator requires " ^ string_of_stack_type (content vts1) ^ + " but stack has " ^ string_of_stack_type (content vts2)) (* Type Synthesis *) @@ -206,7 +206,7 @@ let rec check_expr (c : context) (e : expr) : op_type = (ts @ [fix Int32Type]) --> var () | Return n -> - require (List.length c.return = n) e.at "arity mismatch"; + check_arity c.return n e.at; fix_list c.return --> var () | If (es1, es2) -> @@ -221,17 +221,17 @@ let rec check_expr (c : context) (e : expr) : op_type = | Call (n, x) -> let FuncType (ins, out) = func c x in - require (List.length ins = n) e.at "arity mismatch"; + check_arity ins n e.at; fix_list ins --> fix (fix_list out) | CallImport (n, x) -> let FuncType (ins, out) = import c x in - require (List.length ins = n) e.at "arity mismatch"; + check_arity ins n e.at; fix_list ins --> fix (fix_list out) | CallIndirect (n, x) -> let FuncType (ins, out) = type_ c.types x in - require (List.length ins = n) e.at "arity mismatch"; + check_arity ins n e.at; fix_list (ins @ [Int32Type]) --> fix (fix_list out) | GetLocal x -> @@ -309,6 +309,11 @@ and check_block (c : context) (es : expr list) at : stack_type var = let ts3 = content vts3 in fix (ts1 @ ts3) +and check_arity ts n at = + require (List.length ts = n) at + ("arity mismatch:" ^ + " function requires " ^ string_of_int (List.length ts) ^ + " but operator has " ^ string_of_int n) and check_memop c memop at = require c.has_memory at "memory operator require a memory section"; diff --git a/ml-proto/spec/types.ml b/ml-proto/spec/types.ml index 6a0fbe0fb2..6c62f75da1 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -13,9 +13,12 @@ let string_of_value_type = function | Float32Type -> "f32" | Float64Type -> "f64" -let string_of_stack_type = function +let string_of_value_types = function | [t] -> string_of_value_type t | ts -> "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" +let string_of_stack_type ts = + "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" + let string_of_func_type (FuncType (ins, out)) = string_of_stack_type ins ^ " -> " ^ string_of_stack_type out diff --git a/ml-proto/test/block.wast b/ml-proto/test/block.wast index ea68ad6e71..92fec35055 100644 --- a/ml-proto/test/block.wast +++ b/ml-proto/test/block.wast @@ -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 diff --git a/ml-proto/test/br.wast b/ml-proto/test/br.wast index ce34922420..06d2c72985 100644 --- a/ml-proto/test/br.wast +++ b/ml-proto/test/br.wast @@ -371,26 +371,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) diff --git a/ml-proto/test/br_if.wast b/ml-proto/test/br_if.wast index d0a79b5d14..f870cdc696 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) diff --git a/ml-proto/test/br_table.wast b/ml-proto/test/br_table.wast index aab0a61c70..434236fb46 100644 --- a/ml-proto/test/br_table.wast +++ b/ml-proto/test/br_table.wast @@ -1288,26 +1288,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) diff --git a/ml-proto/test/break-drop.wast b/ml-proto/test/break-drop.wast index 8477175e73..6ccd6982cd 100644 --- a/ml-proto/test/break-drop.wast +++ b/ml-proto/test/break-drop.wast @@ -15,16 +15,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/exports.wast b/ml-proto/test/exports.wast index 08266c4fe9..7f313cc44e 100644 --- a/ml-proto/test/exports.wast +++ b/ml-proto/test/exports.wast @@ -4,7 +4,7 @@ (assert_invalid (module (func) (export "a" 1)) - "unknown function 1" + "unknown function" ) (assert_invalid (module (func) (func) (export "a" 0) (export "a" 1)) @@ -27,4 +27,4 @@ (module (memory 0 0) (export "a" memory)) (module (memory 0 0) (export "a" memory) (export "b" memory)) -(assert_invalid (module (export "a" memory)) "no memory to export") +(assert_invalid (module (export "a" memory)) "memory export requires a memory section") diff --git a/ml-proto/test/func.wast b/ml-proto/test/func.wast index 70b9cc47f4..58e262f40e 100644 --- a/ml-proto/test/func.wast +++ b/ml-proto/test/func.wast @@ -316,6 +316,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) @@ -338,8 +340,9 @@ (module (func $type-value-num-vs-num-after-break (result i32) (br 0 (i32.const 1)) (f32.const 0) )) - "type mismatch" + "arity mismatch" ) +;) (assert_invalid (module (func $type-return-last-void-vs-enpty @@ -407,30 +410,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) @@ -448,19 +453,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) @@ -480,18 +485,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 c1cd2bf1fa..c37c913ba6 100644 --- a/ml-proto/test/labels.wast +++ b/ml-proto/test/labels.wast @@ -314,7 +314,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/loop.wast b/ml-proto/test/loop.wast index bfe3e56829..0d63356ad6 100644 --- a/ml-proto/test/loop.wast +++ b/ml-proto/test/loop.wast @@ -224,6 +224,8 @@ )) "type mismatch" ) + +(; TODO(stack): Should these become legal? (assert_invalid (module (func $type-value-void-vs-num-after-break (result i32) (loop (br 1 (i32.const 1)) (nop)) @@ -236,24 +238,25 @@ )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-last-void-vs-empty (loop (br 1 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-num-vs-empty (loop (br 1 (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-empty-vs-num (result i32) (loop (br 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-last-void-vs-num (result i32) @@ -266,19 +269,19 @@ (module (func $type-break-void-vs-empty (loop (br 1 (nop))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-num-vs-empty (loop (br 1 (i32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-empty-vs-num (result i32) (loop (br 1) (i32.const 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-void-vs-num (result i32) @@ -298,30 +301,32 @@ )) "type mismatch" ) +(; TODO(stack): Should this become legal? (assert_invalid (module (func $type-break-second-num-vs-num (result i32) (loop (br 1 (i32.const 1)) (br 1 (f64.const 1))) )) "type mismatch" ) +;) (assert_invalid (module (func $type-break-nested-void-vs-empty (loop (loop (br 3 (nop))) (br 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-num-vs-empty (loop (loop (br 3 (i32.const 1))) (br 1)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-empty-vs-num (result i32) (loop (loop (br 3)) (br 1 (i32.const 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-nested-void-vs-num (result i32) @@ -340,7 +345,7 @@ (module (func $type-break-operand-empty-vs-num (result i32) (i32.ctz (loop (br 1))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-break-operand-void-vs-num (result i32) @@ -359,37 +364,37 @@ (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) (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)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-cont-nested-num-vs-empty (loop (loop (br 2 (i32.const 1))) (br 1)) )) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/nop.wast b/ml-proto/test/nop.wast index 97e64b1185..2951a95e0d 100644 --- a/ml-proto/test/nop.wast +++ b/ml-proto/test/nop.wast @@ -60,17 +60,17 @@ (assert_invalid (module (func $type-i32 (result i32) (nop))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-i64 (result i64) (nop))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-f32 (result f32) (nop))) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-f64 (result f64) (nop))) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/select.wast b/ml-proto/test/select.wast index 29919f0831..104c13c19c 100644 --- a/ml-proto/test/select.wast +++ b/ml-proto/test/select.wast @@ -60,5 +60,5 @@ (assert_invalid (module (func $arity-0 (select (nop) (nop) (i32.const 1)))) - "arity mismatch" + "type mismatch" ) diff --git a/ml-proto/test/set_local.wast b/ml-proto/test/set_local.wast index 3571918387..52aced9a26 100644 --- a/ml-proto/test/set_local.wast +++ b/ml-proto/test/set_local.wast @@ -95,19 +95,19 @@ (module (func $type-local-num-vs-num (result i64) (local i32) (set_local 0 (i32.const 0)) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-local-num-vs-num (local f32) (i32.eqz (set_local 0 (f32.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (func $type-local-num-vs-num (local f64 i64) (f64.neg (set_local 1 (i64.const 0))) )) - "arity mismatch" + "type mismatch" ) (assert_invalid diff --git a/ml-proto/test/start.wast b/ml-proto/test/start.wast index 6b1e865d7c..6f9019f429 100644 --- a/ml-proto/test/start.wast +++ b/ml-proto/test/start.wast @@ -1,13 +1,13 @@ (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 must be nullary" ) (assert_invalid (module 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" ) From 72352ac1b55f7c90ec3c6a55ee05f171dd88df0a Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Tue, 12 Jul 2016 15:52:28 +0200 Subject: [PATCH 13/44] Remove break label from loops --- ml-proto/host/parser.mly | 13 ++- ml-proto/spec/desugar.ml | 2 +- ml-proto/test/fac.wast | 38 ++++--- ml-proto/test/loop.wast | 234 ++++++++++---------------------------- ml-proto/test/memory.wast | 56 ++++----- 5 files changed, 123 insertions(+), 220 deletions(-) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 683f631b70..68f5a54d1f 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -242,10 +242,11 @@ op : | BLOCK labeling expr_list END { fun c -> let c' = $2 c in Block (snd ($3 c')) } | LOOP labeling expr_list END - { fun c -> let c' = anon_label c in let c'' = $2 c' in - Loop (snd ($3 c'')) } + { fun c -> let c' = $2 c in Loop (snd ($3 c')) } | LOOP labeling1 labeling1 expr_list END - { fun c -> let c' = $2 c in let c'' = $3 c' in Loop (snd ($4 c'')) } + { let at = at () in + fun c -> let c' = $2 c in let c'' = $3 c' in + Block [Loop (snd ($4 c'')) @@ at] } | BR nat var { fun c -> Br ($2, $3 c label) } | BR_IF nat var { fun c -> Br_if ($2, $3 c label) } | BR_TABLE nat var var_list @@ -282,9 +283,11 @@ expr1 : | BLOCK labeling expr_list { fun c -> let c' = $2 c in [], Block (snd ($3 c')) } | LOOP labeling expr_list - { fun c -> let c' = anon_label c in let c'' = $2 c' in [], Loop (snd ($3 c'')) } + { fun c -> let c' = $2 c in [], Loop (snd ($3 c')) } | LOOP labeling1 labeling1 expr_list - { fun c -> let c' = $2 c in let c'' = $3 c' in [], Loop (snd ($4 c'')) } + { let at = at () in + fun c -> let c' = $2 c in let c'' = $3 c' in + [], Block [Loop (snd ($4 c'')) @@ at] } | BR var { fun c -> [], Br (0, $2 c label) } | BR var expr { fun c -> $3 c, Br (1, $2 c label) } | BR_IF var expr { fun c -> $3 c, Br_if (0, $2 c label) } diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 6fc9b517f1..af9253f5d2 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -18,7 +18,7 @@ and expr' at = function | Ast.Unreachable -> Unreachable | Ast.Drop -> Drop | Ast.Block es -> Block (expr_list es) - | Ast.Loop es -> Block [Loop (expr_list es) @@ at] + | Ast.Loop es -> Loop (expr_list es) | Ast.Br (n, x) -> Break (n, x) | Ast.Br_if (n, x) -> BreakIf (n, x) | Ast.Br_table (n, xs, x) -> BreakTable (n, xs, x) diff --git a/ml-proto/test/fac.wast b/ml-proto/test/fac.wast index 6ac120b145..98ae1290cd 100644 --- a/ml-proto/test/fac.wast +++ b/ml-proto/test/fac.wast @@ -23,16 +23,18 @@ (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) ) @@ -43,21 +45,23 @@ (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) ) - ;; More-realistically optimized factorial. + ;; Optimized factorial (func $fac-opt (param i64) (result i64) (local i64) (set_local 1 (i64.const 1)) diff --git a/ml-proto/test/loop.wast b/ml-proto/test/loop.wast index 0d63356ad6..6912f821f0 100644 --- a/ml-proto/test/loop.wast +++ b/ml-proto/test/loop.wast @@ -48,55 +48,59 @@ ) (func "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 "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 "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 "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 "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 "effects" $fx (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 "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 "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) ) @@ -240,126 +252,6 @@ ) ;) -(assert_invalid - (module (func $type-break-last-void-vs-empty - (loop (br 1 (nop))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-last-num-vs-empty - (loop (br 1 (i32.const 0))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-last-empty-vs-num (result i32) - (loop (br 1)) - )) - "type 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))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-num-vs-empty - (loop (br 1 (i32.const 0))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-empty-vs-num (result i32) - (loop (br 1) (i32.const 1)) - )) - "type 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))) - )) - "type mismatch" -) -(; TODO(stack): Should this become legal? -(assert_invalid - (module (func $type-break-second-num-vs-num (result i32) - (loop (br 1 (i32.const 1)) (br 1 (f64.const 1))) - )) - "type mismatch" -) -;) - -(assert_invalid - (module (func $type-break-nested-void-vs-empty - (loop (loop (br 3 (nop))) (br 1)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-nested-num-vs-empty - (loop (loop (br 3 (i32.const 1))) (br 1)) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-nested-empty-vs-num (result i32) - (loop (loop (br 3)) (br 1 (i32.const 1))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-nested-void-vs-num (result i32) - (loop (loop (br 3 (nop))) (br 1 (i32.const 1))) - )) - "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))) - )) - "type mismatch" -) - -(assert_invalid - (module (func $type-break-operand-empty-vs-num (result i32) - (i32.ctz (loop (br 1))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-operand-void-vs-num (result i32) - (i32.ctz (loop (br 1 (nop)))) - )) - "type mismatch" -) -(assert_invalid - (module (func $type-break-operand-num-vs-num (result i32) - (i64.ctz (loop (br 1 (i64.const 9)))) - )) - "type mismatch" -) - (assert_invalid (module (func $type-cont-last-void-vs-empty (result i32) (loop (br 0 (nop))) @@ -380,7 +272,7 @@ "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))) )) "type mismatch" @@ -388,13 +280,13 @@ (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))) )) "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))) )) "type mismatch" ) diff --git a/ml-proto/test/memory.wast b/ml-proto/test/memory.wast index f98118839d..561a12d2e7 100644 --- a/ml-proto/test/memory.wast +++ b/ml-proto/test/memory.wast @@ -105,20 +105,22 @@ (func $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) ) @@ -127,20 +129,22 @@ (func $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) ) From 64d41323bfe8b240657f87ee85da6daeddafd0d4 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Tue, 12 Jul 2016 16:35:04 +0200 Subject: [PATCH 14/44] Make If block semantics primitive --- ml-proto/spec/check.ml | 33 +++++++++++++++++++++------------ ml-proto/spec/desugar.ml | 3 +-- ml-proto/spec/eval.ml | 6 ++++++ ml-proto/test/fac.wast | 18 ++++++------------ 4 files changed, 34 insertions(+), 26 deletions(-) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index b3b25e0243..7cd4d350b2 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -170,21 +170,21 @@ let rec check_expr (c : context) (e : expr) : op_type = | Block es -> let ts = var () in let c' = {c with labels = ts :: c.labels} in - let ts' = check_block c' es e.at in + let ts' = check_block c' es in unify_stack_type ts ts' e.at; [] --> ts' | Loop es -> let c' = {c with labels = fix [] :: c.labels} in - let ts = check_block c' es e.at in + let ts = check_block c' es in [] --> ts | Label (e0, vs, es) -> let ts = var () in let c' = {c with labels = ts :: c.labels} in - let ts1 = check_block c' [e0] e.at in - let ts2 = check_block c' - (List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) @ es) e.at in + let ts1 = check_block c' [e0] in + let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in + let ts2 = check_block c' (ves @ es) in unify_stack_type ts ts1 e.at; unify_stack_type ts ts2 e.at; [] --> ts @@ -210,10 +210,19 @@ let rec check_expr (c : context) (e : expr) : op_type = fix_list c.return --> var () | If (es1, es2) -> - let ts1 = check_block c es1 e.at in - let ts2 = check_block c es2 e.at in + (* TODO(stack): remove if labels + let ts1 = check_block c es1 in + let ts2 = check_block c es2 in unify_stack_type ts1 ts2 e.at; [fix Int32Type] --> ts1 + *) + let ts = var () in + let c' = {c with labels = ts :: c.labels} in + let ts1 = check_block c' es1 in + let ts2 = check_block c' es2 in + unify_stack_type ts ts1 e.at; + unify_stack_type ts ts2 e.at; + [fix Int32Type] --> ts | Select -> let t = var () in @@ -290,21 +299,21 @@ let rec check_expr (c : context) (e : expr) : op_type = | GrowMemory -> [fix Int32Type] --> fix [fix Int32Type] -and check_block (c : context) (es : expr list) at : stack_type var = +and check_block (c : context) (es : expr list) : stack_type var = match es with | [] -> fix [] | _ -> let es', e = Lib.List.split_last es in - let vts0 = check_block c es' at in + let vts0 = check_block c es' in + let ts2, vts3 = check_expr c e in if not (is_fix vts0) then var () else let ts0 = content vts0 in - let ts2, vts3 = check_expr c e 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 - unify_stack_type (fix ts2) (fix ts2') at; + unify_stack_type (fix ts2) (fix ts2') e.at; if not (is_fix vts3) then var () else let ts3 = content vts3 in fix (ts1 @ ts3) @@ -343,7 +352,7 @@ let check_func c f = let {ftype; locals; body} = f.it in let FuncType (ins, out) = type_ c.types ftype in let c' = {c with locals = ins @ locals; return = out; labels = []} in - let ts = check_block c' body f.at in + let ts = check_block c' body in unify_stack_type (fix (fix_list out)) ts f.at let check_elem c x = diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index af9253f5d2..db480b13f3 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -23,8 +23,7 @@ and expr' at = function | Ast.Br_if (n, x) -> BreakIf (n, x) | Ast.Br_table (n, xs, x) -> BreakTable (n, xs, x) | Ast.Return n -> Return n - | Ast.If (es1, es2) -> - If ([Block (expr_list es1) @@ at], [Block (expr_list es2) @@ at]) + | Ast.If (es1, es2) -> If (expr_list es1, expr_list es2) | Ast.Select -> Select | Ast.Call (n, x) -> Call (n, x) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 30821c13a4..de9d665e5f 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -147,10 +147,16 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) assert false (* abrupt *) | If (es1, es2), Int32 0l :: vs' -> + (* TODO(stack): remove if labels vs', es2 + *) + vs', [Block es2 @@ e.at] | If (es1, es2), Int32 i :: vs' -> + (* TODO(stack): remove if labels vs', es1 + *) + vs', [Block es1 @@ e.at] | Select, Int32 0l :: v2 :: v1 :: vs' -> v2 :: vs', [] diff --git a/ml-proto/test/fac.wast b/ml-proto/test/fac.wast index 98ae1290cd..125350ee1d 100644 --- a/ml-proto/test/fac.wast +++ b/ml-proto/test/fac.wast @@ -1,6 +1,6 @@ (module ;; Recursive factorial - (func (param i64) (result i64) + (func "fac-rec" (param i64) (result i64) (if (i64.eq (get_local 0) (i64.const 0)) (i64.const 1) (i64.mul (get_local 0) (call 0 (i64.sub (get_local 0) (i64.const 1)))) @@ -8,18 +8,18 @@ ) ;; Recursive factorial named - (func $fac-rec (param $n i64) (result i64) + (func "fac-rec-named" $fac-rec-named (param $n i64) (result i64) (if (i64.eq (get_local $n) (i64.const 0)) (i64.const 1) (i64.mul (get_local $n) - (call $fac-rec (i64.sub (get_local $n) (i64.const 1))) + (call $fac-rec-named (i64.sub (get_local $n) (i64.const 1))) ) ) ) ;; Iterative factorial - (func (param i64) (result i64) + (func "fac-iter" (param i64) (result i64) (local i64 i64) (set_local 1 (get_local 0)) (set_local 2 (i64.const 1)) @@ -40,7 +40,7 @@ ) ;; Iterative factorial named - (func $fac-iter (param $n i64) (result i64) + (func "fac-iter-named" (param $n i64) (result i64) (local $i i64) (local $res i64) (set_local $i (get_local $n)) @@ -62,7 +62,7 @@ ) ;; Optimized factorial - (func $fac-opt (param i64) (result i64) + (func "fac-opt" (param i64) (result i64) (local i64) (set_local 1 (i64.const 1)) (block @@ -75,12 +75,6 @@ ) (get_local 1) ) - - (export "fac-rec" 0) - (export "fac-iter" 2) - (export "fac-rec-named" $fac-rec) - (export "fac-iter-named" $fac-iter) - (export "fac-opt" $fac-opt) ) (assert_return (invoke "fac-rec" (i64.const 25)) (i64.const 7034535277573963776)) From 96f233a4744189b3dc3b4313992382a1e676e780 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Tue, 12 Jul 2016 20:19:40 +0200 Subject: [PATCH 15/44] Reunify ASTs --- ml-proto/README.md | 14 +- ml-proto/host/arrange.ml | 18 +- ml-proto/host/arrange.mli | 4 +- ml-proto/host/encode.ml | 47 ++--- ml-proto/host/import.ml | 2 +- ml-proto/host/import.mli | 2 +- ml-proto/host/lexer.mll | 182 +++++++++--------- ml-proto/host/parser.mly | 110 +++++------ ml-proto/host/print.ml | 2 +- ml-proto/host/print.mli | 4 +- ml-proto/host/run.ml | 4 +- ml-proto/host/script.ml | 25 ++- ml-proto/host/script.mli | 8 +- ml-proto/runtests.py | 4 +- ml-proto/spec/arithmetic.ml | 8 +- ml-proto/spec/arithmetic.mli | 10 +- ml-proto/spec/ast.ml | 323 +++++++++++++------------------ ml-proto/spec/check.ml | 10 +- ml-proto/spec/check.mli | 2 +- ml-proto/spec/decode.ml | 356 +++++++++++++++++------------------ ml-proto/spec/desugar.ml | 224 ---------------------- ml-proto/spec/desugar.mli | 1 - ml-proto/spec/eval.ml | 34 ++-- ml-proto/spec/eval.mli | 2 +- ml-proto/spec/kernel.ml | 155 --------------- ml-proto/spec/operators.ml | 202 ++++++++++++++++++++ 26 files changed, 755 insertions(+), 998 deletions(-) delete mode 100644 ml-proto/spec/desugar.ml delete mode 100644 ml-proto/spec/desugar.mli delete mode 100644 ml-proto/spec/kernel.ml create mode 100644 ml-proto/spec/operators.ml diff --git a/ml-proto/README.md b/ml-proto/README.md index 8afd5acb27..faf734f4a4 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -158,7 +158,7 @@ memory: ( memory ? * ) segment: ( segment + ) ``` -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). 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. @@ -204,13 +204,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 @@ -225,15 +223,15 @@ 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. diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 8cfa950683..c3bf148082 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 @@ -52,7 +52,7 @@ let struct_type = func_type module IntOp = struct - open Kernel.IntOp + open Ast.IntOp let unop xx = function | Clz -> "clz" @@ -104,7 +104,7 @@ end module FloatOp = struct - open Kernel.FloatOp + open Ast.FloatOp let unop xx = function | Neg -> "neg" @@ -159,7 +159,7 @@ 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} = +let memop name {ty; align; offset} = value_type ty ^ "." ^ name ^ (if offset = 0L then "" else " offset=" ^ int64 offset) ^ (if align = 1 then "" else " align=" ^ int align) @@ -193,9 +193,9 @@ let rec expr e = | Drop -> Atom "drop" | Block es -> Node ("block", list expr es) | Loop es -> Node ("loop", list expr es) - | Break (n, x) -> Atom ("br " ^ int n ^ " " ^ var x) - | BreakIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) - | BreakTable (n, xs, x) -> + | Br (n, x) -> Atom ("br " ^ int n ^ " " ^ var x) + | BrIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) + | BrTable (n, xs, x) -> Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) | Return n -> Atom ("return " ^ int n) | If (es1, es2) -> @@ -224,7 +224,9 @@ let rec expr e = | Convert op -> Atom (cvtop op) | CurrentMemory -> Atom "current_memory" | GrowMemory -> Atom "grow_memory" - | Label _ -> assert false + | Label (e, vs, es) -> + let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in + Node ("label", list expr (ves @ es)) (* Functions *) diff --git a/ml-proto/host/arrange.mli b/ml-proto/host/arrange.mli index 764e54fd5e..dcbc99901e 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 expr : Ast.expr -> sexpr +val module_ : Ast.module_ -> sexpr diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index b4b4b76fcd..1a5ecdec59 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -90,8 +90,8 @@ let encode m = (* Expressions *) open Source - open Kernel open Ast + open Values let op n = u8 n let memop off align = vu align; vu64 off (*TODO: to be resolved*) @@ -110,25 +110,25 @@ let encode m = list expr es2; op 0x0f | Select -> op 0x05 | Br (n, x) -> op 0x06; vu n; var x - | Br_if (n, x) -> op 0x07; vu n; var x - | Br_table (n, xs, x) -> op 0x08; vu n; vec var32 xs; var32 x - | Ast.Return n -> op 0x09; vu n - | Ast.Unreachable -> op 0x0a - | Ast.Drop -> op 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 -> op 0x15; var x - | Ast.Tee_local x -> op 0x19; var x - - | Ast.Call (n, x) -> op 0x16; vu n; var x - | Ast.Call_indirect (n, x) -> op 0x17; vu n; var x - | Ast.Call_import (n, x) -> op 0x18; vu n; var x - + | BrIf (n, x) -> op 0x07; vu n; var x + | BrTable (n, xs, x) -> op 0x08; vu n; vec var32 xs; var32 x + | Return n -> op 0x09; vu n + | Unreachable -> op 0x0a + | Drop -> op 0x0b + + | Const {it = Int32 c} -> op 0x10; vs32 c + | Const {it = Int64 c} -> op 0x11; vs64 c + | Const {it = Float32 c} -> op 0x12; f32 c + | Const {it = Float64 c} -> op 0x13; f64 c + + | GetLocal x -> op 0x14; var x + | SetLocal x -> op 0x15; var x + | TeeLocal x -> op 0x19; var x + + | Call (n, x) -> op 0x16; vu n; var x + | CallIndirect (n, x) -> op 0x17; vu n; var x + | CallImport (n, x) -> op 0x18; vu n; var x +(* | I32_load8_s (o, a) -> op 0x20; memop o a | I32_load8_u (o, a) -> op 0x21; memop o a | I32_load16_s (o, a) -> op 0x22; memop o a @@ -154,8 +154,8 @@ let encode m = | F32_store (o, a) -> op 0x35; memop o a | F64_store (o, a) -> op 0x36; memop o a - | Grow_memory -> op 0x39 - | Current_memory -> op 0x3b + | GrowMemory -> op 0x39 + | CurrentMemory -> op 0x3b | I32_add -> op 0x40 | I32_sub -> op 0x41 @@ -284,6 +284,7 @@ let encode m = | F64_reinterpret_i64 -> op 0xb3 | I32_reinterpret_f32 -> op 0xb4 | I64_reinterpret_f64 -> op 0xb5 +*)| _ -> () (* Sections *) @@ -328,7 +329,7 @@ let encode m = (* Export section *) let export exp = - let {Kernel.name; kind} = exp.it in + let {Ast.name; kind} = exp.it in (match kind with | `Func x -> var x | `Memory -> () (*TODO: pending resolution*) diff --git a/ml-proto/host/import.ml b/ml-proto/host/import.ml index 9c4468b282..0cf09a148e 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 diff --git a/ml-proto/host/import.mli b/ml-proto/host/import.mli index a39b29bb54..b5a4aa2bf4 100644 --- a/ml-proto/host/import.mli +++ b/ml-proto/host/import.mli @@ -1,4 +1,4 @@ exception Unknown of Source.region * string -val link : Kernel.module_ -> Eval.import list (* raises Unknown *) +val link : Ast.module_ -> Eval.import list (* raises Unknown *) val register: string -> (string -> Types.func_type -> Eval.import) -> unit diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 1c3bea84ef..75e1c87c12 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; @@ -133,13 +133,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.Int32 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.Int64 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.Float32 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.Float64 n)) } | "nop" { NOP } @@ -165,119 +165,119 @@ rule token = parse | "tee_local" { TEE_LOCAL } | (nxx as t)".load" - { LOAD (fun (o, a) -> - numop t (I32_load (o, opt a 4)) (I64_load (o, opt a 8)) - (F32_load (o, opt a 4)) (F64_load (o, opt a 8))) } + { 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) -> - numop t (I32_store (o, opt a 4)) (I64_store (o, opt a 8)) - (F32_store (o, opt a 4)) (F64_store (o, opt a 8))) } + { 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) -> + LOAD (fun a o -> intop t (memsz sz - (ext s (I32_load8_s (o, opt a 1)) (I32_load8_u (o, opt a 1))) - (ext s (I32_load16_s (o, opt a 2)) (I32_load16_u (o, opt a 2))) - 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, opt a 1)) (I64_load8_u (o, opt a 1))) - (ext s (I64_load16_s (o, opt a 2)) (I64_load16_u (o, opt a 2))) - (ext s (I64_load32_s (o, opt a 4)) (I64_load32_u (o, opt a 4))))) } + (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) -> + STORE (fun a o -> intop t (memsz sz - (I32_store8 (o, opt a 1)) - (I32_store16 (o, opt a 2)) - Unreachable) + (i32_store8 (opt a 1)) + (i32_store16 (opt a 2)) + (fun _ -> unreachable) o) (memsz sz - (I64_store8 (o, opt a 1)) - (I64_store16 (o, opt a 2)) - (I64_store32 (o, opt a 4)))) } + (i64_store8 (opt a 1)) + (i64_store16 (opt a 2)) + (i64_store32 (opt a 4)) o)) } | "offset="(digits as s) { OFFSET (Int64.of_string s) } | "align="(digits as s) { ALIGN (int_of_string s) } - | (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)".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 (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)".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 (intop t I32_eqz I64_eqz) } + | (ixx as t)".eqz" { TEST (intop t i32_eqz i64_eqz) } - | (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) } + | (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 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 } + | "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 (intop t I32_trunc_s_f32 I64_trunc_s_f32) } + { CONVERT (intop t i32_trunc_s_f32 i64_trunc_s_f32) } | (ixx as t)".trunc_u/f32" - { CONVERT (intop t I32_trunc_u_f32 I64_trunc_u_f32) } + { CONVERT (intop t i32_trunc_u_f32 i64_trunc_u_f32) } | (ixx as t)".trunc_s/f64" - { CONVERT (intop t I32_trunc_s_f64 I64_trunc_s_f64) } + { CONVERT (intop t i32_trunc_s_f64 i64_trunc_s_f64) } | (ixx as t)".trunc_u/f64" - { CONVERT (intop t I32_trunc_u_f64 I64_trunc_u_f64) } + { CONVERT (intop t i32_trunc_u_f64 i64_trunc_u_f64) } | (fxx as t)".convert_s/i32" - { CONVERT (floatop t F32_convert_s_i32 F64_convert_s_i32) } + { CONVERT (floatop t f32_convert_s_i32 f64_convert_s_i32) } | (fxx as t)".convert_u/i32" - { CONVERT (floatop t F32_convert_u_i32 F64_convert_u_i32) } + { CONVERT (floatop t f32_convert_u_i32 f64_convert_u_i32) } | (fxx as t)".convert_s/i64" - { CONVERT (floatop t F32_convert_s_i64 F64_convert_s_i64) } + { CONVERT (floatop t f32_convert_s_i64 f64_convert_s_i64) } | (fxx as t)".convert_u/i64" - { 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 } + { 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 } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 68f5a54d1f..d24f97d186 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 @@ -148,8 +148,8 @@ let implicit_decl c t at = %token TEST %token COMPARE %token CONVERT -%token Ast.expr'> LOAD -%token Ast.expr'> STORE +%token Memory.offset -> Ast.expr'> LOAD +%token Memory.offset -> Ast.expr'> STORE %token OFFSET %token ALIGN @@ -236,98 +236,98 @@ expr : { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } ; op : - | NOP { fun c -> Nop } - | UNREACHABLE { fun c -> Unreachable } - | DROP { fun c -> Drop } + | NOP { fun c -> nop } + | UNREACHABLE { fun c -> unreachable } + | DROP { fun c -> drop } | BLOCK labeling expr_list END - { fun c -> let c' = $2 c in Block (snd ($3 c')) } + { fun c -> let c' = $2 c in block (snd ($3 c')) } | LOOP labeling expr_list END - { fun c -> let c' = $2 c in Loop (snd ($3 c')) } + { fun c -> let c' = $2 c in loop (snd ($3 c')) } | LOOP labeling1 labeling1 expr_list END { let at = at () in fun c -> let c' = $2 c in let c'' = $3 c' in - Block [Loop (snd ($4 c'')) @@ at] } - | BR nat var { fun c -> Br ($2, $3 c label) } - | BR_IF nat var { fun c -> Br_if ($2, $3 c label) } + block [loop (snd ($4 c'')) @@ at] } + | BR nat var { fun c -> br $2 ($3 c label) } + | BR_IF nat var { fun c -> br_if $2 ($3 c label) } | BR_TABLE nat var var_list { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in - Br_table ($2, xs, x) } - | RETURN nat { fun c -> Return $2 } + br_table $2 xs x } + | RETURN nat { fun c -> return $2 } | IF labeling expr_list END - { fun c -> let c' = $2 c in If (snd ($3 c'), []) } + { fun c -> let c' = $2 c in if_ (snd ($3 c')) [] } | IF labeling expr_list ELSE labeling expr_list END { fun c -> let c1 = $2 c in let c2 = $5 c in - If (snd ($3 c1), snd ($6 c2)) } - | SELECT { fun c -> Select } - | CALL nat var { fun c -> Call ($2, $3 c func) } - | CALL_IMPORT nat var { fun c -> Call_import ($2, $3 c import) } - | CALL_INDIRECT nat var { fun c -> Call_indirect ($2, $3 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) } - | LOAD offset align { fun c -> $1 ($2, $3) } - | STORE offset align { fun c -> $1 ($2, $3) } + if_ (snd ($3 c1)) (snd ($6 c2)) } + | SELECT { fun c -> select } + | CALL nat var { fun c -> call $2 ($3 c func) } + | CALL_IMPORT nat var { fun c -> call_import $2 ($3 c import) } + | CALL_INDIRECT nat var { fun c -> call_indirect $2 ($3 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) } + | LOAD offset align { fun c -> $1 $3 $2 } + | STORE offset align { 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 } + | CURRENT_MEMORY { fun c -> current_memory } + | GROW_MEMORY { fun c -> grow_memory } ; expr1 : - | NOP { fun c -> [], Nop } - | UNREACHABLE { fun c -> [], Unreachable } - | DROP expr { fun c -> $2 c, Drop } + | NOP { fun c -> [], nop } + | UNREACHABLE { fun c -> [], unreachable } + | DROP expr { fun c -> $2 c, drop } | BLOCK labeling expr_list - { fun c -> let c' = $2 c in [], Block (snd ($3 c')) } + { fun c -> let c' = $2 c in [], block (snd ($3 c')) } | LOOP labeling expr_list - { fun c -> let c' = $2 c in [], Loop (snd ($3 c')) } + { fun c -> let c' = $2 c in [], loop (snd ($3 c')) } | LOOP labeling1 labeling1 expr_list { let at = at () in fun c -> let c' = $2 c in let c'' = $3 c' in - [], Block [Loop (snd ($4 c'')) @@ at] } - | BR var { fun c -> [], Br (0, $2 c label) } - | BR var expr { fun c -> $3 c, Br (1, $2 c label) } - | BR_IF var expr { fun c -> $3 c, Br_if (0, $2 c label) } - | BR_IF var expr expr { fun c -> $3 c @ $4 c, Br_if (1, $2 c label) } + [], block [loop (snd ($4 c'')) @@ at] } + | BR var { fun c -> [], br 0 ($2 c label) } + | BR var expr { fun c -> $3 c, br 1 ($2 c label) } + | BR_IF var expr { fun c -> $3 c, br_if 0 ($2 c label) } + | BR_IF var expr expr { fun c -> $3 c @ $4 c, br_if 1 ($2 c label) } | BR_TABLE var var_list expr { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c, Br_table (0, xs, x) } + $4 c, br_table 0 xs x } | BR_TABLE var var_list expr expr { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c @ $5 c, Br_table (1, xs, x) } - | RETURN { fun c -> [], Return 0 } - | RETURN expr { fun c -> $2 c, Return 1 } - | IF expr expr { fun c -> let c' = anon_label c in $2 c, If ($3 c', []) } + $4 c @ $5 c, br_table 1 xs x } + | RETURN { fun c -> [], return 0 } + | RETURN expr { fun c -> $2 c, return 1 } + | 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 $2 c, If ($3 c', $4 c') } + { fun c -> let c' = anon_label c in $2 c, if_ ($3 c') ($4 c') } | IF expr LPAR THEN labeling expr_list RPAR - { fun c -> let c' = $5 c in $2 c, If (snd ($6 c'), []) } + { fun c -> let c' = $5 c in $2 c, if_ (snd ($6 c')) [] } | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR { fun c -> let c1 = $5 c in let c2 = $10 c in - $2 c, If (snd ($6 c1), snd ($11 c2)) } - | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, Select } - | CALL var expr_list { fun c -> let n, es = $3 c in es, Call (n, $2 c func) } + $2 c, if_ (snd ($6 c1)) (snd ($11 c2)) } + | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, select } + | CALL var expr_list { fun c -> let n, es = $3 c in es, call n ($2 c func) } | CALL_IMPORT var expr_list - { fun c -> let n, es = $3 c in es, Call_import (n, $2 c import) } + { fun c -> let n, es = $3 c in es, call_import n ($2 c import) } | CALL_INDIRECT var expr expr_list { fun c -> - let e = $3 c and n, es = $4 c in e @ es, Call_indirect (n, $2 c type_) } - | GET_LOCAL var { fun c -> [], Get_local ($2 c local) } - | SET_LOCAL var expr { fun c -> $3 c, Set_local ($2 c local) } - | TEE_LOCAL var expr { fun c -> $3 c, Tee_local ($2 c local) } - | LOAD offset align expr { fun c -> $4 c, $1 ($2, $3) } - | STORE offset align expr expr { fun c -> $4 c @ $5 c, $1 ($2, $3) } + let e = $3 c and n, es = $4 c in e @ es, call_indirect n ($2 c type_) } + | GET_LOCAL var { fun c -> [], get_local ($2 c local) } + | SET_LOCAL var expr { fun c -> $3 c, set_local ($2 c local) } + | TEE_LOCAL var expr { fun c -> $3 c, tee_local ($2 c local) } + | LOAD offset align expr { fun c -> $4 c, $1 $3 $2 } + | STORE offset align expr expr { fun c -> $4 c @ $5 c, $1 $3 $2 } | CONST literal { fun c -> [], fst (literal $1 $2) } | UNARY expr { fun c -> $2 c, $1 } | BINARY expr expr { fun c -> $2 c @ $3 c, $1 } | TEST expr { fun c -> $2 c, $1 } | COMPARE expr expr { fun c -> $2 c @ $3 c, $1 } | CONVERT expr { fun c -> $2 c, $1 } - | CURRENT_MEMORY { fun c -> [], Current_memory } - | GROW_MEMORY expr { fun c -> $2 c, Grow_memory } + | CURRENT_MEMORY { fun c -> [], current_memory } + | GROW_MEMORY expr { fun c -> $2 c, grow_memory } ; expr_list : | /* empty */ { fun c -> 0, [] } diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index b235f018a1..e77d6099c5 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 diff --git a/ml-proto/host/print.mli b/ml-proto/host/print.mli index 9ab7b0991f..eb3bb0582e 100644 --- a/ml-proto/host/print.mli +++ b/ml-proto/host/print.mli @@ -1,3 +1,3 @@ -val print_module : Kernel.module_ -> unit -val print_module_sig : Kernel.module_ -> 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 0bd3ff3b3f..ba4b7b61a1 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -117,13 +117,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 db5617a444..16cd974464 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -11,11 +11,11 @@ and definition' = type command = command' Source.phrase and command' = | Define of definition - | Invoke of string * Kernel.literal list + | Invoke of string * Ast.literal list | AssertInvalid of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal list - | AssertReturnNaN of string * Kernel.literal list - | AssertTrap of string * Kernel.literal list * string + | AssertReturn of string * Ast.literal list * Ast.literal list + | AssertReturnNaN of string * Ast.literal list + | AssertTrap of string * Ast.literal list * string | Input of string | Output of string option @@ -62,17 +62,16 @@ let run_cmd cmd = match cmd.it with | Define def -> let m = run_def def in - let m' = Desugar.desugar m in 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; current_module := Some m; trace "Initializing..."; - let imports = Import.link m' in - current_instance := Some (Eval.init m' imports) + let imports = Import.link m in + current_instance := Some (Eval.init m imports) | Invoke (name, es) -> trace ("Invoking \"" ^ name ^ "\"..."); @@ -84,8 +83,7 @@ let run_cmd cmd = 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,12 +160,11 @@ let dry_cmd cmd = match cmd.it with | Define def -> let m = dry_def def in - let m' = Desugar.desugar m in 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; current_module := Some m | Input file -> diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index 73b1c8226f..977e21a130 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -6,11 +6,11 @@ and definition' = type command = command' Source.phrase and command' = | Define of definition - | Invoke of string * Kernel.literal list + | Invoke of string * Ast.literal list | AssertInvalid of definition * string - | AssertReturn of string * Kernel.literal list * Kernel.literal list - | AssertReturnNaN of string * Kernel.literal list - | AssertTrap of string * Kernel.literal list * string + | AssertReturn of string * Ast.literal list * Ast.literal list + | AssertReturnNaN of string * Ast.literal list + | AssertTrap of string * Ast.literal list * string | Input of string | Output of string option diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index 04522261be..b2e297c873 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -47,6 +47,8 @@ def _runTestFile(self, shortName, fileName, interpreterPath): self._runCommand(("%s %s") % (interpreterPath, fileName), logPath, expectedExitCode) self._compareLog(fileName, logPath) + return # TODO(stack) + if expectedExitCode != 0: return @@ -56,7 +58,7 @@ def _runTestFile(self, shortName, fileName, interpreterPath): self._runCommand(("%s -d %s -o %s") % (interpreterPath, fileName, wasmPath)) self._runCommand(("%s %s") % (interpreterPath, wasmPath), logPath) - return #TODO + return # TODO(stack) # Convert back to text and run again wastPath = auxFile(fileName.replace("test/", "test/output/").replace(".wast", ".wast.wasm.wast")) diff --git a/ml-proto/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml index 1b021a975d..7267248ff2 100644 --- a/ml-proto/spec/arithmetic.ml +++ b/ml-proto/spec/arithmetic.ml @@ -26,7 +26,7 @@ let f64_of_value n = module Int32Op = struct - open Kernel.I32Op + open Ast.I32Op let unop op = let f = match op with @@ -95,7 +95,7 @@ end module Int64Op = struct - open Kernel.I64Op + open Ast.I64Op let unop op = let f = match op with @@ -167,7 +167,7 @@ end module Float32Op = struct - open Kernel.F32Op + open Ast.F32Op let unop op = let f = match op with @@ -223,7 +223,7 @@ end module Float64Op = struct - open Kernel.F64Op + open Ast.F64Op let unop op = let f = match op with diff --git a/ml-proto/spec/arithmetic.mli b/ml-proto/spec/arithmetic.mli index 42d91474b0..7435b3c6bb 100644 --- a/ml-proto/spec/arithmetic.mli +++ b/ml-proto/spec/arithmetic.mli @@ -2,8 +2,8 @@ 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 +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/ast.ml b/ml-proto/spec/ast.ml index af1c6e4aa4..4bcecc0392 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -1,197 +1,108 @@ +(* + * 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 Values + + +(* Types *) + +type value_type = Types.value_type + + +(* 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; align : int; offset : Memory.offset} +type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} +type wrapop = {memop : memop; sz : Memory.mem_size} + + (* Expressions *) type var = int Source.phrase +type literal = value 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 - | Block of expr list - | Loop of expr list - | Br of int * var - | Br_if of int * var - | Br_table of int * var list * var - | Return of int - | If of expr list * expr list - | Select - | Call of int * var - | Call_import of int * var - | Call_indirect of int * var - - (* Locals *) - | Get_local of var - | Set_local of var - | Tee_local of var - - (* Memory access *) - | I32_load of Memory.offset * int - | I64_load of Memory.offset * int - | F32_load of Memory.offset * int - | F64_load of Memory.offset * int - | I32_store of Memory.offset * int - | I64_store of Memory.offset * int - | F32_store of Memory.offset * int - | F64_store of Memory.offset * int - | I32_load8_s of Memory.offset * int - | I32_load8_u of Memory.offset * int - | I32_load16_s of Memory.offset * int - | I32_load16_u of Memory.offset * int - | I64_load8_s of Memory.offset * int - | I64_load8_u of Memory.offset * int - | I64_load16_s of Memory.offset * int - | I64_load16_u of Memory.offset * int - | I64_load32_s of Memory.offset * int - | I64_load32_u of Memory.offset * int - | I32_store8 of Memory.offset * int - | I32_store16 of Memory.offset * int - | I64_store8 of Memory.offset * int - | I64_store16 of Memory.offset * int - | I64_store32 of Memory.offset * int - - (* Unary arithmetic *) - | I32_clz - | I32_ctz - | I32_popcnt - | I64_clz - | I64_ctz - | I64_popcnt - | F32_neg - | F32_abs - | F32_sqrt - | F32_ceil - | F32_floor - | F32_trunc - | F32_nearest - | F64_neg - | F64_abs - | F64_sqrt - | F64_ceil - | F64_floor - | F64_trunc - | F64_nearest - - (* Binary arithmetic *) - | I32_add - | I32_sub - | I32_mul - | I32_div_s - | I32_div_u - | I32_rem_s - | I32_rem_u - | I32_and - | I32_or - | I32_xor - | I32_shl - | I32_shr_s - | I32_shr_u - | I32_rotl - | I32_rotr - | I64_add - | I64_sub - | I64_mul - | I64_div_s - | I64_div_u - | I64_rem_s - | I64_rem_u - | I64_and - | I64_or - | I64_xor - | I64_shl - | I64_shr_s - | I64_shr_u - | I64_rotl - | I64_rotr - | F32_add - | F32_sub - | F32_mul - | F32_div - | F32_min - | F32_max - | F32_copysign - | F64_add - | F64_sub - | F64_mul - | F64_div - | F64_min - | F64_max - | F64_copysign - - (* Predicates *) - | I32_eqz - | I64_eqz - - (* Comparisons *) - | I32_eq - | I32_ne - | I32_lt_s - | I32_lt_u - | I32_le_s - | I32_le_u - | I32_gt_s - | I32_gt_u - | I32_ge_s - | I32_ge_u - | I64_eq - | I64_ne - | I64_lt_s - | I64_lt_u - | I64_le_s - | I64_le_u - | I64_gt_s - | I64_gt_u - | I64_ge_s - | I64_ge_u - | F32_eq - | F32_ne - | F32_lt - | F32_le - | F32_gt - | F32_ge - | F64_eq - | F64_ne - | F64_lt - | F64_le - | F64_gt - | F64_ge - - (* Conversions *) - | I32_wrap_i64 - | I32_trunc_s_f32 - | I32_trunc_u_f32 - | I32_trunc_s_f64 - | I32_trunc_u_f64 - | I64_extend_s_i32 - | I64_extend_u_i32 - | I64_trunc_s_f32 - | I64_trunc_u_f32 - | I64_trunc_s_f64 - | I64_trunc_u_f64 - | F32_convert_s_i32 - | F32_convert_u_i32 - | F32_convert_s_i64 - | F32_convert_u_i64 - | F32_demote_f64 - | F64_convert_s_i32 - | F64_convert_u_i32 - | F64_convert_s_i64 - | F64_convert_u_i64 - | F64_promote_f32 - | I32_reinterpret_f32 - | I64_reinterpret_f64 - | F32_reinterpret_i32 - | F64_reinterpret_i64 - - (* Host queries *) - | Current_memory - | Grow_memory + | Unreachable (* trap *) + | Nop (* do nothing *) + | Drop (* forget a value *) + | Select (* branchless conditional *) + | Block of expr list (* execute in sequence *) + | Loop of expr 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 of int (* break from function body *) + | If of expr list * expr list (* conditional *) + | Call of int * var (* call function *) + | CallImport of int * var (* call imported function *) + | CallIndirect of int * 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 *) + | Load of memop (* read memory at address *) + | Store of memop (* write memory at address *) + | LoadPacked of extop (* read memory at address and extend *) + | StorePacked of wrapop (* wrap and write to memory at address *) + | Const of literal (* constant *) + | Unary of unop (* unary arithmetic operator *) + | Binary of binop (* binary arithmetic operator *) + | Test of testop (* arithmetic test *) + | Compare of relop (* arithmetic comparison *) + | Convert of cvtop (* conversion *) + | CurrentMemory (* size of linear memory *) + | GrowMemory (* grow linear memory *) + | Label of expr * value list * expr list (* control stack *) (* Functions *) @@ -200,21 +111,45 @@ type func = func' Source.phrase and func' = { ftype : var; - locals : Types.value_type list; + locals : value_type list; body : expr list; } (* Modules *) -type module_ = module' Source.phrase -and module' = +type memory = memory' Source.phrase +and memory' = +{ + min : Memory.size; + max : Memory.size; + segments : segment list; +} +and segment = Memory.segment Source.phrase + +type export = export' Source.phrase +and export' = +{ + name : string; + kind : [`Func of var | `Memory] +} + +type import = import' Source.phrase +and import' = +{ + itype : var; + module_name : string; + func_name : string; +} + +type module_ = module_' Source.phrase +and module_' = { - memory : Kernel.memory option; + memory : memory option; types : Types.func_type list; funcs : func list; start : var option; - imports : Kernel.import list; - exports : Kernel.export list; + imports : import list; + exports : export list; table : var list; } diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 7cd4d350b2..48cf92de1d 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 @@ -189,17 +189,17 @@ let rec check_expr (c : context) (e : expr) : op_type = unify_stack_type ts ts2 e.at; [] --> ts - | Break (n, x) -> + | Br (n, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; ts --> var () - | BreakIf (n, x) -> + | BrIf (n, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; (ts @ [fix Int32Type]) --> fix [] - | BreakTable (n, xs, x) -> + | BrTable (n, xs, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; List.iter (fun x -> unify_stack_type (label c x) (fix ts) e.at) xs; @@ -351,7 +351,7 @@ and check_mem_size ty sz at = let check_func c f = let {ftype; locals; body} = f.it in let FuncType (ins, out) = type_ c.types ftype in - let c' = {c with locals = ins @ locals; return = out; labels = []} in + let c' = {c with locals = ins @ locals; return = out; labels = [fix (fix_list out)]} in let ts = check_block c' body in unify_stack_type (fix (fix_list out)) ts f.at 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 cbb4bc1e30..ead8189d90 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -132,8 +132,8 @@ let func_type s = (* Decode expressions *) -open Kernel open Ast +open Operators let op s = u8 s let arity s = vu s @@ -142,7 +142,7 @@ let memop s = let align = vu s in (*TODO: check flag bits*) let offset = vu64 s in - offset, align + align, offset let var s = vu s let var32 s = Int32.to_int (vu32 s) @@ -163,241 +163,241 @@ let args1 b stack s pos = let rec expr s = let pos = pos s in match op s with - | 0x00 -> Nop + | 0x00 -> nop | 0x01 -> let es' = expr_block s in expect 0x0f s "END opcode expected"; - Block es' + block es' | 0x02 -> let es' = expr_block s in expect 0x0f s "END opcode expected"; - Loop es' + loop es' | 0x03 -> let es1 = expr_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 (es1, es2) + if_ es1 es2 end else begin expect 0x0f s "END opcode expected"; - If (es1, []) + if_ es1 [] end | 0x04 -> error s pos "misplaced ELSE opcode" - | 0x05 -> Select + | 0x05 -> select | 0x06 -> let n = arity s in let x = at var s in - Br (n, x) + br n x | 0x07 -> let n = arity s in let x = at var s in - Br_if (n, x) + br_if n x | 0x08 -> let n = arity s in let xs = vec (at var) s in let x = at var s in - Br_table (n, xs, x) + br_table n xs x | 0x09 -> let n = arity s in - Return n - | 0x0a -> Unreachable - | 0x0b -> Drop + return n + | 0x0a -> unreachable + | 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) + | 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 -> let x = at var s in - Get_local x + get_local x | 0x15 -> let x = at var s in - Set_local x + set_local x | 0x16 -> let n = arity s in let x = at var s in - Call (n, x) + call n x | 0x17 -> let n = arity s in let x = at var s in - Call_indirect (n, x) + call_indirect n x | 0x18 -> let n = arity s in let x = at var s in - Call_import (n, x) + call_import n x | 0x19 -> let x = at var s in - Tee_local x + tee_local x | 0x1a | 0x1b | 0x1c | 0x1d | 0x1e | 0x1f as b -> illegal s pos b - | 0x20 -> let o, a = memop s in I32_load8_s (o, a) - | 0x21 -> let o, a = memop s in I32_load8_u (o, a) - | 0x22 -> let o, a = memop s in I32_load16_s (o, a) - | 0x23 -> let o, a = memop s in I32_load16_u (o, a) - | 0x24 -> let o, a = memop s in I64_load8_s (o, a) - | 0x25 -> let o, a = memop s in I64_load8_u (o, a) - | 0x26 -> let o, a = memop s in I64_load16_s (o, a) - | 0x27 -> let o, a = memop s in I64_load16_u (o, a) - | 0x28 -> let o, a = memop s in I64_load32_s (o, a) - | 0x29 -> let o, a = memop s in I64_load32_u (o, a) - | 0x2a -> let o, a = memop s in I32_load (o, a) - | 0x2b -> let o, a = memop s in I64_load (o, a) - | 0x2c -> let o, a = memop s in F32_load (o, a) - | 0x2d -> let o, a = memop s in F64_load (o, a) - - | 0x2e -> let o, a = memop s in I32_store8 (o, a) - | 0x2f -> let o, a = memop s in I32_store16 (o, a) - | 0x30 -> let o, a = memop s in I64_store8 (o, a) - | 0x31 -> let o, a = memop s in I64_store16 (o, a) - | 0x32 -> let o, a = memop s in I64_store32 (o, a) - | 0x33 -> let o, a = memop s in I32_store (o, a) - | 0x34 -> let o, a = memop s in I64_store (o, a) - | 0x35 -> let o, a = memop s in F32_store (o, a) - | 0x36 -> let o, a = memop s in F64_store (o, a) + | 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 + | 0x39 -> grow_memory | 0x3a as b -> illegal s pos b - | 0x3b -> Current_memory + | 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 + | 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 | b when b > 0xba -> illegal s pos b diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml deleted file mode 100644 index db480b13f3..0000000000 --- a/ml-proto/spec/desugar.ml +++ /dev/null @@ -1,224 +0,0 @@ -open Source -open Types -open Values -open Memory -open Kernel - - -(* 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 -> Drop - | Ast.Block es -> Block (expr_list es) - | Ast.Loop es -> Loop (expr_list es) - | Ast.Br (n, x) -> Break (n, x) - | Ast.Br_if (n, x) -> BreakIf (n, x) - | Ast.Br_table (n, xs, x) -> BreakTable (n, xs, x) - | Ast.Return n -> Return n - | Ast.If (es1, es2) -> If (expr_list es1, expr_list es2) - | Ast.Select -> Select - - | Ast.Call (n, x) -> Call (n, x) - | Ast.Call_import (n, x) -> CallImport (n, x) - | Ast.Call_indirect (n, x) -> CallIndirect (n, x) - - | Ast.Get_local x -> GetLocal x - | Ast.Set_local x -> SetLocal x - | Ast.Tee_local x -> TeeLocal x - - | Ast.I32_load (offset, align) -> Load {ty = Int32Type; offset; align} - | Ast.I64_load (offset, align) -> Load {ty = Int64Type; offset; align} - | Ast.F32_load (offset, align) -> Load {ty = Float32Type; offset; align} - | Ast.F64_load (offset, align) -> Load {ty = Float64Type; offset; align} - | Ast.I32_store (offset, align) -> Store {ty = Int32Type; offset; align} - | Ast.I64_store (offset, align) -> Store {ty = Int64Type; offset; align} - | Ast.F32_store (offset, align) -> Store {ty = Float32Type; offset; align} - | Ast.F64_store (offset, align) -> Store {ty = Float64Type; offset; align} - | Ast.I32_load8_s (offset, align) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = SX} - | Ast.I32_load8_u (offset, align) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem8; ext = ZX} - | Ast.I32_load16_s (offset, align) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = SX} - | Ast.I32_load16_u (offset, align) -> - LoadPacked {memop = {ty = Int32Type; offset; align}; sz = Mem16; ext = ZX} - | Ast.I64_load8_s (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = SX} - | Ast.I64_load8_u (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem8; ext = ZX} - | Ast.I64_load16_s (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = SX} - | Ast.I64_load16_u (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem16; ext = ZX} - | Ast.I64_load32_s (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = SX} - | Ast.I64_load32_u (offset, align) -> - LoadPacked {memop = {ty = Int64Type; offset; align}; sz = Mem32; ext = ZX} - | Ast.I32_store8 (offset, align) -> - StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem8} - | Ast.I32_store16 (offset, align) -> - StorePacked {memop = {ty = Int32Type; offset; align}; sz = Mem16} - | Ast.I64_store8 (offset, align) -> - StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem8} - | Ast.I64_store16 (offset, align) -> - StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem16} - | Ast.I64_store32 (offset, align) -> - StorePacked {memop = {ty = Int64Type; offset; align}; sz = Mem32} - - | Ast.I32_clz -> Unary (Int32 I32Op.Clz) - | Ast.I32_ctz -> Unary (Int32 I32Op.Ctz) - | Ast.I32_popcnt -> Unary (Int32 I32Op.Popcnt) - | Ast.I64_clz -> Unary (Int64 I64Op.Clz) - | Ast.I64_ctz -> Unary (Int64 I64Op.Ctz) - | Ast.I64_popcnt -> Unary (Int64 I64Op.Popcnt) - | Ast.F32_neg -> Unary (Float32 F32Op.Neg) - | Ast.F32_abs -> Unary (Float32 F32Op.Abs) - | Ast.F32_sqrt -> Unary (Float32 F32Op.Sqrt) - | Ast.F32_ceil -> Unary (Float32 F32Op.Ceil) - | Ast.F32_floor -> Unary (Float32 F32Op.Floor) - | Ast.F32_trunc -> Unary (Float32 F32Op.Trunc) - | Ast.F32_nearest -> Unary (Float32 F32Op.Nearest) - | Ast.F64_neg -> Unary (Float64 F64Op.Neg) - | Ast.F64_abs -> Unary (Float64 F64Op.Abs) - | Ast.F64_sqrt -> Unary (Float64 F64Op.Sqrt) - | Ast.F64_ceil -> Unary (Float64 F64Op.Ceil) - | Ast.F64_floor -> Unary (Float64 F64Op.Floor) - | Ast.F64_trunc -> Unary (Float64 F64Op.Trunc) - | Ast.F64_nearest -> Unary (Float64 F64Op.Nearest) - - | Ast.I32_add -> Binary (Int32 I32Op.Add) - | Ast.I32_sub -> Binary (Int32 I32Op.Sub) - | Ast.I32_mul -> Binary (Int32 I32Op.Mul) - | Ast.I32_div_s -> Binary (Int32 I32Op.DivS) - | Ast.I32_div_u -> Binary (Int32 I32Op.DivU) - | Ast.I32_rem_s -> Binary (Int32 I32Op.RemS) - | Ast.I32_rem_u -> Binary (Int32 I32Op.RemU) - | Ast.I32_and -> Binary (Int32 I32Op.And) - | Ast.I32_or -> Binary (Int32 I32Op.Or) - | Ast.I32_xor -> Binary (Int32 I32Op.Xor) - | Ast.I32_shl -> Binary (Int32 I32Op.Shl) - | Ast.I32_shr_s -> Binary (Int32 I32Op.ShrS) - | Ast.I32_shr_u -> Binary (Int32 I32Op.ShrU) - | Ast.I32_rotl -> Binary (Int32 I32Op.Rotl) - | Ast.I32_rotr -> Binary (Int32 I32Op.Rotr) - | Ast.I64_add -> Binary (Int64 I64Op.Add) - | Ast.I64_sub -> Binary (Int64 I64Op.Sub) - | Ast.I64_mul -> Binary (Int64 I64Op.Mul) - | Ast.I64_div_s -> Binary (Int64 I64Op.DivS) - | Ast.I64_div_u -> Binary (Int64 I64Op.DivU) - | Ast.I64_rem_s -> Binary (Int64 I64Op.RemS) - | Ast.I64_rem_u -> Binary (Int64 I64Op.RemU) - | Ast.I64_and -> Binary (Int64 I64Op.And) - | Ast.I64_or -> Binary (Int64 I64Op.Or) - | Ast.I64_xor -> Binary (Int64 I64Op.Xor) - | Ast.I64_shl -> Binary (Int64 I64Op.Shl) - | Ast.I64_shr_s -> Binary (Int64 I64Op.ShrS) - | Ast.I64_shr_u -> Binary (Int64 I64Op.ShrU) - | Ast.I64_rotl -> Binary (Int64 I64Op.Rotl) - | Ast.I64_rotr -> Binary (Int64 I64Op.Rotr) - | Ast.F32_add -> Binary (Float32 F32Op.Add) - | Ast.F32_sub -> Binary (Float32 F32Op.Sub) - | Ast.F32_mul -> Binary (Float32 F32Op.Mul) - | Ast.F32_div -> Binary (Float32 F32Op.Div) - | Ast.F32_min -> Binary (Float32 F32Op.Min) - | Ast.F32_max -> Binary (Float32 F32Op.Max) - | Ast.F32_copysign -> Binary (Float32 F32Op.CopySign) - | Ast.F64_add -> Binary (Float64 F64Op.Add) - | Ast.F64_sub -> Binary (Float64 F64Op.Sub) - | Ast.F64_mul -> Binary (Float64 F64Op.Mul) - | Ast.F64_div -> Binary (Float64 F64Op.Div) - | Ast.F64_min -> Binary (Float64 F64Op.Min) - | Ast.F64_max -> Binary (Float64 F64Op.Max) - | Ast.F64_copysign -> Binary (Float64 F64Op.CopySign) - - | Ast.I32_eqz -> Test (Int32 I32Op.Eqz) - | Ast.I64_eqz -> Test (Int64 I64Op.Eqz) - - | Ast.I32_eq -> Compare (Int32 I32Op.Eq) - | Ast.I32_ne -> Compare (Int32 I32Op.Ne) - | Ast.I32_lt_s -> Compare (Int32 I32Op.LtS) - | Ast.I32_lt_u -> Compare (Int32 I32Op.LtU) - | Ast.I32_le_s -> Compare (Int32 I32Op.LeS) - | Ast.I32_le_u -> Compare (Int32 I32Op.LeU) - | Ast.I32_gt_s -> Compare (Int32 I32Op.GtS) - | Ast.I32_gt_u -> Compare (Int32 I32Op.GtU) - | Ast.I32_ge_s -> Compare (Int32 I32Op.GeS) - | Ast.I32_ge_u -> Compare (Int32 I32Op.GeU) - | Ast.I64_eq -> Compare (Int64 I64Op.Eq) - | Ast.I64_ne -> Compare (Int64 I64Op.Ne) - | Ast.I64_lt_s -> Compare (Int64 I64Op.LtS) - | Ast.I64_lt_u -> Compare (Int64 I64Op.LtU) - | Ast.I64_le_s -> Compare (Int64 I64Op.LeS) - | Ast.I64_le_u -> Compare (Int64 I64Op.LeU) - | Ast.I64_gt_s -> Compare (Int64 I64Op.GtS) - | Ast.I64_gt_u -> Compare (Int64 I64Op.GtU) - | Ast.I64_ge_s -> Compare (Int64 I64Op.GeS) - | Ast.I64_ge_u -> Compare (Int64 I64Op.GeU) - | Ast.F32_eq -> Compare (Float32 F32Op.Eq) - | Ast.F32_ne -> Compare (Float32 F32Op.Ne) - | Ast.F32_lt -> Compare (Float32 F32Op.Lt) - | Ast.F32_le -> Compare (Float32 F32Op.Le) - | Ast.F32_gt -> Compare (Float32 F32Op.Gt) - | Ast.F32_ge -> Compare (Float32 F32Op.Ge) - | Ast.F64_eq -> Compare (Float64 F64Op.Eq) - | Ast.F64_ne -> Compare (Float64 F64Op.Ne) - | Ast.F64_lt -> Compare (Float64 F64Op.Lt) - | Ast.F64_le -> Compare (Float64 F64Op.Le) - | Ast.F64_gt -> Compare (Float64 F64Op.Gt) - | Ast.F64_ge -> Compare (Float64 F64Op.Ge) - - | Ast.I32_wrap_i64 -> Convert (Int32 I32Op.WrapInt64) - | Ast.I32_trunc_s_f32 -> Convert (Int32 I32Op.TruncSFloat32) - | Ast.I32_trunc_u_f32 -> Convert (Int32 I32Op.TruncUFloat32) - | Ast.I32_trunc_s_f64 -> Convert (Int32 I32Op.TruncSFloat64) - | Ast.I32_trunc_u_f64 -> Convert (Int32 I32Op.TruncUFloat64) - | Ast.I64_extend_s_i32 -> Convert (Int64 I64Op.ExtendSInt32) - | Ast.I64_extend_u_i32 -> Convert (Int64 I64Op.ExtendUInt32) - | Ast.I64_trunc_s_f32 -> Convert (Int64 I64Op.TruncSFloat32) - | Ast.I64_trunc_u_f32 -> Convert (Int64 I64Op.TruncUFloat32) - | Ast.I64_trunc_s_f64 -> Convert (Int64 I64Op.TruncSFloat64) - | Ast.I64_trunc_u_f64 -> Convert (Int64 I64Op.TruncUFloat64) - | Ast.F32_convert_s_i32 -> Convert (Float32 F32Op.ConvertSInt32) - | Ast.F32_convert_u_i32 -> Convert (Float32 F32Op.ConvertUInt32) - | Ast.F32_convert_s_i64 -> Convert (Float32 F32Op.ConvertSInt64) - | Ast.F32_convert_u_i64 -> Convert (Float32 F32Op.ConvertUInt64) - | Ast.F32_demote_f64 -> Convert (Float32 F32Op.DemoteFloat64) - | Ast.F64_convert_s_i32 -> Convert (Float64 F64Op.ConvertSInt32) - | Ast.F64_convert_u_i32 -> Convert (Float64 F64Op.ConvertUInt32) - | Ast.F64_convert_s_i64 -> Convert (Float64 F64Op.ConvertSInt64) - | Ast.F64_convert_u_i64 -> Convert (Float64 F64Op.ConvertUInt64) - | Ast.F64_promote_f32 -> Convert (Float64 F64Op.PromoteFloat32) - | Ast.I32_reinterpret_f32 -> Convert (Int32 I32Op.ReinterpretFloat) - | Ast.I64_reinterpret_f64 -> Convert (Int64 I64Op.ReinterpretFloat) - | Ast.F32_reinterpret_i32 -> Convert (Float32 F32Op.ReinterpretInt) - | Ast.F64_reinterpret_i64 -> Convert (Float64 F64Op.ReinterpretInt) - - | Ast.Current_memory -> CurrentMemory - | Ast.Grow_memory -> GrowMemory - -and expr_list = function - | [] -> [] - | e :: es -> expr e :: expr_list es - - -(* Functions and Modules *) - -let rec func f = func' f.it @@ f.at -and func' = function - | {Ast.body = es; ftype; locals} -> - {body = [Block (expr_list es) @@ Source.no_region]; ftype; locals} - -let rec module_ m = module' m.it @@ m.at -and module' = function - | {Ast.funcs = fs; start; memory; types; imports; exports; table} -> - {funcs = List.map func fs; start; memory; types; imports; exports; table} - -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 de9d665e5f..d2df7c8b3f 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -1,6 +1,6 @@ open Values open Types -open Kernel +open Ast open Source @@ -128,20 +128,20 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Loop es, vs -> vs, [Label (e, [], es) @@ e.at] - | Break (n, x), vs -> + | Br (n, x), vs -> assert false (* abrupt *) - | BreakIf (n, x), Int32 0l :: vs' -> + | BrIf (n, x), Int32 0l :: vs' -> drop n vs' e.at, [] - | BreakIf (n, x), Int32 i :: vs' -> - vs', [Break (n, x) @@ e.at] + | BrIf (n, x), Int32 i :: vs' -> + vs', [Br (n, x) @@ e.at] - | BreakTable (n, xs, x), Int32 i :: vs' when I32.ge_u i (length32 xs) -> - vs', [Break (n, x) @@ e.at] + | BrTable (n, xs, x), Int32 i :: vs' when I32.ge_u i (length32 xs) -> + vs', [Br (n, x) @@ e.at] - | BreakTable (n, xs, x), Int32 i :: vs' -> - vs', [Break (n, List.nth xs (Int32.to_int i)) @@ e.at] + | BrTable (n, xs, x), Int32 i :: vs' -> + vs', [Br (n, List.nth xs (Int32.to_int i)) @@ e.at] | Return n, vs -> assert false (* abrupt *) @@ -254,11 +254,11 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Label (e_cont, vs', []), vs -> vs' @ vs, [] - | Label (e_cont, vs', {it = Break (n, i); _} :: es), vs when i.it = 0 -> + | Label (e_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> keep n vs' e.at @ vs, [e_cont] - | Label (e_cont, vs', {it = Break (n, i); at} :: es), vs -> - keep n vs' e.at @ vs, [Break (n, (i.it-1) @@ i.at) @@ e.at] + | Label (e_cont, vs', {it = Br (n, i); at} :: es), vs -> + keep n vs' e.at @ vs, [Br (n, (i.it-1) @@ i.at) @@ e.at] | Label (e_cont, vs', {it = Return n; at} :: es), vs -> keep n vs' e.at @ vs, [Return n @@ at] @@ -283,10 +283,10 @@ and eval_body (c : config) (vs : value stack) (es : expr list) : value stack = match es with | [] -> vs | [{it = Return n}] -> assert (List.length vs = n); vs - | [{it = Unreachable; at}] -> Trap.error at "unreachable executed" (*TODO*) - | [{it = Break (n, i); at}] -> Crash.error at "unknown label" + | [{it = Unreachable; at}] -> Trap.error at "unreachable executed" + | [{it = Br (n, i); at}] -> Crash.error at "unknown label" | e :: es -> - let vs', es' = step_expr c [] e in + let vs', es' = step_expr c vs e in eval_body c vs' (es' @ es) (*TODO: Small-step calls @@ -308,7 +308,7 @@ type expr = ... | Func of value ref list * expr list assert (vs = []); [], [e] - | Func (locals, [{it = Break (n, i); at} ]), vs -> + | Func (locals, [{it = Br (n, i); at} ]), vs -> Crash.error at "unknown label" | Func (locals, e :: es), vs -> @@ -334,7 +334,7 @@ type expr = ... | Func of value ref list * value stack * expr list | Func (locals, vs', {it = Unreachable} as e :: es), vs -> [], [e] - | Func (locals, vs', {it = Break (n, i); at} :: es), vs -> + | Func (locals, vs', {it = Br (n, i); at} :: es), vs -> Crash.error at "unknown label" | Func (locals, vs', e :: es), vs -> diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index b96f0a5939..77cc341d98 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -6,6 +6,6 @@ type import = value stack -> value stack exception Trap of Source.region * string exception Crash of Source.region * string -val init : Kernel.module_ -> import list -> instance +val init : Ast.module_ -> import list -> instance val invoke : instance -> string -> value list -> value list (* raises Trap, Crash *) diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml deleted file mode 100644 index 6a9053a920..0000000000 --- a/ml-proto/spec/kernel.ml +++ /dev/null @@ -1,155 +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 Values - - -(* Types *) - -type value_type = Types.value_type - - -(* 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} - - -(* Expressions *) - -type var = int Source.phrase -type literal = value Source.phrase - -type expr = expr' Source.phrase -and expr' = - | Unreachable (* trap *) - | Nop (* do nothing *) - | Drop (* forget a value *) - | Select (* branchless conditional *) - | Block of expr list (* execute in sequence *) - | Loop of expr list (* loop header *) - | Break of int * var (* break to n-th surrounding label *) - | BreakIf of int * var (* conditional break *) - | BreakTable of int * var list * var (* indexed break *) - | Return of int (* break from function body *) - | If of expr list * expr list (* conditional *) - | Call of int * var (* call function *) - | CallImport of int * var (* call imported function *) - | CallIndirect of int * 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 *) - | Load of memop (* read memory at address *) - | Store of memop (* write memory at address *) - | LoadPacked of extop (* read memory at address and extend *) - | StorePacked of wrapop (* wrap and write to memory at address *) - | Const of literal (* constant *) - | Unary of unop (* unary arithmetic operator *) - | Binary of binop (* binary arithmetic operator *) - | Test of testop (* arithmetic test *) - | Compare of relop (* arithmetic comparison *) - | Convert of cvtop (* conversion *) - | CurrentMemory (* size of linear memory *) - | GrowMemory (* grow linear memory *) - | Label of expr * value list * expr list (* control stack *) - - -(* Functions *) - -type func = func' Source.phrase -and func' = -{ - ftype : var; - locals : value_type list; - body : expr list; -} - - -(* Modules *) - -type memory = memory' Source.phrase -and memory' = -{ - min : Memory.size; - max : Memory.size; - segments : segment list; -} -and segment = Memory.segment Source.phrase - -type export = export' Source.phrase -and export' = -{ - name : string; - kind : [`Func of var | `Memory] -} - -type import = import' Source.phrase -and import' = -{ - itype : var; - module_name : string; - func_name : string; -} - -type module_ = module_' Source.phrase -and module_' = -{ - memory : memory option; - types : Types.func_type list; - funcs : func list; - start : var option; - imports : import list; - exports : export list; - table : var list; -} diff --git a/ml-proto/spec/operators.ml b/ml-proto/spec/operators.ml new file mode 100644 index 0000000000..8517a01870 --- /dev/null +++ b/ml-proto/spec/operators.ml @@ -0,0 +1,202 @@ +open Source +open Types +open Values +open Memory +open Ast + + +let i32_const n = Const (Int32 n.it @@ n.at) +let i64_const n = Const (Int64 n.it @@ n.at) +let f32_const n = Const (Float32 n.it @@ n.at) +let f64_const n = Const (Float64 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 n = Return n +let if_ es1 es2 = If (es1, es2) +let select = Select + +let call n x = Call (n, x) +let call_import n x = CallImport (n, x) +let call_indirect n x = CallIndirect (n, x) + +let get_local x = GetLocal x +let set_local x = SetLocal x +let tee_local x = TeeLocal x + +let i32_load align offset = Load {ty = Int32Type; align; offset} +let i64_load align offset = Load {ty = Int64Type; align; offset} +let f32_load align offset = Load {ty = Float32Type; align; offset} +let f64_load align offset = Load {ty = Float64Type; align; offset} +let i32_store align offset = Store {ty = Int32Type; align; offset} +let i64_store align offset = Store {ty = Int64Type; align; offset} +let f32_store align offset = Store {ty = Float32Type; align; offset} +let f64_store align offset = Store {ty = Float64Type; align; offset} +let i32_load8_s align offset = + LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem8; ext = SX} +let i32_load8_u align offset = + LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem8; ext = ZX} +let i32_load16_s align offset = + LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem16; ext = SX} +let i32_load16_u align offset = + LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem16; ext = ZX} +let i64_load8_s align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem8; ext = SX} +let i64_load8_u align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem8; ext = ZX} +let i64_load16_s align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem16; ext = SX} +let i64_load16_u align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem16; ext = ZX} +let i64_load32_s align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem32; ext = SX} +let i64_load32_u align offset = + LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem32; ext = ZX} +let i32_store8 align offset = + StorePacked {memop = {ty = Int32Type; align; offset}; sz = Mem8} +let i32_store16 align offset = + StorePacked {memop = {ty = Int32Type; align; offset}; sz = Mem16} +let i64_store8 align offset = + StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem8} +let i64_store16 align offset = + StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem16} +let i64_store32 align offset = + StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem32} + +let i32_clz = Unary (Int32 I32Op.Clz) +let i32_ctz = Unary (Int32 I32Op.Ctz) +let i32_popcnt = Unary (Int32 I32Op.Popcnt) +let i64_clz = Unary (Int64 I64Op.Clz) +let i64_ctz = Unary (Int64 I64Op.Ctz) +let i64_popcnt = Unary (Int64 I64Op.Popcnt) +let f32_neg = Unary (Float32 F32Op.Neg) +let f32_abs = Unary (Float32 F32Op.Abs) +let f32_sqrt = Unary (Float32 F32Op.Sqrt) +let f32_ceil = Unary (Float32 F32Op.Ceil) +let f32_floor = Unary (Float32 F32Op.Floor) +let f32_trunc = Unary (Float32 F32Op.Trunc) +let f32_nearest = Unary (Float32 F32Op.Nearest) +let f64_neg = Unary (Float64 F64Op.Neg) +let f64_abs = Unary (Float64 F64Op.Abs) +let f64_sqrt = Unary (Float64 F64Op.Sqrt) +let f64_ceil = Unary (Float64 F64Op.Ceil) +let f64_floor = Unary (Float64 F64Op.Floor) +let f64_trunc = Unary (Float64 F64Op.Trunc) +let f64_nearest = Unary (Float64 F64Op.Nearest) + +let i32_add = Binary (Int32 I32Op.Add) +let i32_sub = Binary (Int32 I32Op.Sub) +let i32_mul = Binary (Int32 I32Op.Mul) +let i32_div_s = Binary (Int32 I32Op.DivS) +let i32_div_u = Binary (Int32 I32Op.DivU) +let i32_rem_s = Binary (Int32 I32Op.RemS) +let i32_rem_u = Binary (Int32 I32Op.RemU) +let i32_and = Binary (Int32 I32Op.And) +let i32_or = Binary (Int32 I32Op.Or) +let i32_xor = Binary (Int32 I32Op.Xor) +let i32_shl = Binary (Int32 I32Op.Shl) +let i32_shr_s = Binary (Int32 I32Op.ShrS) +let i32_shr_u = Binary (Int32 I32Op.ShrU) +let i32_rotl = Binary (Int32 I32Op.Rotl) +let i32_rotr = Binary (Int32 I32Op.Rotr) +let i64_add = Binary (Int64 I64Op.Add) +let i64_sub = Binary (Int64 I64Op.Sub) +let i64_mul = Binary (Int64 I64Op.Mul) +let i64_div_s = Binary (Int64 I64Op.DivS) +let i64_div_u = Binary (Int64 I64Op.DivU) +let i64_rem_s = Binary (Int64 I64Op.RemS) +let i64_rem_u = Binary (Int64 I64Op.RemU) +let i64_and = Binary (Int64 I64Op.And) +let i64_or = Binary (Int64 I64Op.Or) +let i64_xor = Binary (Int64 I64Op.Xor) +let i64_shl = Binary (Int64 I64Op.Shl) +let i64_shr_s = Binary (Int64 I64Op.ShrS) +let i64_shr_u = Binary (Int64 I64Op.ShrU) +let i64_rotl = Binary (Int64 I64Op.Rotl) +let i64_rotr = Binary (Int64 I64Op.Rotr) +let f32_add = Binary (Float32 F32Op.Add) +let f32_sub = Binary (Float32 F32Op.Sub) +let f32_mul = Binary (Float32 F32Op.Mul) +let f32_div = Binary (Float32 F32Op.Div) +let f32_min = Binary (Float32 F32Op.Min) +let f32_max = Binary (Float32 F32Op.Max) +let f32_copysign = Binary (Float32 F32Op.CopySign) +let f64_add = Binary (Float64 F64Op.Add) +let f64_sub = Binary (Float64 F64Op.Sub) +let f64_mul = Binary (Float64 F64Op.Mul) +let f64_div = Binary (Float64 F64Op.Div) +let f64_min = Binary (Float64 F64Op.Min) +let f64_max = Binary (Float64 F64Op.Max) +let f64_copysign = Binary (Float64 F64Op.CopySign) + +let i32_eqz = Test (Int32 I32Op.Eqz) +let i64_eqz = Test (Int64 I64Op.Eqz) + +let i32_eq = Compare (Int32 I32Op.Eq) +let i32_ne = Compare (Int32 I32Op.Ne) +let i32_lt_s = Compare (Int32 I32Op.LtS) +let i32_lt_u = Compare (Int32 I32Op.LtU) +let i32_le_s = Compare (Int32 I32Op.LeS) +let i32_le_u = Compare (Int32 I32Op.LeU) +let i32_gt_s = Compare (Int32 I32Op.GtS) +let i32_gt_u = Compare (Int32 I32Op.GtU) +let i32_ge_s = Compare (Int32 I32Op.GeS) +let i32_ge_u = Compare (Int32 I32Op.GeU) +let i64_eq = Compare (Int64 I64Op.Eq) +let i64_ne = Compare (Int64 I64Op.Ne) +let i64_lt_s = Compare (Int64 I64Op.LtS) +let i64_lt_u = Compare (Int64 I64Op.LtU) +let i64_le_s = Compare (Int64 I64Op.LeS) +let i64_le_u = Compare (Int64 I64Op.LeU) +let i64_gt_s = Compare (Int64 I64Op.GtS) +let i64_gt_u = Compare (Int64 I64Op.GtU) +let i64_ge_s = Compare (Int64 I64Op.GeS) +let i64_ge_u = Compare (Int64 I64Op.GeU) +let f32_eq = Compare (Float32 F32Op.Eq) +let f32_ne = Compare (Float32 F32Op.Ne) +let f32_lt = Compare (Float32 F32Op.Lt) +let f32_le = Compare (Float32 F32Op.Le) +let f32_gt = Compare (Float32 F32Op.Gt) +let f32_ge = Compare (Float32 F32Op.Ge) +let f64_eq = Compare (Float64 F64Op.Eq) +let f64_ne = Compare (Float64 F64Op.Ne) +let f64_lt = Compare (Float64 F64Op.Lt) +let f64_le = Compare (Float64 F64Op.Le) +let f64_gt = Compare (Float64 F64Op.Gt) +let f64_ge = Compare (Float64 F64Op.Ge) + +let i32_wrap_i64 = Convert (Int32 I32Op.WrapInt64) +let i32_trunc_s_f32 = Convert (Int32 I32Op.TruncSFloat32) +let i32_trunc_u_f32 = Convert (Int32 I32Op.TruncUFloat32) +let i32_trunc_s_f64 = Convert (Int32 I32Op.TruncSFloat64) +let i32_trunc_u_f64 = Convert (Int32 I32Op.TruncUFloat64) +let i64_extend_s_i32 = Convert (Int64 I64Op.ExtendSInt32) +let i64_extend_u_i32 = Convert (Int64 I64Op.ExtendUInt32) +let i64_trunc_s_f32 = Convert (Int64 I64Op.TruncSFloat32) +let i64_trunc_u_f32 = Convert (Int64 I64Op.TruncUFloat32) +let i64_trunc_s_f64 = Convert (Int64 I64Op.TruncSFloat64) +let i64_trunc_u_f64 = Convert (Int64 I64Op.TruncUFloat64) +let f32_convert_s_i32 = Convert (Float32 F32Op.ConvertSInt32) +let f32_convert_u_i32 = Convert (Float32 F32Op.ConvertUInt32) +let f32_convert_s_i64 = Convert (Float32 F32Op.ConvertSInt64) +let f32_convert_u_i64 = Convert (Float32 F32Op.ConvertUInt64) +let f32_demote_f64 = Convert (Float32 F32Op.DemoteFloat64) +let f64_convert_s_i32 = Convert (Float64 F64Op.ConvertSInt32) +let f64_convert_u_i32 = Convert (Float64 F64Op.ConvertUInt32) +let f64_convert_s_i64 = Convert (Float64 F64Op.ConvertSInt64) +let f64_convert_u_i64 = Convert (Float64 F64Op.ConvertUInt64) +let f64_promote_f32 = Convert (Float64 F64Op.PromoteFloat32) +let i32_reinterpret_f32 = Convert (Int32 I32Op.ReinterpretFloat) +let i64_reinterpret_f64 = Convert (Int64 I64Op.ReinterpretFloat) +let f32_reinterpret_i32 = Convert (Float32 F32Op.ReinterpretInt) +let f64_reinterpret_i64 = Convert (Float64 F64Op.ReinterpretInt) + +let current_memory = CurrentMemory +let grow_memory = GrowMemory + From 8ca2e77e5cd3163997596f87afde7822be29a69e Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 13 Jul 2016 13:06:33 +0200 Subject: [PATCH 16/44] Clean up naming conventions --- ml-proto/host/arrange.ml | 34 ++-- ml-proto/host/encode.ml | 16 +- ml-proto/host/import/env.ml | 6 +- ml-proto/host/lexer.mll | 16 +- ml-proto/host/script.ml | 4 +- ml-proto/spec/arithmetic.ml | 144 ++++++++--------- ml-proto/spec/ast.ml | 8 +- ml-proto/spec/check.ml | 76 ++++----- ml-proto/spec/decode.ml | 8 +- ml-proto/spec/eval.ml | 32 ++-- ml-proto/spec/memory.ml | 46 +++--- ml-proto/spec/operators.ml | 300 ++++++++++++++++++------------------ ml-proto/spec/types.ml | 10 +- ml-proto/spec/values.ml | 28 ++-- 14 files changed, 364 insertions(+), 364 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index c3bf148082..376676949f 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -92,13 +92,13 @@ 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 @@ -135,22 +135,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) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 1a5ecdec59..4c085b1a64 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -77,10 +77,10 @@ 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 expr_type t = vec1 value_type t @@ -116,10 +116,10 @@ let encode m = | Unreachable -> op 0x0a | Drop -> op 0x0b - | Const {it = Int32 c} -> op 0x10; vs32 c - | Const {it = Int64 c} -> op 0x11; vs64 c - | Const {it = Float32 c} -> op 0x12; f32 c - | Const {it = Float64 c} -> op 0x13; f64 c + | 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 diff --git a/ml-proto/host/import/env.ml b/ml-proto/host/import/env.ml index dbe0c393b0..96ada7a274 100644 --- a/ml-proto/host/import/env.ml +++ b/ml-proto/host/import/env.ml @@ -25,8 +25,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 = @@ -41,5 +41,5 @@ let exit vs = let lookup name (FuncType (ins, out)) = match name, ins, out with | "abort", [], [] -> abort - | "exit", [Int32Type], [] -> exit + | "exit", [I32Type], [] -> exit | _ -> raise Not_found diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 75e1c87c12..42d38ba1ec 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -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 = @@ -133,13 +133,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)) } | "nop" { NOP } diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 16cd974464..f54b9d9d50 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -112,9 +112,9 @@ let run_cmd cmd = let got_vs = Eval.invoke m name (List.map it es) in if match got_vs with - | [Values.Float32 got_f32] -> + | [Values.F32 got_f32] -> got_f32 <> F32.pos_nan && got_f32 <> F32.neg_nan - | [Values.Float64 got_f64] -> + | [Values.F64 got_f64] -> got_f64 <> F64.pos_nan && got_f64 <> F64.neg_nan | _ -> true then begin diff --git a/ml-proto/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml index 7267248ff2..2fed54485a 100644 --- a/ml-proto/spec/arithmetic.ml +++ b/ml-proto/spec/arithmetic.ml @@ -10,16 +10,16 @@ exception TypeError of int * value * value_type (* Value unpacking *) let i32_of_value n = - function Int32 i -> i | v -> raise (TypeError (n, v, Int32Type)) + function I32 i -> i | v -> raise (TypeError (n, v, I32Type)) let i64_of_value n = - function Int64 i -> i | v -> raise (TypeError (n, v, Int64Type)) + function I64 i -> i | v -> raise (TypeError (n, v, I64Type)) let f32_of_value n = - function Float32 z -> z | v -> raise (TypeError (n, v, Float32Type)) + function F32 z -> z | v -> raise (TypeError (n, v, F32Type)) let f64_of_value n = - function Float64 z -> z | v -> raise (TypeError (n, v, Float64Type)) + function F64 z -> z | v -> raise (TypeError (n, v, F64Type)) (* Int operators *) @@ -33,7 +33,7 @@ struct | Clz -> I32.clz | Ctz -> I32.ctz | Popcnt -> I32.popcnt - in fun v -> Int32 (f (i32_of_value 1 v)) + in fun v -> I32 (f (i32_of_value 1 v)) let binop op = let f = match op with @@ -52,7 +52,7 @@ struct | 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)) + in fun v1 v2 -> I32 (f (i32_of_value 1 v1) (i32_of_value 2 v2)) let testop op = let f = match op with @@ -75,22 +75,22 @@ struct 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)) + | WrapI64 -> + fun v -> I32 (I32_convert.wrap_i64 (i64_of_value 1 v)) + | TruncSF32 -> + fun v -> I32 (I32_convert.trunc_s_f32 (f32_of_value 1 v)) + | TruncUF32 -> + fun v -> I32 (I32_convert.trunc_u_f32 (f32_of_value 1 v)) + | TruncSF64 -> + fun v -> I32 (I32_convert.trunc_s_f64 (f64_of_value 1 v)) + | TruncUF64 -> + fun v -> I32 (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)) + fun v -> I32 (I32_convert.reinterpret_f32 (f32_of_value 1 v)) + | ExtendSI32 -> + fun v -> raise (TypeError (1, v, I32Type)) + | ExtendUI32 -> + fun v -> raise (TypeError (1, v, I32Type)) end module Int64Op = @@ -102,7 +102,7 @@ struct | Clz -> I64.clz | Ctz -> I64.ctz | Popcnt -> I64.popcnt - in fun v -> Int64 (f (i64_of_value 1 v)) + in fun v -> I64 (f (i64_of_value 1 v)) let binop op = let f = match op with @@ -121,7 +121,7 @@ struct | 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)) + in fun v1 v2 -> I64 (f (i64_of_value 1 v1) (i64_of_value 2 v2)) let testop op = let f = match op with @@ -144,22 +144,22 @@ struct 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)) + | ExtendSI32 -> + fun v -> I64 (I64_convert.extend_s_i32 (i32_of_value 1 v)) + | ExtendUI32 -> + fun v -> I64 (I64_convert.extend_u_i32 (i32_of_value 1 v)) + | TruncSF32 -> + fun v -> I64 (I64_convert.trunc_s_f32 (f32_of_value 1 v)) + | TruncUF32 -> + fun v -> I64 (I64_convert.trunc_u_f32 (f32_of_value 1 v)) + | TruncSF64 -> + fun v -> I64 (I64_convert.trunc_s_f64 (f64_of_value 1 v)) + | TruncUF64 -> + fun v -> I64 (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)) + fun v -> I64 (I64_convert.reinterpret_f64 (f64_of_value 1 v)) + | WrapI64 -> + fun v -> raise (TypeError (1, v, I64Type)) end @@ -178,7 +178,7 @@ struct | Floor -> F32.floor | Trunc -> F32.trunc | Nearest -> F32.nearest - in fun v -> Float32 (f (f32_of_value 1 v)) + in fun v -> F32 (f (f32_of_value 1 v)) let binop op = let f = match op with @@ -189,7 +189,7 @@ struct | 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)) + in fun v1 v2 -> F32 (f (f32_of_value 1 v1) (f32_of_value 2 v2)) let testop op = assert false @@ -205,20 +205,20 @@ struct 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)) + | DemoteF64 -> + fun v -> F32 (F32_convert.demote_f64 (f64_of_value 1 v)) + | ConvertSI32 -> + fun v -> F32 (F32_convert.convert_s_i32 (i32_of_value 1 v)) + | ConvertUI32 -> + fun v -> F32 (F32_convert.convert_u_i32 (i32_of_value 1 v)) + | ConvertSI64 -> + fun v -> F32 (F32_convert.convert_s_i64 (i64_of_value 1 v)) + | ConvertUI64 -> + fun v -> F32 (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)) + fun v -> F32 (F32_convert.reinterpret_i32 (i32_of_value 1 v)) + | PromoteF32 -> + fun v -> raise (TypeError (1, v, F32Type)) end module Float64Op = @@ -234,7 +234,7 @@ struct | Floor -> F64.floor | Trunc -> F64.trunc | Nearest -> F64.nearest - in fun v -> Float64 (f (f64_of_value 1 v)) + in fun v -> F64 (f (f64_of_value 1 v)) let binop op = let f = match op with @@ -245,7 +245,7 @@ struct | 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)) + in fun v1 v2 -> F64 (f (f64_of_value 1 v1) (f64_of_value 2 v2)) let testop op = assert false @@ -261,30 +261,30 @@ struct 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)) + | PromoteF32 -> + fun v -> F64 (F64_convert.promote_f32 (f32_of_value 1 v)) + | ConvertSI32 -> + fun v -> F64 (F64_convert.convert_s_i32 (i32_of_value 1 v)) + | ConvertUI32 -> + fun v -> F64 (F64_convert.convert_u_i32 (i32_of_value 1 v)) + | ConvertSI64 -> + fun v -> F64 (F64_convert.convert_s_i64 (i64_of_value 1 v)) + | ConvertUI64 -> + fun v -> F64 (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)) + fun v -> F64 (F64_convert.reinterpret_i64 (i64_of_value 1 v)) + | DemoteF64 -> + fun v -> raise (TypeError (1, v, F64Type)) 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 + | I32 x -> i32 x + | I64 x -> i64 x + | F32 x -> f32 x + | F64 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 diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 4bcecc0392..e5ff71c1e2 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -34,8 +34,8 @@ struct | 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 + type cvtop = ExtendSI32 | ExtendUI32 | WrapI64 + | TruncSF32 | TruncUF32 | TruncSF64 | TruncUF64 | ReinterpretFloat end @@ -45,8 +45,8 @@ struct 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 + type cvtop = ConvertSI32 | ConvertUI32 | ConvertSI64 | ConvertUI64 + | PromoteF32 | DemoteF64 | ReinterpretInt end diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 48cf92de1d..154341e9e7 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -106,38 +106,38 @@ 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 + | ConvertSI32 | ConvertUI32 -> I32Type + | ConvertSI64 | ConvertUI64 | ReinterpretInt -> I64Type + | PromoteF32 -> F32Type + | DemoteF64 -> error at "invalid conversion" + ), F64Type (* Type Analysis *) @@ -197,13 +197,13 @@ let rec check_expr (c : context) (e : expr) : op_type = | BrIf (n, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; - (ts @ [fix Int32Type]) --> fix [] + (ts @ [fix I32Type]) --> fix [] | BrTable (n, xs, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; List.iter (fun x -> unify_stack_type (label c x) (fix ts) e.at) xs; - (ts @ [fix Int32Type]) --> var () + (ts @ [fix I32Type]) --> var () | Return n -> check_arity c.return n e.at; @@ -222,11 +222,11 @@ let rec check_expr (c : context) (e : expr) : op_type = let ts2 = check_block c' es2 in unify_stack_type ts ts1 e.at; unify_stack_type ts ts2 e.at; - [fix Int32Type] --> ts + [fix I32Type] --> ts | Select -> let t = var () in - [t; t; fix Int32Type] --> fix [t] + [t; t; fix I32Type] --> fix [t] | Call (n, x) -> let FuncType (ins, out) = func c x in @@ -241,7 +241,7 @@ let rec check_expr (c : context) (e : expr) : op_type = | CallIndirect (n, x) -> let FuncType (ins, out) = type_ c.types x in check_arity ins n e.at; - fix_list (ins @ [Int32Type]) --> fix (fix_list out) + fix_list (ins @ [I32Type]) --> fix (fix_list out) | GetLocal x -> [] --> fix [fix (local c x)] @@ -254,21 +254,21 @@ let rec check_expr (c : context) (e : expr) : op_type = | Load memop -> check_memop c memop e.at; - [fix Int32Type] --> fix [fix memop.ty] + [fix I32Type] --> fix [fix memop.ty] | Store memop -> check_memop c memop e.at; - [fix Int32Type; fix memop.ty] --> fix [] + [fix I32Type; fix memop.ty] --> fix [] | LoadPacked {memop; sz; _} -> check_memop c memop e.at; check_mem_size memop.ty sz e.at; - [fix Int32Type] --> fix [fix memop.ty] + [fix I32Type] --> fix [fix memop.ty] | StorePacked {memop; sz} -> check_memop c memop e.at; check_mem_size memop.ty sz e.at; - [fix Int32Type; fix memop.ty] --> fix [] + [fix I32Type; fix memop.ty] --> fix [] | Const v -> [] --> fix [fix (type_value v.it)] @@ -283,21 +283,21 @@ let rec check_expr (c : context) (e : expr) : op_type = | Test testop -> let t = type_testop testop in - [fix t] --> fix [fix Int32Type] + [fix t] --> fix [fix I32Type] | Compare relop -> let t = type_relop relop in - [fix t; fix t] --> fix [fix Int32Type] + [fix t; fix t] --> fix [fix I32Type] | Convert cvtop -> let t1, t2 = type_cvtop e.at cvtop in [fix t1] --> fix [fix t2] | CurrentMemory -> - [] --> fix [fix Int32Type] + [] --> fix [fix I32Type] | GrowMemory -> - [fix Int32Type] --> fix [fix Int32Type] + [fix I32Type] --> fix [fix I32Type] and check_block (c : context) (es : expr list) : stack_type var = match es with @@ -331,7 +331,7 @@ and check_memop c memop at = require (Lib.Int.is_power_of_two memop.align) at "non-power-of-two alignment"; and check_mem_size ty sz at = - require (ty = Int64Type || sz <> Memory.Mem32) at "memory size too big" + require (ty = I64Type || sz <> Memory.Mem32) at "memory size too big" (* diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index ead8189d90..22e589c641 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -115,10 +115,10 @@ open Types let value_type s = match get 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 expr_type s = vec1 value_type s diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index d2df7c8b3f..495dc362b6 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -131,37 +131,37 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Br (n, x), vs -> assert false (* abrupt *) - | BrIf (n, x), Int32 0l :: vs' -> + | BrIf (n, x), I32 0l :: vs' -> drop n vs' e.at, [] - | BrIf (n, x), Int32 i :: vs' -> + | BrIf (n, x), I32 i :: vs' -> vs', [Br (n, x) @@ e.at] - | BrTable (n, xs, x), Int32 i :: vs' when I32.ge_u i (length32 xs) -> + | BrTable (n, xs, x), I32 i :: vs' when I32.ge_u i (length32 xs) -> vs', [Br (n, x) @@ e.at] - | BrTable (n, xs, x), Int32 i :: vs' -> + | BrTable (n, xs, x), I32 i :: vs' -> vs', [Br (n, List.nth xs (Int32.to_int i)) @@ e.at] | Return n, vs -> assert false (* abrupt *) - | If (es1, es2), Int32 0l :: vs' -> + | If (es1, es2), I32 0l :: vs' -> (* TODO(stack): remove if labels vs', es2 *) vs', [Block es2 @@ e.at] - | If (es1, es2), Int32 i :: vs' -> + | If (es1, es2), I32 i :: vs' -> (* TODO(stack): remove if labels vs', es1 *) vs', [Block es1 @@ e.at] - | Select, Int32 0l :: v2 :: v1 :: vs' -> + | Select, I32 0l :: v2 :: v1 :: vs' -> v2 :: vs', [] - | Select, Int32 i :: v2 :: v1 :: vs' -> + | Select, I32 i :: v2 :: v1 :: vs' -> v1 :: vs', [] | Call (n, x), vs -> @@ -173,7 +173,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) drop n vs e.at @ vs', [] with Crash (_, msg) -> Crash.error e.at msg) - | CallIndirect (n, x), Int32 i :: vs -> + | CallIndirect (n, x), I32 i :: vs -> let f = func c.instance (table_elem c.instance i e.at) in if x.it <> f.it.ftype.it then Trap.error e.at "indirect call signature mismatch"; @@ -190,22 +190,22 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) local c x := v; v :: vs', [] - | Load {offset; ty; _}, Int32 i :: vs' -> + | Load {offset; ty; _}, I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in (try Memory.load (memory c e.at) addr offset ty :: vs', [] with exn -> memory_error e.at exn) - | Store {offset; _}, v :: Int32 i :: vs' -> + | Store {offset; _}, v :: I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in (try Memory.store (memory c e.at) addr offset v; vs', [] with exn -> memory_error e.at exn); - | LoadPacked {memop = {offset; ty; _}; sz; ext}, Int32 i :: vs' -> + | LoadPacked {memop = {offset; ty; _}; sz; ext}, I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in (try Memory.load_packed (memory c e.at) addr offset sz ext ty :: vs', [] with exn -> memory_error e.at exn) - | StorePacked {memop = {offset; _}; sz}, v :: Int32 i :: vs' -> + | StorePacked {memop = {offset; _}; sz}, v :: I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in (try Memory.store_packed (memory c e.at) addr offset sz v; vs', [] with exn -> memory_error e.at exn) @@ -235,9 +235,9 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | CurrentMemory, vs -> let size = Memory.size (memory c e.at) in - Int32 (Int64.to_int32 size) :: vs, [] + I32 (Int64.to_int32 size) :: vs, [] - | GrowMemory, Int32 i :: vs' -> + | GrowMemory, I32 i :: vs' -> let mem = memory c e.at in let delta = I64_convert.extend_u_i32 i in let old_size = Memory.size mem in @@ -249,7 +249,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) if I64.gt_u new_size (Int64.of_int32 Int32.max_int) then Trap.error e.at "memory size exceeds implementation limit"; Memory.grow mem delta; - Int32 (Int64.to_int32 old_size) :: vs', [] + I32 (Int64.to_int32 old_size) :: vs', [] | Label (e_cont, vs', []), vs -> vs' @ vs, [] diff --git a/ml-proto/spec/memory.ml b/ml-proto/spec/memory.ml index 5a76bea8c0..19b09e0f56 100644 --- a/ml-proto/spec/memory.ml +++ b/ml-proto/spec/memory.ml @@ -107,18 +107,18 @@ and storen' mem n i 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); @@ -129,24 +129,24 @@ let loadn_sx mem n ea = let load_packed mem a o sz ext 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_packed mem a o sz 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 diff --git a/ml-proto/spec/operators.ml b/ml-proto/spec/operators.ml index 8517a01870..30483aa134 100644 --- a/ml-proto/spec/operators.ml +++ b/ml-proto/spec/operators.ml @@ -5,10 +5,10 @@ open Memory open Ast -let i32_const n = Const (Int32 n.it @@ n.at) -let i64_const n = Const (Int64 n.it @@ n.at) -let f32_const n = Const (Float32 n.it @@ n.at) -let f64_const n = Const (Float64 n.it @@ n.at) +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 @@ -30,172 +30,172 @@ let get_local x = GetLocal x let set_local x = SetLocal x let tee_local x = TeeLocal x -let i32_load align offset = Load {ty = Int32Type; align; offset} -let i64_load align offset = Load {ty = Int64Type; align; offset} -let f32_load align offset = Load {ty = Float32Type; align; offset} -let f64_load align offset = Load {ty = Float64Type; align; offset} -let i32_store align offset = Store {ty = Int32Type; align; offset} -let i64_store align offset = Store {ty = Int64Type; align; offset} -let f32_store align offset = Store {ty = Float32Type; align; offset} -let f64_store align offset = Store {ty = Float64Type; align; offset} +let i32_load align offset = Load {ty = I32Type; align; offset} +let i64_load align offset = Load {ty = I64Type; align; offset} +let f32_load align offset = Load {ty = F32Type; align; offset} +let f64_load align offset = Load {ty = F64Type; align; offset} +let i32_store align offset = Store {ty = I32Type; align; offset} +let i64_store align offset = Store {ty = I64Type; align; offset} +let f32_store align offset = Store {ty = F32Type; align; offset} +let f64_store align offset = Store {ty = F64Type; align; offset} let i32_load8_s align offset = - LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem8; ext = SX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = SX} let i32_load8_u align offset = - LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem8; ext = ZX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = ZX} let i32_load16_s align offset = - LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem16; ext = SX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = SX} let i32_load16_u align offset = - LoadPacked {memop = {ty = Int32Type; align; offset}; sz = Mem16; ext = ZX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = ZX} let i64_load8_s align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem8; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = SX} let i64_load8_u align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem8; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = ZX} let i64_load16_s align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem16; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = SX} let i64_load16_u align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem16; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = ZX} let i64_load32_s align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem32; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = SX} let i64_load32_u align offset = - LoadPacked {memop = {ty = Int64Type; align; offset}; sz = Mem32; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = ZX} let i32_store8 align offset = - StorePacked {memop = {ty = Int32Type; align; offset}; sz = Mem8} + StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem8} let i32_store16 align offset = - StorePacked {memop = {ty = Int32Type; align; offset}; sz = Mem16} + StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem16} let i64_store8 align offset = - StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem8} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem8} let i64_store16 align offset = - StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem16} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem16} let i64_store32 align offset = - StorePacked {memop = {ty = Int64Type; align; offset}; sz = Mem32} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem32} -let i32_clz = Unary (Int32 I32Op.Clz) -let i32_ctz = Unary (Int32 I32Op.Ctz) -let i32_popcnt = Unary (Int32 I32Op.Popcnt) -let i64_clz = Unary (Int64 I64Op.Clz) -let i64_ctz = Unary (Int64 I64Op.Ctz) -let i64_popcnt = Unary (Int64 I64Op.Popcnt) -let f32_neg = Unary (Float32 F32Op.Neg) -let f32_abs = Unary (Float32 F32Op.Abs) -let f32_sqrt = Unary (Float32 F32Op.Sqrt) -let f32_ceil = Unary (Float32 F32Op.Ceil) -let f32_floor = Unary (Float32 F32Op.Floor) -let f32_trunc = Unary (Float32 F32Op.Trunc) -let f32_nearest = Unary (Float32 F32Op.Nearest) -let f64_neg = Unary (Float64 F64Op.Neg) -let f64_abs = Unary (Float64 F64Op.Abs) -let f64_sqrt = Unary (Float64 F64Op.Sqrt) -let f64_ceil = Unary (Float64 F64Op.Ceil) -let f64_floor = Unary (Float64 F64Op.Floor) -let f64_trunc = Unary (Float64 F64Op.Trunc) -let f64_nearest = Unary (Float64 F64Op.Nearest) +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 (Int32 I32Op.Add) -let i32_sub = Binary (Int32 I32Op.Sub) -let i32_mul = Binary (Int32 I32Op.Mul) -let i32_div_s = Binary (Int32 I32Op.DivS) -let i32_div_u = Binary (Int32 I32Op.DivU) -let i32_rem_s = Binary (Int32 I32Op.RemS) -let i32_rem_u = Binary (Int32 I32Op.RemU) -let i32_and = Binary (Int32 I32Op.And) -let i32_or = Binary (Int32 I32Op.Or) -let i32_xor = Binary (Int32 I32Op.Xor) -let i32_shl = Binary (Int32 I32Op.Shl) -let i32_shr_s = Binary (Int32 I32Op.ShrS) -let i32_shr_u = Binary (Int32 I32Op.ShrU) -let i32_rotl = Binary (Int32 I32Op.Rotl) -let i32_rotr = Binary (Int32 I32Op.Rotr) -let i64_add = Binary (Int64 I64Op.Add) -let i64_sub = Binary (Int64 I64Op.Sub) -let i64_mul = Binary (Int64 I64Op.Mul) -let i64_div_s = Binary (Int64 I64Op.DivS) -let i64_div_u = Binary (Int64 I64Op.DivU) -let i64_rem_s = Binary (Int64 I64Op.RemS) -let i64_rem_u = Binary (Int64 I64Op.RemU) -let i64_and = Binary (Int64 I64Op.And) -let i64_or = Binary (Int64 I64Op.Or) -let i64_xor = Binary (Int64 I64Op.Xor) -let i64_shl = Binary (Int64 I64Op.Shl) -let i64_shr_s = Binary (Int64 I64Op.ShrS) -let i64_shr_u = Binary (Int64 I64Op.ShrU) -let i64_rotl = Binary (Int64 I64Op.Rotl) -let i64_rotr = Binary (Int64 I64Op.Rotr) -let f32_add = Binary (Float32 F32Op.Add) -let f32_sub = Binary (Float32 F32Op.Sub) -let f32_mul = Binary (Float32 F32Op.Mul) -let f32_div = Binary (Float32 F32Op.Div) -let f32_min = Binary (Float32 F32Op.Min) -let f32_max = Binary (Float32 F32Op.Max) -let f32_copysign = Binary (Float32 F32Op.CopySign) -let f64_add = Binary (Float64 F64Op.Add) -let f64_sub = Binary (Float64 F64Op.Sub) -let f64_mul = Binary (Float64 F64Op.Mul) -let f64_div = Binary (Float64 F64Op.Div) -let f64_min = Binary (Float64 F64Op.Min) -let f64_max = Binary (Float64 F64Op.Max) -let f64_copysign = Binary (Float64 F64Op.CopySign) +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 (Int32 I32Op.Eqz) -let i64_eqz = Test (Int64 I64Op.Eqz) +let i32_eqz = Test (I32 I32Op.Eqz) +let i64_eqz = Test (I64 I64Op.Eqz) -let i32_eq = Compare (Int32 I32Op.Eq) -let i32_ne = Compare (Int32 I32Op.Ne) -let i32_lt_s = Compare (Int32 I32Op.LtS) -let i32_lt_u = Compare (Int32 I32Op.LtU) -let i32_le_s = Compare (Int32 I32Op.LeS) -let i32_le_u = Compare (Int32 I32Op.LeU) -let i32_gt_s = Compare (Int32 I32Op.GtS) -let i32_gt_u = Compare (Int32 I32Op.GtU) -let i32_ge_s = Compare (Int32 I32Op.GeS) -let i32_ge_u = Compare (Int32 I32Op.GeU) -let i64_eq = Compare (Int64 I64Op.Eq) -let i64_ne = Compare (Int64 I64Op.Ne) -let i64_lt_s = Compare (Int64 I64Op.LtS) -let i64_lt_u = Compare (Int64 I64Op.LtU) -let i64_le_s = Compare (Int64 I64Op.LeS) -let i64_le_u = Compare (Int64 I64Op.LeU) -let i64_gt_s = Compare (Int64 I64Op.GtS) -let i64_gt_u = Compare (Int64 I64Op.GtU) -let i64_ge_s = Compare (Int64 I64Op.GeS) -let i64_ge_u = Compare (Int64 I64Op.GeU) -let f32_eq = Compare (Float32 F32Op.Eq) -let f32_ne = Compare (Float32 F32Op.Ne) -let f32_lt = Compare (Float32 F32Op.Lt) -let f32_le = Compare (Float32 F32Op.Le) -let f32_gt = Compare (Float32 F32Op.Gt) -let f32_ge = Compare (Float32 F32Op.Ge) -let f64_eq = Compare (Float64 F64Op.Eq) -let f64_ne = Compare (Float64 F64Op.Ne) -let f64_lt = Compare (Float64 F64Op.Lt) -let f64_le = Compare (Float64 F64Op.Le) -let f64_gt = Compare (Float64 F64Op.Gt) -let f64_ge = Compare (Float64 F64Op.Ge) +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 (Int32 I32Op.WrapInt64) -let i32_trunc_s_f32 = Convert (Int32 I32Op.TruncSFloat32) -let i32_trunc_u_f32 = Convert (Int32 I32Op.TruncUFloat32) -let i32_trunc_s_f64 = Convert (Int32 I32Op.TruncSFloat64) -let i32_trunc_u_f64 = Convert (Int32 I32Op.TruncUFloat64) -let i64_extend_s_i32 = Convert (Int64 I64Op.ExtendSInt32) -let i64_extend_u_i32 = Convert (Int64 I64Op.ExtendUInt32) -let i64_trunc_s_f32 = Convert (Int64 I64Op.TruncSFloat32) -let i64_trunc_u_f32 = Convert (Int64 I64Op.TruncUFloat32) -let i64_trunc_s_f64 = Convert (Int64 I64Op.TruncSFloat64) -let i64_trunc_u_f64 = Convert (Int64 I64Op.TruncUFloat64) -let f32_convert_s_i32 = Convert (Float32 F32Op.ConvertSInt32) -let f32_convert_u_i32 = Convert (Float32 F32Op.ConvertUInt32) -let f32_convert_s_i64 = Convert (Float32 F32Op.ConvertSInt64) -let f32_convert_u_i64 = Convert (Float32 F32Op.ConvertUInt64) -let f32_demote_f64 = Convert (Float32 F32Op.DemoteFloat64) -let f64_convert_s_i32 = Convert (Float64 F64Op.ConvertSInt32) -let f64_convert_u_i32 = Convert (Float64 F64Op.ConvertUInt32) -let f64_convert_s_i64 = Convert (Float64 F64Op.ConvertSInt64) -let f64_convert_u_i64 = Convert (Float64 F64Op.ConvertUInt64) -let f64_promote_f32 = Convert (Float64 F64Op.PromoteFloat32) -let i32_reinterpret_f32 = Convert (Int32 I32Op.ReinterpretFloat) -let i64_reinterpret_f64 = Convert (Int64 I64Op.ReinterpretFloat) -let f32_reinterpret_i32 = Convert (Float32 F32Op.ReinterpretInt) -let f64_reinterpret_i64 = Convert (Float64 F64Op.ReinterpretInt) +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/types.ml b/ml-proto/spec/types.ml index 6c62f75da1..69f6b94756 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -1,6 +1,6 @@ (* Types *) -type value_type = Int32Type | Int64Type | Float32Type | Float64Type +type value_type = I32Type | I64Type | F32Type | F64Type type stack_type = value_type list type func_type = FuncType of stack_type * stack_type @@ -8,10 +8,10 @@ type func_type = FuncType of stack_type * stack_type (* 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_types = function | [t] -> string_of_value_type t diff --git a/ml-proto/spec/values.ml b/ml-proto/spec/values.ml index 983994acb7..a1996ab44c 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,27 +12,27 @@ 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 (* Conversion *) -let value_of_bool b = Int32 (if b then 1l else 0l) +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 From d8f7bd122263632366dddd0352f46950eb34d3af Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 13 Jul 2016 14:01:44 +0200 Subject: [PATCH 17/44] Remove some code duplication --- ml-proto/README.md | 2 +- ml-proto/spec/arithmetic.ml | 293 ------------------ ml-proto/spec/ast.ml | 8 +- ml-proto/spec/eval.ml | 38 +-- ml-proto/spec/eval_numeric.ml | 197 ++++++++++++ .../spec/{arithmetic.mli => eval_numeric.mli} | 0 ml-proto/spec/float.ml | 4 +- ml-proto/spec/i32_convert.ml | 16 +- ml-proto/spec/i64_convert.ml | 16 +- ml-proto/spec/int.ml | 42 +-- .../spec/{numerics.ml => numeric_error.ml} | 2 - ml-proto/spec/numerics.mli | 5 - ml-proto/spec/operators.ml | 31 +- ml-proto/spec/values.ml | 41 +++ 14 files changed, 319 insertions(+), 376 deletions(-) delete mode 100644 ml-proto/spec/arithmetic.ml create mode 100644 ml-proto/spec/eval_numeric.ml rename ml-proto/spec/{arithmetic.mli => eval_numeric.mli} (100%) rename ml-proto/spec/{numerics.ml => numeric_error.ml} (71%) delete mode 100644 ml-proto/spec/numerics.mli diff --git a/ml-proto/README.md b/ml-proto/README.md index faf734f4a4..2283752146 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -233,7 +233,7 @@ The implementation consists of the following parts: * *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/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml deleted file mode 100644 index 2fed54485a..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 I32 i -> i | v -> raise (TypeError (n, v, I32Type)) - -let i64_of_value n = - function I64 i -> i | v -> raise (TypeError (n, v, I64Type)) - -let f32_of_value n = - function F32 z -> z | v -> raise (TypeError (n, v, F32Type)) - -let f64_of_value n = - function F64 z -> z | v -> raise (TypeError (n, v, F64Type)) - - -(* Int operators *) - -module Int32Op = -struct - open Ast.I32Op - - let unop op = - let f = match op with - | Clz -> I32.clz - | Ctz -> I32.ctz - | Popcnt -> I32.popcnt - in fun v -> I32 (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 -> I32 (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 - | WrapI64 -> - fun v -> I32 (I32_convert.wrap_i64 (i64_of_value 1 v)) - | TruncSF32 -> - fun v -> I32 (I32_convert.trunc_s_f32 (f32_of_value 1 v)) - | TruncUF32 -> - fun v -> I32 (I32_convert.trunc_u_f32 (f32_of_value 1 v)) - | TruncSF64 -> - fun v -> I32 (I32_convert.trunc_s_f64 (f64_of_value 1 v)) - | TruncUF64 -> - fun v -> I32 (I32_convert.trunc_u_f64 (f64_of_value 1 v)) - | ReinterpretFloat -> - fun v -> I32 (I32_convert.reinterpret_f32 (f32_of_value 1 v)) - | ExtendSI32 -> - fun v -> raise (TypeError (1, v, I32Type)) - | ExtendUI32 -> - fun v -> raise (TypeError (1, v, I32Type)) -end - -module Int64Op = -struct - open Ast.I64Op - - let unop op = - let f = match op with - | Clz -> I64.clz - | Ctz -> I64.ctz - | Popcnt -> I64.popcnt - in fun v -> I64 (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 -> I64 (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 - | ExtendSI32 -> - fun v -> I64 (I64_convert.extend_s_i32 (i32_of_value 1 v)) - | ExtendUI32 -> - fun v -> I64 (I64_convert.extend_u_i32 (i32_of_value 1 v)) - | TruncSF32 -> - fun v -> I64 (I64_convert.trunc_s_f32 (f32_of_value 1 v)) - | TruncUF32 -> - fun v -> I64 (I64_convert.trunc_u_f32 (f32_of_value 1 v)) - | TruncSF64 -> - fun v -> I64 (I64_convert.trunc_s_f64 (f64_of_value 1 v)) - | TruncUF64 -> - fun v -> I64 (I64_convert.trunc_u_f64 (f64_of_value 1 v)) - | ReinterpretFloat -> - fun v -> I64 (I64_convert.reinterpret_f64 (f64_of_value 1 v)) - | WrapI64 -> - fun v -> raise (TypeError (1, v, I64Type)) -end - - -(* Float operators *) - -module Float32Op = -struct - open Ast.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 -> F32 (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 -> F32 (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 - | DemoteF64 -> - fun v -> F32 (F32_convert.demote_f64 (f64_of_value 1 v)) - | ConvertSI32 -> - fun v -> F32 (F32_convert.convert_s_i32 (i32_of_value 1 v)) - | ConvertUI32 -> - fun v -> F32 (F32_convert.convert_u_i32 (i32_of_value 1 v)) - | ConvertSI64 -> - fun v -> F32 (F32_convert.convert_s_i64 (i64_of_value 1 v)) - | ConvertUI64 -> - fun v -> F32 (F32_convert.convert_u_i64 (i64_of_value 1 v)) - | ReinterpretInt -> - fun v -> F32 (F32_convert.reinterpret_i32 (i32_of_value 1 v)) - | PromoteF32 -> - fun v -> raise (TypeError (1, v, F32Type)) -end - -module Float64Op = -struct - open Ast.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 -> F64 (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 -> F64 (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 - | PromoteF32 -> - fun v -> F64 (F64_convert.promote_f32 (f32_of_value 1 v)) - | ConvertSI32 -> - fun v -> F64 (F64_convert.convert_s_i32 (i32_of_value 1 v)) - | ConvertUI32 -> - fun v -> F64 (F64_convert.convert_u_i32 (i32_of_value 1 v)) - | ConvertSI64 -> - fun v -> F64 (F64_convert.convert_s_i64 (i64_of_value 1 v)) - | ConvertUI64 -> - fun v -> F64 (F64_convert.convert_u_i64 (i64_of_value 1 v)) - | ReinterpretInt -> - fun v -> F64 (F64_convert.reinterpret_i64 (i64_of_value 1 v)) - | DemoteF64 -> - fun v -> 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 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/ast.ml b/ml-proto/spec/ast.ml index e5ff71c1e2..9aa55b4f03 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -95,10 +95,10 @@ and expr' = | LoadPacked of extop (* read memory at address and extend *) | StorePacked of wrapop (* wrap and write to memory at address *) | Const of literal (* constant *) - | Unary of unop (* unary arithmetic operator *) - | Binary of binop (* binary arithmetic operator *) - | Test of testop (* arithmetic test *) - | Compare of relop (* arithmetic comparison *) + | 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 *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 495dc362b6..34ff40084b 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -37,16 +37,16 @@ let memory_error at = function | Memory.SizeOverflow -> Trap.error at "memory size overflow" | exn -> raise exn -let arithmetic_error at = function - | Arithmetic.TypeError (i, v, t) -> +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)) - | Numerics.IntegerOverflow -> + | 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 @@ -197,8 +197,9 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Store {offset; _}, v :: I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in - (try Memory.store (memory c e.at) addr offset v; vs', [] + (try Memory.store (memory c e.at) addr offset v with exn -> memory_error e.at exn); + vs', [] | LoadPacked {memop = {offset; ty; _}; sz; ext}, I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in @@ -207,31 +208,32 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | StorePacked {memop = {offset; _}; sz}, v :: I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in - (try Memory.store_packed (memory c e.at) addr offset sz v; vs', [] - with exn -> memory_error e.at exn) + (try Memory.store_packed (memory c e.at) addr offset sz v + with exn -> memory_error e.at exn); + vs', [] | Const v, vs -> v.it :: vs, [] | Unary unop, v :: vs' -> - (try Arithmetic.eval_unop unop v :: vs', [] - with exn -> arithmetic_error e.at exn) + (try Eval_numeric.eval_unop unop v :: vs', [] + with exn -> numeric_error e.at exn) | Binary binop, v2 :: v1 :: vs' -> - (try Arithmetic.eval_binop binop v1 v2 :: vs', [] - with exn -> arithmetic_error e.at exn) + (try Eval_numeric.eval_binop binop v1 v2 :: vs', [] + with exn -> numeric_error e.at exn) | Test testop, v :: vs' -> - (try value_of_bool (Arithmetic.eval_testop testop v) :: vs', [] - with exn -> arithmetic_error e.at exn) + (try value_of_bool (Eval_numeric.eval_testop testop v) :: vs', [] + with exn -> numeric_error e.at exn) | Compare relop, v2 :: v1 :: vs' -> - (try value_of_bool (Arithmetic.eval_relop relop v1 v2) :: vs', [] - with exn -> arithmetic_error e.at exn) + (try value_of_bool (Eval_numeric.eval_relop relop v1 v2) :: vs', [] + with exn -> numeric_error e.at exn) | Convert cvtop, v :: vs' -> - (try Arithmetic.eval_cvtop cvtop v :: vs', [] - with exn -> arithmetic_error e.at exn) + (try Eval_numeric.eval_cvtop cvtop v :: vs', [] + with exn -> numeric_error e.at exn) | CurrentMemory, vs -> let size = Memory.size (memory c e.at) in 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/arithmetic.mli b/ml-proto/spec/eval_numeric.mli similarity index 100% rename from ml-proto/spec/arithmetic.mli rename to ml-proto/spec/eval_numeric.mli diff --git a/ml-proto/spec/float.ml b/ml-proto/spec/float.ml index 9a7864c8b9..9085b4488f 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 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_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/int.ml b/ml-proto/spec/int.ml index f53a18cc88..8d8a5b7663 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,7 +88,7 @@ struct * "Unsigned Short Division from Signed Division". *) let divrem_u n d = - if d = Rep.zero then raise Numerics.IntegerDivideByZero else + 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 @@ -114,9 +116,9 @@ 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 @@ -127,7 +129,7 @@ struct (* 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 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 index 30483aa134..3c35ce003d 100644 --- a/ml-proto/spec/operators.ml +++ b/ml-proto/spec/operators.ml @@ -38,36 +38,37 @@ let i32_store align offset = Store {ty = I32Type; align; offset} let i64_store align offset = Store {ty = I64Type; align; offset} let f32_store align offset = Store {ty = F32Type; align; offset} let f64_store align offset = Store {ty = F64Type; align; offset} + let i32_load8_s align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = SX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = SX} let i32_load8_u align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = ZX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = ZX} let i32_load16_s align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = SX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = SX} let i32_load16_u align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = ZX} + LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = ZX} let i64_load8_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = SX} let i64_load8_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = ZX} let i64_load16_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = SX} let i64_load16_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = ZX} let i64_load32_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = SX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = SX} let i64_load32_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = ZX} + LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = ZX} let i32_store8 align offset = - StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem8} + StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem8} let i32_store16 align offset = - StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem16} + StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem16} let i64_store8 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem8} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem8} let i64_store16 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem16} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem16} let i64_store32 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem32} + StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem32} let i32_clz = Unary (I32 I32Op.Clz) let i32_ctz = Unary (I32 I32Op.Ctz) diff --git a/ml-proto/spec/values.ml b/ml-proto/spec/values.ml index a1996ab44c..f31e424d48 100644 --- a/ml-proto/spec/values.ml +++ b/ml-proto/spec/values.ml @@ -37,3 +37,44 @@ let string_of_value = function let string_of_values = function | [v] -> string_of_value v | vs -> "(" ^ String.concat " " (List.map string_of_value vs) ^ ")" + + +(* 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 + From 2647de72e26edbc78a83973e3d43cdbd99a95357 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 13 Jul 2016 15:58:32 +0200 Subject: [PATCH 18/44] Adapt encoder --- ml-proto/host/encode.ml | 354 +++++++++++++++++++++++----------------- ml-proto/runtests.py | 2 - 2 files changed, 200 insertions(+), 156 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 4c085b1a64..32f87a05b0 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -92,9 +92,10 @@ let encode m = open Source open Ast open Values + open Memory let op n = u8 n - let memop off align = vu align; vu64 off (*TODO: to be resolved*) + let memop {align; offset; _} = vu align; vu64 offset (*TODO: to be resolved*) let var x = vu x.it let var32 x = vu32 (Int32.of_int x.it) @@ -128,163 +129,208 @@ let encode m = | Call (n, x) -> op 0x16; vu n; var x | CallIndirect (n, x) -> op 0x17; vu n; var x | CallImport (n, x) -> op 0x18; vu n; var x -(* - | I32_load8_s (o, a) -> op 0x20; memop o a - | I32_load8_u (o, a) -> op 0x21; memop o a - | I32_load16_s (o, a) -> op 0x22; memop o a - | I32_load16_u (o, a) -> op 0x23; memop o a - | I64_load8_s (o, a) -> op 0x24; memop o a - | I64_load8_u (o, a) -> op 0x25; memop o a - | I64_load16_s (o, a) -> op 0x26; memop o a - | I64_load16_u (o, a) -> op 0x27; memop o a - | I64_load32_s (o, a) -> op 0x28; memop o a - | I64_load32_u (o, a) -> op 0x29; memop o a - | I32_load (o, a) -> op 0x2a; memop o a - | I64_load (o, a) -> op 0x2b; memop o a - | F32_load (o, a) -> op 0x2c; memop o a - | F64_load (o, a) -> op 0x2d; memop o a - - | I32_store8 (o, a) -> op 0x2e; memop o a - | I32_store16 (o, a) -> op 0x2f; memop o a - | I64_store8 (o, a) -> op 0x30; memop o a - | I64_store16 (o, a) -> op 0x31; memop o a - | I64_store32 (o, a) -> op 0x32; memop o a - | I32_store (o, a) -> op 0x33; memop o a - | I64_store (o, a) -> op 0x34; memop o a - | F32_store (o, a) -> op 0x35; memop o a - | F64_store (o, a) -> op 0x36; memop o a + + | Load ({ty = I32Type; _} as mo) -> op 0x2a; memop mo + | Load ({ty = I64Type; _} as mo) -> op 0x2b; memop mo + | Load ({ty = F32Type; _} as mo) -> op 0x2c; memop mo + | Load ({ty = F64Type; _} as mo) -> op 0x2d; memop mo + + | Store ({ty = I32Type; _} as mo) -> op 0x33; memop mo + | Store ({ty = I64Type; _} as mo) -> op 0x34; memop mo + | Store ({ty = F32Type; _} as mo) -> op 0x35; memop mo + | Store ({ty = F64Type; _} as mo) -> op 0x36; memop mo + + | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem8; ext = SX} -> + op 0x20; memop mo + | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem8; ext = ZX} -> + op 0x21; memop mo + | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem16; ext = SX} -> + op 0x22; memop mo + | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem16; ext = ZX} -> + op 0x23; memop mo + | LoadPacked {memop = {ty = I32Type; _}; sz = Mem32; _} -> + assert false + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem8; ext = SX} -> + op 0x24; memop mo + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem8; ext = ZX} -> + op 0x25; memop mo + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem16; ext = SX} -> + op 0x26; memop mo + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem16; ext = ZX} -> + op 0x27; memop mo + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem32; ext = SX} -> + op 0x28; memop mo + | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem32; ext = ZX} -> + op 0x29; memop mo + | LoadPacked {memop = {ty = F32Type | F64Type; _}; _} -> + assert false + + | StorePacked {memop = {ty = I32Type; _} as mo; sz = Mem8} -> + op 0x2e; memop mo + | StorePacked {memop = {ty = I32Type; _} as mo; sz = Mem16} -> + op 0x2f; memop mo + | StorePacked {memop = {ty = I32Type; _}; sz = Mem32} -> + assert false + | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem8} -> + op 0x30; memop mo + | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem16} -> + op 0x31; memop mo + | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem32} -> + op 0x32; memop mo + | StorePacked {memop = {ty = F32Type | F64Type; _}; _} -> + assert false | GrowMemory -> op 0x39 | CurrentMemory -> op 0x3b - | I32_add -> op 0x40 - | I32_sub -> op 0x41 - | I32_mul -> op 0x42 - | I32_div_s -> op 0x43 - | I32_div_u -> op 0x44 - | I32_rem_s -> op 0x45 - | I32_rem_u -> op 0x46 - | I32_and -> op 0x47 - | I32_or -> op 0x48 - | I32_xor -> op 0x49 - | I32_shl -> op 0x4a - | I32_shr_u -> op 0x4b - | I32_shr_s -> op 0x4c - | I32_rotl -> op 0xb6 - | I32_rotr -> op 0xb7 - | I32_eq -> op 0x4d - | I32_ne -> op 0x4e - | I32_lt_s -> op 0x4f - | I32_le_s -> op 0x50 - | I32_lt_u -> op 0x51 - | I32_le_u -> op 0x52 - | I32_gt_s -> op 0x53 - | I32_ge_s -> op 0x54 - | I32_gt_u -> op 0x55 - | I32_ge_u -> op 0x56 - | I32_clz -> op 0x57 - | I32_ctz -> op 0x58 - | I32_popcnt -> op 0x59 - | I32_eqz -> op 0x5a - - | I64_add -> op 0x5b - | I64_sub -> op 0x5c - | I64_mul -> op 0x5d - | I64_div_s -> op 0x5e - | I64_div_u -> op 0x5f - | I64_rem_s -> op 0x60 - | I64_rem_u -> op 0x61 - | I64_and -> op 0x62 - | I64_or -> op 0x63 - | I64_xor -> op 0x64 - | I64_shl -> op 0x65 - | I64_shr_u -> op 0x66 - | I64_shr_s -> op 0x67 - | I64_rotl -> op 0xb8 - | I64_rotr -> op 0xb9 - | I64_eq -> op 0x68 - | I64_ne -> op 0x69 - | I64_lt_s -> op 0x6a - | I64_le_s -> op 0x6b - | I64_lt_u -> op 0x6c - | I64_le_u -> op 0x6d - | I64_gt_s -> op 0x6e - | I64_ge_s -> op 0x6f - | I64_gt_u -> op 0x70 - | I64_ge_u -> op 0x71 - | I64_clz -> op 0x72 - | I64_ctz -> op 0x73 - | I64_popcnt -> op 0x74 - | I64_eqz -> op 0xba - - | F32_add -> op 0x75 - | F32_sub -> op 0x76 - | F32_mul -> op 0x77 - | F32_div -> op 0x78 - | F32_min -> op 0x79 - | F32_max -> op 0x7a - | F32_abs -> op 0x7b - | F32_neg -> op 0x7c - | F32_copysign -> op 0x7d - | F32_ceil -> op 0x7e - | F32_floor -> op 0x7f - | F32_trunc -> op 0x80 - | F32_nearest -> op 0x81 - | F32_sqrt -> op 0x82 - | F32_eq -> op 0x83 - | F32_ne -> op 0x84 - | F32_lt -> op 0x85 - | F32_le -> op 0x86 - | F32_gt -> op 0x87 - | F32_ge -> op 0x88 - - | F64_add -> op 0x89 - | F64_sub -> op 0x8a - | F64_mul -> op 0x8b - | F64_div -> op 0x8c - | F64_min -> op 0x8d - | F64_max -> op 0x8e - | F64_abs -> op 0x8f - | F64_neg -> op 0x90 - | F64_copysign -> op 0x91 - | F64_ceil -> op 0x92 - | F64_floor -> op 0x93 - | F64_trunc -> op 0x94 - | F64_nearest -> op 0x95 - | F64_sqrt -> op 0x96 - | F64_eq -> op 0x97 - | F64_ne -> op 0x98 - | F64_lt -> op 0x99 - | F64_le -> op 0x9a - | F64_gt -> op 0x9b - | F64_ge -> op 0x9c - - | I32_trunc_s_f32 -> op 0x9d - | I32_trunc_s_f64 -> op 0x9e - | I32_trunc_u_f32 -> op 0x9f - | I32_trunc_u_f64 -> op 0xa0 - | I32_wrap_i64 -> op 0xa1 - | I64_trunc_s_f32 -> op 0xa2 - | I64_trunc_s_f64 -> op 0xa3 - | I64_trunc_u_f32 -> op 0xa4 - | I64_trunc_u_f64 -> op 0xa5 - | I64_extend_s_i32 -> op 0xa6 - | I64_extend_u_i32 -> op 0xa7 - | F32_convert_s_i32 -> op 0xa8 - | F32_convert_u_i32 -> op 0xa9 - | F32_convert_s_i64 -> op 0xaa - | F32_convert_u_i64 -> op 0xab - | F32_demote_f64 -> op 0xac - | F32_reinterpret_i32 -> op 0xad - | F64_convert_s_i32 -> op 0xae - | F64_convert_u_i32 -> op 0xaf - | F64_convert_s_i64 -> op 0xb0 - | F64_convert_u_i64 -> op 0xb1 - | F64_promote_f32 -> op 0xb2 - | F64_reinterpret_i64 -> op 0xb3 - | I32_reinterpret_f32 -> op 0xb4 - | I64_reinterpret_f64 -> op 0xb5 -*)| _ -> () + | 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 + + | Label _ -> assert false (* Sections *) diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index b2e297c873..1b9a7ae5dc 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -47,8 +47,6 @@ def _runTestFile(self, shortName, fileName, interpreterPath): self._runCommand(("%s %s") % (interpreterPath, fileName), logPath, expectedExitCode) self._compareLog(fileName, logPath) - return # TODO(stack) - if expectedExitCode != 0: return From 4dd20ef2aa160e923f7e8ccbba07efae1b89366f Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 13 Jul 2016 16:31:17 +0200 Subject: [PATCH 19/44] Adjust text conversion --- ml-proto/host/arrange.ml | 9 +-- ml-proto/host/lexer.mll | 2 +- ml-proto/host/parser.mly | 2 + ml-proto/runtests.py | 5 +- ml-proto/spec/float.ml | 73 +++++++++++------------ ml-proto/spec/int.ml | 118 ++++++++++++++++++-------------------- ml-proto/spec/types.ml | 7 +++ ml-proto/test/return.wast | 4 +- 8 files changed, 107 insertions(+), 113 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 376676949f..627ab7bad3 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -162,7 +162,7 @@ let cvtop = oper (IntOp.cvtop, FloatOp.cvtop) let memop name {ty; align; offset} = value_type ty ^ "." ^ name ^ (if offset = 0L then "" else " offset=" ^ int64 offset) ^ - (if align = 1 then "" else " align=" ^ int align) + (if align = size ty then "" else " align=" ^ int align) let mem_size = function | Memory.Mem8 -> "8" @@ -199,12 +199,7 @@ let rec expr e = Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) | Return n -> Atom ("return " ^ int n) | If (es1, es2) -> - (match list expr es1, list expr es2 with - | [sx2], [] -> Node ("if", [sx2]) - | [sx2], [sx3] -> Node ("if", [sx2; sx3]) - | sxs2, [] -> Node ("if", [Node ("then", sxs2)]) - | sxs2, sxs3 -> Node ("if", [Node ("then", sxs2); Node ("else", sxs3)]) - ) + Node ("if", list expr es1 @ [Atom "else"] @ list expr es2) | Select -> Atom "select" | Call (n, x) -> Atom ("call " ^ int n ^ " " ^ var x) | CallImport (n, x) -> Atom ("call_import " ^ int n ^ " " ^ var x) diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 42d38ba1ec..b4a7f57ff6 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -98,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" diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index d24f97d186..4ea8b3c6c2 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -308,6 +308,8 @@ expr1 : | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ (snd ($6 c1)) (snd ($11 c2)) } + | IF expr_list ELSE expr_list + { fun c -> let c' = anon_label c in [], if_ (snd ($2 c')) (snd ($4 c')) } | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, select } | CALL var expr_list { fun c -> let n, es = $3 c in es, call n ($2 c func) } | CALL_IMPORT var expr_list diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index 1b9a7ae5dc..69823fcdf2 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -56,8 +56,6 @@ def _runTestFile(self, shortName, fileName, interpreterPath): self._runCommand(("%s -d %s -o %s") % (interpreterPath, fileName, wasmPath)) self._runCommand(("%s %s") % (interpreterPath, wasmPath), logPath) - return # TODO(stack) - # Convert back to text and run 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")) @@ -68,7 +66,8 @@ def _runTestFile(self, shortName, fileName, interpreterPath): 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 %s") % (interpreterPath, wasm2Path), logPath) - # TODO: Ultimately, the binary should stay the same, but currently desugaring gets in the way. + # 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/float.ml b/ml-proto/spec/float.ml index 9085b4488f..a2f2f007a6 100644 --- a/ml-proto/spec/float.ml +++ b/ml-proto/spec/float.ml @@ -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/int.ml b/ml-proto/spec/int.ml index 8d8a5b7663..0fd5875734 100644 --- a/ml-proto/spec/int.ml +++ b/ml-proto/spec/int.ml @@ -106,7 +106,6 @@ struct 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 @@ -167,37 +166,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 @@ -212,52 +208,50 @@ 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 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/types.ml b/ml-proto/spec/types.ml index 69f6b94756..36b21c6e22 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -5,6 +5,13 @@ type stack_type = value_type list type func_type = FuncType of stack_type * stack_type +(* Attributes *) + +let size = function + | I32Type | F32Type -> 4 + | I64Type | F64Type -> 8 + + (* String conversion *) let string_of_value_type = function diff --git a/ml-proto/test/return.wast b/ml-proto/test/return.wast index 2124b831d9..daa093e4b4 100644 --- a/ml-proto/test/return.wast +++ b/ml-proto/test/return.wast @@ -10,7 +10,7 @@ (func "type-f64" (drop (f64.neg (return)))) (func "nullary" (return)) - (func "unary" (result f64) (return (f64.const 3.1))) + (func "unary" (result f64) (return (f64.const 3))) (func "as-func-first" (result i32) (return (i32.const 1)) (i32.const 2) @@ -196,7 +196,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)) From 67718f7e751d7c994180ca268f976fcecd33ca73 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Wed, 13 Jul 2016 18:45:52 +0200 Subject: [PATCH 20/44] Sketch of formal spec --- formal/wasm.tex | 821 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 821 insertions(+) create mode 100644 formal/wasm.tex diff --git a/formal/wasm.tex b/formal/wasm.tex new file mode 100644 index 0000000000..c73716a7a9 --- /dev/null +++ b/formal/wasm.tex @@ -0,0 +1,821 @@ +\documentclass[a4paper]{scrartcl} + +\usepackage{amsmath} +\usepackage{amssymb} +\usepackage{xspace} +\usepackage{color} + +\newcommand\void[1]{} + + +% Calculus notation + +\newcommand\x[1]{\ensuremath{\mathit{#1}}\xspace} +\newcommand\f[1]{\ensuremath{\mathop{\mathrm{#1\null}}\nolimits}\xspace} +\newcommand\ff[1]{\ensuremath{\mathbin{\mathrm{#1\null}}}\xspace} +\newcommand\y[1]{\ensuremath{{}\hspace{-0.25em}\mathrel{\mathsf{#1\null}}}\xspace} +\newcommand\yy[1]{\ensuremath{\mathrel{\mathsf{#1\null}}}\xspace} + +\renewcommand\vec[1]{\overline{#1}} +\newcommand\tup[1]{\langle#1\rangle} + +\newcommand\append{\mathbin{{+\!\!+}}} +\newcommand\wild{\mathbin{{\_\!\_}}} + +\newcommand\too{\Rightarrow} +\newcommand\evalto{\hookrightarrow} +\newcommand\elabto{\rightsquigarrow} +\newcommand\elabtox[1]{\stackrel{#1}\rightsquigarrow} +\newcommand{\yields}{\uparrow} +\newcommand{\antype}{:_\Leftarrow} +\newcommand{\syntype}{:_\Rightarrow} +\newcommand{\ansub}{\leq_\Leftarrow} +\newcommand{\synsub}{\leq_\Rightarrow} + +\newcommand\LET{\y{let}} +\newcommand\PACK{\y{pack}} +\newcommand\UNPACK{\y{unpack}} +\newcommand\WRAP{\y{wrap}} +\newcommand\UNWRAP{\y{unwrap}} +\newcommand\NEW{\y{new}} +\newcommand\IN{\yy{in}} +\newcommand\AS{\yy{as}} +\newcommand\CAST{\y{cast}} +\newcommand\NAM{{\y{nam}}} +\newcommand\BOOL{{\y{bool}}} +\newcommand\TRUE{{\y{true}}} +\newcommand\FALSE{{\y{false}}} +\newcommand\IF{\y{if}} +\newcommand\THEN{\yy{then}} +\newcommand\ELSE{\yy{else}} +\newcommand\CASE{\y{case}} +\newcommand\OF{\yy{of}} + +\newcommand{\VAL}{\K{val}} +\newcommand{\TYP}{\K{typ}} +\newcommand{\SIG}{\K{sig}} + +\newcommand\Dom{\ff{dom}} +\newcommand\Rng{\ff{rng}} +\newcommand\FTV{\ff{fv}} +\newcommand\Norm{\ff{norm}} + +\newcommand\conty{\chi} +\newcommand\pathty{\pi} +\newcommand\smallty{\sigma} +\newcommand\bigty{\Sigma} +\newcommand\polyty{\Phi} +\newcommand\absty{\Xi} + +\newcommand\emptysubst{\f{id}} + +\newcommand\Rho{{\f{R}}} +\newcommand\pure{{\f{P}}} +\newcommand\impure{{\f{I}}} + +\newcommand\deter{\epsilon} +\newcommand\anal{{\f{an}}} +\newcommand\synth{{\f{syn}}} +\newcommand\inst{{\f{ins}}} + + +% Code notation + +\newcommand\K[1]{\ensuremath{\textsf{#1}}} +%\newcommand\K[1]{\ensuremath{\texttt{#1}}} +\newcommand\KK[1]{\ensuremath{\K{\textbf{#1}}}} + +\newcommand\Kback{\ensuremath{\backslash\!}} +\newcommand\Kto{\ensuremath{\rightarrow}\xspace} +\newcommand\Ktoo{\ensuremath{\Rightarrow}\xspace} +\newcommand\Kfrom{\ensuremath{\leftarrow}\xspace} +\newcommand\Kfroom{\ensuremath{\Leftarrow}\xspace} +\newcommand\Ktimes{\ensuremath{\times}\xspace} +\newcommand\Kappend{\ensuremath{\append}\xspace} +\newcommand\Kwild{\ensuremath{\wild}\xspace} +\newcommand\Kbar{\ensuremath{|}\xspace} +\newcommand\Kneq{\ensuremath{\neq}\xspace} +\newcommand\Kleq{\ensuremath{\leq}\xspace} +\newcommand\Klt{\ensuremath{<}\xspace} +\newcommand\Kgt{\ensuremath{>}\xspace} +\newcommand\Kseal{\ensuremath{:>}\xspace} +\newcommand\Kdot{\ensuremath{\cdot}\xspace} +\newcommand\Kcirc{\ensuremath{\circ}\xspace} +\newcommand\Kalpha{\ensuremath{\alpha}} +\newcommand\Kbeta{\ensuremath{\beta}} +\newcommand\Kgamma{\ensuremath{\gamma}} +\newcommand\Klangle{\ensuremath{\langle}} +\newcommand\Krangle{\ensuremath{\rangle}} +\newcommand\Ksb[1]{\ensuremath{_{#1}}} + +\DeclareTextCommand{\_}{OT1}{\leavevmode \kern.06em\vbox{\hrule width.6em}} + + +% Coloring + +%\definecolor{hilite}{rgb}{0,0,0.9} +\definecolor{hilite}{rgb}{0.7,0,0} +\newcommand{\hilite}[1]{\color{hilite}#1\color{black}} + + +\begin{document} + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\section{Wasm-as-stack} + + +\subsection*{Syntax} + +$$ +\begin{array}{@{}llcl@{}} +\text{(types)} & t &::=& + \KK{i32} ~|~ + \KK{i64} ~|~ + \KK{f32} ~|~ + \KK{f64} \\ +[1ex] +\text{(operators)} & e &::=& + t\KK{.const}~c ~|~ + t\KK{.}\x{unop} ~|~ + t\KK{.}\x{binop} ~|~ + t\KK{.}\x{testop} ~|~ + t\KK{.}\x{relop} ~|~ + \dots ~|~ \\&&& + \KK{unreachable} ~|~ + \KK{nop} ~|~ + \KK{drop} ~|~ + \KK{select} ~|~ + \KK{get}~i ~|~ + \KK{set}~i ~|~ + \KK{tee}~i ~|~ \\&&& + \KK{block}~e^\ast~\KK{end} ~|~ + \KK{loop}~e^\ast~\KK{end} ~|~ + \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} ~|~ \\&&& + \KK{br}_n~i ~|~ + \KK{br\_if}_n~i ~|~ + \KK{br\_table}_n~i^+ \\ +\end{array} +$$ + +%\newcommand\orbot{/\bot} +%\newcommand\poly[1]{\bot} +%\newcommand\botrule[1]{#1} + +\newcommand\orbot{} +\newcommand\poly[1]{[#1]} +\newcommand\botrule[1]{} + + +\subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orbot}$} + +$$ +\frac{ +}{ + C \vdash t\KK{.const}~c : [] \to [t] +} +$$ + +$$ +\frac{ +}{ + C \vdash t\KK{.}\x{unop} : [t] \to [t] +} +%$$ +\qquad +%$$ +\frac{ +}{ + C \vdash t\KK{.}\x{binop} : [t~t] \to [t] +} +$$ + +$$ +\frac{ +}{ + C \vdash t\KK{.}\x{testop} : [t] \to [\K{i32}] +} +%$$ +\qquad +%$$ +\frac{ +}{ + C \vdash t\KK{.}\x{relop} : [t~t] \to [\K{i32}] +} +$$ + +$$ +\frac{ +}{ + C \vdash \KK{nop} : [] \to [] +} +%$$ +\qquad +%$$ +\frac{ +}{ + C \vdash \KK{drop} : [t] \to [] +} +%$$ +\qquad +%$$ +\frac{ +}{ + C \vdash \KK{select} : [t~t~\K{i32}] \to [t] +} +$$ + +$$ +\frac{ + C_{\f{local}}(i) = t +}{ + C \vdash \KK{get}~i : [] \to [t] +} +%$$ +\qquad +%$$ +\frac{ + C_{\f{local}}(i) = t +}{ + C \vdash \KK{set}~i : [t] \to [] +} +%$$ +\qquad +%$$ +\frac{ + C_{\f{local}}(i) = t +}{ + C \vdash \KK{tee}~i : [t] \to [t] +} +$$ + +$$ +\frac{ + C,_{\f{label}}[t^?] \vdash e^\ast : [t^?]\orbot +}{ + C \vdash \KK{block}~e^\ast~\KK{end} : [] \to [t^?]\orbot +} +%$$ +\qquad +%$$ +\frac{ + C,_{\f{label}}[] \vdash e^\ast : [t^?]\orbot +}{ + C \vdash \KK{loop}~e^\ast~\KK{end} : [] \to [t^?]\orbot +} +$$ + +$$ +\frac{ + C \vdash e_1^\ast : [t^?]\orbot + \qquad + C \vdash e_2^\ast : [t^?]\orbot +}{ + C \vdash \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} : [\K{i32}] \to [t^?]\orbot +} +$$ + +$$ +\frac{ + C_{\f{label}}(i) = [t^n] +}{ + C \vdash \KK{br}_n~i : [t^n] \to \poly{t_0^?} +} +%$$ +\qquad +%$$ +\frac{ + C_{\f{label}}(i) = [t^n] +}{ + C \vdash \KK{br\_if}_n~i : [t^n~\K{i32}] \to [t^n] +} +$$ +%\qquad +$$ +\frac{ + (C_{\f{label}}(i) = [t^n])^+ +}{ + C \vdash \KK{br\_table}_n~i^+ : [t^n~\K{i32}] \to \poly{t_0^n} +} +%$$ +\qquad +%$$ +\frac{ +}{ + C \vdash \KK{unreachable} : [] \to \poly{t^?} +} +$$ + + +\subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : [t^\ast]\orbot}$} + +$$ +\frac{ +}{ + C \vdash \epsilon : [] +} +%$$ +\qquad +%$$ +\frac{ + C \vdash e^\ast : [t_1^\ast~t_2^\ast] + \qquad + C \vdash e_2 : [t_2^\ast] \to [t_3^?]\orbot +}{ + C \vdash e^\ast~e_2 : [t_1^\ast~t_3^?]\orbot +} +\botrule{ +%$$ +\qquad +%$$ +\frac{ + C \vdash e^\ast : \bot + \qquad + C \vdash e_2 : [t_2^\ast] \to [t_3^?]/\bot +}{ + C \vdash e^\ast~e_2 : \bot +} +} +$$ + + +\subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} + +$$ +\begin{array}{@{}llcl@{}} +\text{(values)} & v &::=& + t\KK{.const}~c \\ +\text{(administrative operators)} & e &::=& + \dots ~|~ + \KK{label}[e^\ast]~e^\ast~\KK{end} \\ +%\text{(evaluation contexts)} & E &::=& +% [] ~|~ +% \KK{block}~v^\ast~E~e^\ast~\KK{end} \\ +\end{array} +$$ + +\void{ +$$ +\frac{ + S;~e^\ast \evalto S';~{e'}^\ast +}{ + S;~E[e^\ast] \evalto S';~E[{e'}^\ast] +} +$$ +} + +$$ +\begin{array}{rcl} +(t.\KK{const}~c)~t\KK{.}\x{unop} &\evalto& + t.\KK{const}~t.\x{unop}(c) \\ +(t.\KK{const}~c_1)~(t.\KK{const}~c_2)~t\KK{.}\x{binop} &\evalto& + t.\KK{const}~t.\x{binop}(c_1, c_2) \\ +(t.\KK{const}~c)~t\KK{.}\x{testop} &\evalto& + \KK{i32.const}~t.\x{testop}(c) \\ +(t.\KK{const}~c_1)~(t.\KK{const}~c_2)~t\KK{.}\x{binop} &\evalto& + \KK{i32.const}~t.\x{relop}(c_1, c_2) \\ +[1ex] +\KK{nop} &\evalto& + \epsilon \\ +v~\KK{drop} &\evalto& + \epsilon \\ +v_1~v_2~(\KK{i32.const}~0)~\KK{select} &\evalto& + v_2 \\ +v_1~v_2~(\KK{i32.const}~i+1)~\KK{select} &\evalto& + v_1 \\ +[1ex] +S;~ (\KK{get}~i) &\evalto& + S;~ S_{\f{local}}(i) \\ +S;~ v~(\KK{set}~i) &\evalto& + S,i=v;~ \epsilon \\ +v~(\KK{tee}~i) &\evalto& + v~v~(\KK{set}~i) \\ +[1ex] +\void{ +\KK{block}~v^\ast~\KK{end} &\evalto& + v^\ast \\ +\KK{block}~v^\ast~v^n~(\KK{br}_n~0)~e^\ast~\KK{end} &\evalto& + v^n \\ +\KK{block}~v^\ast~v^n~(\KK{br}_n~i+1)~e^\ast~\KK{end} &\evalto& + v^n~(\KK{br}_n~i) \\ +[1ex] +\KK{loop}~e^\ast~\KK{end} &\evalto& + \KK{block}~e^\ast~\KK{end}~\KK{loop}~e^\ast~\KK{end} \\ +[1ex] +} +(\KK{i32.const}~0)~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} &\evalto& + e_2^\ast \\ +(\KK{i32.const}~i+1)~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} &\evalto& + e_1^\ast \\ +\end{array} +$$ +\vspace{2em} +$$ +\begin{array}{rcl} +(\KK{i32.const}~0)~\KK{br\_if}_n~i &\evalto& + \epsilon \\ +(\KK{i32.const}~j+1)~\KK{br\_if}_n~i &\evalto& + \KK{br}_n~i \\ +(\KK{i32.const}~k)~\KK{br\_table}_n~i_1^{k-1}~i~i_2^\ast &\evalto& + \KK{br}_n~i \\ +(\KK{i32.const}~k+j)~\KK{br\_table}_n~i^k~i' &\evalto& + \KK{br}_n~i' \\ +[1ex] +\KK{block}~e^\ast~\KK{end} &\evalto& + \KK{label}[]~e^\ast~\KK{end} \\ +\KK{loop}~e^\ast~\KK{end} &\evalto& + \KK{label}[\KK{loop}~e^\ast~\KK{end}]~e^\ast~\KK{end} \\ +[1ex] +\KK{label}[e^\ast]~v^\ast~\KK{end} &\evalto& + v^\ast \\ +\KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~0)~e^\ast~\KK{end} &\evalto& + v^n~e_0^\ast \\ +\KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~i+1)~e^\ast~\KK{end} &\evalto& + v^n~(\KK{br}_n~i) \\ +\KK{label}[e_0^\ast]~v^\ast~v^n~\KK{unreachable}~e^\ast~\KK{end} &\evalto& + \KK{unreachable} \\ +[1ex] +\end{array} +$$ + +\void{ +$$ +\frac{ + C \vdash e_0^\ast : [t^\ast]/\bot + \qquad + C \vdash e^\ast : [t^\ast]/\bot +}{ + C \vdash \KK{label}[e_0^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]/\bot +} +$$ +} + +\end{document} + +\void{ +\subsection*{Evaluating Expressions \hfill $\boxed{[c^\ast]~e \too r}$} + +$$ +\begin{array}{@{}llcl@{}} +\text{(results)} & r &::=& + [c^*] ~|~ + \K{br}~i~[c^*] \\ +\end{array} +$$ + +$$ +\frac{ +}{ + []~t\KK{.const}~c \too [c] +} +%$$ +\qquad +%$$ +\frac{ +}{ + [c]~t\KK{.}\x{unop} \too [t.\x{unop}(c)] +} +\qquad +%$$ +\frac{ +}{ + [c_1~c_2]~t\KK{.}\x{binop} \too [t.\x{binop}(c_1, c_2)] +} +$$ + +$$ +\frac{ + e^\ast \too [c^?] +}{ + []~\KK{block}~e^\ast~\KK{end} \too [c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~0~[c^?] +}{ + []~\KK{block}~e^\ast~\KK{end} \too [c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~(i+1)~[c^?] +}{ + []~\KK{block}~e^\ast~\KK{end} \too \K{br}~i~[c^?] +} +$$ + +$$ +\frac{ + e^\ast \too [c^?] +}{ + []~\KK{loop}~e^\ast~\KK{end} \too [c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~0~[] + \qquad + []~\KK{loop}~e^\ast~\KK{end} \too r +}{ + []~\KK{loop}~e^\ast~\KK{end} \too r +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~(i+1)~[c^?] +}{ + []~\KK{loop}~e^\ast~\KK{end} \too \K{br}~i~[c^?] +} +$$ + +$$ +\frac{ + c \neq 0 + \qquad + e_1^\ast \too r +}{ + [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r +} +%$$ +\qquad +%$$ +\frac{ + c = 0 + \qquad + e_2^\ast \too r +}{ + [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r +} +$$ + +$$ +\frac{ +}{ + [c^n]~\KK{br}_n~i \too \K{br}~i~[c^n] +} +$$ + + +\subsection*{Evaluating Sequences \hfill $\boxed{e^\ast \too r}$} + +$$ +\frac{ +}{ + \epsilon \too [] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too [c_1^\ast~c_2^\ast] + \qquad + [c_2^\ast]~e_2 \too [c_3^?] +}{ + e^\ast~e_2 \too [c_1^\ast~c_3^?] +} +$$ +%\qquad +$$ +\frac{ + e^\ast \too \K{br}~i~[c^?] +}{ + e^\ast~e_2 \too \K{br}~i~[c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too [c_1^\ast~c_2^\ast] + \qquad + [c_2^\ast]~e \too \K{br}~i~[c^?] +}{ + e^\ast~e_2 \too \K{br}~i~[c^?] +} +$$ +} + + +\clearpage +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +\section{Wasm-as-stack, Flat} + + +\subsection*{Syntax} + +$$ +\begin{array}{@{}llcl@{}} +\text{(expressions)} & e &::=& + t\KK{.const}~c ~|~ + t\KK{.}\x{unop} ~|~ + t\KK{.}\x{binop} ~|~ + \dots ~|~ \\&&& + \KK{block} ~|~ + \KK{loop} ~|~ + \KK{if} ~|~ + \KK{else }~|~ + \KK{end} ~|~ + \KK{br}_n~i \\ +[2ex] +\text{(control stacks)} & s &::=& + b^* \\ +\text{(control blocks)} & b &::=& + [t^*]e\langle t^?\rangle \\ +[2ex] +\text{(results)} & r &::=& + [c^*] ~|~ + \K{br}~i~[c^*] \\ +\end{array} +$$ + + +\subsection*{Typing Expressions \hfill $\boxed{C \vdash e : s~[t^\ast] \to s~[t^?]}$} + +$$ +\begin{array}{@{}rcl@{}} +t\KK{.const}~c &:& s~[t_0^\ast] \to s~[t_0^\ast~t] +\\ +t\KK{.}\x{unop} &:& s~[t_0^\ast~t] \to s~[t_0^\ast~t] +\\ +t\KK{.}\x{binop} &:& s~[t_0^\ast~t~t] \to s~[t_0^\ast~t] +\\ +\KK{block} &:& s~[t_0^\ast] \to s~[t_0^\ast]\K{block}\langle t^?\rangle~[] +\\ +\KK{loop} &:& s~[t_0^\ast] \to s~[t_0^\ast]\K{loop}\langle t^?\rangle~[] +\\ +\KK{if} &:& s~[t_0^\ast~\K{i32}] \to s~[t_0^\ast]\K{if}\langle t^?\rangle~[] +\\ +\KK{end} &:& s~[t_0^\ast]e\langle t^?\rangle~[t^?] \to s~[t_0^\ast~t^?] +\\ +\KK{else} &:& s~[t_0^\ast]\K{if}\langle t^?\rangle~[t^?] \to s~[t_0^\ast]\K{else}\langle t^?\rangle~[] +\\ +\KK{br}_n~i &:& s~[t_0^\ast]\K{block}\langle t^n\rangle~b^i~[t_1^\ast~t^n] \to s~[t_0^\ast~t^n] +\\ +\KK{br}_0~i &:& s~[t_0^\ast]\K{loop}\langle t^?\rangle~b^i~[t_1^\ast] \to s~[t_0^\ast] +\end{array} +$$ + + +\subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : s~[t^\ast] \to s~[t^\ast]}$} + +$$ +\frac{ +}{ + \epsilon : s~[] \to s~[] +} +%$$ +\qquad +%$$ +\frac{ + e_1^\ast : s_1~[t_1^\ast] \to s_2~[t_2^\ast] + \qquad + e_2 : s_2~[t_3^\ast] \to s_3~[t_3^\ast] +}{ + e_1^\ast~e_2 : s_1~[t_1^\ast] \to s_3~[t_3^\ast] +} +$$ + + +\subsection*{Evaluating Expressions \hfill $\boxed{[c^\ast]~e \too r}$} + +$$ +\frac{ +}{ + []~t\KK{.const}~c \too [c] +} +%$$ +\qquad +%$$ +\frac{ +}{ + [c]~t\KK{.}\x{unop} \too [t.\x{unop}(c)] +} +\qquad +%$$ +\frac{ +}{ + [c_1~c_2]~t\KK{.}\x{binop} \too [t.\x{binop}(c_1, c_2)] +} +$$ + +$$ +\frac{ +}{ + []~\KK{block} \too [\K{block}] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~0~[c^?] +}{ + []~\KK{block}~e^\ast~\KK{end} \too [c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~(i+1)~[c^?] +}{ + []~\KK{block}~e^\ast~\KK{end} \too \K{br}~i~[c^?] +} +$$ + +$$ +\frac{ + e^\ast \too [c^?] +}{ + []~\KK{loop}~e^\ast~\KK{end} \too [c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~0~[] + \qquad + []~\KK{loop}~e^\ast~\KK{end} \too r +}{ + []~\KK{loop}~e^\ast~\KK{end} \too r +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too \K{br}~(i+1)~[c^?] +}{ + []~\KK{loop}~e^\ast~\KK{end} \too \K{br}~i~[c^?] +} +$$ + +$$ +\frac{ + c \neq 0 + \qquad + e_1^\ast \too r +}{ + [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r +} +%$$ +\qquad +%$$ +\frac{ + c = 0 + \qquad + e_2^\ast \too r +}{ + [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r +} +$$ + +$$ +\frac{ +}{ + [c^n]~\KK{br}_n~i \too \K{br}~i~[c^n] +} +$$ + + +\subsection*{Evaluating Sequences \hfill $\boxed{e^\ast \too r}$} + +$$ +\frac{ +}{ + \epsilon \too [] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too [c_1^\ast~c_2^\ast] + \qquad + [c_2^\ast]~e_2 \too [c_3^?] +}{ + e^\ast~e_2 \too [c_1^\ast~c_3^?] +} +$$ +%\qquad +$$ +\frac{ + e^\ast \too \K{br}~i~[c^?] +}{ + e^\ast~e_2 \too \K{br}~i~[c^?] +} +%$$ +\qquad +%$$ +\frac{ + e^\ast \too [c_1^\ast~c_2^\ast] + \qquad + [c_2^\ast]~e \too \K{br}~i~[c^?] +}{ + e^\ast~e_2 \too \K{br}~i~[c^?] +} +$$ + + +\end{document} From 21ceedfa7e0af0bc426ca1007227dcf8e7a39be6 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Thu, 14 Jul 2016 19:53:26 +0200 Subject: [PATCH 21/44] Formal rules for calls, returns, locals --- formal/wasm.tex | 134 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 102 insertions(+), 32 deletions(-) diff --git a/formal/wasm.tex b/formal/wasm.tex index c73716a7a9..e60010b55a 100644 --- a/formal/wasm.tex +++ b/formal/wasm.tex @@ -154,7 +154,9 @@ \subsection*{Syntax} \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} ~|~ \\&&& \KK{br}_n~i ~|~ \KK{br\_if}_n~i ~|~ - \KK{br\_table}_n~i^+ \\ + \KK{br\_table}_n~i^+ ~|~ + \KK{call}_n~i ~|~ + \KK{return}_n \\ \end{array} $$ @@ -295,7 +297,7 @@ \subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orb \frac{ (C_{\f{label}}(i) = [t^n])^+ }{ - C \vdash \KK{br\_table}_n~i^+ : [t^n~\K{i32}] \to \poly{t_0^n} + C \vdash \KK{br\_table}_n~i^+ : [t^n~\K{i32}] \to \poly{t_0^?} } %$$ \qquad @@ -306,6 +308,22 @@ \subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orb } $$ +$$ +\frac{ + C_{\f{func}}(i) = [t_1^n] \to [t_2^?] +}{ + C \vdash \KK{call}_n~i^+ : [t_1^n] \to [t_2^?] +} +%$$ +\qquad +%$$ +\frac{ + C_{\f{return}} = [t^n] +}{ + C \vdash \KK{return}_n : [t^n] \to \poly{t_0^?} +} +$$ + \subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : [t^\ast]\orbot}$} @@ -347,22 +365,36 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} t\KK{.const}~c \\ \text{(administrative operators)} & e &::=& \dots ~|~ - \KK{label}[e^\ast]~e^\ast~\KK{end} \\ -%\text{(evaluation contexts)} & E &::=& -% [] ~|~ -% \KK{block}~v^\ast~E~e^\ast~\KK{end} \\ + \KK{trap} ~|~ + \KK{label}[e^\ast]~e^\ast~\KK{end} ~|~ + \KK{local}[v^\ast]~e^\ast~\KK{end} \\ +\text{(local contexts)} & L &::=& + [] ~|~ + v^\ast~L~e^\ast ~|~ + \KK{label}[e^\ast]~L~\KK{end} \\ +\text{(evaluation contexts)} & E &::=& + [] ~|~ + v^\ast~E~e^\ast ~|~ + \KK{label}[e^\ast]~E~\KK{end} ~|~ + \KK{local}[v^\ast]~E~\KK{end} \\ \end{array} $$ -\void{ $$ \frac{ S;~e^\ast \evalto S';~{e'}^\ast }{ S;~E[e^\ast] \evalto S';~E[{e'}^\ast] } -$$ +%$$ +\qquad +%$$ +\frac{ +}{ + S;~E[\KK{trap}] \evalto S;~\KK{trap} } +$$ + $$ \begin{array}{rcl} @@ -375,6 +407,8 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} (t.\KK{const}~c_1)~(t.\KK{const}~c_2)~t\KK{.}\x{binop} &\evalto& \KK{i32.const}~t.\x{relop}(c_1, c_2) \\ [1ex] +\KK{unreachable} &\evalto& + \KK{trap} \\ \KK{nop} &\evalto& \epsilon \\ v~\KK{drop} &\evalto& @@ -384,13 +418,6 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} v_1~v_2~(\KK{i32.const}~i+1)~\KK{select} &\evalto& v_1 \\ [1ex] -S;~ (\KK{get}~i) &\evalto& - S;~ S_{\f{local}}(i) \\ -S;~ v~(\KK{set}~i) &\evalto& - S,i=v;~ \epsilon \\ -v~(\KK{tee}~i) &\evalto& - v~v~(\KK{set}~i) \\ -[1ex] \void{ \KK{block}~v^\ast~\KK{end} &\evalto& v^\ast \\ @@ -407,19 +434,15 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} e_2^\ast \\ (\KK{i32.const}~i+1)~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} &\evalto& e_1^\ast \\ -\end{array} -$$ -\vspace{2em} -$$ -\begin{array}{rcl} -(\KK{i32.const}~0)~\KK{br\_if}_n~i &\evalto& +[2ex] +(\KK{i32.const}~0)~(\KK{br\_if}_n~i) &\evalto& \epsilon \\ -(\KK{i32.const}~j+1)~\KK{br\_if}_n~i &\evalto& +(\KK{i32.const}~j+1)~(\KK{br\_if}_n~i) &\evalto& \KK{br}_n~i \\ -(\KK{i32.const}~k)~\KK{br\_table}_n~i_1^{k-1}~i~i_2^\ast &\evalto& +(\KK{i32.const}~k)~(\KK{br\_table}_n~i_1^k~i~i_2^\ast) &\evalto& + \KK{br}_n~i \\ +(\KK{i32.const}~k+j)~(\KK{br\_table}_n~i_1^k~i) &\evalto& \KK{br}_n~i \\ -(\KK{i32.const}~k+j)~\KK{br\_table}_n~i^k~i' &\evalto& - \KK{br}_n~i' \\ [1ex] \KK{block}~e^\ast~\KK{end} &\evalto& \KK{label}[]~e^\ast~\KK{end} \\ @@ -431,26 +454,73 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} \KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~0)~e^\ast~\KK{end} &\evalto& v^n~e_0^\ast \\ \KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~i+1)~e^\ast~\KK{end} &\evalto& - v^n~(\KK{br}_n~i) \\ -\KK{label}[e_0^\ast]~v^\ast~v^n~\KK{unreachable}~e^\ast~\KK{end} &\evalto& - \KK{unreachable} \\ + v^n~(\KK{br}_n~i) \\ +%\KK{label}[e_0^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& +% v^n~\KK{return}_n \\ +%\KK{label}[e_0^\ast]~v^\ast~\KK{unreachable}~e^\ast~\KK{end} &\evalto& +% \KK{unreachable} \\ +[1ex] +S;~ v^n~\KK{call}_n~i &\evalto& + S;~ \KK{local}[v^n~S_{\f{func}}(i).{\f{locals}}]~S_{\f{func}}(i).{\f{body}}~\KK{end} \\ +\KK{local}[v_l^\ast]~v^\ast~\KK{end} &\evalto& + v^\ast \\ +%\KK{local}[v_l^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& +% v^n \\ +\KK{local}[v_l^\ast]~L[v^n~\KK{return}_n]~\KK{end} &\evalto& + v^n \\ +%\KK{local}[v_l^\ast]~v^\ast~\KK{unreachable}~e^\ast~\KK{end} &\evalto& +% \KK{unreachable} \\ +[2ex] +\void{ +S;~ (\KK{get}~i) &\evalto& + S;~ S_{\f{local}}(i) \\ +S;~ v~(\KK{set}~i) &\evalto& + S,i=v;~ \epsilon \\ +v~(\KK{tee}~i) &\evalto& + v~v~(\KK{set}~i) \\ +[1ex] +} +\KK{local}[v_1^i~v~v_2^\ast]~L[\KK{get}~i]~\KK{end} &\evalto& + \KK{local}[v_1^i~v~v_2^\ast]~L[v]~\KK{end} \\ +\KK{local}[v_1^i~v~v_2^\ast]~L[v'~(\KK{set}~i)]~\KK{end} &\evalto& + \KK{local}[v_1^i~v'~v_2^\ast]~L[\epsilon]~\KK{end} \\ +v~(\KK{tee}~i) &\evalto& + v~v~(\KK{set}~i) \\ [1ex] \end{array} $$ -\void{ +{ $$ \frac{ - C \vdash e_0^\ast : [t^\ast]/\bot +}{ + C \vdash \KK{trap} : [] \to \poly{t^\ast} +} +%$$ +\qquad +%$$ +\frac{ + C \vdash e_0^\ast : [t^\ast]\orbot \qquad - C \vdash e^\ast : [t^\ast]/\bot + C \vdash e^\ast : [t^\ast]\orbot }{ - C \vdash \KK{label}[e_0^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]/\bot + C \vdash \KK{label}[e_0^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot +} +%$$ +\qquad +%$$ +\frac{ + (\vdash v : t_v)^\ast + \qquad + C,_{\f{local}}t_v^\ast \vdash e^\ast : [t^\ast]\orbot +}{ + C \vdash \KK{local}[v^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot } $$ } \end{document} +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \void{ \subsection*{Evaluating Expressions \hfill $\boxed{[c^\ast]~e \too r}$} From 7353bc6d54df46954874933d23ea8e79b937edf0 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 15 Jul 2016 17:20:19 +0200 Subject: [PATCH 22/44] Convert calls to small-step --- ml-proto/host/arrange.ml | 12 ++-- ml-proto/host/encode.ml | 2 +- ml-proto/spec/ast.ml | 8 ++- ml-proto/spec/check.ml | 32 ++++++--- ml-proto/spec/eval.ml | 145 ++++++++++++++++----------------------- ml-proto/spec/int.ml | 20 +++--- 6 files changed, 105 insertions(+), 114 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 627ab7bad3..d9263b5d65 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -219,9 +219,15 @@ let rec expr e = | Convert op -> Atom (cvtop op) | CurrentMemory -> Atom "current_memory" | GrowMemory -> Atom "grow_memory" - | Label (e, vs, es) -> + + | Trapping msg -> Atom ("trap[\"" ^ String.escaped msg ^ "\"]") + | Label (es_cont, vs, es) -> + let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in + Node ("label[...]", list expr (ves @ es)) + | Local (vs_local, vs, es) -> let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in - Node ("label", list expr (ves @ es)) + Node ("local[" ^ String.concat " " (List.map string_of_value vs_local) ^ + "]", list expr (ves @ es)) (* Functions *) @@ -269,8 +275,6 @@ let export ex = Node ("export", [atom string name; Atom desc]) -(* Modules *) - let module_ m = Node ("module", listi typedef m.it.types @ diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 32f87a05b0..05b17df0c7 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -330,7 +330,7 @@ let encode m = | Convert (F64 F64Op.DemoteF64) -> assert false | Convert (F64 F64Op.ReinterpretInt) -> op 0xb3 - | Label _ -> assert false + | Trapping _ | Label _ | Local _ -> assert false (* Sections *) diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 9aa55b4f03..1024e777da 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -73,7 +73,7 @@ type literal = value Source.phrase type expr = expr' Source.phrase and expr' = - | Unreachable (* trap *) + | Unreachable (* trap unconditionally *) | Nop (* do nothing *) | Drop (* forget a value *) | Select (* branchless conditional *) @@ -102,7 +102,11 @@ and expr' = | Convert of cvtop (* conversion *) | CurrentMemory (* size of linear memory *) | GrowMemory (* grow linear memory *) - | Label of expr * value list * expr list (* control stack *) + + (* Administrative expressions *) + | Trapping of string (* trap *) + | Label of expr list * value list * expr list (* control stack *) + | Local of value list * value list * expr list (* call stack *) (* Functions *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 154341e9e7..3b974df085 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -179,16 +179,6 @@ let rec check_expr (c : context) (e : expr) : op_type = let ts = check_block c' es in [] --> ts - | Label (e0, vs, es) -> - let ts = var () in - let c' = {c with labels = ts :: c.labels} in - let ts1 = check_block c' [e0] in - let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in - let ts2 = check_block c' (ves @ es) in - unify_stack_type ts ts1 e.at; - unify_stack_type ts ts2 e.at; - [] --> ts - | Br (n, x) -> let ts = Lib.List.table n var in unify_stack_type (label c x) (fix ts) e.at; @@ -299,6 +289,28 @@ let rec check_expr (c : context) (e : expr) : op_type = | GrowMemory -> [fix I32Type] --> fix [fix I32Type] + | Trapping msg -> + [] --> var () + + | Label (es0, vs, es) -> + let ts = var () in + let c' = {c with labels = ts :: c.labels} in + let ts1 = check_block c' es0 in + let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in + let ts2 = check_block c' (ves @ es) in + unify_stack_type ts ts1 e.at; + unify_stack_type ts ts2 e.at; + [] --> ts + + | Local (vs0, vs, es) -> + let ts = var () in + (* TODO(stack): remove function label? *) + let c' = {c with locals = List.map Values.type_of vs0; labels = ts :: c.labels} in + let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in + let ts' = check_block c' (ves @ es) in + unify_stack_type ts ts' e.at; + [] --> ts + and check_block (c : context) (es : expr list) : stack_type var = match es with | [] -> diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 34ff40084b..a938f5cf30 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -17,7 +17,7 @@ type instance = { module_ : module_; imports : import list; - exports : func map; + exports : int map; memory : Memory.t option } @@ -28,9 +28,7 @@ module Trap = Error.Make () module Crash = Error.Make () 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" @@ -56,9 +54,12 @@ let numeric_error at = function type config = { instance : instance; - locals : value ref list + locals : value ref list; + resources : int } +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) @@ -114,7 +115,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) : value stack * expr list = match e.it, vs with | Unreachable, vs -> - assert false (* abrupt *) + vs, [Trapping "unreachable executed" @@ e.at] | Nop, vs -> vs, [] @@ -123,10 +124,10 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) vs', [] | Block es, vs -> - vs, [Label (Nop @@ e.at, [], es) @@ e.at] + vs, [Label ([], [], es) @@ e.at] | Loop es, vs -> - vs, [Label (e, [], es) @@ e.at] + vs, [Label ([e], [], es) @@ e.at] | Br (n, x), vs -> assert false (* abrupt *) @@ -165,7 +166,11 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) v1 :: vs', [] | Call (n, x), vs -> - eval_func c.instance vs n (func c.instance x), [] + if c.resources = 0 then Trap.error e.at "call stack exhausted"; + let f = func c.instance x in + let args = List.rev (keep n vs e.at) in + let locals = List.map default_value f.it.locals in + drop n vs e.at, [Local (args @ locals, [], f.it.body) @@ e.at] | CallImport (n, x), vs -> (try @@ -177,7 +182,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) let f = func c.instance (table_elem c.instance i e.at) in if x.it <> f.it.ftype.it then Trap.error e.at "indirect call signature mismatch"; - eval_func c.instance vs n f, [] + vs, [Call (n, table_elem c.instance i e.at) @@ e.at] | GetLocal x, vs -> !(local c x) :: vs, [] @@ -253,96 +258,63 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) Memory.grow mem delta; I32 (Int64.to_int32 old_size) :: vs', [] - | Label (e_cont, vs', []), vs -> + | Trapping msg, vs -> + assert false (* abrupt *) + + | Label (es_cont, vs', []), vs -> vs' @ vs, [] - | Label (e_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> - keep n vs' e.at @ vs, [e_cont] + | Label (es_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> + keep n vs' e.at @ vs, es_cont - | Label (e_cont, vs', {it = Br (n, i); at} :: es), vs -> + | Label (es_cont, vs', {it = Br (n, i); at} :: es), vs -> keep n vs' e.at @ vs, [Br (n, (i.it-1) @@ i.at) @@ e.at] - | Label (e_cont, vs', {it = Return n; at} :: es), vs -> + | Label (es_cont, vs', {it = Return n; at} :: es), vs -> keep n vs' e.at @ vs, [Return n @@ at] - | Label (e_cont, vs', {it = Unreachable; at} :: es), vs -> - [], [Unreachable @@ at] + | Label (es_cont, vs', {it = Trapping msg; at} :: es), vs -> + [], [Trapping msg @@ at] - | Label (e_cont, vs', e :: es), vs -> + | Label (es_cont, vs', e :: es), vs -> let vs'', es' = step_expr c vs' e in - vs, [Label (e_cont, vs'', es' @ es) @@ e.at] - - | _, _ -> - Crash.error e.at "type error: missing or ill-typed operand on stack" - -and eval_func (inst : instance) (vs : value stack) n (f : func) : value stack = - let args = List.map ref (List.rev (keep n vs f.at)) in - let vars = List.map (fun t -> ref (default_value t)) f.it.locals in - let c = {instance = inst; locals = args @ vars} in - eval_body c [] [Label (Nop @@ f.at, [], f.it.body) @@ f.at] @ drop n vs f.at - -and eval_body (c : config) (vs : value stack) (es : expr list) : value stack = - match es with - | [] -> vs - | [{it = Return n}] -> assert (List.length vs = n); vs - | [{it = Unreachable; at}] -> Trap.error at "unreachable executed" - | [{it = Br (n, i); at}] -> Crash.error at "unknown label" - | e :: es -> - let vs', es' = step_expr c vs e in - eval_body c vs' (es' @ es) - -(*TODO: Small-step calls -type expr = ... | Func of value ref list * expr list - - | Call x, vs -> - let f = ... in - let locals = ... in - vs, [Func (locals, [Label (Nop @@ e.at, [], f.it.body)]) @@ e.at] - - | Func (locals, []), vs -> - vs, [] + vs, [Label (es_cont, vs'', es' @ es) @@ e.at] - | Func (locals, [{it = Return n}]), vs -> - assert (List.length vs >= n); - vs, [] - - | Func (locals, [{it = Unreachable} as e]), vs -> - assert (vs = []); - [], [e] - - | Func (locals, [{it = Br (n, i); at} ]), vs -> - Crash.error at "unknown label" + | Local (vs_local, vs', []), vs -> + vs' @ vs, [] - | Func (locals, e :: es), vs -> - assert (es = []); - let vs', es' = step_expr c [] e in - vs' @ vs, [Func (locals, es' @ es) @@ e.at] + | Local (vs_local, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> + (* TODO(stack): remove function label? *) + keep n vs' e.at @ vs, [] -OR + | Local (vs_local, vs', {it = Return n; at} :: es), vs -> + keep n vs' e.at @ vs, [] -type expr = ... | Func of value ref list * value stack * expr list + | Local (vs_local, vs', {it = Trapping msg; at} :: es), vs -> + [], [Trapping msg @@ at] - | Call x, vs -> - let f = ... in - let locals = ... in - vs, [Func (locals, [], f.it.body) @@ e.at] + | Local (vs_local, vs', e :: es), vs -> + let c' = {c with locals = List.map ref vs_local; resources = c.resources - 1} in + let vs'', es' = step_expr c' vs' e in + vs, [Local (List.map (!) c'.locals, vs'', es' @ es) @@ e.at] - | Func (locals, vs', []), vs -> - vs' @ vs, [] + | _, _ -> + Crash.error e.at "type error: missing or ill-typed operand on stack" - | Func (locals, vs', {it = Return n; at} :: es), vs -> - keep n vs' at @ vs, [] - | Func (locals, vs', {it = Unreachable} as e :: es), vs -> - [], [e] +(* Functions *) - | Func (locals, vs', {it = Br (n, i); at} :: es), vs -> - Crash.error at "unknown label" +let eval_func (inst : instance) (vs : value list) (x : var) : value list = + let c = {instance = inst; locals = []; resources = resource_limit} in + let rec loop vs es = + match es with + | [] -> vs + | [{it = Trapping msg; at}] -> Trap.error at msg + | e :: es -> + let vs', es' = step_expr c vs e in + loop vs' (es' @ es) + in List.rev (loop (List.rev vs) [Call (List.length vs, x) @@ x.at]) - | Func (locals, vs', e :: es), vs -> - let vs'', es' = step_expr {c with locals} vs' e in - vs, [Func (locals, vs'', es' @ es) @@ e.at] -*) (* Modules *) @@ -351,10 +323,10 @@ let init_memory {it = {min; segments; _}} = Memory.init mem (List.map it segments); mem -let add_export funcs ex = +let add_export ex = let {name; kind} = ex.it in match kind with - | `Func x -> Map.add name (List.nth funcs x.it) + | `Func x -> Map.add name x.it | `Memory -> fun x -> x let init (m : module_) imports = @@ -364,12 +336,11 @@ let init (m : module_) imports = let inst = {module_ = m; imports; - exports = List.fold_right (add_export funcs) exports Map.empty; + exports = List.fold_right add_export exports Map.empty; memory = Lib.Option.map init_memory memory} in - Lib.Option.app (fun x -> ignore (eval_func inst [] 0 (func inst x))) start; + Lib.Option.app (fun x -> ignore (eval_func inst [] x)) start; inst let invoke (inst : instance) name (vs : value list) : value list = - try List.rev (eval_func inst (List.rev vs) (List.length vs) (export inst (name @@ no_region))) - with Stack_overflow -> Trap.error Source.no_region "call stack exhausted" + eval_func inst vs (export inst (name @@ no_region) @@ no_region) diff --git a/ml-proto/spec/int.ml b/ml-proto/spec/int.ml index 0fd5875734..7dbb596dd4 100644 --- a/ml-proto/spec/int.ml +++ b/ml-proto/spec/int.ml @@ -89,14 +89,14 @@ struct *) let divrem_u n 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 + 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 @@ -105,7 +105,6 @@ struct let to_bits x = x let zero = Rep.zero - let ten = Rep.of_int 10 (* add, sub, and mul are sign-agnostic and do not trap on overflow. *) let add = Rep.add @@ -121,7 +120,7 @@ struct 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 @@ -225,6 +224,7 @@ struct | 'A' .. 'F' as c -> 0xa + Char.code c - Char.code 'A' | _ -> failwith "of_string" + let ten = Rep.of_int 10 let max_upper, max_lower = divrem_u Rep.minus_one ten let of_string s = From dd5dd726ccf33569007ab001e1df71ca226b88d2 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Mon, 18 Jul 2016 15:00:49 +0200 Subject: [PATCH 23/44] New tests for stack machine --- formal/wasm.tex | 30 ++++-- ml-proto/spec/check.ml | 6 +- ml-proto/spec/eval.ml | 6 +- ml-proto/test/nop.wast | 202 +++++++++++++++++++++++++++++++++-- ml-proto/test/typecheck.wast | 139 ++++++++++++++++++++++++ 5 files changed, 360 insertions(+), 23 deletions(-) diff --git a/formal/wasm.tex b/formal/wasm.tex index e60010b55a..89ddd6a6fd 100644 --- a/formal/wasm.tex +++ b/formal/wasm.tex @@ -156,6 +156,7 @@ \subsection*{Syntax} \KK{br\_if}_n~i ~|~ \KK{br\_table}_n~i^+ ~|~ \KK{call}_n~i ~|~ + \KK{call\_indirect}_n~i ~|~ \KK{return}_n \\ \end{array} $$ @@ -312,11 +313,19 @@ \subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orb \frac{ C_{\f{func}}(i) = [t_1^n] \to [t_2^?] }{ - C \vdash \KK{call}_n~i^+ : [t_1^n] \to [t_2^?] + C \vdash \KK{call}_n~i : [t_1^n] \to [t_2^?] } %$$ \qquad %$$ +\frac{ + C_{\f{type}}(i) = [t_1^n] \to [t_2^?] +}{ + C \vdash \KK{call\_indirect}_n~i : [t_1^n~\K{i32}] \to [t_2^?] +} +$$ + +$$ \frac{ C_{\f{return}} = [t^n] }{ @@ -462,6 +471,13 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} [1ex] S;~ v^n~\KK{call}_n~i &\evalto& S;~ \KK{local}[v^n~S_{\f{func}}(i).{\f{locals}}]~S_{\f{func}}(i).{\f{body}}~\KK{end} \\ +S;~ (\KK{i32.const} j)~\KK{call\_indirect}_n~i &\evalto& + S;~ \KK{trap} + \hfill \text{if $S_{\f{func}}(S_{\f{table}}(j)).{\f{type}} \neq S_{\f{type}}(i)$} \\ +S;~ (\KK{i32.const} j)~\KK{call\_indirect}_n~i &\evalto& + S;~ \KK{call}_n~S_{\f{table}}(j) + \hfill \text{otherwise} \\ +[2ex] \KK{local}[v_l^\ast]~v^\ast~\KK{end} &\evalto& v^\ast \\ %\KK{local}[v_l^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& @@ -489,35 +505,33 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} [1ex] \end{array} $$ - -{ +% $$ \frac{ }{ C \vdash \KK{trap} : [] \to \poly{t^\ast} } %$$ -\qquad +\quad %$$ \frac{ C \vdash e_0^\ast : [t^\ast]\orbot - \qquad + \quad C \vdash e^\ast : [t^\ast]\orbot }{ C \vdash \KK{label}[e_0^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot } %$$ -\qquad +\quad %$$ \frac{ (\vdash v : t_v)^\ast - \qquad + \quad C,_{\f{local}}t_v^\ast \vdash e^\ast : [t^\ast]\orbot }{ C \vdash \KK{local}[v^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot } $$ -} \end{document} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 3b974df085..56907ca447 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -200,7 +200,7 @@ let rec check_expr (c : context) (e : expr) : op_type = fix_list c.return --> var () | If (es1, es2) -> - (* TODO(stack): remove if labels + (* TODO(stack): remove `if` labels let ts1 = check_block c es1 in let ts2 = check_block c es2 in unify_stack_type ts1 ts2 e.at; @@ -304,7 +304,7 @@ let rec check_expr (c : context) (e : expr) : op_type = | Local (vs0, vs, es) -> let ts = var () in - (* TODO(stack): remove function label? *) + (* TODO(stack): remove function labels? *) let c' = {c with locals = List.map Values.type_of vs0; labels = ts :: c.labels} in let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in let ts' = check_block c' (ves @ es) in @@ -317,7 +317,7 @@ and check_block (c : context) (es : expr list) : stack_type var = fix [] | _ -> - let es', e = Lib.List.split_last es in + let es', e = Lib.List.split_last es in let vts0 = check_block c es' in let ts2, vts3 = check_expr c e in if not (is_fix vts0) then var () else diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index a938f5cf30..9f06867c04 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -148,13 +148,13 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) assert false (* abrupt *) | If (es1, es2), I32 0l :: vs' -> - (* TODO(stack): remove if labels + (* TODO(stack): remove `if` labels vs', es2 *) vs', [Block es2 @@ e.at] | If (es1, es2), I32 i :: vs' -> - (* TODO(stack): remove if labels + (* TODO(stack): remove `if` labels vs', es1 *) vs', [Block es1 @@ e.at] @@ -284,7 +284,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) vs' @ vs, [] | Local (vs_local, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> - (* TODO(stack): remove function label? *) + (* TODO(stack): remove function labels? *) keep n vs' e.at @ vs, [] | Local (vs_local, vs', {it = Return n; at} :: es), vs -> diff --git a/ml-proto/test/nop.wast b/ml-proto/test/nop.wast index 2951a95e0d..58e0783cce 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 "as-func-first" (result i32) (nop) (i32.const 1) @@ -9,8 +14,32 @@ (func "as-func-mid" (result i32) (call $dummy) (nop) (i32.const 2) ) - (func "as-func-last" - (call $dummy) (nop) + (func "as-func-last" (result i32) + (call $dummy) (i32.const 3) (nop) + ) + (func "as-func-everywhere" (result i32) + (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop) + ) + + (func "as-drop-last" (param i32) + (get_local 0) (nop) drop + ) + (func "as-drop-everywhere" (param i32) + (nop) (nop) (get_local 0) (nop) (nop) drop + ) + + (func "as-select-mid1" (param i32) (result i32) + (get_local 0) (nop) (get_local 0) (get_local 0) select + ) + (func "as-select-mid2" (param i32) (result i32) + (get_local 0) (get_local 0) (nop) (get_local 0) select + ) + (func "as-select-last" (param i32) (result i32) + (get_local 0) (get_local 0) (get_local 0) (nop) select + ) + (func "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 "as-block-first" (result i32) @@ -19,8 +48,11 @@ (func "as-block-mid" (result i32) (block (call $dummy) (nop) (i32.const 2)) ) - (func "as-block-last" - (block (nop) (call $dummy) (nop)) + (func "as-block-last" (result i32) + (block (nop) (call $dummy) (i32.const 3) (nop)) + ) + (func "as-block-everywhere" (result i32) + (block (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop)) ) (func "as-loop-first" (result i32) @@ -29,35 +61,187 @@ (func "as-loop-mid" (result i32) (loop (call $dummy) (nop) (i32.const 2)) ) - (func "as-loop-last" - (loop (call $dummy) (nop)) + (func "as-loop-last" (result i32) + (loop (call $dummy) (i32.const 3) (nop)) + ) + (func "as-loop-everywhere" (result i32) + (loop (nop) (nop) (call $dummy) (nop) (i32.const 4) (nop) (nop)) ) + (func "as-if-condition" (param i32) + (get_local 0) (nop) if (call $dummy) end + ) (func "as-if-then" (param i32) (if (get_local 0) (nop) (call $dummy)) ) (func "as-if-else" (param i32) (if (get_local 0) (call $dummy) (nop)) ) + + (func "as-br-last" (param i32) (result i32) + block (get_local 0) (nop) br 1 0 end + ) + (func "as-br-everywhere" (param i32) (result i32) + block (nop) (nop) (get_local 0) (nop) (nop) br 1 0 end + ) + + (func "as-br_if-mid" (param i32) (result i32) + block (get_local 0) (nop) (get_local 0) br_if 1 0 (i32.const 0) end + ) + (func "as-br_if-last" (param i32) (result i32) + block (get_local 0) (get_local 0) (nop) br_if 1 0 (i32.const 0) end + ) + (func "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) + end + ) + + (func "as-br_table-mid" (param i32) (result i32) + block (get_local 0) (nop) (get_local 0) br_table 1 0 0 end + ) + (func "as-br_table-last" (param i32) (result i32) + block (get_local 0) (get_local 0) (nop) br_table 1 0 0 end + ) + (func "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 + end + ) + + (func "as-return-last" (param i32) (result i32) + (get_local 0) (nop) return 1 + ) + (func "as-return-everywhere" (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) return 1 + ) + + (func "as-call-mid1" (param i32 i32 i32) (result i32) + (get_local 0) (nop) (get_local 1) (get_local 2) call 3 $3-ary + ) + (func "as-call-mid2" (param i32 i32 i32) (result i32) + (get_local 0) (get_local 1) (nop) (get_local 2) call 3 $3-ary + ) + (func "as-call-last" (param i32 i32 i32) (result i32) + (get_local 0) (get_local 1) (get_local 2) (nop) call 3 $3-ary + ) + (func "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 $3-ary + ) + + ;; TODO(stack): call_indirect, *_local, load*, store* + + (func "as-unary-last" (param i32) (result i32) + (get_local 0) (nop) i32.ctz + ) + (func "as-unary-everywhere" (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) i32.ctz + ) + + (func "as-binary-mid" (param i32) (result i32) + (get_local 0) (nop) (get_local 0) i32.add + ) + (func "as-binary-last" (param i32) (result i32) + (get_local 0) (get_local 0) (nop) i32.add + ) + (func "as-binary-everywhere" (param i32) (result i32) + (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) i32.add + ) + + (func "as-test-last" (param i32) (result i32) + (get_local 0) (nop) i32.eqz + ) + (func "as-test-everywhere" (param i32) (result i32) + (nop) (nop) (get_local 0) (nop) (nop) i32.eqz + ) + + (func "as-compare-mid" (param i32) (result i32) + (get_local 0) (nop) (get_local 0) i32.ne + ) + (func "as-compare-last" (param i32) (result i32) + (get_local 0) (get_local 0) (nop) i32.lt_u + ) + (func "as-compare-everywhere" (param i32) (result i32) + (nop) (get_local 0) (nop) (nop) (get_local 0) (nop) (nop) i32.le_s + ) + + (func "as-grow_memory-last" (param i32) (result i32) + (get_local 0) (nop) grow_memory + ) + (func "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/typecheck.wast b/ml-proto/test/typecheck.wast index 8522f754f1..b136ee4ce1 100644 --- a/ml-proto/test/typecheck.wast +++ b/ml-proto/test/typecheck.wast @@ -1,6 +1,145 @@ +;; 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 1 + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-block (result i32) + (i32.const 0) block return 1 end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-loop (result i32) + (i32.const 0) loop return 1 end + )) + "type mismatch" +) +(assert_invalid + (module (func $type-return-operand-missing-in-if (result i32) + (i32.const 0) (i32.const 0) if return 1 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 1 end drop + )) + "type mismatch" +) + +;; TODO(stack): more of the above + ;; if condition (assert_invalid (module (func (if (f32.const 0) (nop) (nop)))) "type mismatch") From 90e7a4721cd688fab01fd90873a157f4dba85e4e Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Mon, 18 Jul 2016 16:48:51 +0200 Subject: [PATCH 24/44] Dead code is dead to the spec --- formal/wasm.tex | 65 +++++++++++++++++++++++++++++++------------------ 1 file changed, 41 insertions(+), 24 deletions(-) diff --git a/formal/wasm.tex b/formal/wasm.tex index 89ddd6a6fd..c598d8d2ed 100644 --- a/formal/wasm.tex +++ b/formal/wasm.tex @@ -124,6 +124,14 @@ \section{Wasm-as-stack} +\newcommand\orbot{/\bot} +\newcommand\poly[1]{\bot} +\newcommand\botrule[1]{#1} + +%\newcommand\orbot{} +%\newcommand\poly[1]{[#1]} +%\newcommand\botrule[1]{} + \subsection*{Syntax} @@ -135,6 +143,12 @@ \subsection*{Syntax} \KK{f32} ~|~ \KK{f64} \\ [1ex] +\void{ +\text{(result)} & t &::=& + [t^\ast] ~|~ + \bot \\ +[1ex] +} \text{(operators)} & e &::=& t\KK{.const}~c ~|~ t\KK{.}\x{unop} ~|~ @@ -161,17 +175,10 @@ \subsection*{Syntax} \end{array} $$ -%\newcommand\orbot{/\bot} -%\newcommand\poly[1]{\bot} -%\newcommand\botrule[1]{#1} - -\newcommand\orbot{} -\newcommand\poly[1]{[#1]} -\newcommand\botrule[1]{} - \subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orbot}$} +\botrule{\vspace{-0.5\baselineskip}} $$ \frac{ }{ @@ -268,14 +275,24 @@ \subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orb } $$ +%\botrule{\vspace{-1ex}} $$ \frac{ - C \vdash e_1^\ast : [t^?]\orbot + C \vdash e_1^\ast : [t^?]\botrule{\orbot_1} \qquad - C \vdash e_2^\ast : [t^?]\orbot -}{ - C \vdash \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} : [\K{i32}] \to [t^?]\orbot -} + C \vdash e_2^\ast : [t^?]\botrule{\orbot_2} +}{ + C \vdash \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} : [\K{i32}] \to [t^?]\botrule{\orbot_1 \vee [t^?]\orbot_2} +}% +\void{\botrule{ +~~~~ +\begin{array}{rc} +[t^\ast]\vee[t^\ast] = [t^\ast] & +[t^\ast]\vee\bot = [t^\ast] \\ +\bot\vee[t^\ast] = [t^\ast] & +\bot\vee\bot = \bot +\end{array} +}} $$ $$ @@ -357,8 +374,8 @@ \subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : [t^\ast]\orbot}$} %$$ \frac{ C \vdash e^\ast : \bot - \qquad - C \vdash e_2 : [t_2^\ast] \to [t_3^?]/\bot + %\qquad + %C \vdash e_2 : [t_2^\ast] \to [t_3^?]/\bot }{ C \vdash e^\ast~e_2 : \bot } @@ -378,11 +395,11 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} \KK{label}[e^\ast]~e^\ast~\KK{end} ~|~ \KK{local}[v^\ast]~e^\ast~\KK{end} \\ \text{(local contexts)} & L &::=& - [] ~|~ + \{\_\} ~|~ v^\ast~L~e^\ast ~|~ \KK{label}[e^\ast]~L~\KK{end} \\ \text{(evaluation contexts)} & E &::=& - [] ~|~ + \{\_\} ~|~ v^\ast~E~e^\ast ~|~ \KK{label}[e^\ast]~E~\KK{end} ~|~ \KK{local}[v^\ast]~E~\KK{end} \\ @@ -393,14 +410,14 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} \frac{ S;~e^\ast \evalto S';~{e'}^\ast }{ - S;~E[e^\ast] \evalto S';~E[{e'}^\ast] + S;~E\{e^\ast\} \evalto S';~E\{{e'}^\ast\} } %$$ \qquad %$$ \frac{ }{ - S;~E[\KK{trap}] \evalto S;~\KK{trap} + S;~E\{\KK{trap}\} \evalto S;~\KK{trap} } $$ @@ -482,7 +499,7 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} v^\ast \\ %\KK{local}[v_l^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& % v^n \\ -\KK{local}[v_l^\ast]~L[v^n~\KK{return}_n]~\KK{end} &\evalto& +\KK{local}[v_l^\ast]~L\{v^n~\KK{return}_n\}~\KK{end} &\evalto& v^n \\ %\KK{local}[v_l^\ast]~v^\ast~\KK{unreachable}~e^\ast~\KK{end} &\evalto& % \KK{unreachable} \\ @@ -496,10 +513,10 @@ \subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} v~v~(\KK{set}~i) \\ [1ex] } -\KK{local}[v_1^i~v~v_2^\ast]~L[\KK{get}~i]~\KK{end} &\evalto& - \KK{local}[v_1^i~v~v_2^\ast]~L[v]~\KK{end} \\ -\KK{local}[v_1^i~v~v_2^\ast]~L[v'~(\KK{set}~i)]~\KK{end} &\evalto& - \KK{local}[v_1^i~v'~v_2^\ast]~L[\epsilon]~\KK{end} \\ +\KK{local}[v_1^i~v~v_2^\ast]~L\{\KK{get}~i\}~\KK{end} &\evalto& + \KK{local}[v_1^i~v~v_2^\ast]~L\{v\}~\KK{end} \\ +\KK{local}[v_1^i~v~v_2^\ast]~L\{v'~(\KK{set}~i)\}~\KK{end} &\evalto& + \KK{local}[v_1^i~v'~v_2^\ast]~L\{\epsilon\}~\KK{end} \\ v~(\KK{tee}~i) &\evalto& v~v~(\KK{set}~i) \\ [1ex] From 8a0490718f4aa993d279a984aa61973b9abce93e Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Thu, 4 Aug 2016 19:26:05 +0200 Subject: [PATCH 25/44] Don't type unreachable operators; simplify typing --- ml-proto/given/lib.mli | 4 +- ml-proto/spec/check.ml | 243 +++++++++++++++++------------------------ ml-proto/spec/types.ml | 5 + 3 files changed, 107 insertions(+), 145 deletions(-) diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 827abb2b85..c0cb6bf16d 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -4,8 +4,8 @@ module List : sig val make : int -> 'a -> 'a list val table : int -> (int -> 'a) -> 'a list - val take : int -> 'a list -> 'a list - val drop : int -> 'a list -> '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 *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 56907ca447..1b19ffa7d2 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -11,48 +11,15 @@ exception Invalid = Invalid.Error let error = Invalid.error let require b at s = if not b then error at s - -(* Type variables *) - -type 'a var' = Fix of 'a | Var | Fwd of 'a var -and 'a var = 'a var' ref - -let var _ = ref Var -let fix x = ref (Fix x) -let fix_list = List.map fix - -let rec is_fix v = - match !v with - | Fix _ -> true - | Var -> false - | Fwd v' -> is_fix v' - -let rec content v = - match !v with - | Fix x -> x - | Var -> assert false - | Fwd v' -> content v' - -let rec unify f v1 v2 = - if v1 != v2 then - match !v1, !v2 with - | Fwd v1', _ -> unify f v1' v2 - | _, Fwd v2' -> unify f v1 v2' - | Var, _ -> v1 := Fwd v2 - | _, Var -> v2 := Fwd v1 - | Fix x1, Fix x2 -> f x1 x2 - -let rec string_of_var string_of name v = - match !v with - | Fix x -> string_of x - | Var -> name - | Fwd v' -> string_of_var string_of name v' +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 stack_type = value_type var list -type op_type = stack_type * stack_type var +type op_type = stack_type * result_type type context = { @@ -61,7 +28,7 @@ type context = imports : func_type list; locals : value_type list; return : value_type list; - labels : stack_type var list; + labels : result_type ref list; has_memory : bool } @@ -76,25 +43,17 @@ let local c x = lookup "local" c.locals x let label c x = lookup "label" c.labels x -(* Type Unification *) - -let string_of_value_type_var = string_of_var string_of_value_type "?" -let string_of_stack_type ts = - "(" ^ String.concat " " (List.map string_of_value_type_var ts) ^ ")" - +(* Join *) -exception Unify +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 unify_value_type vt1 vt2 = - unify (fun t1 t2 -> if t1 <> t2 then raise Unify) vt1 vt2 - -let unify_stack_type vts1 vts2 at = - try unify (List.iter2 unify_value_type) vts1 vts2 - with Unify | Invalid_argument _ -> - error at - ("type mismatch:" ^ - " operator requires " ^ string_of_stack_type (content vts1) ^ - " but stack has " ^ string_of_stack_type (content vts2)) +let unknown () = ref Bot +let known ts = ref (Stack ts) +let unify v ts at = v := join !v (Stack ts) at (* Type Synthesis *) @@ -154,181 +113,178 @@ let type_cvtop at = function * ts : stack_type *) -let (-->) ts1 ts2 = ts1, ts2 +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_expr (c : context) (e : expr) : op_type = +let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = match e.it with | Unreachable -> - [] --> var () + [] --> Bot | Nop -> - [] --> fix [] + [] --> Stack [] | Drop -> - [var ()] --> fix [] + [peek 0 stack] --> Stack [] | Block es -> - let ts = var () in - let c' = {c with labels = ts :: c.labels} in - let ts' = check_block c' es in - unify_stack_type ts ts' e.at; - [] --> ts' + let vr = unknown () in + let c' = {c with labels = vr :: c.labels} in + let r = check_block c' es in + [] --> join !vr r e.at | Loop es -> - let c' = {c with labels = fix [] :: c.labels} in - let ts = check_block c' es in - [] --> ts + let c' = {c with labels = known [] :: c.labels} in + let r = check_block c' es in + [] --> r | Br (n, x) -> - let ts = Lib.List.table n var in - unify_stack_type (label c x) (fix ts) e.at; - ts --> var () + let ts = peek_n n stack in + unify (label c x) ts e.at; + ts --> Bot | BrIf (n, x) -> - let ts = Lib.List.table n var in - unify_stack_type (label c x) (fix ts) e.at; - (ts @ [fix I32Type]) --> fix [] + let ts = List.tl (peek_n (n + 1) stack) in + unify (label c x) ts e.at; + (ts @ [I32Type]) --> Stack [] | BrTable (n, xs, x) -> - let ts = Lib.List.table n var in - unify_stack_type (label c x) (fix ts) e.at; - List.iter (fun x -> unify_stack_type (label c x) (fix ts) e.at) xs; - (ts @ [fix I32Type]) --> var () + 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 n -> check_arity c.return n e.at; - fix_list c.return --> var () + c.return --> Bot | If (es1, es2) -> - (* TODO(stack): remove `if` labels - let ts1 = check_block c es1 in - let ts2 = check_block c es2 in - unify_stack_type ts1 ts2 e.at; - [fix Int32Type] --> ts1 - *) - let ts = var () in - let c' = {c with labels = ts :: c.labels} in - let ts1 = check_block c' es1 in - let ts2 = check_block c' es2 in - unify_stack_type ts ts1 e.at; - unify_stack_type ts ts2 e.at; - [fix I32Type] --> ts + 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 + [I32Type] --> join !vr (join r1 r2 e.at) e.at | Select -> - let t = var () in - [t; t; fix I32Type] --> fix [t] + let t = peek 1 stack in + [t; t; I32Type] --> Stack [t] | Call (n, x) -> let FuncType (ins, out) = func c x in check_arity ins n e.at; - fix_list ins --> fix (fix_list out) + ins --> Stack out | CallImport (n, x) -> let FuncType (ins, out) = import c x in check_arity ins n e.at; - fix_list ins --> fix (fix_list out) + ins --> Stack out | CallIndirect (n, x) -> let FuncType (ins, out) = type_ c.types x in check_arity ins n e.at; - fix_list (ins @ [I32Type]) --> fix (fix_list out) + (ins @ [I32Type]) --> Stack out | GetLocal x -> - [] --> fix [fix (local c x)] + [] --> Stack [local c x] | SetLocal x -> - [fix (local c x)] --> fix [] + [local c x] --> Stack [] | TeeLocal x -> - [fix (local c x)] --> fix [fix (local c x)] + [local c x] --> Stack [local c x] | Load memop -> check_memop c memop e.at; - [fix I32Type] --> fix [fix memop.ty] + [I32Type] --> Stack [memop.ty] | Store memop -> check_memop c memop e.at; - [fix I32Type; fix memop.ty] --> fix [] + [I32Type; memop.ty] --> Stack [] | LoadPacked {memop; sz; _} -> check_memop c memop e.at; check_mem_size memop.ty sz e.at; - [fix I32Type] --> fix [fix memop.ty] + [I32Type] --> Stack [memop.ty] | StorePacked {memop; sz} -> check_memop c memop e.at; check_mem_size memop.ty sz e.at; - [fix I32Type; fix memop.ty] --> fix [] + [I32Type; memop.ty] --> Stack [] | Const v -> - [] --> fix [fix (type_value v.it)] + let t = type_value v.it in + [] --> Stack [t] | Unary unop -> let t = type_unop unop in - [fix t] --> fix [fix t] + [t] --> Stack [t] | Binary binop -> let t = type_binop binop in - [fix t; fix t] --> fix [fix t] + [t; t] --> Stack [t] | Test testop -> let t = type_testop testop in - [fix t] --> fix [fix I32Type] + [t] --> Stack [I32Type] | Compare relop -> let t = type_relop relop in - [fix t; fix t] --> fix [fix I32Type] + [t; t] --> Stack [I32Type] | Convert cvtop -> let t1, t2 = type_cvtop e.at cvtop in - [fix t1] --> fix [fix t2] + [t1] --> Stack [t2] | CurrentMemory -> - [] --> fix [fix I32Type] + [] --> Stack [I32Type] | GrowMemory -> - [fix I32Type] --> fix [fix I32Type] + [I32Type] --> Stack [I32Type] | Trapping msg -> - [] --> var () + [] --> Bot | Label (es0, vs, es) -> - let ts = var () in - let c' = {c with labels = ts :: c.labels} in - let ts1 = check_block c' es0 in + let vr = unknown () in + let c' = {c with labels = vr :: c.labels} in + let r1 = check_block c' es0 in let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in - let ts2 = check_block c' (ves @ es) in - unify_stack_type ts ts1 e.at; - unify_stack_type ts ts2 e.at; - [] --> ts + let r2 = check_block c' (ves @ es) in + [] --> join !vr (join r1 r2 e.at) e.at | Local (vs0, vs, es) -> - let ts = var () in - (* TODO(stack): remove function labels? *) - let c' = {c with locals = List.map Values.type_of vs0; labels = ts :: c.labels} in + let locals = List.map Values.type_of vs0 in + let vr = unknown () in + let c' = {c with locals; labels = vr :: c.labels} in let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in - let ts' = check_block c' (ves @ es) in - unify_stack_type ts ts' e.at; - [] --> ts + let r = check_block c' (ves @ es) in + [] --> join !vr r e.at -and check_block (c : context) (es : expr list) : stack_type var = +and check_block (c : context) (es : expr list) : result_type = match es with | [] -> - fix [] + Stack [] | _ -> let es', e = Lib.List.split_last es in - let vts0 = check_block c es' in - let ts2, vts3 = check_expr c e in - if not (is_fix vts0) then var () else - let ts0 = content vts0 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 - unify_stack_type (fix ts2) (fix ts2') e.at; - if not (is_fix vts3) then var () else - let ts3 = content vts3 in - fix (ts1 @ ts3) + let r1 = check_block c es' in + match r1 with + | Bot -> Bot + | Stack ts0 -> + let ts2, r2 = check_expr 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) and check_arity ts n at = require (List.length ts = n) at @@ -363,9 +319,10 @@ and check_mem_size ty sz at = let check_func c f = let {ftype; locals; body} = f.it in let FuncType (ins, out) = type_ c.types ftype in - let c' = {c with locals = ins @ locals; return = out; labels = [fix (fix_list out)]} in - let ts = check_block c' body in - unify_stack_type (fix (fix_list out)) ts f.at + let vr = known out in + let c' = {c with locals = ins @ locals; return = out; labels = [vr]} in + let r = check_block c' body in + ignore (join !vr r f.at) let check_elem c x = ignore (func c x) diff --git a/ml-proto/spec/types.ml b/ml-proto/spec/types.ml index 36b21c6e22..dd88264f4d 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -2,6 +2,7 @@ type value_type = I32Type | I64Type | F32Type | F64Type type stack_type = value_type list +type result_type = Stack of stack_type | Bot type func_type = FuncType of stack_type * stack_type @@ -27,5 +28,9 @@ let string_of_value_types = function let string_of_stack_type ts = "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" +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 From a0d777c8890f26a9c619cdec0e8a403dbc08a71a Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Fri, 5 Aug 2016 15:15:24 +0200 Subject: [PATCH 26/44] Clean up arity checking --- ml-proto/host/arrange.ml | 15 ++-- ml-proto/host/encode.ml | 12 +-- ml-proto/host/parser.mly | 70 +++++++-------- ml-proto/spec/ast.ml | 64 +++++++------- ml-proto/spec/check.ml | 43 +++++---- ml-proto/spec/decode.ml | 35 ++------ ml-proto/spec/eval.ml | 58 ++++++------ ml-proto/spec/operators.ml | 8 +- ml-proto/test/block.wast | 13 +-- ml-proto/test/br.wast | 13 +++ ml-proto/test/br_if.wast | 15 ++++ ml-proto/test/br_table.wast | 15 ++++ ml-proto/test/call.wast | 34 +++---- ml-proto/test/call_indirect.wast | 40 +++------ ml-proto/test/func.wast | 48 +++++----- ml-proto/test/loop.wast | 13 +++ ml-proto/test/nop.wast | 12 +-- ml-proto/test/return.wast | 14 ++- ml-proto/test/typecheck.wast | 146 ++++++++++++++++++++++++------- 19 files changed, 381 insertions(+), 287 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index d9263b5d65..d4e5315e4c 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -188,8 +188,8 @@ let constop v = value_type (type_of v.it) ^ ".const" let rec expr e = match e.it with - | Nop -> Atom "nop" | Unreachable -> Atom "unreachable" + | Nop -> Atom "nop" | Drop -> Atom "drop" | Block es -> Node ("block", list expr es) | Loop es -> Node ("loop", list expr es) @@ -197,13 +197,13 @@ let rec expr e = | BrIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) | BrTable (n, xs, x) -> Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) - | Return n -> Atom ("return " ^ int n) + | Return -> Atom "return" | If (es1, es2) -> Node ("if", list expr es1 @ [Atom "else"] @ list expr es2) | Select -> Atom "select" - | Call (n, x) -> Atom ("call " ^ int n ^ " " ^ var x) - | CallImport (n, x) -> Atom ("call_import " ^ int n ^ " " ^ var x) - | CallIndirect (n, x) -> Atom ("call_indirect " ^ int n ^ " " ^ var x) + | Call x -> Atom ("call " ^ var x) + | CallImport x -> Atom ("call_import " ^ var x) + | CallIndirect x -> Atom ("call_indirect " ^ var x) | GetLocal x -> Atom ("get_local " ^ var x) | SetLocal x -> Atom ("set_local " ^ var x) | TeeLocal x -> Atom ("tee_local " ^ var x) @@ -224,9 +224,10 @@ let rec expr e = | Label (es_cont, vs, es) -> let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in Node ("label[...]", list expr (ves @ es)) - | Local (vs_local, vs, es) -> + | Local (n, vs_local, vs, es) -> let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in - Node ("local[" ^ String.concat " " (List.map string_of_value vs_local) ^ + Node ("local" ^ string_of_int n ^ "[" ^ + String.concat " " (List.map string_of_value vs_local) ^ "]", list expr (ves @ es)) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 05b17df0c7..d4f4a621d5 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -102,7 +102,7 @@ let encode m = let rec expr e = match e.it with - | Nop -> op 0x00 + | Unreachable -> op 0x00 | Block es -> op 0x01; list expr es; op 0x0f | Loop es -> op 0x02; list expr es; op 0x0f | If (es1, es2) -> @@ -113,8 +113,8 @@ let encode m = | 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 var32 xs; var32 x - | Return n -> op 0x09; vu n - | Unreachable -> op 0x0a + | Return -> op 0x09 + | Nop -> op 0x0a | Drop -> op 0x0b | Const {it = I32 c} -> op 0x10; vs32 c @@ -126,9 +126,9 @@ let encode m = | SetLocal x -> op 0x15; var x | TeeLocal x -> op 0x19; var x - | Call (n, x) -> op 0x16; vu n; var x - | CallIndirect (n, x) -> op 0x17; vu n; var x - | CallImport (n, x) -> op 0x18; vu n; var x + | Call x -> op 0x16; var x + | CallIndirect x -> op 0x17; var x + | CallImport x -> op 0x18; var x | Load ({ty = I32Type; _} as mo) -> op 0x2a; memop mo | Load ({ty = I64Type; _} as mo) -> op 0x2b; memop mo diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 4ea8b3c6c2..d5f9abe5d0 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -181,10 +181,10 @@ func_type : { FuncType ([], []) } | LPAR PARAM value_type_list RPAR { FuncType ($3, []) } - | LPAR PARAM value_type_list RPAR LPAR RESULT VALUE_TYPE RPAR - { FuncType ($3, [$7]) } - | LPAR RESULT VALUE_TYPE RPAR - { FuncType ([], [$3]) } + | LPAR PARAM value_type_list RPAR LPAR RESULT value_type_list RPAR + { FuncType ($3, $7) } + | LPAR RESULT value_type_list RPAR + { FuncType ([], $3) } ; @@ -232,36 +232,35 @@ align : expr : | op { let at = at () in fun c -> [$1 c @@ at] } - | LPAR expr1 RPAR + | LPAR expr1 RPAR /* Sugar */ { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } ; op : - | NOP { fun c -> nop } | UNREACHABLE { fun c -> unreachable } + | NOP { fun c -> nop } | DROP { fun c -> drop } | BLOCK labeling expr_list END - { fun c -> let c' = $2 c in block (snd ($3 c')) } + { fun c -> let c' = $2 c in block ($3 c') } | LOOP labeling expr_list END - { fun c -> let c' = $2 c in loop (snd ($3 c')) } + { fun c -> let c' = $2 c in loop ($3 c') } | LOOP labeling1 labeling1 expr_list END { let at = at () in fun c -> let c' = $2 c in let c'' = $3 c' in - block [loop (snd ($4 c'')) @@ at] } + block [loop ($4 c'') @@ at] } | BR nat var { fun c -> br $2 ($3 c label) } | BR_IF nat var { fun c -> br_if $2 ($3 c label) } | BR_TABLE nat var var_list { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in br_table $2 xs x } - | RETURN nat { fun c -> return $2 } + | RETURN { fun c -> return } | IF labeling expr_list END - { fun c -> let c' = $2 c in if_ (snd ($3 c')) [] } + { fun c -> let c' = $2 c in if_ ($3 c') [] } | IF labeling expr_list ELSE labeling expr_list END - { fun c -> let c1 = $2 c in let c2 = $5 c in - if_ (snd ($3 c1)) (snd ($6 c2)) } + { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) } | SELECT { fun c -> select } - | CALL nat var { fun c -> call $2 ($3 c func) } - | CALL_IMPORT nat var { fun c -> call_import $2 ($3 c import) } - | CALL_INDIRECT nat var { fun c -> call_indirect $2 ($3 c type_) } + | CALL var { fun c -> call ($2 c func) } + | CALL_IMPORT var { fun c -> call_import ($2 c import) } + | 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) } @@ -276,18 +275,18 @@ op : | CURRENT_MEMORY { fun c -> current_memory } | GROW_MEMORY { fun c -> grow_memory } ; -expr1 : - | NOP { fun c -> [], nop } +expr1 : /* Sugar */ | UNREACHABLE { fun c -> [], unreachable } + | NOP { fun c -> [], nop } | DROP expr { fun c -> $2 c, drop } | BLOCK labeling expr_list - { fun c -> let c' = $2 c in [], block (snd ($3 c')) } + { fun c -> let c' = $2 c in [], block ($3 c') } | LOOP labeling expr_list - { fun c -> let c' = $2 c in [], loop (snd ($3 c')) } + { fun c -> let c' = $2 c in [], loop ($3 c') } | LOOP labeling1 labeling1 expr_list { let at = at () in fun c -> let c' = $2 c in let c'' = $3 c' in - [], block [loop (snd ($4 c'')) @@ at] } + [], block [loop ($4 c'') @@ at] } | BR var { fun c -> [], br 0 ($2 c label) } | BR var expr { fun c -> $3 c, br 1 ($2 c label) } | BR_IF var expr { fun c -> $3 c, br_if 0 ($2 c label) } @@ -298,25 +297,21 @@ expr1 : | BR_TABLE var var_list expr expr { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in $4 c @ $5 c, br_table 1 xs x } - | RETURN { fun c -> [], return 0 } - | RETURN expr { fun c -> $2 c, return 1 } + | RETURN expr_list { fun c -> $2 c, return } | 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 $2 c, if_ ($3 c') ($4 c') } | IF expr LPAR THEN labeling expr_list RPAR - { fun c -> let c' = $5 c in $2 c, if_ (snd ($6 c')) [] } + { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] } | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR - { fun c -> let c1 = $5 c in let c2 = $10 c in - $2 c, if_ (snd ($6 c1)) (snd ($11 c2)) } + { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) } | IF expr_list ELSE expr_list - { fun c -> let c' = anon_label c in [], if_ (snd ($2 c')) (snd ($4 c')) } + { fun c -> let c' = anon_label c in [], if_ ($2 c') ($4 c') } | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, select } - | CALL var expr_list { fun c -> let n, es = $3 c in es, call n ($2 c func) } - | CALL_IMPORT var expr_list - { fun c -> let n, es = $3 c in es, call_import n ($2 c import) } + | CALL var expr_list { fun c -> $3 c, call ($2 c func) } + | CALL_IMPORT var expr_list { fun c -> $3 c, call_import ($2 c import) } | CALL_INDIRECT var expr expr_list - { fun c -> - let e = $3 c and n, es = $4 c in e @ es, call_indirect n ($2 c type_) } + { fun c -> $3 c @ $4 c, call_indirect ($2 c type_) } | GET_LOCAL var { fun c -> [], get_local ($2 c local) } | SET_LOCAL var expr { fun c -> $3 c, set_local ($2 c local) } | TEE_LOCAL var expr { fun c -> $3 c, tee_local ($2 c local) } @@ -332,8 +327,8 @@ expr1 : | GROW_MEMORY expr { fun c -> $2 c, grow_memory } ; expr_list : - | /* empty */ { fun c -> 0, [] } - | expr expr_list { fun c -> let e = $1 c and n, es = $2 c in n + 1, e @ es } + | /* empty */ { fun c -> [] } + | expr expr_list { fun c -> $1 c @ $2 c } ; @@ -341,10 +336,9 @@ expr_list : func_fields : | func_body { $1 } - | LPAR RESULT VALUE_TYPE RPAR func_body + | LPAR RESULT value_type_list RPAR func_body { let FuncType (ins, out) = fst $5 in - if out <> [] then error (at ()) "multiple return types"; - FuncType (ins, [$3]), fun c -> (snd $5) c } + FuncType (ins, $3 @ out), fun c -> snd $5 c } | LPAR PARAM value_type_list RPAR func_fields { let FuncType (ins, out) = fst $5 in FuncType ($3 @ ins, out), fun c -> anon_locals c $3; (snd $5) c } @@ -356,7 +350,7 @@ func_body : | expr_list { empty_type, fun c -> let c' = anon_label c in - {ftype = -1 @@ at(); locals = []; body = snd ($1 c')} } + {ftype = -1 @@ 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 diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 1024e777da..adabd1e264 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -73,40 +73,40 @@ type literal = value Source.phrase type expr = expr' Source.phrase and expr' = - | Unreachable (* trap unconditionally *) - | Nop (* do nothing *) - | Drop (* forget a value *) - | Select (* branchless conditional *) - | Block of expr list (* execute in sequence *) - | Loop of expr 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 of int (* break from function body *) - | If of expr list * expr list (* conditional *) - | Call of int * var (* call function *) - | CallImport of int * var (* call imported function *) - | CallIndirect of int * 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 *) - | Load of memop (* read memory at address *) - | Store of memop (* write memory at address *) - | LoadPacked of extop (* read memory at address and extend *) - | StorePacked of wrapop (* wrap and write to 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 *) + | Unreachable (* trap unconditionally *) + | Nop (* do nothing *) + | Drop (* forget a value *) + | Select (* branchless conditional *) + | Block of expr list (* execute in sequence *) + | Loop of expr 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 expr list * expr list (* conditional *) + | Call of var (* call function *) + | CallImport of var (* call imported 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 *) + | Load of memop (* read memory at address *) + | Store of memop (* write memory at address *) + | LoadPacked of extop (* read memory at address and extend *) + | StorePacked of wrapop (* wrap and write to 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 *) (* Administrative expressions *) - | Trapping of string (* trap *) - | Label of expr list * value list * expr list (* control stack *) - | Local of value list * value list * expr list (* call stack *) + | Trapping of string (* trap *) + | Label of expr list * value list * expr list (* control stack *) + | Local of int * value list * value list * expr list (* call stack *) (* Functions *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 1b19ffa7d2..b0425baad3 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -137,31 +137,35 @@ let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = 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 n -> - check_arity c.return n e.at; + | Return -> c.return --> Bot | If (es1, es2) -> @@ -169,25 +173,24 @@ let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = let c' = {c with labels = vr :: c.labels} in let r1 = check_block c' es1 in let r2 = check_block c' es2 in - [I32Type] --> join !vr (join r1 r2 e.at) e.at + 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 (n, x) -> + | Call x -> let FuncType (ins, out) = func c x in - check_arity ins n e.at; ins --> Stack out - | CallImport (n, x) -> + | CallImport x -> let FuncType (ins, out) = import c x in - check_arity ins n e.at; ins --> Stack out - | CallIndirect (n, x) -> + | CallIndirect x -> let FuncType (ins, out) = type_ c.types x in - check_arity ins n e.at; (ins @ [I32Type]) --> Stack out | GetLocal x -> @@ -258,13 +261,16 @@ let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = let r2 = check_block c' (ves @ es) in [] --> join !vr (join r1 r2 e.at) e.at - | Local (vs0, vs, es) -> + | Local (n, vs0, vs, es) -> let locals = List.map Values.type_of vs0 in let vr = unknown () in let c' = {c with locals; labels = vr :: c.labels} in let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in let r = check_block c' (ves @ es) in - [] --> join !vr r e.at + match join !vr r e.at with + | Stack ts when List.length ts <> n -> + error e.at "arity mismatch for local result" + | r' -> [] --> r' and check_block (c : context) (es : expr list) : result_type = match es with @@ -286,12 +292,6 @@ and check_block (c : context) (es : expr list) : result_type = | Bot -> Bot | Stack ts3 -> Stack (ts1 @ ts3) -and check_arity ts n at = - require (List.length ts = n) at - ("arity mismatch:" ^ - " function requires " ^ string_of_int (List.length ts) ^ - " but operator has " ^ string_of_int n) - and check_memop c memop at = require c.has_memory at "memory operator require a memory section"; require (memop.offset >= 0L) at "negative offset"; @@ -301,6 +301,14 @@ and check_memop c memop at = and check_mem_size ty sz at = require (ty = I64Type || sz <> Memory.Mem32) at "memory size too big" +and check_arity n at = + require (n <= 1) at "invalid result arity, larger than 1 is not (yet) allowed" + +and check_result_arity r at = + match r with + | Stack ts -> check_arity (List.length ts) at + | Bot -> () + (* * check_func : context -> func -> unit @@ -319,6 +327,7 @@ and check_mem_size ty sz at = let check_func c f = let {ftype; locals; body} = f.it in let FuncType (ins, out) = type_ c.types ftype in + check_arity (List.length out) f.at; let vr = known out in let c' = {c with locals = ins @ locals; return = out; labels = [vr]} in let r = check_block c' body in diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 22e589c641..0c5f90291a 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -163,7 +163,7 @@ let args1 b stack s pos = let rec expr s = let pos = pos s in match op s with - | 0x00 -> nop + | 0x00 -> unreachable | 0x01 -> let es' = expr_block s in expect 0x0f s "END opcode expected"; @@ -198,10 +198,8 @@ let rec expr s = let xs = vec (at var) s in let x = at var s in br_table n xs x - | 0x09 -> - let n = arity s in - return n - | 0x0a -> unreachable + | 0x09 -> return + | 0x0a -> nop | 0x0b -> drop | 0x0c | 0x0d | 0x0e as b -> illegal s pos b | 0x0f -> error s pos "misplaced END opcode" @@ -211,29 +209,14 @@ let rec expr s = | 0x12 -> f32_const (at f32 s) | 0x13 -> f64_const (at f64 s) - | 0x14 -> - let x = at var s in - get_local x - | 0x15 -> - let x = at var s in - set_local x + | 0x14 -> get_local (at var s) + | 0x15 -> set_local (at var s) - | 0x16 -> - let n = arity s in - let x = at var s in - call n x - | 0x17 -> - let n = arity s in - let x = at var s in - call_indirect n x - | 0x18 -> - let n = arity s in - let x = at var s in - call_import n x + | 0x16 -> call (at var s) + | 0x17 -> call_indirect (at var s) + | 0x18 -> call_import (at var s) - | 0x19 -> - let x = at var s in - tee_local x + | 0x19 -> tee_local (at var s) | 0x1a | 0x1b | 0x1c | 0x1d | 0x1e | 0x1f as b -> illegal s pos b diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 9f06867c04..40a3f3d549 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -16,7 +16,7 @@ type 'a map = 'a Map.t type instance = { module_ : module_; - imports : import list; + imports : (int * import) list; exports : int map; memory : Memory.t option } @@ -55,7 +55,7 @@ type config = { instance : instance; locals : value ref list; - resources : int + resources : int; } let resource_limit = 1000 @@ -144,19 +144,13 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | BrTable (n, xs, x), I32 i :: vs' -> vs', [Br (n, List.nth xs (Int32.to_int i)) @@ e.at] - | Return n, vs -> + | Return, vs -> assert false (* abrupt *) | If (es1, es2), I32 0l :: vs' -> - (* TODO(stack): remove `if` labels - vs', es2 - *) vs', [Block es2 @@ e.at] | If (es1, es2), I32 i :: vs' -> - (* TODO(stack): remove `if` labels - vs', es1 - *) vs', [Block es1 @@ e.at] | Select, I32 0l :: v2 :: v1 :: vs' -> @@ -165,24 +159,30 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Select, I32 i :: v2 :: v1 :: vs' -> v1 :: vs', [] - | Call (n, x), vs -> + | Call x, vs -> if c.resources = 0 then Trap.error e.at "call stack exhausted"; let f = func c.instance x in + let FuncType (ins, out) = type_ c.instance f.it.ftype in + let n = List.length ins in + let m = List.length out in let args = List.rev (keep n vs e.at) in let locals = List.map default_value f.it.locals in - drop n vs e.at, [Local (args @ locals, [], f.it.body) @@ e.at] + drop n vs e.at, [Local (m, args @ locals, [], f.it.body) @@ e.at] - | CallImport (n, x), vs -> + | CallImport x, vs -> + let x, f = import c.instance x in + let FuncType (ins, out) = type_ c.instance (x @@ e.at) in + let n = List.length ins in (try - let vs' = List.rev (import c.instance x (List.rev (keep n vs e.at))) in + let vs' = List.rev (f (List.rev (keep n vs e.at))) in drop n vs e.at @ vs', [] with Crash (_, msg) -> Crash.error e.at msg) - | CallIndirect (n, x), I32 i :: vs -> + | CallIndirect x, I32 i :: vs -> let f = func c.instance (table_elem c.instance i e.at) in if x.it <> f.it.ftype.it then Trap.error e.at "indirect call signature mismatch"; - vs, [Call (n, table_elem c.instance i e.at) @@ e.at] + vs, [Call (table_elem c.instance i e.at) @@ e.at] | GetLocal x, vs -> !(local c x) :: vs, [] @@ -268,10 +268,10 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) keep n vs' e.at @ vs, es_cont | Label (es_cont, vs', {it = Br (n, i); at} :: es), vs -> - keep n vs' e.at @ vs, [Br (n, (i.it-1) @@ i.at) @@ e.at] + vs', [Br (n, (i.it - 1) @@ i.at) @@ e.at] - | Label (es_cont, vs', {it = Return n; at} :: es), vs -> - keep n vs' e.at @ vs, [Return n @@ at] + | Label (es_cont, vs', {it = Return; at} :: es), vs -> + vs', [Return @@ at] | Label (es_cont, vs', {it = Trapping msg; at} :: es), vs -> [], [Trapping msg @@ at] @@ -280,23 +280,23 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) let vs'', es' = step_expr c vs' e in vs, [Label (es_cont, vs'', es' @ es) @@ e.at] - | Local (vs_local, vs', []), vs -> + | Local (n, vs_local, vs', []), vs -> vs' @ vs, [] - | Local (vs_local, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> - (* TODO(stack): remove function labels? *) - keep n vs' e.at @ vs, [] + | Local (n, vs_local, vs', {it = Br (n', i); at} :: es), vs when i.it = 0 -> + if n <> n' then Crash.error at "inconsistent result arity"; + keep n vs' at @ vs, [] - | Local (vs_local, vs', {it = Return n; at} :: es), vs -> - keep n vs' e.at @ vs, [] + | Local (n, vs_local, vs', {it = Return; at} :: es), vs -> + keep n vs' at @ vs, [] - | Local (vs_local, vs', {it = Trapping msg; at} :: es), vs -> + | Local (n, vs_local, vs', {it = Trapping msg; at} :: es), vs -> [], [Trapping msg @@ at] - | Local (vs_local, vs', e :: es), vs -> + | Local (n, vs_local, vs', e :: es), vs -> let c' = {c with locals = List.map ref vs_local; resources = c.resources - 1} in let vs'', es' = step_expr c' vs' e in - vs, [Local (List.map (!) c'.locals, vs'', es' @ es) @@ e.at] + vs, [Local (n, List.map (!) c'.locals, vs'', es' @ es) @@ e.at] | _, _ -> Crash.error e.at "type error: missing or ill-typed operand on stack" @@ -313,7 +313,7 @@ let eval_func (inst : instance) (vs : value list) (x : var) : value list = | e :: es -> let vs', es' = step_expr c vs e in loop vs' (es' @ es) - in List.rev (loop (List.rev vs) [Call (List.length vs, x) @@ x.at]) + in List.rev (loop (List.rev vs) [Call x @@ x.at]) (* Modules *) @@ -335,7 +335,7 @@ let init (m : module_) imports = let {memory; funcs; exports; start; _} = m.it in let inst = {module_ = m; - imports; + imports = List.combine (List.map (fun imp -> imp.it.itype.it) m.it.imports) imports; exports = List.fold_right add_export exports Map.empty; memory = Lib.Option.map init_memory memory} in diff --git a/ml-proto/spec/operators.ml b/ml-proto/spec/operators.ml index 3c35ce003d..a8227c9fc1 100644 --- a/ml-proto/spec/operators.ml +++ b/ml-proto/spec/operators.ml @@ -18,13 +18,13 @@ 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 n = Return n +let return = Return let if_ es1 es2 = If (es1, es2) let select = Select -let call n x = Call (n, x) -let call_import n x = CallImport (n, x) -let call_indirect n x = CallIndirect (n, x) +let call x = Call x +let call_import x = CallImport x +let call_indirect x = CallIndirect x let get_local x = GetLocal x let set_local x = SetLocal x diff --git a/ml-proto/test/block.wast b/ml-proto/test/block.wast index 92fec35055..6da741d2ed 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 @@ -322,3 +322,4 @@ )) "type mismatch" ) + diff --git a/ml-proto/test/br.wast b/ml-proto/test/br.wast index 06d2c72985..272fe546d8 100644 --- a/ml-proto/test/br.wast +++ b/ml-proto/test/br.wast @@ -407,6 +407,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" diff --git a/ml-proto/test/br_if.wast b/ml-proto/test/br_if.wast index f870cdc696..957cec4a4b 100644 --- a/ml-proto/test/br_if.wast +++ b/ml-proto/test/br_if.wast @@ -295,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" diff --git a/ml-proto/test/br_table.wast b/ml-proto/test/br_table.wast index 434236fb46..e1e846bbe0 100644 --- a/ml-proto/test/br_table.wast +++ b/ml-proto/test/br_table.wast @@ -1349,6 +1349,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))) diff --git a/ml-proto/test/call.wast b/ml-proto/test/call.wast index b903a8d056..056412bca0 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 diff --git a/ml-proto/test/call_indirect.wast b/ml-proto/test/call_indirect.wast index e6523da08e..43a2ba2fe1 100644 --- a/ml-proto/test/call_indirect.wast +++ b/ml-proto/test/call_indirect.wast @@ -220,21 +220,21 @@ (type (func (param i32))) (func $arity-0-vs-1 (call_indirect 0 (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (type (func (param f64 i32))) (func $arity-0-vs-2 (call_indirect 0 (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module (type (func)) (func $arity-1-vs-0 (call_indirect 0 (i32.const 1) (i32.const 0))) ) - "arity mismatch" + "type mismatch" ) (assert_invalid (module @@ -243,35 +243,21 @@ (call_indirect 0 (f64.const 2) (i32.const 1) (i32.const 0)) ) ) - "arity mismatch" + "type mismatch" ) -(assert_invalid - (module - (type (func (param i32 i32))) - (func $arity-nop-first - (call_indirect 0 (nop) (i32.const 1) (i32.const 2) (i32.const 0)) - ) +;; TODO(stack): move these elsewhere +(module + (type (func (param i32 i32))) + (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))) - (func $arity-nop-mid - (call_indirect 0 (i32.const 1) (nop) (i32.const 2) (i32.const 0)) - ) + (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))) - (func $arity-nop-last - (call_indirect 0 (i32.const 1) (i32.const 2) (nop) (i32.const 0)) - ) + (func $arity-nop-last + (call_indirect 0 (i32.const 1) (i32.const 2) (nop) (i32.const 0)) ) - "arity mismatch" ) (assert_invalid diff --git a/ml-proto/test/func.wast b/ml-proto/test/func.wast index 58e262f40e..9ee34dd995 100644 --- a/ml-proto/test/func.wast +++ b/ml-proto/test/func.wast @@ -13,6 +13,7 @@ (func "g" $h) (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)) @@ -281,6 +283,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" @@ -344,23 +359,15 @@ ) ;) -(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) @@ -374,23 +381,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) diff --git a/ml-proto/test/loop.wast b/ml-proto/test/loop.wast index 6912f821f0..df7da5bfe7 100644 --- a/ml-proto/test/loop.wast +++ b/ml-proto/test/loop.wast @@ -224,6 +224,19 @@ "type mismatch" ) +(assert_invalid + (module (func $type-binary (result i64) + (loop (i64.const 1) (i64.const 2)) i64.add + )) + "invalid result arity" +) +(assert_invalid + (module (func $type-binary-with-nop (result i32) + (loop (nop) (i32.const 7) (nop) (i32.const 8)) i32.add + )) + "invalid result arity" +) + (assert_invalid (module (func $type-value-void-vs-num (result i32) (loop (nop)) diff --git a/ml-proto/test/nop.wast b/ml-proto/test/nop.wast index 58e0783cce..bde3b7d63b 100644 --- a/ml-proto/test/nop.wast +++ b/ml-proto/test/nop.wast @@ -112,24 +112,24 @@ ) (func "as-return-last" (param i32) (result i32) - (get_local 0) (nop) return 1 + (get_local 0) (nop) return ) (func "as-return-everywhere" (param i32) (result i32) - (nop) (nop) (get_local 0) (nop) (nop) return 1 + (nop) (nop) (get_local 0) (nop) (nop) return ) (func "as-call-mid1" (param i32 i32 i32) (result i32) - (get_local 0) (nop) (get_local 1) (get_local 2) call 3 $3-ary + (get_local 0) (nop) (get_local 1) (get_local 2) call $3-ary ) (func "as-call-mid2" (param i32 i32 i32) (result i32) - (get_local 0) (get_local 1) (nop) (get_local 2) call 3 $3-ary + (get_local 0) (get_local 1) (nop) (get_local 2) call $3-ary ) (func "as-call-last" (param i32 i32 i32) (result i32) - (get_local 0) (get_local 1) (get_local 2) (nop) call 3 $3-ary + (get_local 0) (get_local 1) (get_local 2) (nop) call $3-ary ) (func "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 $3-ary + (nop) (nop) (get_local 2) (nop) (nop) call $3-ary ) ;; TODO(stack): call_indirect, *_local, load*, store* diff --git a/ml-proto/test/return.wast b/ml-proto/test/return.wast index daa093e4b4..351b6ad7f3 100644 --- a/ml-proto/test/return.wast +++ b/ml-proto/test/return.wast @@ -273,17 +273,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/typecheck.wast b/ml-proto/test/typecheck.wast index b136ee4ce1..ec665e7ddf 100644 --- a/ml-proto/test/typecheck.wast +++ b/ml-proto/test/typecheck.wast @@ -4,136 +4,222 @@ (module) (assert_invalid - (module (func $type-unary-operand-missing i32.eqz drop)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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)) + (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 1 + return )) "type mismatch" ) (assert_invalid (module (func $type-return-operand-missing-in-block (result i32) - (i32.const 0) block return 1 end + (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 1 end + (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 1 end + (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 1 end drop + (i32.const 0) (i32.const 0) + if (i32.const 0) else return end drop )) "type mismatch" ) From d7f4d02e0bcd90b12336cb78cd5f3a19bf0b31d2 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Tue, 23 Aug 2016 19:22:20 +0200 Subject: [PATCH 27/44] Tweak S-expr grammar --- formal/wasm.tex | 922 ---------------------------------- ml-proto/host/arrange.ml | 2 +- ml-proto/host/parser.mly | 126 +++-- ml-proto/host/parser.mly.orig | 510 ------------------- ml-proto/host/parser.mly.save | 510 ------------------- ml-proto/winmake.bat | 110 ++-- 6 files changed, 114 insertions(+), 2066 deletions(-) delete mode 100644 formal/wasm.tex delete mode 100644 ml-proto/host/parser.mly.orig delete mode 100644 ml-proto/host/parser.mly.save diff --git a/formal/wasm.tex b/formal/wasm.tex deleted file mode 100644 index c598d8d2ed..0000000000 --- a/formal/wasm.tex +++ /dev/null @@ -1,922 +0,0 @@ -\documentclass[a4paper]{scrartcl} - -\usepackage{amsmath} -\usepackage{amssymb} -\usepackage{xspace} -\usepackage{color} - -\newcommand\void[1]{} - - -% Calculus notation - -\newcommand\x[1]{\ensuremath{\mathit{#1}}\xspace} -\newcommand\f[1]{\ensuremath{\mathop{\mathrm{#1\null}}\nolimits}\xspace} -\newcommand\ff[1]{\ensuremath{\mathbin{\mathrm{#1\null}}}\xspace} -\newcommand\y[1]{\ensuremath{{}\hspace{-0.25em}\mathrel{\mathsf{#1\null}}}\xspace} -\newcommand\yy[1]{\ensuremath{\mathrel{\mathsf{#1\null}}}\xspace} - -\renewcommand\vec[1]{\overline{#1}} -\newcommand\tup[1]{\langle#1\rangle} - -\newcommand\append{\mathbin{{+\!\!+}}} -\newcommand\wild{\mathbin{{\_\!\_}}} - -\newcommand\too{\Rightarrow} -\newcommand\evalto{\hookrightarrow} -\newcommand\elabto{\rightsquigarrow} -\newcommand\elabtox[1]{\stackrel{#1}\rightsquigarrow} -\newcommand{\yields}{\uparrow} -\newcommand{\antype}{:_\Leftarrow} -\newcommand{\syntype}{:_\Rightarrow} -\newcommand{\ansub}{\leq_\Leftarrow} -\newcommand{\synsub}{\leq_\Rightarrow} - -\newcommand\LET{\y{let}} -\newcommand\PACK{\y{pack}} -\newcommand\UNPACK{\y{unpack}} -\newcommand\WRAP{\y{wrap}} -\newcommand\UNWRAP{\y{unwrap}} -\newcommand\NEW{\y{new}} -\newcommand\IN{\yy{in}} -\newcommand\AS{\yy{as}} -\newcommand\CAST{\y{cast}} -\newcommand\NAM{{\y{nam}}} -\newcommand\BOOL{{\y{bool}}} -\newcommand\TRUE{{\y{true}}} -\newcommand\FALSE{{\y{false}}} -\newcommand\IF{\y{if}} -\newcommand\THEN{\yy{then}} -\newcommand\ELSE{\yy{else}} -\newcommand\CASE{\y{case}} -\newcommand\OF{\yy{of}} - -\newcommand{\VAL}{\K{val}} -\newcommand{\TYP}{\K{typ}} -\newcommand{\SIG}{\K{sig}} - -\newcommand\Dom{\ff{dom}} -\newcommand\Rng{\ff{rng}} -\newcommand\FTV{\ff{fv}} -\newcommand\Norm{\ff{norm}} - -\newcommand\conty{\chi} -\newcommand\pathty{\pi} -\newcommand\smallty{\sigma} -\newcommand\bigty{\Sigma} -\newcommand\polyty{\Phi} -\newcommand\absty{\Xi} - -\newcommand\emptysubst{\f{id}} - -\newcommand\Rho{{\f{R}}} -\newcommand\pure{{\f{P}}} -\newcommand\impure{{\f{I}}} - -\newcommand\deter{\epsilon} -\newcommand\anal{{\f{an}}} -\newcommand\synth{{\f{syn}}} -\newcommand\inst{{\f{ins}}} - - -% Code notation - -\newcommand\K[1]{\ensuremath{\textsf{#1}}} -%\newcommand\K[1]{\ensuremath{\texttt{#1}}} -\newcommand\KK[1]{\ensuremath{\K{\textbf{#1}}}} - -\newcommand\Kback{\ensuremath{\backslash\!}} -\newcommand\Kto{\ensuremath{\rightarrow}\xspace} -\newcommand\Ktoo{\ensuremath{\Rightarrow}\xspace} -\newcommand\Kfrom{\ensuremath{\leftarrow}\xspace} -\newcommand\Kfroom{\ensuremath{\Leftarrow}\xspace} -\newcommand\Ktimes{\ensuremath{\times}\xspace} -\newcommand\Kappend{\ensuremath{\append}\xspace} -\newcommand\Kwild{\ensuremath{\wild}\xspace} -\newcommand\Kbar{\ensuremath{|}\xspace} -\newcommand\Kneq{\ensuremath{\neq}\xspace} -\newcommand\Kleq{\ensuremath{\leq}\xspace} -\newcommand\Klt{\ensuremath{<}\xspace} -\newcommand\Kgt{\ensuremath{>}\xspace} -\newcommand\Kseal{\ensuremath{:>}\xspace} -\newcommand\Kdot{\ensuremath{\cdot}\xspace} -\newcommand\Kcirc{\ensuremath{\circ}\xspace} -\newcommand\Kalpha{\ensuremath{\alpha}} -\newcommand\Kbeta{\ensuremath{\beta}} -\newcommand\Kgamma{\ensuremath{\gamma}} -\newcommand\Klangle{\ensuremath{\langle}} -\newcommand\Krangle{\ensuremath{\rangle}} -\newcommand\Ksb[1]{\ensuremath{_{#1}}} - -\DeclareTextCommand{\_}{OT1}{\leavevmode \kern.06em\vbox{\hrule width.6em}} - - -% Coloring - -%\definecolor{hilite}{rgb}{0,0,0.9} -\definecolor{hilite}{rgb}{0.7,0,0} -\newcommand{\hilite}[1]{\color{hilite}#1\color{black}} - - -\begin{document} - -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Wasm-as-stack} - -\newcommand\orbot{/\bot} -\newcommand\poly[1]{\bot} -\newcommand\botrule[1]{#1} - -%\newcommand\orbot{} -%\newcommand\poly[1]{[#1]} -%\newcommand\botrule[1]{} - - -\subsection*{Syntax} - -$$ -\begin{array}{@{}llcl@{}} -\text{(types)} & t &::=& - \KK{i32} ~|~ - \KK{i64} ~|~ - \KK{f32} ~|~ - \KK{f64} \\ -[1ex] -\void{ -\text{(result)} & t &::=& - [t^\ast] ~|~ - \bot \\ -[1ex] -} -\text{(operators)} & e &::=& - t\KK{.const}~c ~|~ - t\KK{.}\x{unop} ~|~ - t\KK{.}\x{binop} ~|~ - t\KK{.}\x{testop} ~|~ - t\KK{.}\x{relop} ~|~ - \dots ~|~ \\&&& - \KK{unreachable} ~|~ - \KK{nop} ~|~ - \KK{drop} ~|~ - \KK{select} ~|~ - \KK{get}~i ~|~ - \KK{set}~i ~|~ - \KK{tee}~i ~|~ \\&&& - \KK{block}~e^\ast~\KK{end} ~|~ - \KK{loop}~e^\ast~\KK{end} ~|~ - \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} ~|~ \\&&& - \KK{br}_n~i ~|~ - \KK{br\_if}_n~i ~|~ - \KK{br\_table}_n~i^+ ~|~ - \KK{call}_n~i ~|~ - \KK{call\_indirect}_n~i ~|~ - \KK{return}_n \\ -\end{array} -$$ - - -\subsection*{Typing Operators \hfill $\boxed{C \vdash e : [t^\ast] \to [t^?]\orbot}$} - -\botrule{\vspace{-0.5\baselineskip}} -$$ -\frac{ -}{ - C \vdash t\KK{.const}~c : [] \to [t] -} -$$ - -$$ -\frac{ -}{ - C \vdash t\KK{.}\x{unop} : [t] \to [t] -} -%$$ -\qquad -%$$ -\frac{ -}{ - C \vdash t\KK{.}\x{binop} : [t~t] \to [t] -} -$$ - -$$ -\frac{ -}{ - C \vdash t\KK{.}\x{testop} : [t] \to [\K{i32}] -} -%$$ -\qquad -%$$ -\frac{ -}{ - C \vdash t\KK{.}\x{relop} : [t~t] \to [\K{i32}] -} -$$ - -$$ -\frac{ -}{ - C \vdash \KK{nop} : [] \to [] -} -%$$ -\qquad -%$$ -\frac{ -}{ - C \vdash \KK{drop} : [t] \to [] -} -%$$ -\qquad -%$$ -\frac{ -}{ - C \vdash \KK{select} : [t~t~\K{i32}] \to [t] -} -$$ - -$$ -\frac{ - C_{\f{local}}(i) = t -}{ - C \vdash \KK{get}~i : [] \to [t] -} -%$$ -\qquad -%$$ -\frac{ - C_{\f{local}}(i) = t -}{ - C \vdash \KK{set}~i : [t] \to [] -} -%$$ -\qquad -%$$ -\frac{ - C_{\f{local}}(i) = t -}{ - C \vdash \KK{tee}~i : [t] \to [t] -} -$$ - -$$ -\frac{ - C,_{\f{label}}[t^?] \vdash e^\ast : [t^?]\orbot -}{ - C \vdash \KK{block}~e^\ast~\KK{end} : [] \to [t^?]\orbot -} -%$$ -\qquad -%$$ -\frac{ - C,_{\f{label}}[] \vdash e^\ast : [t^?]\orbot -}{ - C \vdash \KK{loop}~e^\ast~\KK{end} : [] \to [t^?]\orbot -} -$$ - -%\botrule{\vspace{-1ex}} -$$ -\frac{ - C \vdash e_1^\ast : [t^?]\botrule{\orbot_1} - \qquad - C \vdash e_2^\ast : [t^?]\botrule{\orbot_2} -}{ - C \vdash \KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} : [\K{i32}] \to [t^?]\botrule{\orbot_1 \vee [t^?]\orbot_2} -}% -\void{\botrule{ -~~~~ -\begin{array}{rc} -[t^\ast]\vee[t^\ast] = [t^\ast] & -[t^\ast]\vee\bot = [t^\ast] \\ -\bot\vee[t^\ast] = [t^\ast] & -\bot\vee\bot = \bot -\end{array} -}} -$$ - -$$ -\frac{ - C_{\f{label}}(i) = [t^n] -}{ - C \vdash \KK{br}_n~i : [t^n] \to \poly{t_0^?} -} -%$$ -\qquad -%$$ -\frac{ - C_{\f{label}}(i) = [t^n] -}{ - C \vdash \KK{br\_if}_n~i : [t^n~\K{i32}] \to [t^n] -} -$$ -%\qquad -$$ -\frac{ - (C_{\f{label}}(i) = [t^n])^+ -}{ - C \vdash \KK{br\_table}_n~i^+ : [t^n~\K{i32}] \to \poly{t_0^?} -} -%$$ -\qquad -%$$ -\frac{ -}{ - C \vdash \KK{unreachable} : [] \to \poly{t^?} -} -$$ - -$$ -\frac{ - C_{\f{func}}(i) = [t_1^n] \to [t_2^?] -}{ - C \vdash \KK{call}_n~i : [t_1^n] \to [t_2^?] -} -%$$ -\qquad -%$$ -\frac{ - C_{\f{type}}(i) = [t_1^n] \to [t_2^?] -}{ - C \vdash \KK{call\_indirect}_n~i : [t_1^n~\K{i32}] \to [t_2^?] -} -$$ - -$$ -\frac{ - C_{\f{return}} = [t^n] -}{ - C \vdash \KK{return}_n : [t^n] \to \poly{t_0^?} -} -$$ - - -\subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : [t^\ast]\orbot}$} - -$$ -\frac{ -}{ - C \vdash \epsilon : [] -} -%$$ -\qquad -%$$ -\frac{ - C \vdash e^\ast : [t_1^\ast~t_2^\ast] - \qquad - C \vdash e_2 : [t_2^\ast] \to [t_3^?]\orbot -}{ - C \vdash e^\ast~e_2 : [t_1^\ast~t_3^?]\orbot -} -\botrule{ -%$$ -\qquad -%$$ -\frac{ - C \vdash e^\ast : \bot - %\qquad - %C \vdash e_2 : [t_2^\ast] \to [t_3^?]/\bot -}{ - C \vdash e^\ast~e_2 : \bot -} -} -$$ - - -\subsection*{Reduction \hfill $\boxed{S;~e^\ast \evalto S;~e^\ast}$} - -$$ -\begin{array}{@{}llcl@{}} -\text{(values)} & v &::=& - t\KK{.const}~c \\ -\text{(administrative operators)} & e &::=& - \dots ~|~ - \KK{trap} ~|~ - \KK{label}[e^\ast]~e^\ast~\KK{end} ~|~ - \KK{local}[v^\ast]~e^\ast~\KK{end} \\ -\text{(local contexts)} & L &::=& - \{\_\} ~|~ - v^\ast~L~e^\ast ~|~ - \KK{label}[e^\ast]~L~\KK{end} \\ -\text{(evaluation contexts)} & E &::=& - \{\_\} ~|~ - v^\ast~E~e^\ast ~|~ - \KK{label}[e^\ast]~E~\KK{end} ~|~ - \KK{local}[v^\ast]~E~\KK{end} \\ -\end{array} -$$ - -$$ -\frac{ - S;~e^\ast \evalto S';~{e'}^\ast -}{ - S;~E\{e^\ast\} \evalto S';~E\{{e'}^\ast\} -} -%$$ -\qquad -%$$ -\frac{ -}{ - S;~E\{\KK{trap}\} \evalto S;~\KK{trap} -} -$$ - - -$$ -\begin{array}{rcl} -(t.\KK{const}~c)~t\KK{.}\x{unop} &\evalto& - t.\KK{const}~t.\x{unop}(c) \\ -(t.\KK{const}~c_1)~(t.\KK{const}~c_2)~t\KK{.}\x{binop} &\evalto& - t.\KK{const}~t.\x{binop}(c_1, c_2) \\ -(t.\KK{const}~c)~t\KK{.}\x{testop} &\evalto& - \KK{i32.const}~t.\x{testop}(c) \\ -(t.\KK{const}~c_1)~(t.\KK{const}~c_2)~t\KK{.}\x{binop} &\evalto& - \KK{i32.const}~t.\x{relop}(c_1, c_2) \\ -[1ex] -\KK{unreachable} &\evalto& - \KK{trap} \\ -\KK{nop} &\evalto& - \epsilon \\ -v~\KK{drop} &\evalto& - \epsilon \\ -v_1~v_2~(\KK{i32.const}~0)~\KK{select} &\evalto& - v_2 \\ -v_1~v_2~(\KK{i32.const}~i+1)~\KK{select} &\evalto& - v_1 \\ -[1ex] -\void{ -\KK{block}~v^\ast~\KK{end} &\evalto& - v^\ast \\ -\KK{block}~v^\ast~v^n~(\KK{br}_n~0)~e^\ast~\KK{end} &\evalto& - v^n \\ -\KK{block}~v^\ast~v^n~(\KK{br}_n~i+1)~e^\ast~\KK{end} &\evalto& - v^n~(\KK{br}_n~i) \\ -[1ex] -\KK{loop}~e^\ast~\KK{end} &\evalto& - \KK{block}~e^\ast~\KK{end}~\KK{loop}~e^\ast~\KK{end} \\ -[1ex] -} -(\KK{i32.const}~0)~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} &\evalto& - e_2^\ast \\ -(\KK{i32.const}~i+1)~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} &\evalto& - e_1^\ast \\ -[2ex] -(\KK{i32.const}~0)~(\KK{br\_if}_n~i) &\evalto& - \epsilon \\ -(\KK{i32.const}~j+1)~(\KK{br\_if}_n~i) &\evalto& - \KK{br}_n~i \\ -(\KK{i32.const}~k)~(\KK{br\_table}_n~i_1^k~i~i_2^\ast) &\evalto& - \KK{br}_n~i \\ -(\KK{i32.const}~k+j)~(\KK{br\_table}_n~i_1^k~i) &\evalto& - \KK{br}_n~i \\ -[1ex] -\KK{block}~e^\ast~\KK{end} &\evalto& - \KK{label}[]~e^\ast~\KK{end} \\ -\KK{loop}~e^\ast~\KK{end} &\evalto& - \KK{label}[\KK{loop}~e^\ast~\KK{end}]~e^\ast~\KK{end} \\ -[1ex] -\KK{label}[e^\ast]~v^\ast~\KK{end} &\evalto& - v^\ast \\ -\KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~0)~e^\ast~\KK{end} &\evalto& - v^n~e_0^\ast \\ -\KK{label}[e_0^\ast]~v^\ast~v^n~(\KK{br}_n~i+1)~e^\ast~\KK{end} &\evalto& - v^n~(\KK{br}_n~i) \\ -%\KK{label}[e_0^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& -% v^n~\KK{return}_n \\ -%\KK{label}[e_0^\ast]~v^\ast~\KK{unreachable}~e^\ast~\KK{end} &\evalto& -% \KK{unreachable} \\ -[1ex] -S;~ v^n~\KK{call}_n~i &\evalto& - S;~ \KK{local}[v^n~S_{\f{func}}(i).{\f{locals}}]~S_{\f{func}}(i).{\f{body}}~\KK{end} \\ -S;~ (\KK{i32.const} j)~\KK{call\_indirect}_n~i &\evalto& - S;~ \KK{trap} - \hfill \text{if $S_{\f{func}}(S_{\f{table}}(j)).{\f{type}} \neq S_{\f{type}}(i)$} \\ -S;~ (\KK{i32.const} j)~\KK{call\_indirect}_n~i &\evalto& - S;~ \KK{call}_n~S_{\f{table}}(j) - \hfill \text{otherwise} \\ -[2ex] -\KK{local}[v_l^\ast]~v^\ast~\KK{end} &\evalto& - v^\ast \\ -%\KK{local}[v_l^\ast]~v^\ast~v^n~\KK{return}_n~e^\ast~\KK{end} &\evalto& -% v^n \\ -\KK{local}[v_l^\ast]~L\{v^n~\KK{return}_n\}~\KK{end} &\evalto& - v^n \\ -%\KK{local}[v_l^\ast]~v^\ast~\KK{unreachable}~e^\ast~\KK{end} &\evalto& -% \KK{unreachable} \\ -[2ex] -\void{ -S;~ (\KK{get}~i) &\evalto& - S;~ S_{\f{local}}(i) \\ -S;~ v~(\KK{set}~i) &\evalto& - S,i=v;~ \epsilon \\ -v~(\KK{tee}~i) &\evalto& - v~v~(\KK{set}~i) \\ -[1ex] -} -\KK{local}[v_1^i~v~v_2^\ast]~L\{\KK{get}~i\}~\KK{end} &\evalto& - \KK{local}[v_1^i~v~v_2^\ast]~L\{v\}~\KK{end} \\ -\KK{local}[v_1^i~v~v_2^\ast]~L\{v'~(\KK{set}~i)\}~\KK{end} &\evalto& - \KK{local}[v_1^i~v'~v_2^\ast]~L\{\epsilon\}~\KK{end} \\ -v~(\KK{tee}~i) &\evalto& - v~v~(\KK{set}~i) \\ -[1ex] -\end{array} -$$ -% -$$ -\frac{ -}{ - C \vdash \KK{trap} : [] \to \poly{t^\ast} -} -%$$ -\quad -%$$ -\frac{ - C \vdash e_0^\ast : [t^\ast]\orbot - \quad - C \vdash e^\ast : [t^\ast]\orbot -}{ - C \vdash \KK{label}[e_0^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot -} -%$$ -\quad -%$$ -\frac{ - (\vdash v : t_v)^\ast - \quad - C,_{\f{local}}t_v^\ast \vdash e^\ast : [t^\ast]\orbot -}{ - C \vdash \KK{local}[v^\ast]~e^\ast~\KK{end} : [] \to [t^\ast]\orbot -} -$$ - -\end{document} -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\void{ -\subsection*{Evaluating Expressions \hfill $\boxed{[c^\ast]~e \too r}$} - -$$ -\begin{array}{@{}llcl@{}} -\text{(results)} & r &::=& - [c^*] ~|~ - \K{br}~i~[c^*] \\ -\end{array} -$$ - -$$ -\frac{ -}{ - []~t\KK{.const}~c \too [c] -} -%$$ -\qquad -%$$ -\frac{ -}{ - [c]~t\KK{.}\x{unop} \too [t.\x{unop}(c)] -} -\qquad -%$$ -\frac{ -}{ - [c_1~c_2]~t\KK{.}\x{binop} \too [t.\x{binop}(c_1, c_2)] -} -$$ - -$$ -\frac{ - e^\ast \too [c^?] -}{ - []~\KK{block}~e^\ast~\KK{end} \too [c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~0~[c^?] -}{ - []~\KK{block}~e^\ast~\KK{end} \too [c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~(i+1)~[c^?] -}{ - []~\KK{block}~e^\ast~\KK{end} \too \K{br}~i~[c^?] -} -$$ - -$$ -\frac{ - e^\ast \too [c^?] -}{ - []~\KK{loop}~e^\ast~\KK{end} \too [c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~0~[] - \qquad - []~\KK{loop}~e^\ast~\KK{end} \too r -}{ - []~\KK{loop}~e^\ast~\KK{end} \too r -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~(i+1)~[c^?] -}{ - []~\KK{loop}~e^\ast~\KK{end} \too \K{br}~i~[c^?] -} -$$ - -$$ -\frac{ - c \neq 0 - \qquad - e_1^\ast \too r -}{ - [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r -} -%$$ -\qquad -%$$ -\frac{ - c = 0 - \qquad - e_2^\ast \too r -}{ - [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r -} -$$ - -$$ -\frac{ -}{ - [c^n]~\KK{br}_n~i \too \K{br}~i~[c^n] -} -$$ - - -\subsection*{Evaluating Sequences \hfill $\boxed{e^\ast \too r}$} - -$$ -\frac{ -}{ - \epsilon \too [] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too [c_1^\ast~c_2^\ast] - \qquad - [c_2^\ast]~e_2 \too [c_3^?] -}{ - e^\ast~e_2 \too [c_1^\ast~c_3^?] -} -$$ -%\qquad -$$ -\frac{ - e^\ast \too \K{br}~i~[c^?] -}{ - e^\ast~e_2 \too \K{br}~i~[c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too [c_1^\ast~c_2^\ast] - \qquad - [c_2^\ast]~e \too \K{br}~i~[c^?] -}{ - e^\ast~e_2 \too \K{br}~i~[c^?] -} -$$ -} - - -\clearpage -%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - -\section{Wasm-as-stack, Flat} - - -\subsection*{Syntax} - -$$ -\begin{array}{@{}llcl@{}} -\text{(expressions)} & e &::=& - t\KK{.const}~c ~|~ - t\KK{.}\x{unop} ~|~ - t\KK{.}\x{binop} ~|~ - \dots ~|~ \\&&& - \KK{block} ~|~ - \KK{loop} ~|~ - \KK{if} ~|~ - \KK{else }~|~ - \KK{end} ~|~ - \KK{br}_n~i \\ -[2ex] -\text{(control stacks)} & s &::=& - b^* \\ -\text{(control blocks)} & b &::=& - [t^*]e\langle t^?\rangle \\ -[2ex] -\text{(results)} & r &::=& - [c^*] ~|~ - \K{br}~i~[c^*] \\ -\end{array} -$$ - - -\subsection*{Typing Expressions \hfill $\boxed{C \vdash e : s~[t^\ast] \to s~[t^?]}$} - -$$ -\begin{array}{@{}rcl@{}} -t\KK{.const}~c &:& s~[t_0^\ast] \to s~[t_0^\ast~t] -\\ -t\KK{.}\x{unop} &:& s~[t_0^\ast~t] \to s~[t_0^\ast~t] -\\ -t\KK{.}\x{binop} &:& s~[t_0^\ast~t~t] \to s~[t_0^\ast~t] -\\ -\KK{block} &:& s~[t_0^\ast] \to s~[t_0^\ast]\K{block}\langle t^?\rangle~[] -\\ -\KK{loop} &:& s~[t_0^\ast] \to s~[t_0^\ast]\K{loop}\langle t^?\rangle~[] -\\ -\KK{if} &:& s~[t_0^\ast~\K{i32}] \to s~[t_0^\ast]\K{if}\langle t^?\rangle~[] -\\ -\KK{end} &:& s~[t_0^\ast]e\langle t^?\rangle~[t^?] \to s~[t_0^\ast~t^?] -\\ -\KK{else} &:& s~[t_0^\ast]\K{if}\langle t^?\rangle~[t^?] \to s~[t_0^\ast]\K{else}\langle t^?\rangle~[] -\\ -\KK{br}_n~i &:& s~[t_0^\ast]\K{block}\langle t^n\rangle~b^i~[t_1^\ast~t^n] \to s~[t_0^\ast~t^n] -\\ -\KK{br}_0~i &:& s~[t_0^\ast]\K{loop}\langle t^?\rangle~b^i~[t_1^\ast] \to s~[t_0^\ast] -\end{array} -$$ - - -\subsection*{Typing Sequences \hfill $\boxed{C \vdash e^\ast : s~[t^\ast] \to s~[t^\ast]}$} - -$$ -\frac{ -}{ - \epsilon : s~[] \to s~[] -} -%$$ -\qquad -%$$ -\frac{ - e_1^\ast : s_1~[t_1^\ast] \to s_2~[t_2^\ast] - \qquad - e_2 : s_2~[t_3^\ast] \to s_3~[t_3^\ast] -}{ - e_1^\ast~e_2 : s_1~[t_1^\ast] \to s_3~[t_3^\ast] -} -$$ - - -\subsection*{Evaluating Expressions \hfill $\boxed{[c^\ast]~e \too r}$} - -$$ -\frac{ -}{ - []~t\KK{.const}~c \too [c] -} -%$$ -\qquad -%$$ -\frac{ -}{ - [c]~t\KK{.}\x{unop} \too [t.\x{unop}(c)] -} -\qquad -%$$ -\frac{ -}{ - [c_1~c_2]~t\KK{.}\x{binop} \too [t.\x{binop}(c_1, c_2)] -} -$$ - -$$ -\frac{ -}{ - []~\KK{block} \too [\K{block}] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~0~[c^?] -}{ - []~\KK{block}~e^\ast~\KK{end} \too [c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~(i+1)~[c^?] -}{ - []~\KK{block}~e^\ast~\KK{end} \too \K{br}~i~[c^?] -} -$$ - -$$ -\frac{ - e^\ast \too [c^?] -}{ - []~\KK{loop}~e^\ast~\KK{end} \too [c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~0~[] - \qquad - []~\KK{loop}~e^\ast~\KK{end} \too r -}{ - []~\KK{loop}~e^\ast~\KK{end} \too r -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too \K{br}~(i+1)~[c^?] -}{ - []~\KK{loop}~e^\ast~\KK{end} \too \K{br}~i~[c^?] -} -$$ - -$$ -\frac{ - c \neq 0 - \qquad - e_1^\ast \too r -}{ - [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r -} -%$$ -\qquad -%$$ -\frac{ - c = 0 - \qquad - e_2^\ast \too r -}{ - [c]~\KK{if}~e_1^\ast~\KK{else}~e_2^\ast~\KK{end} \too r -} -$$ - -$$ -\frac{ -}{ - [c^n]~\KK{br}_n~i \too \K{br}~i~[c^n] -} -$$ - - -\subsection*{Evaluating Sequences \hfill $\boxed{e^\ast \too r}$} - -$$ -\frac{ -}{ - \epsilon \too [] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too [c_1^\ast~c_2^\ast] - \qquad - [c_2^\ast]~e_2 \too [c_3^?] -}{ - e^\ast~e_2 \too [c_1^\ast~c_3^?] -} -$$ -%\qquad -$$ -\frac{ - e^\ast \too \K{br}~i~[c^?] -}{ - e^\ast~e_2 \too \K{br}~i~[c^?] -} -%$$ -\qquad -%$$ -\frac{ - e^\ast \too [c_1^\ast~c_2^\ast] - \qquad - [c_2^\ast]~e \too \K{br}~i~[c^?] -}{ - e^\ast~e_2 \too \K{br}~i~[c^?] -} -$$ - - -\end{document} diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 37cffd2bbb..539bda6f0a 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -205,7 +205,7 @@ let rec expr e = Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) | Return -> Atom "return" | If (es1, es2) -> - Node ("if", list expr es1 @ [Atom "else"] @ list expr es2) + Node ("if", [Node ("then", list expr es1); Node ("else", list expr es2)]) | Select -> Atom "select" | Call x -> Atom ("call " ^ var x) | CallImport x -> Atom ("call_import " ^ var x) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 1ab1abd51b..ca178aea3d 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -250,34 +250,16 @@ align_opt : | ALIGN_EQ_NAT { Some $1 } ; -expr : - | op - { let at = at () in fun c -> [$1 c @@ at] } - | LPAR expr1 RPAR /* Sugar */ - { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } +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 */ ; -op : +plain_instr : | UNREACHABLE { fun c -> unreachable } | NOP { fun c -> nop } | DROP { fun c -> drop } - | BLOCK labeling expr_list END - { fun c -> let c' = $2 c in block ($3 c') } - | LOOP labeling expr_list END - { fun c -> let c' = $2 c in loop ($3 c') } - | LOOP labeling1 labeling1 expr_list END - { let at = at () in - fun c -> let c' = $2 c in let c'' = $3 c' in - block [loop ($4 c'') @@ at] } - | BR nat var { fun c -> br $2 ($3 c label) } - | BR_IF nat var { fun c -> br_if $2 ($3 c label) } - | BR_TABLE nat var var_list - { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in - br_table $2 xs x } | RETURN { fun c -> return } - | IF labeling expr_list END - { fun c -> let c' = $2 c in if_ ($3 c') [] } - | IF labeling expr_list ELSE labeling expr_list END - { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) } | SELECT { fun c -> select } | CALL var { fun c -> call ($2 c func) } | CALL_IMPORT var { fun c -> call_import ($2 c import) } @@ -298,67 +280,72 @@ op : | CURRENT_MEMORY { fun c -> current_memory } | GROW_MEMORY { fun c -> grow_memory } ; +ctrl_instr : + | BR nat var { fun c -> br $2 ($3 c label) } + | BR_IF nat var { fun c -> br_if $2 ($3 c label) } + | BR_TABLE nat var var_list + { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in + br_table $2 xs x } + | BLOCK labeling instr_list END + { fun c -> let c' = $2 c in block ($3 c') } + | LOOP labeling instr_list END + { fun c -> let c' = $2 c in loop ($3 c') } + | LOOP labeling1 labeling1 instr_list END + { let at = at () in + fun c -> let c' = $2 c in let c'' = $3 c' in + block [loop ($4 c'') @@ at] } + | IF labeling instr_list END + { fun c -> let c' = $2 c in if_ ($3 c') [] } + | IF labeling instr_list ELSE labeling 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 */ - | UNREACHABLE { fun c -> [], unreachable } - | NOP { fun c -> [], nop } - | DROP expr { fun c -> $2 c, drop } - | BLOCK labeling expr_list + | plain_instr expr_list { fun c -> snd ($2 c), $1 c } + | 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 + let es1 = $4 c and n, es2 = $5 c in es1 @ es2, br_table n xs x } + | BLOCK labeling instr_list { fun c -> let c' = $2 c in [], block ($3 c') } - | LOOP labeling expr_list + | LOOP labeling instr_list { fun c -> let c' = $2 c in [], loop ($3 c') } - | LOOP labeling1 labeling1 expr_list + | LOOP labeling1 labeling1 instr_list { let at = at () in fun c -> let c' = $2 c in let c'' = $3 c' in [], block [loop ($4 c'') @@ at] } - | BR var { fun c -> [], br 0 ($2 c label) } - | BR var expr { fun c -> $3 c, br 1 ($2 c label) } - | BR_IF var expr { fun c -> $3 c, br_if 0 ($2 c label) } - | BR_IF var expr expr { fun c -> $3 c @ $4 c, br_if 1 ($2 c label) } - | BR_TABLE var var_list expr - { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c, br_table 0 xs x } - | BR_TABLE var var_list expr expr - { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c @ $5 c, br_table 1 xs x } - | RETURN expr_list { fun c -> $2 c, return } | 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 $2 c, if_ ($3 c') ($4 c') } - | IF expr LPAR THEN labeling expr_list RPAR + | IF expr LPAR THEN labeling instr_list RPAR { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] } - | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR + | IF expr LPAR THEN labeling instr_list RPAR LPAR ELSE labeling instr_list RPAR { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) } - | IF expr_list ELSE expr_list - { fun c -> let c' = anon_label c in [], if_ ($2 c') ($4 c') } - | SELECT expr expr expr { fun c -> $2 c @ $3 c @ $4 c, select } - | CALL var expr_list { fun c -> $3 c, call ($2 c func) } - | CALL_IMPORT var expr_list { fun c -> $3 c, call_import ($2 c import) } - | CALL_INDIRECT var expr expr_list - { fun c -> $3 c @ $4 c, call_indirect ($2 c type_) } - | GET_LOCAL var { fun c -> [], get_local ($2 c local) } - | SET_LOCAL var expr { fun c -> $3 c, set_local ($2 c local) } - | TEE_LOCAL var expr { fun c -> $3 c, tee_local ($2 c local) } - | GET_GLOBAL var { fun c -> [], get_global ($2 c global) } - | SET_GLOBAL var expr { fun c -> $3 c, set_global ($2 c global) } - | LOAD offset_opt align_opt expr { fun c -> $4 c, $1 $3 $2 } - | STORE offset_opt align_opt expr expr { fun c -> $4 c @ $5 c, $1 $3 $2 } - | CONST literal { fun c -> [], fst (literal $1 $2) } - | UNARY expr { fun c -> $2 c, $1 } - | BINARY expr expr { fun c -> $2 c @ $3 c, $1 } - | TEST expr { fun c -> $2 c, $1 } - | COMPARE expr expr { fun c -> $2 c @ $3 c, $1 } - | CONVERT expr { fun c -> $2 c, $1 } - | CURRENT_MEMORY { fun c -> [], current_memory } - | GROW_MEMORY expr { fun c -> $2 c, grow_memory } + | IF LPAR THEN labeling instr_list RPAR + { fun c -> let c' = $4 c in [], if_ ($5 c') [] } + | IF LPAR THEN labeling instr_list RPAR LPAR ELSE labeling instr_list RPAR + { fun c -> let c1 = $4 c in let c2 = $9 c in [], if_ ($5 c1) ($10 c2) } ; -expr_list : +instr_list : | /* empty */ { fun c -> [] } - | expr expr_list { fun c -> $1 c @ $2 c } + | instr instr_list { fun c -> $1 c @ $2 c } +; +expr_list : + | /* 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 : - | expr_list { let at = at () in fun c -> $1 c @@ at } + | instr_list { let at = at () in fun c -> $1 c @@ at } ; @@ -377,7 +364,7 @@ func_fields : 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'} } @@ -427,8 +414,7 @@ export_opt : offset : | LPAR OFFSET const_expr RPAR { $3 } - | LPAR expr1 RPAR /* Sugar */ - { let at = at () in fun c -> let es, e' = $2 c in (es @ [e' @@ at]) @@ at } + | expr { let at = at () in fun c -> $1 c @@ at } /* Sugar */ ; elem : diff --git a/ml-proto/host/parser.mly.orig b/ml-proto/host/parser.mly.orig deleted file mode 100644 index bde2f98495..0000000000 --- a/ml-proto/host/parser.mly.orig +++ /dev/null @@ -1,510 +0,0 @@ -%{ -open Source -open Types -open Ast -open Operators -open Script - - -(* Error handling *) - -let error at msg = raise (Script.Syntax (at, msg)) - -let parse_error msg = error Source.no_region msg - - -(* Position handling *) - -let position_to_pos position = - { file = position.Lexing.pos_fname; - line = position.Lexing.pos_lnum; - column = position.Lexing.pos_cnum - position.Lexing.pos_bol - } - -let positions_to_region position1 position2 = - { left = position_to_pos position1; - right = position_to_pos position2 - } - -let at () = - positions_to_region (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ()) -let ati i = - positions_to_region (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) - - -(* Literals *) - -let literal f s = - try f s with - | Failure msg -> error s.at ("constant out of range: " ^ msg) - | _ -> error s.at "constant out of range" - - -(* Symbolic variables *) - -module VarMap = Map.Make(String) - -type space = {mutable map : int VarMap.t; mutable count : int} -let empty () = {map = VarMap.empty; count = 0} - -type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} -let empty_types () = {tmap = VarMap.empty; tlist = []} - -type context = - {types : types; funcs : space; imports : space; - locals : space; labels : int VarMap.t} - -let empty_context () = - {types = empty_types (); funcs = empty (); imports = empty (); - locals = empty (); labels = VarMap.empty} - -let enter_func c = - assert (VarMap.is_empty c.labels); - {c with labels = VarMap.empty; locals = empty ()} - -let type_ c x = - try VarMap.find x.it c.types.tmap - with Not_found -> error x.at ("unknown type " ^ x.it) - -let lookup category space x = - try VarMap.find x.it space.map - with Not_found -> error x.at ("unknown " ^ category ^ " " ^ x.it) - -let func c x = lookup "function" c.funcs x -let import c x = lookup "import" c.imports x -let local c x = lookup "local" c.locals x -let label c x = - try VarMap.find x.it c.labels - with Not_found -> error x.at ("unknown label " ^ x.it) - -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.tlist <- c.types.tlist @ [ty] - -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 - -let bind_func c x = bind "function" c.funcs x -let bind_import c x = bind "import" c.imports x -let bind_local c x = bind "local" c.locals x -let bind_label c x = - {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} - -let anon_type c ty = - c.types.tlist <- c.types.tlist @ [ty] - -let anon space n = space.count <- space.count + n - -let anon_func c = anon c.funcs 1 -let anon_import c = anon c.imports 1 -let anon_locals c ts = anon c.locals (List.length ts) -let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} - -let empty_type = FuncType ([], []) - -let explicit_decl c name t at = - let x = name c type_ in - if - x.it < List.length c.types.tlist && - t <> empty_type && - t <> List.nth c.types.tlist x.it - then - error at "signature mismatch"; - x - -let implicit_decl 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 - -%} - -%token NAT INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR -%token NOP DROP BLOCK END IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE -%token CALL CALL_IMPORT CALL_INDIRECT RETURN -%token GET_LOCAL SET_LOCAL TEE_LOCAL LOAD STORE OFFSET ALIGN -%token CONST UNARY BINARY COMPARE CONVERT -%token UNREACHABLE CURRENT_MEMORY GROW_MEMORY -%token FUNC START TYPE PARAM RESULT LOCAL -%token MODULE MEMORY SEGMENT IMPORT EXPORT TABLE -%token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE -%token INPUT OUTPUT -%token EOF - -%token NAT -%token INT -%token FLOAT -%token TEXT -%token VAR -%token VALUE_TYPE -%token Ast.expr' * Values.value> CONST -%token UNARY -%token BINARY -%token TEST -%token COMPARE -%token CONVERT -%token Memory.offset -> Ast.expr'> LOAD -%token Memory.offset -> Ast.expr'> STORE -%token OFFSET -%token ALIGN - -%nonassoc LOW -%nonassoc VAR - -%start script script1 module1 -%type script -%type script1 -%type module1 - -%% - -/* Auxiliaries */ - -text_list : - | TEXT { $1 } - | text_list TEXT { $1 ^ $2 } -; - -/* Types */ - -value_type_list : - | /* empty */ { [] } - | VALUE_TYPE value_type_list { $1 :: $2 } -; -func_type : - | /* empty */ - { FuncType ([], []) } - | LPAR PARAM value_type_list RPAR - { FuncType ($3, []) } - | LPAR PARAM value_type_list RPAR LPAR RESULT value_type_list RPAR - { FuncType ($3, $7) } - | LPAR RESULT value_type_list RPAR - { FuncType ([], $3) } -; - - -/* Expressions */ - -nat : - | NAT { int_of_string $1 } -; - -literal : - | NAT { $1 @@ at () } - | INT { $1 @@ at () } - | FLOAT { $1 @@ at () } -; - -var : - | NAT { let at = at () in fun c lookup -> int_of_string $1 @@ at } - | VAR { let at = at () in fun c lookup -> lookup c ($1 @@ at) @@ at } -; -var_list : - | /* empty */ { fun c lookup -> [] } - | var var_list { fun c lookup -> $1 c lookup :: $2 c lookup } -; -bind_var : - | VAR { $1 @@ at () } -; - -labeling : - | /* empty */ %prec LOW { fun c -> anon_label c } - | labeling1 { $1 } -; -labeling1 : - | bind_var { fun c -> bind_label c $1 } -; - -offset : - | /* empty */ { 0L } - | OFFSET { $1 } -; -align : - | /* empty */ { None } - | ALIGN { Some $1 } -; - -expr : - | op - { let at = at () in fun c -> [$1 c @@ at] } - | LPAR expr1 RPAR /* Sugar */ - { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } -; -op : - | plain_op { $1 } - | arity_op { $1 } - | block_op END { $1 } - | if_op END { $1 } -; -plain_op : - | UNREACHABLE { fun c -> unreachable } - | NOP { fun c -> nop } - | DROP { fun c -> drop } - | SELECT { fun c -> select } - | RETURN { fun c -> return } - | CALL var { fun c -> call ($2 c func) } - | CALL_IMPORT var { fun c -> call_import ($2 c import) } - | 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) } - | LOAD offset align { fun c -> $1 $3 $2 } - | STORE offset align { 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 } -; -arity_op : - | BR nat var { fun c -> br $2 ($3 c label) } - | BR_IF nat var { fun c -> br_if $2 ($3 c label) } - | BR_TABLE nat var var_list - { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in - br_table $2 xs x } -; -block_op : - | BLOCK labeling expr_list - { fun c -> let c' = $2 c in block ($3 c') } - | LOOP labeling expr_list - { fun c -> let c' = $2 c in loop ($3 c') } - | LOOP labeling1 labeling1 expr_list - { let at = at () in - fun c -> let c' = $2 c in let c'' = $3 c' in - block [loop ($4 c'') @@ at] } -; -if_op : - | IF labeling expr_list - { fun c -> let c' = $2 c in if_ ($3 c') [] } - | IF labeling expr_list ELSE labeling expr_list - { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) } -; -expr1 : /* Sugar */ - | plain_op expr_list { fun c -> $2 c, $1 c } - | block_op { fun c -> [], $1 c } - | BR var expr_list { fun c -> $3 c, br 1 ($2 c label) } - | BR_IF var expr_list { fun c -> $3 c, br_if 0 ($2 c label) } - | BR_TABLE var var_list expr_list - { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c, br_table 0 xs x } - | 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 $2 c, if_ ($3 c') ($4 c') } - | IF expr LPAR THEN labeling expr_list RPAR - { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] } - | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR - { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) } - | IF labeling expr_list ELSE labeling expr_list /* TODO(stack): remove? */ - { fun c -> let c1 = $2 c in let c2 = $5 c in [], if_ ($3 c1) ($6 c2) } -; -expr_list : - | /* empty */ { fun c -> [] } - | expr expr_list { fun c -> $1 c @ $2 c } -; - - -/* Functions */ - -func_fields : - | func_body { $1 } - | 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 - { 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 */ - { let FuncType (ins, out) = fst $6 in - FuncType ($4 :: ins, out), fun c -> bind_local c $3; (snd $6) c } -; -func_body : - | expr_list - { empty_type, - fun c -> let c' = anon_label c in - {ftype = -1 @@ 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 - {f with locals = $3 @ f.locals} } - | LPAR LOCAL bind_var VALUE_TYPE RPAR func_body /* Sugar */ - { fst $6, - fun c -> bind_local c $3; let f = (snd $6) c in - {f with locals = $4 :: f.locals} } -; -type_use : - | LPAR TYPE var RPAR { $3 } -; -func : - | LPAR FUNC export_opt type_use func_fields RPAR - { let at = at () in - fun c -> anon_func c; let t = explicit_decl c $4 (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var type_use func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> bind_func c $4; let t = explicit_decl c $5 (fst $6) at in - let exs = $3 c in - fun () -> {(snd $6 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> anon_func c; let t = implicit_decl c (fst $4) at in - let exs = $3 c in - fun () -> {(snd $4 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> bind_func c $4; let t = implicit_decl c (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } -; -export_opt : - | /* empty */ { fun c -> [] } - | TEXT - { let at = at () in - fun c -> [{name = $1; kind = `Func (c.funcs.count - 1 @@ at)} @@ at] } -; - - -/* Modules */ - -start : - | LPAR START var RPAR - { fun c -> $3 c func } - -segment : - | LPAR SEGMENT NAT text_list RPAR - { {Memory.addr = Int64.of_string $3; Memory.data = $4} @@ at () } -; -segment_list : - | /* empty */ { [] } - | segment segment_list { $1 :: $2 } -; - -memory : - | LPAR MEMORY NAT NAT segment_list RPAR - { {min = Int64.of_string $3; max = Int64.of_string $4; segments = $5} - @@ at () } - | LPAR MEMORY NAT segment_list RPAR - { {min = Int64.of_string $3; max = Int64.of_string $3; segments = $4} - @@ at () } -; - -type_def : - | LPAR TYPE LPAR FUNC func_type RPAR RPAR - { fun c -> anon_type c $5 } - | LPAR TYPE bind_var LPAR FUNC func_type RPAR RPAR - { fun c -> bind_type c $3 $6 } -; - -table : - | LPAR TABLE var_list RPAR - { fun c -> $3 c func } -; - -import : - | LPAR IMPORT TEXT TEXT type_use RPAR - { let at = at () in - fun c -> anon_import c; let itype = explicit_decl c $5 empty_type at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT type_use RPAR /* Sugar */ - { let at = at () in - fun c -> bind_import c $3; let itype = explicit_decl c $6 empty_type at in - {itype; module_name = $4; func_name = $5} @@ at } - | LPAR IMPORT TEXT TEXT func_type RPAR /* Sugar */ - { let at = at () in - fun c -> anon_import c; let itype = implicit_decl c $5 at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT func_type RPAR /* Sugar */ - { let at = at () in - fun c -> bind_import c $3; let itype = implicit_decl c $6 at in - {itype; module_name = $4; func_name = $5} @@ at } -; - -export : - | LPAR EXPORT TEXT var RPAR - { let at = at () in fun c -> {name = $3; kind = `Func ($4 c func)} @@ at } - | LPAR EXPORT TEXT MEMORY RPAR - { let at = at () in fun c -> {name = $3; kind = `Memory} @@ at } -; - -module_fields : - | /* empty */ - { fun c -> - {memory = None; types = c.types.tlist; funcs = []; start = None; imports = []; - exports = []; table = []} } - | func module_fields - { fun c -> let f = $1 c in let m = $2 c in let func, exs = f () in - {m with funcs = func :: m.funcs; exports = exs @ m.exports} } - | import module_fields - { fun c -> let i = $1 c in let m = $2 c in - {m with imports = i :: m.imports} } - | export module_fields - { fun c -> let m = $2 c in - {m with exports = $1 c :: m.exports} } - | table module_fields - { fun c -> let m = $2 c in - {m with table = ($1 c) @ m.table} } - | type_def module_fields - { fun c -> $1 c; $2 c } - | memory module_fields - { fun c -> let m = $2 c in - match m.memory with - | Some _ -> error $1.at "multiple memory sections" - | None -> {m with memory = Some $1} } - | start module_fields - { fun c -> let m = $2 c in - {m with start = Some ($1 c)} } -; -module_ : - | LPAR MODULE module_fields RPAR - { Textual ($3 (empty_context ()) @@ at ()) @@ at() } - | LPAR MODULE text_list RPAR { Binary $3 @@ at() } -; - - -/* Scripts */ - -cmd : - | module_ { Define $1 @@ at () } - | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () } - | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () } - | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_list RPAR - { AssertReturn ($5, $6, $8) @@ at () } - | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR - { AssertReturnNaN ($5, $6) @@ at () } - | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR - { AssertTrap ($5, $6, $8) @@ at () } - | LPAR INPUT TEXT RPAR { Input $3 @@ at () } - | LPAR OUTPUT TEXT RPAR { Output (Some $3) @@ at () } - | LPAR OUTPUT RPAR { Output None @@ at () } -; -cmd_list : - | /* empty */ { [] } - | cmd cmd_list { $1 :: $2 } -; - -const : - | LPAR CONST literal RPAR { snd (literal $2 $3) @@ ati 3 } -; -const_list : - | /* empty */ { [] } - | const const_list { $1 :: $2 } -; - -script : - | cmd_list EOF { $1 } -; -script1 : - | cmd { [$1] } -; -module1 : - | module_ EOF { $1 } -; -%% diff --git a/ml-proto/host/parser.mly.save b/ml-proto/host/parser.mly.save deleted file mode 100644 index bde2f98495..0000000000 --- a/ml-proto/host/parser.mly.save +++ /dev/null @@ -1,510 +0,0 @@ -%{ -open Source -open Types -open Ast -open Operators -open Script - - -(* Error handling *) - -let error at msg = raise (Script.Syntax (at, msg)) - -let parse_error msg = error Source.no_region msg - - -(* Position handling *) - -let position_to_pos position = - { file = position.Lexing.pos_fname; - line = position.Lexing.pos_lnum; - column = position.Lexing.pos_cnum - position.Lexing.pos_bol - } - -let positions_to_region position1 position2 = - { left = position_to_pos position1; - right = position_to_pos position2 - } - -let at () = - positions_to_region (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ()) -let ati i = - positions_to_region (Parsing.rhs_start_pos i) (Parsing.rhs_end_pos i) - - -(* Literals *) - -let literal f s = - try f s with - | Failure msg -> error s.at ("constant out of range: " ^ msg) - | _ -> error s.at "constant out of range" - - -(* Symbolic variables *) - -module VarMap = Map.Make(String) - -type space = {mutable map : int VarMap.t; mutable count : int} -let empty () = {map = VarMap.empty; count = 0} - -type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} -let empty_types () = {tmap = VarMap.empty; tlist = []} - -type context = - {types : types; funcs : space; imports : space; - locals : space; labels : int VarMap.t} - -let empty_context () = - {types = empty_types (); funcs = empty (); imports = empty (); - locals = empty (); labels = VarMap.empty} - -let enter_func c = - assert (VarMap.is_empty c.labels); - {c with labels = VarMap.empty; locals = empty ()} - -let type_ c x = - try VarMap.find x.it c.types.tmap - with Not_found -> error x.at ("unknown type " ^ x.it) - -let lookup category space x = - try VarMap.find x.it space.map - with Not_found -> error x.at ("unknown " ^ category ^ " " ^ x.it) - -let func c x = lookup "function" c.funcs x -let import c x = lookup "import" c.imports x -let local c x = lookup "local" c.locals x -let label c x = - try VarMap.find x.it c.labels - with Not_found -> error x.at ("unknown label " ^ x.it) - -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.tlist <- c.types.tlist @ [ty] - -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 - -let bind_func c x = bind "function" c.funcs x -let bind_import c x = bind "import" c.imports x -let bind_local c x = bind "local" c.locals x -let bind_label c x = - {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} - -let anon_type c ty = - c.types.tlist <- c.types.tlist @ [ty] - -let anon space n = space.count <- space.count + n - -let anon_func c = anon c.funcs 1 -let anon_import c = anon c.imports 1 -let anon_locals c ts = anon c.locals (List.length ts) -let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} - -let empty_type = FuncType ([], []) - -let explicit_decl c name t at = - let x = name c type_ in - if - x.it < List.length c.types.tlist && - t <> empty_type && - t <> List.nth c.types.tlist x.it - then - error at "signature mismatch"; - x - -let implicit_decl 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 - -%} - -%token NAT INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR -%token NOP DROP BLOCK END IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE -%token CALL CALL_IMPORT CALL_INDIRECT RETURN -%token GET_LOCAL SET_LOCAL TEE_LOCAL LOAD STORE OFFSET ALIGN -%token CONST UNARY BINARY COMPARE CONVERT -%token UNREACHABLE CURRENT_MEMORY GROW_MEMORY -%token FUNC START TYPE PARAM RESULT LOCAL -%token MODULE MEMORY SEGMENT IMPORT EXPORT TABLE -%token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE -%token INPUT OUTPUT -%token EOF - -%token NAT -%token INT -%token FLOAT -%token TEXT -%token VAR -%token VALUE_TYPE -%token Ast.expr' * Values.value> CONST -%token UNARY -%token BINARY -%token TEST -%token COMPARE -%token CONVERT -%token Memory.offset -> Ast.expr'> LOAD -%token Memory.offset -> Ast.expr'> STORE -%token OFFSET -%token ALIGN - -%nonassoc LOW -%nonassoc VAR - -%start script script1 module1 -%type script -%type script1 -%type module1 - -%% - -/* Auxiliaries */ - -text_list : - | TEXT { $1 } - | text_list TEXT { $1 ^ $2 } -; - -/* Types */ - -value_type_list : - | /* empty */ { [] } - | VALUE_TYPE value_type_list { $1 :: $2 } -; -func_type : - | /* empty */ - { FuncType ([], []) } - | LPAR PARAM value_type_list RPAR - { FuncType ($3, []) } - | LPAR PARAM value_type_list RPAR LPAR RESULT value_type_list RPAR - { FuncType ($3, $7) } - | LPAR RESULT value_type_list RPAR - { FuncType ([], $3) } -; - - -/* Expressions */ - -nat : - | NAT { int_of_string $1 } -; - -literal : - | NAT { $1 @@ at () } - | INT { $1 @@ at () } - | FLOAT { $1 @@ at () } -; - -var : - | NAT { let at = at () in fun c lookup -> int_of_string $1 @@ at } - | VAR { let at = at () in fun c lookup -> lookup c ($1 @@ at) @@ at } -; -var_list : - | /* empty */ { fun c lookup -> [] } - | var var_list { fun c lookup -> $1 c lookup :: $2 c lookup } -; -bind_var : - | VAR { $1 @@ at () } -; - -labeling : - | /* empty */ %prec LOW { fun c -> anon_label c } - | labeling1 { $1 } -; -labeling1 : - | bind_var { fun c -> bind_label c $1 } -; - -offset : - | /* empty */ { 0L } - | OFFSET { $1 } -; -align : - | /* empty */ { None } - | ALIGN { Some $1 } -; - -expr : - | op - { let at = at () in fun c -> [$1 c @@ at] } - | LPAR expr1 RPAR /* Sugar */ - { let at = at () in fun c -> let es, e' = $2 c in es @ [e' @@ at] } -; -op : - | plain_op { $1 } - | arity_op { $1 } - | block_op END { $1 } - | if_op END { $1 } -; -plain_op : - | UNREACHABLE { fun c -> unreachable } - | NOP { fun c -> nop } - | DROP { fun c -> drop } - | SELECT { fun c -> select } - | RETURN { fun c -> return } - | CALL var { fun c -> call ($2 c func) } - | CALL_IMPORT var { fun c -> call_import ($2 c import) } - | 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) } - | LOAD offset align { fun c -> $1 $3 $2 } - | STORE offset align { 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 } -; -arity_op : - | BR nat var { fun c -> br $2 ($3 c label) } - | BR_IF nat var { fun c -> br_if $2 ($3 c label) } - | BR_TABLE nat var var_list - { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in - br_table $2 xs x } -; -block_op : - | BLOCK labeling expr_list - { fun c -> let c' = $2 c in block ($3 c') } - | LOOP labeling expr_list - { fun c -> let c' = $2 c in loop ($3 c') } - | LOOP labeling1 labeling1 expr_list - { let at = at () in - fun c -> let c' = $2 c in let c'' = $3 c' in - block [loop ($4 c'') @@ at] } -; -if_op : - | IF labeling expr_list - { fun c -> let c' = $2 c in if_ ($3 c') [] } - | IF labeling expr_list ELSE labeling expr_list - { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) } -; -expr1 : /* Sugar */ - | plain_op expr_list { fun c -> $2 c, $1 c } - | block_op { fun c -> [], $1 c } - | BR var expr_list { fun c -> $3 c, br 1 ($2 c label) } - | BR_IF var expr_list { fun c -> $3 c, br_if 0 ($2 c label) } - | BR_TABLE var var_list expr_list - { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in - $4 c, br_table 0 xs x } - | 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 $2 c, if_ ($3 c') ($4 c') } - | IF expr LPAR THEN labeling expr_list RPAR - { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] } - | IF expr LPAR THEN labeling expr_list RPAR LPAR ELSE labeling expr_list RPAR - { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) } - | IF labeling expr_list ELSE labeling expr_list /* TODO(stack): remove? */ - { fun c -> let c1 = $2 c in let c2 = $5 c in [], if_ ($3 c1) ($6 c2) } -; -expr_list : - | /* empty */ { fun c -> [] } - | expr expr_list { fun c -> $1 c @ $2 c } -; - - -/* Functions */ - -func_fields : - | func_body { $1 } - | 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 - { 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 */ - { let FuncType (ins, out) = fst $6 in - FuncType ($4 :: ins, out), fun c -> bind_local c $3; (snd $6) c } -; -func_body : - | expr_list - { empty_type, - fun c -> let c' = anon_label c in - {ftype = -1 @@ 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 - {f with locals = $3 @ f.locals} } - | LPAR LOCAL bind_var VALUE_TYPE RPAR func_body /* Sugar */ - { fst $6, - fun c -> bind_local c $3; let f = (snd $6) c in - {f with locals = $4 :: f.locals} } -; -type_use : - | LPAR TYPE var RPAR { $3 } -; -func : - | LPAR FUNC export_opt type_use func_fields RPAR - { let at = at () in - fun c -> anon_func c; let t = explicit_decl c $4 (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var type_use func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> bind_func c $4; let t = explicit_decl c $5 (fst $6) at in - let exs = $3 c in - fun () -> {(snd $6 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> anon_func c; let t = implicit_decl c (fst $4) at in - let exs = $3 c in - fun () -> {(snd $4 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> bind_func c $4; let t = implicit_decl c (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } -; -export_opt : - | /* empty */ { fun c -> [] } - | TEXT - { let at = at () in - fun c -> [{name = $1; kind = `Func (c.funcs.count - 1 @@ at)} @@ at] } -; - - -/* Modules */ - -start : - | LPAR START var RPAR - { fun c -> $3 c func } - -segment : - | LPAR SEGMENT NAT text_list RPAR - { {Memory.addr = Int64.of_string $3; Memory.data = $4} @@ at () } -; -segment_list : - | /* empty */ { [] } - | segment segment_list { $1 :: $2 } -; - -memory : - | LPAR MEMORY NAT NAT segment_list RPAR - { {min = Int64.of_string $3; max = Int64.of_string $4; segments = $5} - @@ at () } - | LPAR MEMORY NAT segment_list RPAR - { {min = Int64.of_string $3; max = Int64.of_string $3; segments = $4} - @@ at () } -; - -type_def : - | LPAR TYPE LPAR FUNC func_type RPAR RPAR - { fun c -> anon_type c $5 } - | LPAR TYPE bind_var LPAR FUNC func_type RPAR RPAR - { fun c -> bind_type c $3 $6 } -; - -table : - | LPAR TABLE var_list RPAR - { fun c -> $3 c func } -; - -import : - | LPAR IMPORT TEXT TEXT type_use RPAR - { let at = at () in - fun c -> anon_import c; let itype = explicit_decl c $5 empty_type at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT type_use RPAR /* Sugar */ - { let at = at () in - fun c -> bind_import c $3; let itype = explicit_decl c $6 empty_type at in - {itype; module_name = $4; func_name = $5} @@ at } - | LPAR IMPORT TEXT TEXT func_type RPAR /* Sugar */ - { let at = at () in - fun c -> anon_import c; let itype = implicit_decl c $5 at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT func_type RPAR /* Sugar */ - { let at = at () in - fun c -> bind_import c $3; let itype = implicit_decl c $6 at in - {itype; module_name = $4; func_name = $5} @@ at } -; - -export : - | LPAR EXPORT TEXT var RPAR - { let at = at () in fun c -> {name = $3; kind = `Func ($4 c func)} @@ at } - | LPAR EXPORT TEXT MEMORY RPAR - { let at = at () in fun c -> {name = $3; kind = `Memory} @@ at } -; - -module_fields : - | /* empty */ - { fun c -> - {memory = None; types = c.types.tlist; funcs = []; start = None; imports = []; - exports = []; table = []} } - | func module_fields - { fun c -> let f = $1 c in let m = $2 c in let func, exs = f () in - {m with funcs = func :: m.funcs; exports = exs @ m.exports} } - | import module_fields - { fun c -> let i = $1 c in let m = $2 c in - {m with imports = i :: m.imports} } - | export module_fields - { fun c -> let m = $2 c in - {m with exports = $1 c :: m.exports} } - | table module_fields - { fun c -> let m = $2 c in - {m with table = ($1 c) @ m.table} } - | type_def module_fields - { fun c -> $1 c; $2 c } - | memory module_fields - { fun c -> let m = $2 c in - match m.memory with - | Some _ -> error $1.at "multiple memory sections" - | None -> {m with memory = Some $1} } - | start module_fields - { fun c -> let m = $2 c in - {m with start = Some ($1 c)} } -; -module_ : - | LPAR MODULE module_fields RPAR - { Textual ($3 (empty_context ()) @@ at ()) @@ at() } - | LPAR MODULE text_list RPAR { Binary $3 @@ at() } -; - - -/* Scripts */ - -cmd : - | module_ { Define $1 @@ at () } - | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () } - | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () } - | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_list RPAR - { AssertReturn ($5, $6, $8) @@ at () } - | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR - { AssertReturnNaN ($5, $6) @@ at () } - | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR - { AssertTrap ($5, $6, $8) @@ at () } - | LPAR INPUT TEXT RPAR { Input $3 @@ at () } - | LPAR OUTPUT TEXT RPAR { Output (Some $3) @@ at () } - | LPAR OUTPUT RPAR { Output None @@ at () } -; -cmd_list : - | /* empty */ { [] } - | cmd cmd_list { $1 :: $2 } -; - -const : - | LPAR CONST literal RPAR { snd (literal $2 $3) @@ ati 3 } -; -const_list : - | /* empty */ { [] } - | const const_list { $1 :: $2 } -; - -script : - | cmd_list EOF { $1 } -; -script1 : - | cmd { [$1] } -; -module1 : - | module_ EOF { $1 } -; -%% diff --git a/ml-proto/winmake.bat b/ml-proto/winmake.bat index b5f44272ba..234c4770a5 100644 --- a/ml-proto/winmake.bat +++ b/ml-proto/winmake.bat @@ -1,78 +1,82 @@ rem Auto-generated from Makefile! set NAME=wasm if '%1' neq '' set NAME=%1 -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/numerics.cmi spec/numerics.mli -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/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/i32.cmo spec/i32.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 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/numeric_error.cmo spec/numeric_error.ml +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/types.cmo spec/types.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/i32.cmo spec/i32.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/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 given -I spec -I host -I host/import -o given/source.cmi given/source.mli -ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/kernel.cmo spec/kernel.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 spec -I given -I host -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/ast.cmo spec/ast.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 host -I spec -I given -I host/import -o host/print.cmi host/print.mli -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/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 -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 given -I host -o host/import/spectest.cmo host/import/spectest.ml +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 -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 given -I host -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 host -I given -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 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/encode.cmi host/encode.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 host -I spec -I given -I host/import -o host/parse.cmi host/parse.mli -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/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 -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 given -I host -o host/import/spectest.d.cmo host/import/spectest.ml -ocamlc.opt -c -bin-annot -I spec -I given -I host -I host/import -o spec/arithmetic.cmi spec/arithmetic.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 -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 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 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 -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 -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/arithmetic.d.cmo spec/arithmetic.ml -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/i32.d.cmo spec/i32.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/kernel.d.cmo spec/kernel.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 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 spec -I given -I host -I host/import -o spec/numerics.d.cmo spec/numerics.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/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.d.cmo spec/f64.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 -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/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 host -I given -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/values.d.cmo spec/values.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/i32.d.cmo spec/i32.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/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/numeric_error.d.cmo spec/numeric_error.ml +ocamlc.opt -c -bin-annot -I spec -I host -I given -I host/import -o spec/eval_numeric.cmi spec/eval_numeric.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/eval.d.cmo spec/eval.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 -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/eval_numeric.d.cmo spec/eval_numeric.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 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 -bin-annot -I spec -I host -I given -I host/import -o spec/operators.cmo spec/operators.ml ocamlyacc host/parser.mly 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 -bin-annot -I spec -I given -I host -I host/import -o spec/desugar.cmi spec/desugar.mli -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 host -I spec -I given -I host/import -o host/encode.d.cmo host/encode.ml +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 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 spec -I given -I host -I host/import -o spec/ast.d.cmo spec/ast.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 host -I given -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 spec -I given -I host -I host/import -o spec/desugar.d.cmo spec/desugar.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 host/flags.d.cmo given/source.d.cmo spec/error.d.cmo given/lib.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/i32_convert.d.cmo spec/f32_convert.d.cmo spec/i64_convert.d.cmo spec/f64_convert.d.cmo spec/types.d.cmo spec/values.d.cmo spec/memory.d.cmo spec/kernel.d.cmo spec/arithmetic.d.cmo spec/eval.d.cmo host/import.d.cmo host/import/env.d.cmo host/print.d.cmo host/import/spectest.d.cmo spec/ast.d.cmo host/encode.d.cmo spec/check.d.cmo spec/desugar.d.cmo host/script.d.cmo host/parser.d.cmo host/lexer.d.cmo host/parse.d.cmo spec/decode.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/table.d.cmo spec/ast.d.cmo host/encode.d.cmo host/flags.d.cmo spec/error.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.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% From 6e8d71eb2afab1f6b53ba5f53679cc555cb84e1a Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 14:12:15 +0200 Subject: [PATCH 28/44] Eliminate second loop label --- ml-proto/README.md | 76 ++++++++++++++---------- ml-proto/host/parser.mly | 11 ---- ml-proto/test/float_exprs.wast | 104 ++++++++++++++++++++++++--------- ml-proto/test/labels.wast | 61 ++++++++++--------- ml-proto/test/stack.wast | 72 ++++++++++++----------- 5 files changed, 195 insertions(+), 129 deletions(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index b88f2d6799..a1205416ca 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -115,35 +115,48 @@ offset: offset= align: align=(1|2|4|8|...) cvtop: trunc_s | trunc_u | extend_s | extend_u | ... +instr: + + block ? * end + loop ? * end + if ? * else ? * end + if ? * end ;; = if ? * else end + + +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 + 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 ) (func ? * *) + ( * ) ;; = * + ( block ? * ) ;; = block ? * end + ( loop ? * ) ;; = loop ? * end + ( if ? ) ;; = if else ? end + ( if ? ( then ? * ) ( else ? * )? ) ;; = ? if ? * else ? * end + +func: ( func ? * * ) + ( func ? * * ) ;; = (export ) (func ? * *) sig: ( type ) | * ? param: ( param * ) | ( param ) result: ( result ) @@ -156,13 +169,16 @@ export: ( export ) | ( export memory) start: ( start ) table: ( table ? ) ( table ( elem * ) ) ;; = (table ) (elem (i32.const 0) *) -elem: ( elem * ) +elem: ( elem ( offset ) * ) + ( elem * ) ;; = (elem (offset ) *) memory: ( memory ? ) ( memory ( data * ) ) ;; = (memory ) (data (i32.const 0) *) -data: ( data * ) +data: ( data ( offset * ) * ) + ( data * ) ;; = (data (offset ) *) ``` Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the AST below). +WebAssembly is a stack machine, so all expressions are merely abbreviations of a corresponding post-order sequence of instructions. 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. diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index ca178aea3d..676b904713 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -235,9 +235,6 @@ bind_var : labeling : | /* empty */ %prec LOW { fun c -> anon_label c } - | labeling1 { $1 } -; -labeling1 : | bind_var { fun c -> bind_label c $1 } ; @@ -290,10 +287,6 @@ ctrl_instr : { fun c -> let c' = $2 c in block ($3 c') } | LOOP labeling instr_list END { fun c -> let c' = $2 c in loop ($3 c') } - | LOOP labeling1 labeling1 instr_list END - { let at = at () in - fun c -> let c' = $2 c in let c'' = $3 c' in - block [loop ($4 c'') @@ at] } | IF labeling instr_list END { fun c -> let c' = $2 c in if_ ($3 c') [] } | IF labeling instr_list ELSE labeling instr_list END @@ -317,10 +310,6 @@ expr1 : /* Sugar */ { fun c -> let c' = $2 c in [], block ($3 c') } | LOOP labeling instr_list { fun c -> let c' = $2 c in [], loop ($3 c') } - | LOOP labeling1 labeling1 instr_list - { let at = at () in - fun c -> let c' = $2 c in let c'' = $3 c' in - [], block [loop ($4 c'') @@ at] } | 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 $2 c, if_ ($3 c') ($4 c') } diff --git a/ml-proto/test/float_exprs.wast b/ml-proto/test/float_exprs.wast index 2f968f6bb5..570a79c2f4 100644 --- a/ml-proto/test/float_exprs.wast +++ b/ml-proto/test/float_exprs.wast @@ -871,10 +871,15 @@ (func $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))) + ) ) ) (export "run" $run) @@ -904,10 +909,15 @@ (func $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))) + ) ) ) (export "run" $run) @@ -1506,11 +1516,28 @@ (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) ) @@ -1518,11 +1545,13 @@ (func $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) ) @@ -1540,11 +1569,28 @@ (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) ) @@ -1552,11 +1598,13 @@ (func $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/labels.wast b/ml-proto/test/labels.wast index c37c913ba6..3e511ac405 100644 --- a/ml-proto/test/labels.wast +++ b/ml-proto/test/labels.wast @@ -9,60 +9,67 @@ (func $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 $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 $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 $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 $loop5 (result i32) - (i32.add (loop $l0 $l1 - (i32.const 1) - ) - (i32.const 1) + (i32.add + (loop $l (i32.const 1)) + (i32.const 1) ) ) diff --git a/ml-proto/test/stack.wast b/ml-proto/test/stack.wast index 3ca373fe35..40a5b6ff27 100644 --- a/ml-proto/test/stack.wast +++ b/ml-proto/test/stack.wast @@ -4,16 +4,18 @@ (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) ) @@ -25,23 +27,25 @@ set_local $i i64.const 1 set_local $res - loop $done $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 + block $done + loop $loop get_local $i - i64.const 1 - i64.sub - set_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 - br 0 $loop end get_local $res ) @@ -51,17 +55,19 @@ (local $res i64) (set_local $i (get_local $n)) (set_local $res (i64.const 1)) - loop $done $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 + 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 - br 0 $loop end get_local $res ) From 7b9f237238c9967a3a0726af8901961ad1bfe8af Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 14:14:44 +0200 Subject: [PATCH 29/44] Tweak --- ml-proto/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index a1205416ca..61e087692e 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -178,7 +178,7 @@ data: ( data ( offset * ) * ) ``` Here, productions marked with respective comments are abbreviation forms for equivalent expansions (see the explanation of the AST below). -WebAssembly is a stack machine, so all expressions are merely abbreviations of a corresponding post-order sequence of instructions. +In particular, WebAssembly is a stack machine, so that all expressions `` are merely abbreviations of a corresponding post-order sequence of instructions. 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. From d924eff055967bbaaa7b3b0283afbe2cbb564b00 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 14:15:51 +0200 Subject: [PATCH 30/44] Tweak --- ml-proto/README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index 61e087692e..556ee514dc 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -111,7 +111,7 @@ 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 | ... From 4dc09e3d2f73d5c3832e8928ce6ce79475acafce Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 15:15:10 +0200 Subject: [PATCH 31/44] Simplify memop --- ml-proto/host/arrange.ml | 28 +++++++++-------- ml-proto/host/encode.ml | 63 ++++++++++++++++--------------------- ml-proto/host/encode.ml.rej | 51 ------------------------------ ml-proto/spec/ast.ml | 13 ++++---- ml-proto/spec/check.ml | 52 +++++++++++++----------------- ml-proto/spec/eval.ml | 32 +++++++++---------- ml-proto/spec/memory.ml | 4 +-- ml-proto/spec/memory.mli | 4 +-- ml-proto/spec/operators.ml | 48 ++++++++++++++-------------- 9 files changed, 113 insertions(+), 182 deletions(-) delete mode 100644 ml-proto/host/encode.ml.rej diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 539bda6f0a..188eb93b8b 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -165,11 +165,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; align; offset} = - value_type ty ^ "." ^ name ^ - (if offset = 0L then "" else " offset=" ^ int64 offset) ^ - (if align = size ty then "" else " align=" ^ int align) - let mem_size = function | Memory.Mem8 -> "8" | Memory.Mem16 -> "16" @@ -179,11 +174,20 @@ 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 loadop op = + match op.sz with + | None -> memop "load" op + | Some (sz, ext) -> memop ("load" ^ mem_size sz ^ extension ext) op -let wrapop {memop = op; sz} = - memop ("store" ^ mem_size sz) op +let storeop op = + match op.sz with + | None -> memop "store" op + | Some sz -> memop ("store" ^ mem_size sz) op (* Expressions *) @@ -215,10 +219,8 @@ let rec expr e = | TeeLocal x -> Atom ("tee_local " ^ var x) | GetGlobal x -> Atom ("get_global " ^ var x) | SetGlobal x -> Atom ("set_global " ^ var x) - | Load op -> Atom (memop "load" op) - | Store op -> Atom (memop "store" op) - | LoadPacked op -> Atom (extop op) - | StorePacked op -> Atom (wrapop op) + | Load op -> Atom (loadop op) + | Store op -> Atom (storeop op) | Const lit -> Atom (constop lit ^ " " ^ value lit) | Unary op -> Atom (unop op) | Binary op -> Atom (binop op) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 88d9f148d3..cd75daa72e 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -135,55 +135,46 @@ let encode m = | CallIndirect x -> op 0x17; var x | CallImport x -> op 0x18; var x - | Load ({ty = I32Type; _} as mo) -> op 0x2a; memop mo - | Load ({ty = I64Type; _} as mo) -> op 0x2b; memop mo - | Load ({ty = F32Type; _} as mo) -> op 0x2c; memop mo - | Load ({ty = F64Type; _} as mo) -> op 0x2d; memop mo - - | Store ({ty = I32Type; _} as mo) -> op 0x33; memop mo - | Store ({ty = I64Type; _} as mo) -> op 0x34; memop mo - | Store ({ty = F32Type; _} as mo) -> op 0x35; memop mo - | Store ({ty = F64Type; _} as mo) -> op 0x36; memop mo - - | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem8; ext = SX} -> + | 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 - | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem8; ext = ZX} -> + | Load ({ty = I32Type; sz = Some (Mem8, ZX); _} as mo) -> op 0x21; memop mo - | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem16; ext = SX} -> + | Load ({ty = I32Type; sz = Some (Mem16, SX); _} as mo) -> op 0x22; memop mo - | LoadPacked {memop = {ty = I32Type; _} as mo; sz = Mem16; ext = ZX} -> + | Load ({ty = I32Type; sz = Some (Mem16, ZX); _} as mo) -> op 0x23; memop mo - | LoadPacked {memop = {ty = I32Type; _}; sz = Mem32; _} -> + | Load {ty = I32Type; sz = Some (Mem32, _); _} -> assert false - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem8; ext = SX} -> + | Load ({ty = I64Type; sz = Some (Mem8, SX); _} as mo) -> op 0x24; memop mo - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem8; ext = ZX} -> + | Load ({ty = I64Type; sz = Some (Mem8, ZX); _} as mo) -> op 0x25; memop mo - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem16; ext = SX} -> + | Load ({ty = I64Type; sz = Some (Mem16, SX); _} as mo) -> op 0x26; memop mo - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem16; ext = ZX} -> + | Load ({ty = I64Type; sz = Some (Mem16, ZX); _} as mo) -> op 0x27; memop mo - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem32; ext = SX} -> + | Load ({ty = I64Type; sz = Some (Mem32, SX); _} as mo) -> op 0x28; memop mo - | LoadPacked {memop = {ty = I64Type; _} as mo; sz = Mem32; ext = ZX} -> + | Load ({ty = I64Type; sz = Some (Mem32, ZX); _} as mo) -> op 0x29; memop mo - | LoadPacked {memop = {ty = F32Type | F64Type; _}; _} -> + | Load {ty = F32Type | F64Type; sz = Some _; _} -> assert false - | StorePacked {memop = {ty = I32Type; _} as mo; sz = Mem8} -> - op 0x2e; memop mo - | StorePacked {memop = {ty = I32Type; _} as mo; sz = Mem16} -> - op 0x2f; memop mo - | StorePacked {memop = {ty = I32Type; _}; sz = Mem32} -> - assert false - | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem8} -> - op 0x30; memop mo - | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem16} -> - op 0x31; memop mo - | StorePacked {memop = {ty = I64Type; _} as mo; sz = Mem32} -> - op 0x32; memop mo - | StorePacked {memop = {ty = F32Type | F64Type; _}; _} -> - 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 diff --git a/ml-proto/host/encode.ml.rej b/ml-proto/host/encode.ml.rej deleted file mode 100644 index 3b3e977cb1..0000000000 --- a/ml-proto/host/encode.ml.rej +++ /dev/null @@ -1,51 +0,0 @@ ---- host/encode.ml -+++ host/encode.ml -@@ -105,31 +105,30 @@ - let rec expr e = - match e.it with - | Nop -> op 0x00 -- | Block es -> op 0x01; list expr es; op 0x17 -- | Loop es -> op 0x02; list expr es; op 0x17 -+ | 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 0x17 -+ 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.I32_const c -> op 0x0a; vs32 c.it -- | Ast.I64_const c -> op 0x0b; vs64 c.it -- | Ast.F32_const c -> op 0x0c; f32 c.it -- | Ast.F64_const c -> op 0x0d; f64 c.it -- -- | Ast.Get_local x -> op 0x0e; var x -- | Ast.Set_local (x, e) -> unary e 0x0f; var x -- | Ast.Tee_local (x, e) -> unary e 0x10; var x -- -- | Ast.Call (x, es) -> nary es 0x12; var x -- | Ast.Call_import (x, es) -> nary es 0x1f; var x -- | Ast.Call_indirect (x, e, es) -> expr e; nary es 0x13; var x -- | Ast.Return eo -> nary1 eo 0x14 -- | Ast.Unreachable -> op 0x15 -+ | Ast.Return eo -> nary1 eo 0x09 -+ | Ast.Unreachable -> op 0x0a -+ -+ | 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.Call (x, es) -> nary es 0x16; var x -+ | Ast.Call_indirect (x, e, es) -> expr e; nary es 0x17; var x -+ | Ast.Call_import (x, es) -> nary es 0x18; 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 diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 9e112e8d4b..ec9867e130 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -62,9 +62,10 @@ 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; align : int; offset : Memory.offset} -type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} -type wrapop = {memop : memop; sz : Memory.mem_size} +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 *) @@ -93,10 +94,8 @@ and expr' = | TeeLocal of var (* write local variable and keep value *) | GetGlobal of var (* read global variable *) | SetGlobal of var (* write global variable *) - | Load of memop (* read memory at address *) - | Store of memop (* write memory at address *) - | LoadPacked of extop (* read memory at address and extend *) - | StorePacked of wrapop (* wrap and write to memory at address *) + | 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 *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index bde53ff8ff..6baf562f2d 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -113,6 +113,26 @@ let type_cvtop at = function (* Expressions *) +let check_memop (c : context) (memop : 'a memop) get_sz at = + ignore (memory c 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 <= size memop.ty) at + "alignment must not be larger than natural"; + let sz = get_sz memop.sz in + require (sz = None || memop.ty = I64Type || sz <> Some Memory.Mem32) at + "memory size too big" + +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 * @@ -222,21 +242,11 @@ let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = [global c x] --> Stack [] | Load memop -> - check_memop c memop e.at; + check_memop c memop (Lib.Option.map fst) e.at; [I32Type] --> Stack [memop.ty] | Store memop -> - check_memop c memop e.at; - [I32Type; memop.ty] --> Stack [] - - | LoadPacked {memop; sz; _} -> - check_memop c memop e.at; - check_mem_size memop.ty sz e.at; - [I32Type] --> Stack [memop.ty] - - | StorePacked {memop; sz} -> - check_memop c memop e.at; - check_mem_size memop.ty sz e.at; + check_memop c memop (fun sz -> sz) e.at; [I32Type; memop.ty] --> Stack [] | Const v -> @@ -313,24 +323,6 @@ and check_block (c : context) (es : expr list) : result_type = | Bot -> Bot | Stack ts3 -> Stack (ts1 @ ts3) -and check_memop c memop at = - ignore (memory c 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 <= size memop.ty) at "alignment must not be larger than natural" - -and check_mem_size ty sz at = - require (ty = I64Type || sz <> Memory.Mem32) at "memory size too big" - -and check_arity n at = - require (n <= 1) at "invalid result arity, larger than 1 is not (yet) allowed" - -and check_result_arity r at = - match r with - | Stack ts -> check_arity (List.length ts) at - | Bot -> () - (* Functions & Constants *) diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 4bfab24907..8eafbf8012 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -209,25 +209,23 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) global c x := v; vs', [] - | Load {offset; ty; _}, I32 i :: vs' -> + | Load {offset; ty; sz; _}, I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in - (try Memory.load (memory c e.at) addr offset ty :: vs', [] - with exn -> memory_error e.at exn) - - | Store {offset; _}, v :: I32 i :: vs' -> - let addr = I64_convert.extend_u_i32 i in - (try Memory.store (memory c e.at) addr offset v - with exn -> memory_error e.at exn); - vs', [] - - | LoadPacked {memop = {offset; ty; _}; sz; ext}, I32 i :: vs' -> - let addr = I64_convert.extend_u_i32 i in - (try Memory.load_packed (memory c e.at) addr offset sz ext ty :: vs', [] - with exn -> memory_error e.at exn) - - | StorePacked {memop = {offset; _}; sz}, v :: I32 i :: vs' -> + let v = + try + match sz with + | None -> Memory.load (memory c e.at) addr offset ty + | Some (sz, ext) -> + Memory.load_packed sz ext (memory c e.at) addr offset ty + with exn -> memory_error e.at exn + in v :: vs', [] + + | Store {offset; sz; _}, v :: I32 i :: vs' -> let addr = I64_convert.extend_u_i32 i in - (try Memory.store_packed (memory c e.at) addr offset sz v + (try + match sz with + | None -> Memory.store (memory c e.at) addr offset v + | Some sz -> Memory.store_packed sz (memory c e.at) addr offset v with exn -> memory_error e.at exn); vs', [] diff --git a/ml-proto/spec/memory.ml b/ml-proto/spec/memory.ml index a26bdff67d..9826d94e02 100644 --- a/ml-proto/spec/memory.ml +++ b/ml-proto/spec/memory.ml @@ -129,7 +129,7 @@ let loadn_sx mem n ea = let shift = 64 - (8 * n) in Int64.shift_right (Int64.shift_left v shift) shift -let load_packed 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, I32Type -> I32 (Int64.to_int32 (loadn mem 1 ea)) @@ -144,7 +144,7 @@ let load_packed mem a o sz ext t = | Mem32, SX, I64Type -> I64 (loadn_sx mem 4 ea) | _ -> raise Type -let store_packed 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, I32 x -> storen mem 1 ea (Int64.of_int32 x) diff --git a/ml-proto/spec/memory.mli b/ml-proto/spec/memory.mli index b9778576e7..be342ddded 100644 --- a/ml-proto/spec/memory.mli +++ b/ml-proto/spec/memory.mli @@ -26,7 +26,7 @@ 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_packed : - memory -> address -> offset -> mem_size -> extension -> value_type -> value -val store_packed : memory -> address -> offset -> mem_size -> value -> unit + 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/operators.ml b/ml-proto/spec/operators.ml index 04cfe42311..54030cd61e 100644 --- a/ml-proto/spec/operators.ml +++ b/ml-proto/spec/operators.ml @@ -32,45 +32,45 @@ 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} -let i64_load align offset = Load {ty = I64Type; align; offset} -let f32_load align offset = Load {ty = F32Type; align; offset} -let f64_load align offset = Load {ty = F64Type; align; offset} -let i32_store align offset = Store {ty = I32Type; align; offset} -let i64_store align offset = Store {ty = I64Type; align; offset} -let f32_store align offset = Store {ty = F32Type; align; offset} -let f64_store align offset = Store {ty = F64Type; align; offset} - +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 = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = SX} + Load {ty = I32Type; align; offset; sz = Some (Mem8, SX)} let i32_load8_u align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem8; ext = ZX} + Load {ty = I32Type; align; offset; sz = Some (Mem8, ZX)} let i32_load16_s align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = SX} + Load {ty = I32Type; align; offset; sz = Some (Mem16, SX)} let i32_load16_u align offset = - LoadPacked {memop = {ty = I32Type; align; offset}; sz = Mem16; ext = ZX} + Load {ty = I32Type; align; offset; sz = Some (Mem16, ZX)} let i64_load8_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = SX} + Load {ty = I64Type; align; offset; sz = Some (Mem8, SX)} let i64_load8_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem8; ext = ZX} + Load {ty = I64Type; align; offset; sz = Some (Mem8, ZX)} let i64_load16_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = SX} + Load {ty = I64Type; align; offset; sz = Some (Mem16, SX)} let i64_load16_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem16; ext = ZX} + Load {ty = I64Type; align; offset; sz = Some (Mem16, ZX)} let i64_load32_s align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = SX} + Load {ty = I64Type; align; offset; sz = Some (Mem32, SX)} let i64_load32_u align offset = - LoadPacked {memop = {ty = I64Type; align; offset}; sz = Mem32; ext = ZX} + 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 = - StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem8} + Store {ty = I32Type; align; offset; sz = Some Mem8} let i32_store16 align offset = - StorePacked {memop = {ty = I32Type; align; offset}; sz = Mem16} + Store {ty = I32Type; align; offset; sz = Some Mem16} let i64_store8 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem8} + Store {ty = I64Type; align; offset; sz = Some Mem8} let i64_store16 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem16} + Store {ty = I64Type; align; offset; sz = Some Mem16} let i64_store32 align offset = - StorePacked {memop = {ty = I64Type; align; offset}; sz = Mem32} + Store {ty = I64Type; align; offset; sz = Some Mem32} let i32_clz = Unary (I32 I32Op.Clz) let i32_ctz = Unary (I32 I32Op.Ctz) From cf2d51d13c347f554cb2be32a8093ab16a1415e1 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 16:54:46 +0200 Subject: [PATCH 32/44] Rename expressions to instructions --- ml-proto/host/arrange.ml | 16 ++++++++-------- ml-proto/host/arrange.mli | 2 +- ml-proto/host/encode.ml | 16 +++++++--------- ml-proto/host/parser.mly | 16 ++++++++-------- ml-proto/spec/ast.ml | 22 +++++++++++----------- ml-proto/spec/check.ml | 17 +++++++++-------- ml-proto/spec/decode.ml | 30 ++++++++++++++---------------- ml-proto/spec/eval.ml | 16 ++++++++-------- 8 files changed, 66 insertions(+), 69 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 188eb93b8b..6185be79b9 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -196,20 +196,20 @@ let var x = string_of_int 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 = match e.it with | Unreachable -> Atom "unreachable" | Nop -> Atom "nop" | Drop -> Atom "drop" - | Block es -> Node ("block", list expr es) - | Loop es -> Node ("loop", list expr es) + | Block es -> Node ("block", list instr es) + | Loop es -> Node ("loop", list instr es) | Br (n, x) -> Atom ("br " ^ int n ^ " " ^ var x) | BrIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) | BrTable (n, xs, x) -> Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) | Return -> Atom "return" | If (es1, es2) -> - Node ("if", [Node ("then", list expr es1); Node ("else", list expr es2)]) + Node ("if", [Node ("then", list instr es1); Node ("else", list instr es2)]) | Select -> Atom "select" | Call x -> Atom ("call " ^ var x) | CallImport x -> Atom ("call_import " ^ var x) @@ -233,15 +233,15 @@ let rec expr e = | Trapping msg -> Atom ("trap[\"" ^ String.escaped msg ^ "\"]") | Label (es_cont, vs, es) -> let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in - Node ("label[...]", list expr (ves @ es)) + Node ("label[...]", list instr (ves @ es)) | Local (n, vs_local, vs, es) -> let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in Node ("local" ^ string_of_int n ^ "[" ^ String.concat " " (List.map string_of_value vs_local) ^ - "]", list expr (ves @ es)) + "]", list instr (ves @ es)) let const c = - list expr c.it + list instr c.it (* Functions *) @@ -251,7 +251,7 @@ let func i f = Node ("func $" ^ string_of_int i, [Node ("type " ^ var ftype, [])] @ decls "local" locals @ - list expr body + list instr body ) let start x = Node ("start " ^ var x, []) diff --git a/ml-proto/host/arrange.mli b/ml-proto/host/arrange.mli index dcbc99901e..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 : Ast.expr -> 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 cd75daa72e..7b032984ba 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -85,8 +85,6 @@ let encode m = let elem_type = function | AnyFuncType -> u8 0x20 - let expr_type t = vec1 value_type t - let func_type = function | FuncType (ins, out) -> u8 0x40; vec value_type ins; vec value_type out @@ -103,15 +101,15 @@ let encode m = let var x = vu x.it let var32 x = vu32 (Int32.of_int x.it) - let rec expr e = + let rec instr e = match e.it with | Unreachable -> op 0x00 - | Block es -> op 0x01; list expr es; op 0x0f - | Loop es -> op 0x02; list expr es; op 0x0f + | Block es -> op 0x01; list instr es; op 0x0f + | Loop es -> op 0x02; list instr es; op 0x0f | If (es1, es2) -> - op 0x03; list expr es1; + op 0x03; list instr es1; if es2 <> [] then op 0x04; - list expr es2; op 0x0f + 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 @@ -329,7 +327,7 @@ let encode m = | Trapping _ | Label _ | Local _ -> assert false let const c = - list expr c.it; op 0x0f + list instr c.it; op 0x0f (* Sections *) @@ -420,7 +418,7 @@ let encode m = vec local (compress locals); let g = gap () in let p = pos s in - list expr body; + list instr body; patch_gap g (pos s - p) let code_section fs = diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 676b904713..c9b25ba60c 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -158,14 +158,14 @@ let implicit_decl c t at = %token TEXT %token VAR %token VALUE_TYPE -%token Ast.expr' * Values.value> CONST -%token UNARY -%token BINARY -%token TEST -%token COMPARE -%token CONVERT -%token Memory.offset -> Ast.expr'> LOAD -%token Memory.offset -> Ast.expr'> STORE +%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 diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index ec9867e130..be20bab1b8 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -5,7 +5,7 @@ * * x : var * v : value - * e : expr + * e : instrr * f : func * m : module_ * @@ -73,19 +73,19 @@ type storeop = Memory.mem_size memop type var = int Source.phrase type literal = value Source.phrase -type expr = expr' Source.phrase -and expr' = +type instr = instr' Source.phrase +and instr' = | Unreachable (* trap unconditionally *) | Nop (* do nothing *) | Drop (* forget a value *) | Select (* branchless conditional *) - | Block of expr list (* execute in sequence *) - | Loop of expr list (* loop header *) + | 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 expr list * expr list (* conditional *) + | If of instr list * instr list (* conditional *) | Call of var (* call function *) | CallImport of var (* call imported function *) | CallIndirect of var (* call function through table *) @@ -106,14 +106,14 @@ and expr' = | GrowMemory (* grow linear memory *) (* Administrative expressions *) - | Trapping of string (* trap *) - | Label of expr list * value list * expr list (* control stack *) - | Local of int * value list * value list * expr list (* call stack *) + | Trapping of string (* trap *) + | Label of instr list * value list * instr list (* control stack *) + | Local of int * value list * value list * instr list (* call stack *) (* Globals & Functions *) -type const = expr list Source.phrase +type const = instr list Source.phrase type global = global' Source.phrase and global' = @@ -127,7 +127,7 @@ and func' = { ftype : var; locals : value_type list; - body : expr list; + body : instr list; } diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 6baf562f2d..6920dcf8d4 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -134,12 +134,12 @@ let check_result_arity r at = | Bot -> () (* - * check_expr : context -> expr_type_future -> expr -> unit + * check_instr : context -> instr -> stack_type -> unit * * Conventions: * c : context - * e : expr - * es : expr list + * e : instr + * es : instr list * v : value * t : value_type var * ts : stack_type @@ -154,7 +154,7 @@ 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_expr (c : context) (e : expr) (stack : stack_type) : op_type = +let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = match e.it with | Unreachable -> [] --> Bot @@ -303,7 +303,7 @@ let rec check_expr (c : context) (e : expr) (stack : stack_type) : op_type = error e.at "arity mismatch for local result" | r' -> [] --> r' -and check_block (c : context) (es : expr list) : result_type = +and check_block (c : context) (es : instr list) : result_type = match es with | [] -> Stack [] @@ -314,7 +314,7 @@ and check_block (c : context) (es : expr list) : result_type = match r1 with | Bot -> Bot | Stack ts0 -> - let ts2, r2 = check_expr c e (List.rev ts0) in + 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 @@ -334,7 +334,7 @@ and check_block (c : context) (es : expr list) : result_type = * c : context * m : module_ * f : func - * e : expr + * e : instr * v : value * t : value_type * s : func_type @@ -356,7 +356,8 @@ let is_const e = | _ -> false let check_const (c : context) (const : const) (t : value_type) = - require (List.for_all is_const const.it) const.at "constant expression required"; + 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 diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 9a5e469963..5243852916 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -126,16 +126,14 @@ 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 - FuncType (ins, match out with None -> [] | Some t -> [t]) + let out = vec value_type s in + FuncType (ins, out) -(* Decode expressions *) +(* Decode instructions *) open Ast open Operators @@ -165,23 +163,23 @@ let args1 b stack s pos = | [e], stack' -> Some e, stack' | _ -> assert false -let rec expr s = +let rec instr s = let pos = pos s in match op s with | 0x00 -> unreachable | 0x01 -> - let es' = expr_block s in + let es' = instr_block s in expect 0x0f s "END opcode expected"; block es' | 0x02 -> - let es' = expr_block s in + let es' = instr_block s in expect 0x0f s "END opcode expected"; loop es' | 0x03 -> - let es1 = expr_block s in + 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 + let es2 = instr_block s in expect 0x0f s "END opcode expected"; if_ es1 es2 end else begin @@ -394,18 +392,18 @@ let rec expr s = | b -> error s pos "too few operands for operator" -and expr_block s = List.rev (expr_block' s []) -and expr_block' s es = +and instr_block s = List.rev (instr_block' s []) +and instr_block' s es = if eos s then es else match peek s with | None | Some (0x04 | 0x0f) -> es | _ -> let pos = pos s in - let e' = expr s in - expr_block' s (Source.(e' @@ region s pos pos) :: es) + let e' = instr s in + instr_block' s (Source.(e' @@ region s pos pos) :: es) let const s = - let c = at expr_block s in + let c = at instr_block s in expect 0x0f s "`end` opcode expected"; c @@ -532,7 +530,7 @@ let local s = let code s = let locals = List.flatten (vec local s) in let size = vu s in - let body = expr_block (substream s (pos s + size)) in + let body = instr_block (substream s (pos s + size)) in {locals; body; ftype = Source.((-1) @@ Source.no_region)} let code_section s = diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 8eafbf8012..715d676abe 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -102,9 +102,9 @@ let elem c i t at = (* * Conventions: * c : config - * e : expr + * e : instr * v : value - * es : expr list + * es : instr list * vs : value list *) @@ -118,8 +118,8 @@ let drop n (vs : value stack) at = try Lib.List.drop n vs with Failure _ -> Crash.error at "stack underflow" -let rec step_expr (c : config) (vs : value stack) (e : expr) - : value stack * expr list = +let rec step_instr (c : config) (vs : value stack) (e : instr) + : value stack * instr list = match e.it, vs with | Unreachable, vs -> vs, [Trapping "unreachable executed" @@ e.at] @@ -283,7 +283,7 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) [], [Trapping msg @@ at] | Label (es_cont, vs', e :: es), vs -> - let vs'', es' = step_expr c vs' e in + let vs'', es' = step_instr c vs' e in vs, [Label (es_cont, vs'', es' @ es) @@ e.at] | Local (n, vs_local, vs', []), vs -> @@ -301,19 +301,19 @@ let rec step_expr (c : config) (vs : value stack) (e : expr) | Local (n, vs_local, vs', e :: es), vs -> let c' = {c with locals = List.map ref vs_local; resources = c.resources - 1} in - let vs'', es' = step_expr c' vs' e in + let vs'', es' = step_instr c' vs' e in vs, [Local (n, List.map (!) c'.locals, vs'', es' @ es) @@ e.at] | _, _ -> Crash.error e.at "type error: missing or ill-typed operand on stack" -let rec eval_block (c : config) (vs : value stack) (es : expr list) : value stack = +let rec eval_block (c : config) (vs : value stack) (es : instr list) : value stack = match es with | [] -> vs | [{it = Trapping msg; at}] -> Trap.error at msg | e :: es -> - let vs', es' = step_expr c vs e in + let vs', es' = step_instr c vs e in eval_block c vs' (es' @ es) From 812b5a0b43455ba9cabd7328f5930bec83ce5d2e Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Wed, 24 Aug 2016 17:10:52 +0200 Subject: [PATCH 33/44] Added todos --- ml-proto/host/parser.mly | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index c9b25ba60c..4f1dae6af0 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -256,8 +256,8 @@ plain_instr : | UNREACHABLE { fun c -> unreachable } | NOP { fun c -> nop } | DROP { fun c -> drop } - | RETURN { fun c -> return } | SELECT { fun c -> select } + | RETURN { fun c -> return } | CALL var { fun c -> call ($2 c func) } | CALL_IMPORT var { fun c -> call_import ($2 c import) } | CALL_INDIRECT var { fun c -> call_indirect ($2 c type_) } @@ -278,6 +278,7 @@ plain_instr : | GROW_MEMORY { fun c -> grow_memory } ; ctrl_instr : + /* TODO: move branches to plain_instr once arities are gone */ | BR nat var { fun c -> br $2 ($3 c label) } | BR_IF nat var { fun c -> br_if $2 ($3 c label) } | BR_TABLE nat var var_list @@ -299,6 +300,7 @@ expr : /* Sugar */ ; 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 -> From 4a63a5c6c1a48fea034c764f963033e147eab440 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Tue, 30 Aug 2016 17:13:16 +0200 Subject: [PATCH 34/44] Tweak error message --- ml-proto/spec/check.ml | 3 ++- ml-proto/test/start.wast | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 32c35b887c..a15d3131fb 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -433,7 +433,8 @@ let check_global c g = let check_start c start = Lib.Option.app (fun x -> - require (func c x = FuncType ([], [])) x.at "start function must be nullary" + require (func c x = FuncType ([], [])) x.at + "start function must not have parameters or results" ) start module NameSet = Set.Make(String) diff --git a/ml-proto/test/start.wast b/ml-proto/test/start.wast index afe4fa5593..94ba2cc539 100644 --- a/ml-proto/test/start.wast +++ b/ml-proto/test/start.wast @@ -7,14 +7,14 @@ (func $main (result i32) (return (i32.const 0))) (start $main) ) - "start function must be nullary" + "start function" ) (assert_invalid (module (func $main (param $a i32)) (start $main) ) - "start function must be nullary" + "start function" ) (module (memory (data "A")) From 0acc8b069f9fd6fb3a7bd78cb5ea0c682c16cee0 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 2 Sep 2016 11:51:00 +0200 Subject: [PATCH 35/44] Numeric section names (PR 740) --- ml-proto/host/encode.ml | 24 ++++++++--------- ml-proto/spec/decode.ml | 59 ++++++++++++++++++++--------------------- 2 files changed, 41 insertions(+), 42 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 7b032984ba..b289e64ea3 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -334,7 +334,7 @@ let encode m = let section id f x needed = if needed then begin - string id; + u8 id; let g = gap () in let p = pos s in f x; @@ -343,7 +343,7 @@ let encode m = (* Type section *) let type_section ts = - section "type" (vec func_type) ts (ts <> []) + section 1 (vec func_type) ts (ts <> []) (* Import section *) let import imp = @@ -351,13 +351,13 @@ let encode m = var itype; string module_name; string func_name 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 limits vu lim = @@ -369,7 +369,7 @@ let encode m = elem_type etype; limits vu32 tlimits let table_section tabo = - section "table" (opt table) tabo (tabo <> None) + section 4 (opt table) tabo (tabo <> None) (* Memory section *) let memory mem = @@ -377,7 +377,7 @@ let encode m = limits vu32 mlimits let memory_section memo = - section "memory" (opt memory) memo (memo <> None) + section 5 (opt memory) memo (memo <> None) (* Global section *) let global g = @@ -385,7 +385,7 @@ let encode m = value_type gtype; const value let global_section gs = - section "global" (vec global) gs (gs <> []) + section 6 (vec global) gs (gs <> []) (* Export section *) let export exp = @@ -398,11 +398,11 @@ let encode m = let export_section exps = (*TODO: pending resolution*) let exps = List.filter (fun exp -> exp.it.kind <> `Memory) exps in - 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 = @@ -422,7 +422,7 @@ let encode m = patch_gap 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 = @@ -433,14 +433,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 *) diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 5243852916..24a8c71c8e 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -415,19 +415,20 @@ 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 + match u8 s with + | 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 - 1) "invalid section id" let section tag f default s = if eos s then default else @@ -560,10 +561,10 @@ 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_section s = + section `UserSection (fun s -> skip (len s - pos s) s; true) false s (* Modules *) @@ -575,31 +576,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 table = table_section s in - iterate unknown_section s; + iterate user_section s; let memory = 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; + iterate user_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 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"; From 2482e44ee33ffe37376d90eeb3567684d976d40d Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 2 Sep 2016 11:56:13 +0200 Subject: [PATCH 36/44] Move element section before code section (PR 779) --- ml-proto/host/encode.ml | 2 +- ml-proto/spec/decode.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index b289e64ea3..8a34d55020 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -455,8 +455,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/spec/decode.ml b/ml-proto/spec/decode.ml index 24a8c71c8e..498d6537a0 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -593,10 +593,10 @@ let module_ s = iterate user_section s; let start = start_section s in iterate user_section s; - let func_bodies = code_section s in - iterate user_section s; let elems = elem_section s in iterate user_section s; + let func_bodies = code_section s in + iterate user_section s; let data = data_section s in iterate user_section s; require (pos s = len s) s (len s) "junk after last section"; From fb3be97859d6d63fd71d8c0e9e6ae8220ed08b37 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 2 Sep 2016 12:09:14 +0200 Subject: [PATCH 37/44] Require END opcode for functions; simplify streams --- ml-proto/host/encode.ml | 3 +- ml-proto/spec/decode.ml | 65 +++++++++++++++++++++-------------------- 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 8a34d55020..c0091834b2 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -415,10 +415,11 @@ let encode m = let code f = let {locals; body; _} = f.it in - vec local (compress locals); let g = gap () in let p = pos s in + vec local (compress locals); list instr body; + u8 0x0f; patch_gap g (pos s - p) let code_section fs = diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 498d6537a0..c284ddadc5 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) @@ -108,6 +105,13 @@ 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 vec1 f s = let b = bool s in opt f b s +let sized f s = + let size = vu s in + let start = pos s in + let x = f s in + require (pos s = start + size) s start "section size mismatch"; + x + (* Types *) @@ -404,7 +408,7 @@ and instr_block' s es = let const s = let c = at instr_block s in - expect 0x0f s "`end` opcode expected"; + expect 0x0f s "END opcode expected"; c @@ -415,31 +419,28 @@ let trace s name = (name ^ " @ " ^ string_of_int (pos s) ^ " = " ^ string_of_byte (read s)) let id s = - match u8 s with - | 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 - 1) "invalid section id" + 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 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 + match id s with + | Some tag' when tag' = tag -> ignore (get s); sized f s + | _ -> default (* Type section *) @@ -530,12 +531,12 @@ let local s = let code s = let locals = List.flatten (vec local s) in - let size = vu s in - let body = instr_block (substream s (pos s + size)) in + let body = instr_block s in + expect 0x0f s "END opcode expected"; {locals; body; ftype = Source.((-1) @@ Source.no_region)} let code_section s = - section `CodeSection (vec (at code)) [] s + section `CodeSection (vec (at (sized code))) [] s (* Element section *) From ab65e4d17db1c34ac7c644621b78664e596a7bf2 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Mon, 5 Sep 2016 15:01:08 +0200 Subject: [PATCH 38/44] Check length & value of var(u)ints --- ml-proto/host/encode.ml | 15 ++++++++------- ml-proto/host/parser.mly | 13 ++++--------- ml-proto/spec/decode.ml | 29 ++++++++++++++++++----------- 3 files changed, 30 insertions(+), 27 deletions(-) diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index c0091834b2..b1cb927389 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -63,14 +63,15 @@ 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; 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)); patch s (p + 1) (lsb ((n lsr 7) lor 0x80)); patch s (p + 2) (lsb ((n lsr 14) lor 0x80)); - patch s (p + 3) (lsb (n lsr 21)) + patch s (p + 3) (lsb ((n lsr 21) lor 0x80)); + patch s (p + 4) (lsb (n lsr 28)) (* Types *) @@ -335,10 +336,10 @@ let encode m = let section id f x needed = if needed then begin u8 id; - let g = gap () in + 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 *) @@ -415,12 +416,12 @@ 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 instr body; u8 0x0f; - patch_gap g (pos s - p) + patch_gap32 g (pos s - p) let code_section fs = section 9 (vec code) fs (fs <> []) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 4f1dae6af0..98ff908610 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -35,21 +35,16 @@ let ati i = (* Literals *) let literal f s = - try f s with - | Failure msg -> error s.at ("constant out of range: " ^ msg) - | _ -> error s.at "constant out of range" + try f s with Failure _ -> error s.at ("constant out of range") let int s at = - try int_of_string s with Failure _ -> - error at "int constant out of range" + try int_of_string s with Failure _ -> error at "int constant out of range" let int32 s at = - try I32.of_string s with Failure _ -> - error at "i32 constant out of range" + try I32.of_string s with Failure _ -> error at "i32 constant out of range" let int64 s at = - try I64.of_string s with Failure _ -> - error at "i64 constant out of range" + try I64.of_string s with Failure _ -> error at "i64 constant out of range" (* Symbolic variables *) diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index c284ddadc5..fd80c1fdd4 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -77,24 +77,31 @@ 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 vu s = Int64.to_int (vuN 31 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) From 025fa0bd4ee5c414cd01c9f0a359bb39f4a34def Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Mon, 5 Sep 2016 15:35:49 +0200 Subject: [PATCH 39/44] Abstract length limit --- ml-proto/spec/decode.ml | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index fd80c1fdd4..cc21b32217 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -97,7 +97,6 @@ let rec vsN n s = let vu1 s = Int64.to_int (vuN 1 s) let vu7 s = Int64.to_int (vuN 7 s) -let vu s = Int64.to_int (vuN 31 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 @@ -105,15 +104,21 @@ 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 = vu s in + let size = len32 s in let start = pos s in let x = f s in require (pos s = start + size) s start "section size mismatch"; @@ -150,16 +155,15 @@ open Ast open Operators let op s = u8 s -let arity s = vu s +let arity s = u8 s let memop s = - let align = vu s in + let align = len32 s in (*TODO: check flag bits*) let offset = vu64 s in align, offset -let var s = vu s -let var32 s = Int32.to_int (vu32 s) +let var s = len32 s let rec args n stack s pos = args' n stack [] s pos and args' n stack es s pos = @@ -532,7 +536,7 @@ 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 From cddb36bbf4d4d1ae4928a7797ffb926db9ef1513 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Mon, 5 Sep 2016 16:07:45 +0200 Subject: [PATCH 40/44] Make variables i32 --- ml-proto/given/lib.ml | 8 ++++++ ml-proto/given/lib.mli | 3 +++ ml-proto/host/arrange.ml | 2 +- ml-proto/host/encode.ml | 5 ++-- ml-proto/host/import.ml | 2 +- ml-proto/host/parser.mly | 42 +++++++++++++++++--------------- ml-proto/host/print.ml | 6 ++--- ml-proto/spec/ast.ml | 2 +- ml-proto/spec/check.ml | 4 +-- ml-proto/spec/decode.ml | 4 +-- ml-proto/spec/eval.ml | 14 +++++------ ml-proto/spec/kernel.ml | 2 +- ml-proto/spec/table.ml | 2 +- ml-proto/spec/table.mli | 2 +- ml-proto/test/br.wast | 2 +- ml-proto/test/br_if.wast | 2 +- ml-proto/test/br_table.wast | 4 +-- ml-proto/test/call.wast | 2 +- ml-proto/test/call_indirect.wast | 2 +- 19 files changed, 61 insertions(+), 49 deletions(-) diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index c13a00666b..5820f3e1ed 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -19,6 +19,14 @@ struct | n, _::xs' when n > 0 -> drop (n - 1) xs' | _ -> failwith "drop" + let length32 xs = Int32.of_int (List.length xs) + + let rec nth32 xs n = + match n, xs with + | 0l, x::_ -> x + | n, _::xs' when n > 0l -> nth32 xs' (Int32.sub n 1l) + | _ -> failwith "nth32" + let rec last = function | x::[] -> x | _::xs -> last xs diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index c0cb6bf16d..ef7c3addc3 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -7,6 +7,9 @@ sig val take : int -> 'a list -> 'a list (* raise Failure *) val drop : int -> 'a list -> 'a list (* raise Failure *) + val length32 : 'a list -> int32 + val nth32 : 'a list -> int32 -> 'a (* raise Failure *) + val last : 'a list -> 'a (* raise Failure *) val split_last : 'a list -> 'a list * 'a (* raise Failure *) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 6185be79b9..61d518e17f 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -192,7 +192,7 @@ let storeop 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" diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index b1cb927389..b4113dc5d0 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -99,8 +99,7 @@ let encode m = let op n = u8 n let memop {align; offset; _} = vu align; vu64 offset (*TODO: to be resolved*) - let var x = vu x.it - let var32 x = vu32 (Int32.of_int x.it) + let var x = vu32 x.it let rec instr e = match e.it with @@ -114,7 +113,7 @@ let encode m = | 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 var32 xs; var32 x + | BrTable (n, xs, x) -> op 0x08; vu n; vec var xs; var x | Return -> op 0x09 | Nop -> op 0x0a | Drop -> op 0x0b diff --git a/ml-proto/host/import.ml b/ml-proto/host/import.ml index 0cf09a148e..5489bd7251 100644 --- a/ml-proto/host/import.ml +++ b/ml-proto/host/import.ml @@ -13,7 +13,7 @@ let register name lookup = registry := Registry.add name lookup !registry let lookup m import = let {module_name; func_name; itype} = import.it in - let ty = List.nth m.it.types itype.it in + let ty = Lib.List.nth32 m.it.types itype.it in try Registry.find module_name !registry func_name ty with Not_found -> Unknown.error import.at ("no function \"" ^ module_name ^ "." ^ func_name ^ diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 98ff908610..ed93f96158 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -51,15 +51,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; funcs : space; imports : space; - locals : space; globals : space; labels : int VarMap.t} + locals : space; globals : space; labels : int32 VarMap.t} let empty_context () = {types = empty_types (); funcs = empty (); imports = empty (); @@ -88,49 +88,50 @@ let label c x = 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.List.length32 c.types.tlist) c.types.tmap; c.types.tlist <- c.types.tlist @ [ty] 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 let bind_func c x = bind "function" c.funcs x let bind_import c x = bind "import" c.imports x let bind_local c x = bind "local" c.locals x let bind_global c x = bind "global" c.globals 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_type c ty = c.types.tlist <- c.types.tlist @ [ty] -let anon space n = space.count <- space.count + n +let anon space n = space.count <- Int32.add space.count n -let anon_func c = anon c.funcs 1 -let anon_import c = anon c.imports 1 -let anon_locals c ts = anon c.locals (List.length ts) -let anon_global c = anon c.globals 1 -let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} +let anon_func c = anon c.funcs 1l +let anon_import c = anon c.imports 1l +let anon_locals c ts = anon c.locals (Lib.List.length32 ts) +let anon_global c = anon c.globals 1l +let anon_label c = {c with labels = VarMap.map (Int32.add 1l) c.labels} let empty_type = FuncType ([], []) let explicit_decl c name t at = let x = name c type_ in if - x.it < List.length c.types.tlist && + x.it < Lib.List.length32 c.types.tlist && t <> empty_type && - t <> List.nth c.types.tlist x.it + t <> Lib.List.nth32 c.types.tlist x.it then error at "signature mismatch"; x let implicit_decl 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.List.length32 c.types.tlist in anon_type c t; i @@ at + | Some i -> Int32.of_int i @@ at %} @@ -217,7 +218,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 : @@ -353,7 +354,7 @@ func_body : | 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 @@ -392,7 +393,8 @@ export_opt : | /* empty */ { fun c -> [] } | TEXT { let at = at () in - fun c -> [{name = $1; kind = `Func (c.funcs.count - 1 @@ at)} @@ at] } + fun c -> + [{name = $1; kind = `Func (Int32.sub c.funcs.count 1l @@ at)} @@ at] } ; diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 68c29a47fc..bd4b47c6b5 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -8,7 +8,7 @@ open Printf open Types let func_type m f = - List.nth m.it.types f.it.ftype.it + Lib.List.nth32 m.it.types f.it.ftype.it let string_of_table_type = function | None -> "()" @@ -25,12 +25,12 @@ let print_export m i ex = let {name; kind} = ex.it in let ascription = match kind with - | `Func x -> string_of_func_type (func_type m (List.nth m.it.funcs x.it)) + | `Func x -> string_of_func_type (func_type m (Lib.List.nth32 m.it.funcs x.it)) | `Memory -> "memory" in printf "export \"%s\" : %s\n" name ascription 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 (* Ast *) diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index be20bab1b8..0739ef0d09 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -70,7 +70,7 @@ type storeop = Memory.mem_size memop (* Expressions *) -type var = int Source.phrase +type var = int32 Source.phrase type literal = value Source.phrase type instr = instr' Source.phrase diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index a15d3131fb..bf3b46714e 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -36,8 +36,8 @@ type context = } 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.List.nth32 list x.it with Failure _ -> + error x.at ("unknown " ^ category ^ " " ^ Int32.to_string x.it) let type_ types x = lookup "function type" types x let func c x = lookup "function" c.funcs x diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index cc21b32217..2859e9fa60 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -163,7 +163,7 @@ let memop s = let offset = vu64 s in align, offset -let var s = len32 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 = @@ -544,7 +544,7 @@ let code s = let locals = List.flatten (vec local s) in let body = instr_block s in expect 0x0f s "END opcode expected"; - {locals; body; ftype = Source.((-1) @@ Source.no_region)} + {locals; body; ftype = Source.((-1l) @@ Source.no_region)} let code_section s = section `CodeSection (vec (at (sized code))) [] s diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 715d676abe..52c8e47640 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -16,8 +16,8 @@ type 'a map = 'a Map.t type instance = { module_ : module_; - imports : (int * import) list; - exports : int map; + imports : (int32 * import) list; + exports : int32 map; table : Table.t option; memory : Memory.t option; globals : value ref list; @@ -65,8 +65,8 @@ type config = 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.List.nth32 list x.it with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ Int32.to_string x.it) let type_ c x = lookup "type" c.instance.module_.it.types x let func c x = lookup "function" c.instance.module_.it.funcs x @@ -270,11 +270,11 @@ let rec step_instr (c : config) (vs : value stack) (e : instr) | Label (es_cont, vs', []), vs -> vs' @ vs, [] - | Label (es_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> + | Label (es_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0l -> keep n vs' e.at @ vs, es_cont | Label (es_cont, vs', {it = Br (n, i); at} :: es), vs -> - vs', [Br (n, (i.it - 1) @@ i.at) @@ e.at] + vs', [Br (n, (Int32.sub i.it 1l) @@ i.at) @@ e.at] | Label (es_cont, vs', {it = Return; at} :: es), vs -> vs', [Return @@ at] @@ -289,7 +289,7 @@ let rec step_instr (c : config) (vs : value stack) (e : instr) | Local (n, vs_local, vs', []), vs -> vs' @ vs, [] - | Local (n, vs_local, vs', {it = Br (n', i); at} :: es), vs when i.it = 0 -> + | Local (n, vs_local, vs', {it = Br (n', i); at} :: es), vs when i.it = 0l -> if n <> n' then Crash.error at "inconsistent result arity"; keep n vs' at @ vs, [] diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml index d89b12debf..d04f936a9b 100644 --- a/ml-proto/spec/kernel.ml +++ b/ml-proto/spec/kernel.ml @@ -67,7 +67,7 @@ type hostop = (* Expressions *) -type var = int Source.phrase +type var = int32 Source.phrase type literal = value Source.phrase type expr = expr' Source.phrase diff --git a/ml-proto/spec/table.ml b/ml-proto/spec/table.ml index a2b96375a0..9e9e9eda37 100644 --- a/ml-proto/spec/table.ml +++ b/ml-proto/spec/table.ml @@ -4,7 +4,7 @@ open Values type size = int32 type index = int32 -type elem = int option +type elem = int32 option type elem_type = Types.elem_type type table' = elem array diff --git a/ml-proto/spec/table.mli b/ml-proto/spec/table.mli index 579c917545..5cbfa7bb51 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 = int option +type elem = int32 option type elem_type = Types.elem_type exception Bounds diff --git a/ml-proto/test/br.wast b/ml-proto/test/br.wast index da7f1074dd..964aa0cfa2 100644 --- a/ml-proto/test/br.wast +++ b/ml-proto/test/br.wast @@ -429,6 +429,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 957cec4a4b..ed98fa4091 100644 --- a/ml-proto/test/br_if.wast +++ b/ml-proto/test/br_if.wast @@ -319,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 ff46c57428..5b834d0735 100644 --- a/ml-proto/test/br_table.wast +++ b/ml-proto/test/br_table.wast @@ -1378,7 +1378,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" ) @@ -1397,7 +1397,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/call.wast b/ml-proto/test/call.wast index 056412bca0..67d95c26f5 100644 --- a/ml-proto/test/call.wast +++ b/ml-proto/test/call.wast @@ -236,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 2b464d7f1a..6788b1b3c8 100644 --- a/ml-proto/test/call_indirect.wast +++ b/ml-proto/test/call_indirect.wast @@ -371,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 function type" ) From 9e4b6a9c90384cad768e11f9ccdf1cdd3f9ee54a Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Thu, 8 Sep 2016 11:34:21 +0200 Subject: [PATCH 41/44] Remove kernel.ml --- ml-proto/spec/kernel.ml | 187 ---------------------------------------- 1 file changed, 187 deletions(-) delete mode 100644 ml-proto/spec/kernel.ml diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml deleted file mode 100644 index d89b12debf..0000000000 --- a/ml-proto/spec/kernel.ml +++ /dev/null @@ -1,187 +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 *) - | CallImport of var * expr list (* call imported 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 : Types.value_type; - value : expr; -} - -type func = func' Source.phrase -and func' = -{ - ftype : var; - locals : value_type list; - body : expr; -} - - -(* Tables & Memories *) - -type 'size limits = 'size limits' Source.phrase -and 'size limits' = -{ - min : 'size; - max : 'size option; -} - -type table = table' Source.phrase -and table' = -{ - tlimits : Table.size limits; - etype : elem_type; -} - -type memory = memory' Source.phrase -and memory' = -{ - mlimits : Memory.size limits; -} - -type 'data segment = 'data segment' Source.phrase -and 'data segment' = -{ - offset : expr; - init : 'data; -} - -type table_segment = var list segment -type memory_segment = string segment - - -(* Modules *) - -type export = export' Source.phrase -and export' = -{ - name : string; - kind : [`Func of var | `Memory] -} - -type import = import' Source.phrase -and import' = -{ - itype : var; - module_name : string; - func_name : string; -} - -type module_ = module_' Source.phrase -and module_' = -{ - types : Types.func_type list; - globals : global list; - table : table option; - memory : memory option; - funcs : func list; - start : var option; - elems : table_segment list; - data : memory_segment list; - imports : import list; - exports : export list; -} From 5440555f43980b55d9784c42c072ab58e4f4def8 Mon Sep 17 00:00:00 2001 From: rossberg-chromium Date: Thu, 8 Sep 2016 15:31:10 +0200 Subject: [PATCH 42/44] Eliminate administrative expressions, in preparation of import/export merge --- ml-proto/host/arrange.ml | 10 -- ml-proto/host/encode.ml | 2 - ml-proto/spec/ast.ml | 5 - ml-proto/spec/check.ml | 22 --- ml-proto/spec/eval.ml | 290 +++++++++++++++++++-------------------- 5 files changed, 145 insertions(+), 184 deletions(-) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 6185be79b9..9e540f4987 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -230,16 +230,6 @@ let rec instr e = | CurrentMemory -> Atom "current_memory" | GrowMemory -> Atom "grow_memory" - | Trapping msg -> Atom ("trap[\"" ^ String.escaped msg ^ "\"]") - | Label (es_cont, vs, es) -> - let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in - Node ("label[...]", list instr (ves @ es)) - | Local (n, vs_local, vs, es) -> - let ves = List.map (fun v -> Const (v @@ e.at) @@ e.at) (List.rev vs) in - Node ("local" ^ string_of_int n ^ "[" ^ - String.concat " " (List.map string_of_value vs_local) ^ - "]", list instr (ves @ es)) - let const c = list instr c.it diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index 7b032984ba..de97e1d2d8 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -324,8 +324,6 @@ let encode m = | Convert (F64 F64Op.DemoteF64) -> assert false | Convert (F64 F64Op.ReinterpretInt) -> op 0xb3 - | Trapping _ | Label _ | Local _ -> assert false - let const c = list instr c.it; op 0x0f diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index be20bab1b8..26c4903e0f 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -105,11 +105,6 @@ and instr' = | CurrentMemory (* size of linear memory *) | GrowMemory (* grow linear memory *) - (* Administrative expressions *) - | Trapping of string (* trap *) - | Label of instr list * value list * instr list (* control stack *) - | Local of int * value list * value list * instr list (* call stack *) - (* Globals & Functions *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index a15d3131fb..8f547b50a6 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -285,28 +285,6 @@ let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = ignore (memory c e.at); [I32Type] --> Stack [I32Type] - | Trapping msg -> - [] --> Bot - - | Label (es0, vs, es) -> - let vr = unknown () in - let c' = {c with labels = vr :: c.labels} in - let r1 = check_block c' es0 in - let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in - let r2 = check_block c' (ves @ es) in - [] --> join !vr (join r1 r2 e.at) e.at - - | Local (n, vs0, vs, es) -> - let locals = List.map Values.type_of vs0 in - let vr = unknown () in - let c' = {c with locals; labels = vr :: c.labels} in - let ves = List.rev (List.map (fun v -> Const (v @@ e.at) @@ e.at) vs) in - let r = check_block c' (ves @ es) in - match join !vr r e.at with - | Stack ts when List.length ts <> n -> - error e.at "arity mismatch for local result" - | r' -> [] --> r' - and check_block (c : context) (es : instr list) : result_type = match es with | [] -> diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 715d676abe..438de0ee2a 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -55,12 +55,36 @@ let numeric_error at = function (* Configurations *) -type config = -{ - instance : instance; - locals : value ref list; - resources : int; -} +(* + * 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 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 + +and block = {target : instr list; bcontext : block_context} +and call = {locals : value list; arity : int; ccontext : call_context} + +type config = {instance : instance} let resource_limit = 1000 @@ -68,11 +92,18 @@ let lookup category list x = try List.nth list x.it with Failure _ -> Crash.error x.at ("undefined " ^ category ^ " " ^ string_of_int x.it) +let update category list x y = + try Lib.List.take x.it list @ [y] @ Lib.List.drop (x.it + 1) list + with Failure _ -> + Crash.error x.at ("undefined " ^ category ^ " " ^ string_of_int x.it) + let type_ c x = lookup "type" c.instance.module_.it.types x let func c x = lookup "function" c.instance.module_.it.funcs x let import c x = lookup "import" c.instance.imports x let global c x = lookup "global" c.instance.globals x + let local c x = lookup "local" c.locals x +let update_local c x v = {c with locals = update "local" c.locals x v} let export inst name = try Map.find name.it inst.exports with Not_found -> @@ -96,6 +127,14 @@ let elem c i t at = | exception Table.Bounds -> Trap.error at ("undefined element " ^ Int32.to_string i) +let take n (vs : 'a stack) at = + try Lib.List.take n vs with Failure _ -> + Crash.error at "stack underflow" + +let drop n (vs : 'a stack) at = + try Lib.List.drop n vs with Failure _ -> + Crash.error at "stack underflow" + (* Evaluation *) @@ -109,107 +148,103 @@ let elem c i t at = *) let length32 xs = Int32.of_int (List.length xs) +let nth32 xs n = List.nth xs (Int32.to_int n) -let keep n (vs : value stack) at = - try Lib.List.take n vs with Failure _ -> - Crash.error at "stack underflow" - -let drop n (vs : value stack) at = - try Lib.List.drop n vs with Failure _ -> - Crash.error at "stack underflow" +let eval_call (c : config) (f : func) (es, vs, bs, cs : eval_context) at = + if List.length cs = resource_limit then Trap.error at "call stack exhausted"; + let FuncType (ins, out) = type_ c f.it.ftype in + let n = List.length ins in + let m = List.length out in + let args = List.rev (take n vs at) in + let locals = args @ List.map default_value f.it.locals in + [Block f.it.body @@ f.at], [], [], + {locals; arity = m; ccontext = es, drop n vs at, bs} :: cs -let rec step_instr (c : config) (vs : value stack) (e : instr) - : value stack * instr list = - match e.it, vs with - | Unreachable, vs -> - vs, [Trapping "unreachable executed" @@ e.at] +let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_context = + match e.it, vs, bs, cs with + | Unreachable, _, _, _ -> + Trap.error e.at "unreachable executed" - | Nop, vs -> - vs, [] + | Nop, _, _, _ -> + es, vs, bs, cs - | Drop, v :: vs' -> - vs', [] + | Drop, v :: vs', _, _ -> + es, vs', bs, cs - | Block es, vs -> - vs, [Label ([], [], es) @@ e.at] + | Block es', vs, bs, _ -> + es', [], {target = []; bcontext = es, vs} :: bs, cs - | Loop es, vs -> - vs, [Label ([e], [], es) @@ e.at] + | Loop es', vs, bs, _ -> + es', [], {target = [e]; bcontext = es, vs} :: bs, cs - | Br (n, x), vs -> - assert false (* abrupt *) + | Br (n, x), vs, bs, _ -> + let b = List.hd (take 1 (drop x.it bs e.at) e.at) in + let es', vs' = b.bcontext in + b.target @ es', take n vs e.at @ vs', drop (x.it + 1) bs e.at, cs - | BrIf (n, x), I32 0l :: vs' -> - drop n vs' e.at, [] + | BrIf (n, x), I32 0l :: vs', _, _ -> + es, drop n vs' e.at, bs, cs - | BrIf (n, x), I32 i :: vs' -> - vs', [Br (n, x) @@ e.at] + | 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 (length32 xs) -> - vs', [Br (n, x) @@ e.at] + | BrTable (n, xs, x), I32 i :: vs', _, _ when I32.ge_u i (length32 xs) -> + (Br (n, x) @@ e.at) :: es, vs', bs, cs - | BrTable (n, xs, x), I32 i :: vs' -> - vs', [Br (n, List.nth xs (Int32.to_int i)) @@ e.at] + | BrTable (n, xs, x), I32 i :: vs', _, _ -> + (Br (n, nth32 xs i) @@ e.at) :: es, vs', bs, cs - | Return, vs -> - assert false (* abrupt *) + | 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' -> - vs', [Block es2 @@ e.at] + | If (es1, es2), I32 0l :: vs', _, _ -> + (Block es2 @@ e.at) :: es, vs', bs, cs - | If (es1, es2), I32 i :: vs' -> - vs', [Block es1 @@ e.at] + | If (es1, es2), I32 i :: vs', _, _ -> + (Block es1 @@ e.at) :: es, vs', bs, cs - | Select, I32 0l :: v2 :: v1 :: vs' -> - v2 :: vs', [] + | Select, I32 0l :: v2 :: v1 :: vs', _, _ -> + es, v2 :: vs', bs, cs - | Select, I32 i :: v2 :: v1 :: vs' -> - v1 :: vs', [] + | Select, I32 i :: v2 :: v1 :: vs', _, _ -> + es, v1 :: vs', bs, cs - | Call x, vs -> - if c.resources = 0 then Trap.error e.at "call stack exhausted"; - let f = func c x in - let FuncType (ins, out) = type_ c f.it.ftype in - let n = List.length ins in - let m = List.length out in - let args = List.rev (keep n vs e.at) in - let locals = List.map default_value f.it.locals in - drop n vs e.at, [Local (m, args @ locals, [], f.it.body) @@ e.at] + | Call x, _, _, _ -> + eval_call c (func c x) (es, vs, bs, cs) e.at - | CallImport x, vs -> + | CallImport x, vs, _, _ -> let x, f = import c x in let FuncType (ins, out) = type_ c (x @@ e.at) in let n = List.length ins in (try - let vs' = List.rev (f (List.rev (keep n vs e.at))) in - drop n vs e.at @ vs', [] + let vs' = List.rev (f (List.rev (take n vs e.at))) in + es, drop n vs e.at @ vs', bs, cs with Crash (_, msg) -> Crash.error e.at msg) - | CallIndirect x, I32 i :: vs -> - let y = elem c i AnyFuncType e.at @@ e.at in - if type_ c x <> type_ c (func c y).it.ftype then + | CallIndirect x, I32 i :: vs, _, _ -> + let f = func c (elem c i AnyFuncType e.at @@ e.at) in + if type_ c x <> type_ c f.it.ftype then Trap.error e.at "indirect call signature mismatch"; - vs, [Call y @@ e.at] + eval_call c f (es, vs, bs, cs) e.at - | GetLocal x, vs -> - !(local c x) :: vs, [] + | GetLocal x, vs, _, c :: _ -> + es, (local c x) :: vs, bs, cs - | SetLocal x, v :: vs' -> - local c x := v; - vs', [] + | SetLocal x, v :: vs', _, c :: cs' -> + es, vs', bs, update_local c x v :: cs' - | TeeLocal x, v :: vs' -> - local c x := v; - v :: vs', [] + | TeeLocal x, v :: vs', _, c :: cs' -> + es, v :: vs', bs, update_local c x v :: cs' - | GetGlobal x, vs -> - !(global c x) :: vs, [] + | GetGlobal x, vs, _, _ -> + es, !(global c x) :: vs, bs, cs - | SetGlobal x, v :: vs' -> + | SetGlobal x, v :: vs', _, _ -> global c x := v; - vs', [] + es, vs', bs, cs - | Load {offset; ty; sz; _}, I32 i :: vs' -> + | Load {offset; ty; sz; _}, I32 i :: vs', _, _ -> let addr = I64_convert.extend_u_i32 i in let v = try @@ -218,114 +253,79 @@ let rec step_instr (c : config) (vs : value stack) (e : instr) | Some (sz, ext) -> Memory.load_packed sz ext (memory c e.at) addr offset ty with exn -> memory_error e.at exn - in v :: vs', [] + in es, v :: vs', bs, cs - | Store {offset; sz; _}, v :: I32 i :: vs' -> + | Store {offset; sz; _}, v :: I32 i :: vs', _, _ -> let addr = I64_convert.extend_u_i32 i in (try match sz with | None -> Memory.store (memory c e.at) addr offset v | Some sz -> Memory.store_packed sz (memory c e.at) addr offset v with exn -> memory_error e.at exn); - vs', [] + es, vs', bs, cs - | Const v, vs -> - v.it :: vs, [] + | Const v, vs, _, _ -> + es, v.it :: vs, bs, cs - | Unary unop, v :: vs' -> - (try Eval_numeric.eval_unop unop v :: vs', [] + | Unary unop, v :: vs', _, _ -> + (try es, Eval_numeric.eval_unop unop v :: vs', bs, cs with exn -> numeric_error e.at exn) - | Binary binop, v2 :: v1 :: vs' -> - (try Eval_numeric.eval_binop binop v1 v2 :: vs', [] + | 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 value_of_bool (Eval_numeric.eval_testop testop v) :: vs', [] + | 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) - | Compare relop, v2 :: v1 :: vs' -> - (try value_of_bool (Eval_numeric.eval_relop relop v1 v2) :: vs', [] + | 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) - | Convert cvtop, v :: vs' -> - (try Eval_numeric.eval_cvtop cvtop v :: vs', [] + | Convert cvtop, v :: vs', _, _ -> + (try es, Eval_numeric.eval_cvtop cvtop v :: vs', bs, cs with exn -> numeric_error e.at exn) - | CurrentMemory, vs -> + | CurrentMemory, vs, _, _ -> let size = Memory.size (memory c e.at) in - I32 size :: vs, [] + es, I32 size :: vs, bs, cs - | GrowMemory, I32 delta :: vs' -> + | GrowMemory, I32 delta :: vs', _, _ -> let mem = memory c 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 I32 result :: vs', [] - - | Trapping msg, vs -> - assert false (* abrupt *) - - | Label (es_cont, vs', []), vs -> - vs' @ vs, [] - - | Label (es_cont, vs', {it = Br (n, i); _} :: es), vs when i.it = 0 -> - keep n vs' e.at @ vs, es_cont - - | Label (es_cont, vs', {it = Br (n, i); at} :: es), vs -> - vs', [Br (n, (i.it - 1) @@ i.at) @@ e.at] + in es, I32 result :: vs', bs, cs - | Label (es_cont, vs', {it = Return; at} :: es), vs -> - vs', [Return @@ at] - - | Label (es_cont, vs', {it = Trapping msg; at} :: es), vs -> - [], [Trapping msg @@ at] - - | Label (es_cont, vs', e :: es), vs -> - let vs'', es' = step_instr c vs' e in - vs, [Label (es_cont, vs'', es' @ es) @@ e.at] - - | Local (n, vs_local, vs', []), vs -> - vs' @ vs, [] - - | Local (n, vs_local, vs', {it = Br (n', i); at} :: es), vs when i.it = 0 -> - if n <> n' then Crash.error at "inconsistent result arity"; - keep n vs' at @ vs, [] - - | Local (n, vs_local, vs', {it = Return; at} :: es), vs -> - keep n vs' at @ vs, [] - - | Local (n, vs_local, vs', {it = Trapping msg; at} :: es), vs -> - [], [Trapping msg @@ at] + | _ -> + Crash.error e.at "type error: missing or ill-typed operand on stack" - | Local (n, vs_local, vs', e :: es), vs -> - let c' = {c with locals = List.map ref vs_local; resources = c.resources - 1} in - let vs'', es' = step_instr c' vs' e in - vs, [Local (n, List.map (!) c'.locals, vs'', es' @ es) @@ e.at] +let rec eval_seq (conf : config) (es, vs, bs, cs : eval_context) = + match es, bs, cs with + | e :: es', _, _ -> + eval_seq conf (eval_instr conf e (es', vs, bs, cs)) - | _, _ -> - Crash.error e.at "type error: missing or ill-typed operand on stack" + | [], b :: bs', _ -> + let es', vs' = b.bcontext in + eval_seq conf (es', vs @ vs', bs', cs) + | [], [], c :: cs' -> + let es', vs', bs' = c.ccontext in + eval_seq conf (es', vs @ vs', bs', cs') -let rec eval_block (c : config) (vs : value stack) (es : instr list) : value stack = - match es with - | [] -> vs - | [{it = Trapping msg; at}] -> Trap.error at msg - | e :: es -> - let vs', es' = step_instr c vs e in - eval_block c vs' (es' @ es) + | [], [], [] -> + vs (* Functions & Constants *) let eval_func (inst : instance) (vs : value list) (x : var) : value list = - let c = {instance = inst; locals = []; resources = resource_limit} in - List.rev (eval_block c (List.rev vs) [Call x @@ x.at]) + List.rev (eval_seq {instance = inst} ([Call x @@ x.at], List.rev vs, [], [])) let eval_const inst const = - let c = {instance = inst; locals = []; resources = resource_limit} in - match eval_block c [] const.it with + match eval_seq {instance = inst} (const.it, [], [], []) with | [v] -> v | _ -> Crash.error const.at "type error: wrong number of values on stack" From de0af623ee5a45fdc8142756f54c008e9ca6a61a Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 9 Sep 2016 09:21:18 +0200 Subject: [PATCH 43/44] Merge branch 'binary-0xc' into stack; resolve many conflicts with imports/exports --- ml-proto/README.md | 129 ++-- ml-proto/given/lib.ml | 13 + ml-proto/given/lib.mli | 8 + ml-proto/host/arrange.ml | 155 ++-- ml-proto/host/encode.ml | 88 ++- ml-proto/host/flags.ml | 1 + ml-proto/host/import.ml | 20 +- ml-proto/host/import.mli | 8 +- ml-proto/host/import/env.ml | 11 +- ml-proto/host/import/spectest.ml | 29 +- ml-proto/host/lexer.mll | 7 +- ml-proto/host/main.ml | 1 + ml-proto/host/parser.mly | 437 +++++++---- ml-proto/host/print.ml | 49 +- ml-proto/host/run.ml | 3 +- ml-proto/host/script.ml | 195 +++-- ml-proto/host/script.mli | 21 +- ml-proto/runtests.py | 18 +- ml-proto/spec/ast.ml | 58 +- ml-proto/spec/check.ml | 165 ++-- ml-proto/spec/decode.ml | 101 ++- ml-proto/spec/desugar.ml | 8 +- ml-proto/spec/eval.ml | 352 +++++---- ml-proto/spec/eval.mli | 12 +- ml-proto/spec/instance.ml | 34 + ml-proto/spec/memory.ml | 10 +- ml-proto/spec/memory.mli | 5 +- ml-proto/spec/operators.ml | 1 - ml-proto/spec/table.ml | 14 +- ml-proto/spec/table.mli | 6 +- ml-proto/spec/types.ml | 25 + ml-proto/test/address.wast | 41 +- ml-proto/test/binary.wast | 2 + ml-proto/test/block.wast | 28 +- ml-proto/test/br.wast | 129 ++-- ml-proto/test/br_if.wast | 32 +- ml-proto/test/br_table.wast | 143 ++-- ml-proto/test/break-drop.wast | 11 +- ml-proto/test/call.wast | 38 +- ml-proto/test/call_indirect.wast | 48 +- ml-proto/test/conversions.wast | 99 +-- ml-proto/test/endianness.wast | 58 +- .../test/expected-output/imports.wast.log | 4 + ml-proto/test/exports.wast | 170 ++++- ml-proto/test/f32.wast | 43 +- ml-proto/test/f32_cmp.wast | 19 +- ml-proto/test/f64.wast | 43 +- ml-proto/test/f64_cmp.wast | 19 +- ml-proto/test/fac.wast | 12 +- ml-proto/test/float_exprs.wast | 721 ++++++------------ ml-proto/test/float_literals.wast | 186 ++--- ml-proto/test/float_memory.wast | 114 +-- ml-proto/test/float_misc.wast | 88 +-- ml-proto/test/forward.wast | 7 +- ml-proto/test/func.wast | 110 +-- ml-proto/test/func_ptrs.wast | 27 +- ml-proto/test/get_local.wast | 20 +- ml-proto/test/globals.wast | 77 +- ml-proto/test/i32.wast | 88 +-- ml-proto/test/i64.wast | 88 +-- ml-proto/test/import-after-func.fail.wast | 1 + ml-proto/test/import-after-global.fail.wast | 1 + ml-proto/test/import-after-memory.fail.wast | 1 + ml-proto/test/import-after-table.fail.wast | 1 + ml-proto/test/imports.wast | 234 +++++- ml-proto/test/int_exprs.wast | 162 ++-- ml-proto/test/int_literals.wast | 68 +- ml-proto/test/labels.wast | 60 +- ml-proto/test/left-to-right.wast | 252 +++--- ml-proto/test/linking.wast | 228 ++++++ ml-proto/test/loop.wast | 38 +- ml-proto/test/memory.wast | 68 +- ml-proto/test/memory_redundancy.wast | 12 +- ml-proto/test/memory_trap.wast | 9 +- ml-proto/test/names.wast | 69 +- ml-proto/test/nan-propagation.wast | 101 +-- ml-proto/test/nop.wast | 171 ++--- ml-proto/test/resizing.wast | 25 +- ml-proto/test/return.wast | 121 ++- ml-proto/test/select.wast | 19 +- ml-proto/test/set_local.wast | 20 +- ml-proto/test/stack.wast | 60 +- ml-proto/test/start.wast | 23 +- ml-proto/test/switch.wast | 13 +- ml-proto/test/tee_local.wast | 22 +- ml-proto/test/traps.wast | 61 +- ml-proto/test/typecheck.wast | 1 - ml-proto/test/unreachable.wast | 121 ++- ml-proto/winmake.bat | 32 +- 89 files changed, 3340 insertions(+), 3103 deletions(-) create mode 100644 ml-proto/spec/instance.ml create mode 100644 ml-proto/test/import-after-func.fail.wast create mode 100644 ml-proto/test/import-after-global.fail.wast create mode 100644 ml-proto/test/import-after-memory.fail.wast create mode 100644 ml-proto/test/import-after-table.fail.wast create mode 100644 ml-proto/test/linking.wast diff --git a/ml-proto/README.md b/ml-proto/README.md index 556ee514dc..912fba5415 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -18,7 +18,7 @@ The interpreter can also be run as a REPL, allowing to enter pieces of scripts i ## Building -You'll need OCaml 4.02. The best way to get this is to download the [source tarball from our mirror of the ocaml website](https://wasm.storage.googleapis.com/ocaml-4.02.2.tar.gz) and do the configure / make dance. On OSX, with [Homebrew](http://brew.sh/) installed, simply `brew install ocaml`. +You'll need OCaml 4.02. The best way to get this is to download the [source tarball from our mirror of the ocaml website](https://wasm.storage.googleapis.com/ocaml-4.02.2.tar.gz) and do the configure / make dance. On OSX, with [Homebrew](http://brew.sh/) installed, simply `brew install ocaml ocamlbuild`. Once you have OCaml, simply do @@ -69,6 +69,10 @@ wasm [option | file ...] where `file`, depending on its extension, either should be an S-expression script file (see below) to be run, or a binary module file to be loaded. +By default, the interpreter validates all modules. +The `-u` option selects "unchecked mode", which skips validation and runs code as is. +Runtime type errors will be captured and reported appropriately. + A file prefixed by `-o` is taken to be an output file. Depending on its extension, this will write out the preceding module definition in either S-expression or binary format. This option can be used to convert between the two in both directions, e.g.: ``` @@ -76,8 +80,9 @@ wasm -d module.wast -o module.wasm wasm -d module.wasm -o module.wast ``` -The `-d` option selects "dry mode" and ensures that the input module is not run, even if it has a start section. In the second case, the produced script contains exactly one module definition. +The `-d` option selects "dry mode" and ensures that the input module is not run, even if it has a start section. +In addition, the `-u` option for "unchecked mode" can be used to convert even modules that do not validate. Finally, the option `-e` allows to provide arbitrary script commands directly on the command line. For example: @@ -115,13 +120,22 @@ offset: offset= align: align=(1|2|4|8|...) cvtop: trunc_s | trunc_u | extend_s | extend_u | ... +expr: + ( ) + ( + ) ;; = + () + ( block ? * ) + ( loop ? * ) + ( if ( then ? * ) ( else ? * )? ) + ( if ( then ? * ) ( else ? * )? ) ;; = (if (then ? *) (else ? *)?) + ( if ? ) ;; = (if (then ) (else ?)) + instr: - - block ? * end - loop ? * end - if ? * else ? * end - if ? * end ;; = if ? * else end + ;; = () + block ? * end ;; = (block ? *) + loop ? * end ;; = (loop ? *) + if ? * end ;; = (if (then ? *)) + if ? * else ? * end ;; = (if (then ? instr>*) (else ? *)) op: unreachable @@ -146,39 +160,58 @@ op: .load((8|16|32)_)? ? ? .store(8|16|32)? ? ? current_memory - grow_memory + grow_memory + +func: ( func ? * * ) + ( func ? ( export ) * * ) ;; = (export (func ) (func ? * *) + ( func ? ( import ) ) ;; = (import ? (func )) +param: ( param * ) | ( param ) +result: ( result ) +local: ( local * ) | ( local ) + +func_sig: ( type ) | * ? +global_sig: | ( mut ) +table_sig: ? +memory_sig: ? + +global: ( global ? ) + ( global ? ( export ) ) ;; = (export (global )) (global ? ) + ( global ? ( import ) ) ;; = (import ? (global )) +table: ( table ? ) + ( table ? ( export ) ) ;; = (export (table )) (table ? ) + ( table ? ( import ) ) ;; = (import ? (table )) + ( table ? ( export )? ( elem * ) ) ;; = (table ? ( export )? ) (elem (i32.const 0) *) +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 ( offset * ) * ) + ( data * ) ;; = (data (offset ) *) -expr: - ( * ) ;; = * - ( block ? * ) ;; = block ? * end - ( loop ? * ) ;; = loop ? * end - ( if ? ) ;; = if else ? end - ( if ? ( then ? * ) ( else ? * )? ) ;; = ? if ? * else ? * end - -func: ( func ? * * ) - ( func ? * * ) ;; = (export ) (func ? * *) -sig: ( type ) | * ? -param: ( param * ) | ( param ) -result: ( result ) -local: ( local * ) | ( local ) - -module: ( module * * * * ? ? * * ? ) | (module +) -typedef: ( type ? ( func * ? ) ) -import: ( import ? ) -export: ( export ) | ( export memory) start: ( start ) -table: ( table ? ) - ( table ( elem * ) ) ;; = (table ) (elem (i32.const 0) *) -elem: ( elem ( offset ) * ) - ( elem * ) ;; = (elem (offset ) *) -memory: ( memory ? ) - ( memory ( data * ) ) ;; = (memory ) (data (i32.const 0) *) -data: ( data ( offset * ) * ) - ( data * ) ;; = (data (offset ) *) + +typedef: ( type ? ( func ) ) + +import: ( import ) +imkind: ( func ? ) + ( global ? ) + ( table ? ) + ( memory ? ) +export: ( export ) +exkind: ( func ) + ( global ) + ( table ) + ( memory ) + +module: ( module ? * * * *
? ? * * ? ) + ( module ? + ) ``` 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 `` are merely abbreviations of a corresponding post-order sequence of instructions. +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. @@ -206,17 +239,25 @@ In order to be able to check and run modules for testing purposes, the S-express script: * cmd: - ;; define, validate, and initialize module - ( invoke * ) ;; invoke export and print result - ( assert_return (invoke * ) ) ;; assert return with expected result of invocation - ( assert_return_nan (invoke * )) ;; assert return with floating point nan result of invocation - ( assert_trap (invoke * ) ) ;; assert invocation traps with given failure string - ( assert_invalid ) ;; assert invalid module with given failure string - ( input ) ;; read script or module from file - ( output ? ) ;; output module to stout or file + ;; define, validate, and initialize module + ;; perform action and print results + ( register ? ) ;; register module for imports + ( 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 + ( assert_unlinkable ) ;; assert module fails to link module with given failure string + ( input ) ;; read script or module from file + ( output ? ? ) ;; output module to stout or file + +action: + ( invoke ? * ) ;; invoke function export + ( get ? ) ;; get global export ``` -Commands are executed in sequence. Invocation, assertions, and output apply to the most recently defined module (the _current_ module), and are only possible after a module has been defined. Note that there only ever is one current module, the different module definitions cannot interact. +Commands are executed in sequence. Commands taking an optional module name refer to the most recently defined module if no name is given. They are only possible after a module has been defined. + +After a module is _registered_ under a string name it is available for importing in other modules. The input and output commands determine the requested file format from the file name extension. They can handle both `.wast` and `.wasm` files. In the case of input, a `.wast` script will be recursively executed. diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index c13a00666b..5ac1c6215b 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -1,3 +1,9 @@ +module Fun = +struct + let rec repeat n f x = + if n = 0 then () else (f x; repeat (n - 1) f x) +end + module List = struct let rec make n x = @@ -19,6 +25,13 @@ struct | n, _::xs' when n > 0 -> drop (n - 1) xs' | _ -> failwith "drop" + let length32 xs = Int32.of_int (List.length xs) + let rec nth32 xs n = + match n, xs with + | 0l, x::xs -> x + | n, x::xs' when n > 0l -> nth32 xs' (Int32.sub n 1l) + | _ -> failwith "nth32" + let rec last = function | x::[] -> x | _::xs -> last xs diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index c0cb6bf16d..ad86d4f14c 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -1,5 +1,10 @@ (* Things that should be in the OCaml library... *) +module Fun : +sig + val repeat : int -> ('a -> unit) -> 'a -> unit +end + module List : sig val make : int -> 'a -> 'a list @@ -7,6 +12,9 @@ sig val take : int -> 'a list -> 'a list (* raise Failure *) val drop : int -> 'a list -> 'a list (* raise Failure *) + val length32 : 'a list -> int32 + val nth32 : 'a list -> int32 -> 'a (* raise Failure *) + val last : 'a list -> 'a (* raise Failure *) val split_last : 'a list -> 'a list * 'a (* raise Failure *) diff --git a/ml-proto/host/arrange.ml b/ml-proto/host/arrange.ml index 9e540f4987..860f1a72a0 100644 --- a/ml-proto/host/arrange.ml +++ b/ml-proto/host/arrange.ml @@ -53,6 +53,13 @@ let func_type (FuncType (ins, out)) = let struct_type = func_type +let limits int {min; max} = + String.concat " " (int min :: opt int max) + +let global_type = function + | GlobalType (t, Immutable) -> atom string_of_value_type t + | GlobalType (t, Mutable) -> Node ("mut", [atom string_of_value_type t]) + (* Operators *) @@ -197,38 +204,39 @@ let value v = string_of_value v.it let constop v = value_type (type_of v.it) ^ ".const" let rec instr e = + let head, inner = match e.it with - | Unreachable -> Atom "unreachable" - | Nop -> Atom "nop" - | Drop -> Atom "drop" - | Block es -> Node ("block", list instr es) - | Loop es -> Node ("loop", list instr es) - | Br (n, x) -> Atom ("br " ^ int n ^ " " ^ var x) - | BrIf (n, x) -> Atom ("br_if " ^ int n ^ " " ^ var x) + | Unreachable -> "unreachable", [] + | 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) -> - Atom ("br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x]))) - | Return -> Atom "return" + "br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x])), [] + | Return -> "return", [] | If (es1, es2) -> - Node ("if", [Node ("then", list instr es1); Node ("else", list instr es2)]) - | Select -> Atom "select" - | Call x -> Atom ("call " ^ var x) - | CallImport x -> Atom ("call_import " ^ var x) - | CallIndirect x -> Atom ("call_indirect " ^ var x) - | GetLocal x -> Atom ("get_local " ^ var x) - | SetLocal x -> Atom ("set_local " ^ var x) - | TeeLocal x -> Atom ("tee_local " ^ var x) - | GetGlobal x -> Atom ("get_global " ^ var x) - | SetGlobal x -> Atom ("set_global " ^ var x) - | Load op -> Atom (loadop op) - | Store op -> Atom (storeop op) - | Const lit -> Atom (constop lit ^ " " ^ value lit) - | Unary op -> Atom (unop op) - | Binary op -> Atom (binop op) - | Test op -> Atom (testop op) - | Compare op -> Atom (relop op) - | Convert op -> Atom (cvtop op) - | CurrentMemory -> Atom "current_memory" - | GrowMemory -> Atom "grow_memory" + "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 -> "set_local " ^ var x, [] + | TeeLocal x -> "tee_local " ^ var x, [] + | GetGlobal x -> "get_global " ^ var x, [] + | 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) let const c = list instr c.it @@ -236,9 +244,9 @@ let const c = (* Functions *) -let func i f = +let func off i f = let {ftype; locals; body} = f.it in - Node ("func $" ^ string_of_int i, + Node ("func $" ^ string_of_int (off + i), [Node ("type " ^ var ftype, [])] @ decls "local" locals @ list instr body @@ -251,21 +259,19 @@ let table xs = tab "table" (atom var) xs (* Tables & memories *) -let limits int lim = - let {min; max} = lim.it in - String.concat " " (int min :: opt int max) - -let table tab = - let {tlimits = lim; etype} = tab.it in - Node ("table " ^ limits int32 lim, [atom elem_type etype]) +let table off i tab = + let {ttype = TableType (lim, t)} = tab.it in + Node ("table $" ^ string_of_int (off + i) ^ " " ^ limits int32 lim, + [atom elem_type t] + ) -let memory mem = - let {mlimits = lim} = mem.it in - Node ("memory " ^ limits int32 lim, []) +let memory off i mem = + let {mtype = MemoryType lim} = mem.it in + Node ("memory $" ^ string_of_int (off + i) ^ " " ^ limits int32 lim, []) let segment head dat seg = - let {offset; init} = seg.it in - Node (head, Node ("offset", const offset) :: dat init) + let {index; offset; init} = seg.it in + Node (head, atom var index :: Node ("offset", const offset) :: dat init) let elems seg = segment "elem" (list (atom var)) seg @@ -279,31 +285,64 @@ let data seg = let typedef i t = Node ("type $" ^ string_of_int i, [struct_type t]) +let import_kind i k = + match k.it with + | FuncImport x -> + Node ("func $" ^ string_of_int i, [Node ("type", [atom var x])]) + | TableImport t -> table 0 i ({ttype = t} @@ k.at) + | MemoryImport t -> memory 0 i ({mtype = t} @@ k.at) + | GlobalImport t -> Node ("global $" ^ string_of_int i, [global_type t]) + let import i im = - let {itype; module_name; func_name} = im.it in - let ty = Node ("type " ^ var itype, []) in - Node ("import $" ^ string_of_int i, - [atom string module_name; atom string func_name; ty] + let {module_name; item_name; ikind} = im.it in + Node ("import", + [atom string module_name; atom string item_name; import_kind i ikind] ) -let global g = - let {gtype; value} = g.it in - Node ("global", atom value_type gtype :: const value) +let export_kind k = + match k.it with + | FuncExport -> "func" + | TableExport -> "table" + | MemoryExport -> "memory" + | GlobalExport -> "global" let export ex = - let {name; kind} = ex.it in - let desc = match kind with `Func x -> var x | `Memory -> "memory" in - Node ("export", [atom string name; Atom desc]) + let {name; ekind; item} = ex.it in + Node ("export", + [atom string name; Node (export_kind ekind, [atom var item])] + ) + +let global off i g = + let {gtype; value} = g.it in + Node ("global $" ^ string_of_int (off + i), global_type gtype :: const value) + + +(* Modules *) +let is_func_import im = + match im.it.ikind.it with FuncImport _ -> true | _ -> false +let is_table_import im = + match im.it.ikind.it with TableImport _ -> true | _ -> false +let is_memory_import im = + match im.it.ikind.it with MemoryImport _ -> true | _ -> false +let is_global_import im = + match im.it.ikind.it with GlobalImport _ -> true | _ -> false let module_ m = + let func_imports = List.filter is_func_import m.it.imports in + let table_imports = List.filter is_table_import m.it.imports in + let memory_imports = List.filter is_memory_import m.it.imports in + let global_imports = List.filter is_global_import m.it.imports in Node ("module", listi typedef m.it.types @ - listi import m.it.imports @ - opt table m.it.table @ - opt memory m.it.memory @ - list global m.it.globals @ - listi func m.it.funcs @ + listi import table_imports @ + listi import memory_imports @ + listi import global_imports @ + listi import func_imports @ + listi (table (List.length table_imports)) m.it.tables @ + listi (memory (List.length memory_imports)) m.it.memories @ + listi (global (List.length global_imports)) m.it.globals @ + listi (func (List.length func_imports)) m.it.funcs @ list export m.it.exports @ opt start m.it.start @ list elems m.it.elems @ diff --git a/ml-proto/host/encode.ml b/ml-proto/host/encode.ml index de97e1d2d8..7c784d8796 100644 --- a/ml-proto/host/encode.ml +++ b/ml-proto/host/encode.ml @@ -63,14 +63,15 @@ 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; p + let gap () = let p = pos s in u32 0l; u8 0; p let patch_gap 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)); patch s (p + 1) (lsb ((n lsr 7) lor 0x80)); patch s (p + 2) (lsb ((n lsr 14) lor 0x80)); - patch s (p + 3) (lsb (n lsr 21)) + patch s (p + 3) (lsb ((n lsr 21) lor 0x80)); + patch s (p + 4) (lsb (n lsr 28)) (* Types *) @@ -88,6 +89,22 @@ let encode m = let func_type = function | 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 + (* Expressions *) open Source @@ -95,8 +112,12 @@ let encode m = open Values open Memory + let arity xs = vu (List.length xs) + let arity1 xo = bool (xo <> None) + let op n = u8 n - let memop {align; offset; _} = vu align; vu64 offset (*TODO: to be resolved*) + 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) @@ -131,7 +152,6 @@ let encode m = | Call x -> op 0x16; var x | CallIndirect x -> op 0x17; var x - | CallImport x -> op 0x18; var x | Load ({ty = I32Type; sz = None; _} as mo) -> op 0x2a; memop mo | Load ({ty = I64Type; sz = None; _} as mo) -> op 0x2b; memop mo @@ -327,7 +347,6 @@ let encode m = let const c = list instr c.it; op 0x0f - (* Sections *) let section id f x needed = @@ -344,9 +363,16 @@ let encode m = section "type" (vec func_type) ts (ts <> []) (* Import section *) + let import_kind k = + match k.it with + | FuncImport x -> u8 0x00; var x + | TableImport t -> u8 0x01; table_type t + | MemoryImport t -> u8 0x02; memory_type t + | GlobalImport t -> u8 0x03; global_type t + let import imp = - let {itype; module_name; func_name} = imp.it in - var itype; string module_name; string func_name + let {module_name; item_name; ikind} = imp.it in + string module_name; string item_name; import_kind ikind let import_section imps = section "import" (vec import) imps (imps <> []) @@ -358,44 +384,42 @@ let encode m = section "function" (vec func) fs (fs <> []) (* Table section *) - let limits vu lim = - let {min; max} = lim.it in - bool (max <> None); vu min; opt vu max - let table tab = - let {etype; tlimits} = tab.it in - elem_type etype; limits vu32 tlimits + let {ttype} = tab.it in + table_type ttype - let table_section tabo = - section "table" (opt table) tabo (tabo <> None) + let table_section tabs = + section "table" (vec table) tabs (tabs <> []) (* Memory section *) let memory mem = - let {mlimits} = mem.it in - limits vu32 mlimits + let {mtype} = mem.it in + memory_type mtype - let memory_section memo = - section "memory" (opt memory) memo (memo <> None) + let memory_section mems = + section "memory" (vec memory) mems (mems <> []) (* Global section *) let global g = let {gtype; value} = g.it in - value_type gtype; const value + global_type gtype; const value; op 0x0f let global_section gs = section "global" (vec global) gs (gs <> []) (* Export section *) + let export_kind k = + match k.it with + | FuncExport -> u8 0 + | TableExport -> u8 1 + | MemoryExport -> u8 2 + | GlobalExport -> u8 3 + let export exp = - let {Ast.name; kind} = exp.it in - (match kind with - | `Func x -> var x - | `Memory -> () (*TODO: pending resolution*) - ); string name + let {name; ekind; item} = exp.it in + string name; export_kind ekind; var item let export_section exps = - (*TODO: pending resolution*) - let exps = List.filter (fun exp -> exp.it.kind <> `Memory) exps in section "export" (vec export) exps (exps <> []) (* Start section *) @@ -413,9 +437,9 @@ let encode m = let code f = let {locals; body; _} = f.it in - vec local (compress locals); let g = gap () in let p = pos s in + vec local (compress locals); list instr body; patch_gap g (pos s - p) @@ -424,8 +448,8 @@ let encode m = (* Element section *) let segment dat seg = - let {offset; init} = seg.it in - const offset; dat init + let {index; offset; init} = seg.it in + var index; const offset; dat init let table_segment seg = segment (vec var) seg @@ -448,8 +472,8 @@ let encode m = type_section m.it.types; import_section m.it.imports; func_section m.it.funcs; - table_section m.it.table; - memory_section m.it.memory; + table_section m.it.tables; + memory_section m.it.memories; global_section m.it.globals; export_section m.it.exports; start_section m.it.start; diff --git a/ml-proto/host/flags.ml b/ml-proto/host/flags.ml index 913e909199..13348dab67 100644 --- a/ml-proto/host/flags.ml +++ b/ml-proto/host/flags.ml @@ -3,6 +3,7 @@ let version = "0.2" let interactive = ref false let trace = ref false +let unchecked = ref false let print_sig = ref false let dry = ref false let width = ref 80 diff --git a/ml-proto/host/import.ml b/ml-proto/host/import.ml index 0cf09a148e..7898b3dce5 100644 --- a/ml-proto/host/import.ml +++ b/ml-proto/host/import.ml @@ -11,12 +11,18 @@ let registry = ref Registry.empty let register name lookup = registry := Registry.add name lookup !registry -let lookup m import = - let {module_name; func_name; itype} = import.it in - let ty = List.nth m.it.types itype.it in - try Registry.find module_name !registry func_name ty with Not_found -> - Unknown.error import.at - ("no function \"" ^ module_name ^ "." ^ func_name ^ - "\" of requested type") +let external_type_of_import_kind m ikind = + match ikind.it with + | FuncImport x -> ExternalFuncType (List.nth m.it.types x.it) + | TableImport t -> ExternalTableType t + | MemoryImport t -> ExternalMemoryType t + | GlobalImport t -> ExternalGlobalType t + +let lookup (m : module_) (imp : import) : Instance.extern = + let {module_name; item_name; ikind} = imp.it in + let ty = external_type_of_import_kind m ikind in + try Registry.find module_name !registry item_name ty with Not_found -> + Unknown.error imp.at + ("unknown import \"" ^ module_name ^ "." ^ item_name ^ "\"") let link m = List.map (lookup m) m.it.imports diff --git a/ml-proto/host/import.mli b/ml-proto/host/import.mli index b5a4aa2bf4..9310553df1 100644 --- a/ml-proto/host/import.mli +++ b/ml-proto/host/import.mli @@ -1,4 +1,8 @@ exception Unknown of Source.region * string -val link : Ast.module_ -> Eval.import list (* raises Unknown *) -val register: string -> (string -> Types.func_type -> Eval.import) -> unit +val link : Ast.module_ -> Instance.extern list (* raises Unknown *) + +val register : + string -> + (string -> Types.external_type -> Instance.extern (* raise Not_found *)) -> + unit diff --git a/ml-proto/host/import/env.ml b/ml-proto/host/import/env.ml index 96ada7a274..b0bb8d1b81 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)) @@ -13,7 +14,7 @@ let error msg = raise (Eval.Crash (Source.no_region, msg)) let type_error v t = error ("type error, expected " ^ string_of_value_type t ^ - ", got " ^ string_of_value_type (type_of v)) + ", got " ^ string_of_value_type (type_of v)) let empty = function | [] -> () @@ -38,8 +39,8 @@ let exit vs = exit (int (single vs)) -let lookup name (FuncType (ins, out)) = - match name, ins, out with - | "abort", [], [] -> abort - | "exit", [I32Type], [] -> exit +let lookup name t = + match name with + | "abort" -> ExternalFunc (HostFunc abort) + | "exit" -> ExternalFunc (HostFunc exit) | _ -> raise Not_found diff --git a/ml-proto/host/import/spectest.ml b/ml-proto/host/import/spectest.ml index 24650f3b57..0cb433d558 100644 --- a/ml-proto/host/import/spectest.ml +++ b/ml-proto/host/import/spectest.ml @@ -3,14 +3,31 @@ *) open Types +open Values +open Instance -let print vs = - List.iter Print.print_result (List.map (fun v -> [v]) vs); - [] +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 lookup name (FuncType (ins, out)) = - match name, ins, out with - | "print", _, [] -> print +let print (FuncType (_, out)) vs = + Print.print_result vs; + List.map default_value out + + +let lookup name t = + match name, t with + | "print", ExternalFuncType t -> ExternalFunc (HostFunc (print t)) + | "print", _ -> ExternalFunc (HostFunc (print (FuncType ([], [])))) + | "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 53b984aecd..73846fec3b 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -141,6 +141,7 @@ rule token = parse f64_const (n @@ s.at), Values.F64 n)) } | "anyfunc" { ANYFUNC } + | "mut" { MUT } | "nop" { NOP } | "unreachable" { UNREACHABLE } @@ -157,7 +158,6 @@ rule token = parse | "else" { ELSE } | "select" { SELECT } | "call" { CALL } - | "call_import" { CALL_IMPORT } | "call_indirect" { CALL_INDIRECT } | "get_local" { GET_LOCAL } @@ -300,11 +300,14 @@ rule token = parse | "import" { IMPORT } | "export" { EXPORT } + | "register" { REGISTER } + | "invoke" { INVOKE } + | "get" { GET } | "assert_invalid" { ASSERT_INVALID } + | "assert_unlinkable" { ASSERT_UNLINKABLE } | "assert_return" { ASSERT_RETURN } | "assert_return_nan" { ASSERT_RETURN_NAN } | "assert_trap" { ASSERT_TRAP } - | "invoke" { INVOKE } | "input" { INPUT } | "output" { OUTPUT } diff --git a/ml-proto/host/main.ml b/ml-proto/host/main.ml index 89056ad2fa..f71199bab4 100644 --- a/ml-proto/host/main.ml +++ b/ml-proto/host/main.ml @@ -25,6 +25,7 @@ let argspec = Arg.align "-w", Arg.Int (fun n -> Flags.width := n), " configure output width (default is 80)"; "-s", Arg.Set Flags.print_sig, " show module signatures"; + "-u", Arg.Set Flags.unchecked, " unchecked, do not perform validation"; "-d", Arg.Set Flags.dry, " dry, do not run program"; "-t", Arg.Set Flags.trace, " trace execution"; "-v", Arg.Unit banner, " show version" diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 4f1dae6af0..4a91856df4 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -35,21 +35,16 @@ let ati i = (* Literals *) let literal f s = - try f s with - | Failure msg -> error s.at ("constant out of range: " ^ msg) - | _ -> error s.at "constant out of range" + try f s with Failure _ -> error s.at "constant out of range" let int s at = - try int_of_string s with Failure _ -> - error at "int constant out of range" + try int_of_string s with Failure _ -> error at "int constant out of range" let int32 s at = - try I32.of_string s with Failure _ -> - error at "i32 constant out of range" + try I32.of_string s with Failure _ -> error at "i32 constant out of range" let int64 s at = - try I64.of_string s with Failure _ -> - error at "i64 constant out of range" + try I64.of_string s with Failure _ -> error at "i64 constant out of range" (* Symbolic variables *) @@ -63,15 +58,15 @@ type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} let empty_types () = {tmap = VarMap.empty; tlist = []} type context = - {types : types; funcs : space; imports : space; - locals : space; globals : space; labels : int VarMap.t} + { types : types; tables : space; memories : space; + funcs : space; locals : space; globals : space; labels : int VarMap.t } let empty_context () = - {types = empty_types (); funcs = empty (); imports = empty (); - locals = empty (); globals = empty (); labels = VarMap.empty} + { types = empty_types (); tables = empty (); memories = empty (); + funcs = empty (); locals = empty (); globals = empty (); + labels = VarMap.empty } let enter_func c = - assert (VarMap.is_empty c.labels); {c with labels = VarMap.empty; locals = empty ()} let type_ c x = @@ -83,19 +78,26 @@ let lookup category space x = with Not_found -> error x.at ("unknown " ^ category ^ " " ^ x.it) let func c x = lookup "function" c.funcs x -let import c x = lookup "import" c.imports x let local c x = lookup "local" c.locals x let global c x = lookup "global" c.globals x +let table c x = lookup "table" c.tables x +let memory c x = lookup "memory" c.memories x let label c x = try VarMap.find x.it c.labels with Not_found -> error x.at ("unknown label " ^ x.it) +let bind_module () x = Some x +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.tlist <- c.types.tlist @ [ty] +let anon_type c ty = + c.types.tlist <- c.types.tlist @ [ty] + let bind category space x = if VarMap.mem x.it space.map then error x.at ("duplicate " ^ category ^ " " ^ x.it); @@ -103,27 +105,26 @@ let bind category space x = space.count <- space.count + 1 let bind_func c x = bind "function" c.funcs x -let bind_import c x = bind "import" c.imports x let bind_local c x = bind "local" c.locals x 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)} -let anon_type c ty = - c.types.tlist <- c.types.tlist @ [ty] - let anon space n = space.count <- space.count + n let anon_func c = anon c.funcs 1 -let anon_import c = anon c.imports 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 empty_type = FuncType ([], []) -let explicit_decl c name t at = - let x = name c type_ in +let explicit_sig c var t at = + let x = var c type_ in if x.it < List.length c.types.tlist && t <> empty_type && @@ -132,23 +133,25 @@ let explicit_decl c name t at = error at "signature mismatch"; x -let implicit_decl c t at = +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 %} -%token NAT INT FLOAT TEXT VAR VALUE_TYPE ANYFUNC LPAR RPAR +%token NAT INT FLOAT TEXT VAR VALUE_TYPE ANYFUNC MUT LPAR RPAR %token NOP DROP BLOCK END IF THEN ELSE SELECT LOOP BR BR_IF BR_TABLE -%token CALL CALL_IMPORT CALL_INDIRECT RETURN +%token CALL CALL_INDIRECT RETURN %token GET_LOCAL SET_LOCAL TEE_LOCAL GET_GLOBAL SET_GLOBAL %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 OFFSET IMPORT EXPORT TABLE -%token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE +%token REGISTER INVOKE GET +%token ASSERT_INVALID ASSERT_UNLINKABLE +%token ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP %token INPUT OUTPUT %token EOF @@ -197,15 +200,43 @@ elem_type : | ANYFUNC { AnyFuncType } ; +global_type : + | VALUE_TYPE { GlobalType ($1, Immutable) } + | LPAR MUT VALUE_TYPE RPAR { GlobalType ($3, Mutable) } +; + func_type : + | LPAR FUNC func_sig RPAR { $3 } +; + +func_sig : | /* empty */ { FuncType ([], []) } - | LPAR PARAM value_type_list RPAR - { FuncType ($3, []) } - | LPAR PARAM value_type_list RPAR LPAR RESULT value_type_list RPAR - { FuncType ($3, $7) } - | LPAR RESULT value_type_list RPAR - { FuncType ([], $3) } + | LPAR RESULT VALUE_TYPE RPAR func_sig + { let FuncType (ins, out) = $5 in + if ins <> [] then error (at ()) "result before parameter"; + if out <> [] then + error (at ()) "multiple return types are not supported (yet)"; + FuncType (ins, [$3]) } + | LPAR PARAM value_type_list RPAR func_sig + { let FuncType (ins, out) = $5 in FuncType ($3 @ ins, out) } + | LPAR PARAM bind_var VALUE_TYPE RPAR func_sig /* Sugar */ + { let FuncType (ins, out) = $6 in FuncType ($4 :: ins, out) } +; + +table_sig : + | limits elem_type { TableType ($1, $2) } +; +memory_sig : + | limits { MemoryType $1 } +; +limits : + | NAT { {min = int32 $1 (ati 1); max = None} } + | NAT NAT { {min = int32 $1 (ati 1); max = Some (int32 $2 (ati 2))} } +; + +type_use : + | LPAR TYPE var RPAR { $3 } ; @@ -229,11 +260,16 @@ var_list : | /* empty */ { fun c lookup -> [] } | var var_list { fun c lookup -> $1 c lookup :: $2 c lookup } ; + +bind_var_opt : + | /* empty */ { fun c anon bind -> anon c } + | bind_var { fun c anon bind -> bind c $1 } /* Sugar */ +; bind_var : | VAR { $1 @@ at () } ; -labeling : +labeling_opt : | /* empty */ %prec LOW { fun c -> anon_label c } | bind_var { fun c -> bind_label c $1 } ; @@ -257,9 +293,15 @@ plain_instr : | 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 n.it xs x } | RETURN { fun c -> return } | CALL var { fun c -> call ($2 c func) } - | CALL_IMPORT var { fun c -> call_import ($2 c import) } | 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) } @@ -278,19 +320,13 @@ plain_instr : | GROW_MEMORY { fun c -> grow_memory } ; ctrl_instr : - /* TODO: move branches to plain_instr once arities are gone */ - | BR nat var { fun c -> br $2 ($3 c label) } - | BR_IF nat var { fun c -> br_if $2 ($3 c label) } - | BR_TABLE nat var var_list - { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in - br_table $2 xs x } - | BLOCK labeling instr_list END + | BLOCK labeling_opt instr_list END { fun c -> let c' = $2 c in block ($3 c') } - | LOOP labeling instr_list END + | LOOP labeling_opt instr_list END { fun c -> let c' = $2 c in loop ($3 c') } - | IF labeling instr_list END + | IF labeling_opt instr_list END { fun c -> let c' = $2 c in if_ ($3 c') [] } - | IF labeling instr_list ELSE labeling instr_list END + | 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) } ; @@ -308,20 +344,22 @@ expr1 : /* Sugar */ | BR_TABLE var var_list expr expr_list { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in let es1 = $4 c and n, es2 = $5 c in es1 @ es2, br_table n xs x } - | BLOCK labeling instr_list + | BLOCK labeling_opt instr_list { fun c -> let c' = $2 c in [], block ($3 c') } - | LOOP labeling instr_list + | 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 $2 c, if_ ($3 c') ($4 c') } - | IF expr LPAR THEN labeling instr_list RPAR + | 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 instr_list RPAR LPAR ELSE labeling instr_list RPAR + | 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 instr_list RPAR + | IF LPAR THEN labeling_opt instr_list RPAR { fun c -> let c' = $4 c in [], if_ ($5 c') [] } - | IF LPAR THEN labeling instr_list RPAR LPAR ELSE labeling instr_list RPAR + | 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) } ; @@ -368,40 +406,37 @@ func_body : fun c -> bind_local c $3; let f = (snd $6) c in {f with locals = $4 :: f.locals} } ; -type_use : - | LPAR TYPE var RPAR { $3 } -; func : - | LPAR FUNC export_opt type_use func_fields RPAR + | LPAR FUNC bind_var_opt inline_export type_use func_fields RPAR { let at = at () in - fun c -> anon_func c; let t = explicit_decl c $4 (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var type_use func_fields RPAR /* Sugar */ + fun c -> $3 c anon_func bind_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 } + /* 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 -> bind_func c $4; let t = explicit_decl c $5 (fst $6) at in - let exs = $3 c in - fun () -> {(snd $6 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt func_fields RPAR /* Sugar */ + fun c -> $3 c anon_func bind_func; + let t = explicit_sig c $4 (fst $5) at in + (fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at), + [] } + | LPAR FUNC bind_var_opt inline_export func_fields RPAR /* Sugar */ { let at = at () in - fun c -> anon_func c; let t = implicit_decl c (fst $4) at in - let exs = $3 c in - fun () -> {(snd $4 (enter_func c)) with ftype = t} @@ at, exs } - | LPAR FUNC export_opt bind_var func_fields RPAR /* Sugar */ - { let at = at () in - fun c -> bind_func c $4; let t = implicit_decl c (fst $5) at in - let exs = $3 c in - fun () -> {(snd $5 (enter_func c)) with ftype = t} @@ at, exs } -; -export_opt : - | /* empty */ { fun c -> [] } - | TEXT + fun c -> $3 c anon_func bind_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 } + /* 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 -> [{name = $1; kind = `Func (c.funcs.count - 1 @@ at)} @@ at] } + fun c -> $3 c anon_func bind_func; + let t = inline_type c (fst $4) at in + (fun () -> {(snd $4 (enter_func c)) with ftype = t} @@ at), + [] } ; -/* Tables & Memories */ +/* Tables, Memories & Globals */ offset : | LPAR OFFSET const_expr RPAR { $3 } @@ -409,91 +444,155 @@ offset : ; elem : - | LPAR ELEM offset 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 offset var_list RPAR /* Sugar */ { let at = at () in - fun c -> {offset = $3 c; init = $4 c func} @@ at } + fun c -> {index = 0 @@ at; offset = $3 c; init = $4 c func} @@ at } ; -table_limits : - | NAT { {min = int32 $1 (ati 1); max = None} @@ at () } - | NAT NAT - { {min = int32 $1 (ati 1); max = Some (int32 $2 (ati 2))} @@ at () } -; table : - | LPAR TABLE table_limits elem_type RPAR - { let at = at () in fun c -> {tlimits = $3; etype = $4} @@ at, [] } - | LPAR TABLE elem_type LPAR ELEM var_list RPAR RPAR /* Sugar */ + | LPAR TABLE bind_var_opt inline_export_opt table_sig RPAR + { 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 */ { let at = at () in - fun c -> let init = $6 c func in - let size = Int32.of_int (List.length init) in - {tlimits = {min = size; max = Some size} @@ at; etype = $3} @@ at, - [{offset = [i32_const (0l @@ at) @@ at] @@ at; init} @@ at] } + fun c -> $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] @@ at; init} @@ at], + $4 TableExport c.tables.count c } ; data : - | LPAR DATA offset text_list RPAR - { fun c -> {offset = $3 c; init = $4} @@ at () } + | 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 offset text_list RPAR /* Sugar */ + { let at = at () in + fun c -> {index = 0 @@ at; offset = $3 c; init = $4} @@ at } ; -memory_limits : - | NAT { {min = int32 $1 (ati 1); max = None} @@ at () } - | NAT NAT - { {min = int32 $1 (ati 1); max = Some (int32 $2 (ati 2))} @@ at () } -; memory : - | LPAR MEMORY memory_limits RPAR - { fun c -> {mlimits = $3} @@ at (), [] } - | LPAR MEMORY LPAR DATA text_list RPAR RPAR /* Sugar */ + | LPAR MEMORY bind_var_opt inline_export_opt memory_sig RPAR + { 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 */ { let at = at () in - fun c -> - let size = Int32.(div (add (of_int (String.length $5)) 65535l) 65536l) in - {mlimits = {min = size; max = Some size} @@ at} @@ at, - [{offset = [i32_const (0l @@ at) @@ at] @@ at; init = $5} @@ at] } + fun c -> $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] @@ at; init = $7} @@ at], + $4 MemoryExport c.memories.count c } + /* 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; + 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] @@ at; init = $6} @@ at], + [] } ; +global : + | 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 } + /* 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), [] } +; -/* Modules */ -type_def : - | LPAR TYPE LPAR FUNC func_type RPAR RPAR - { fun c -> anon_type c $5 } - | LPAR TYPE bind_var LPAR FUNC func_type RPAR RPAR - { fun c -> bind_type c $3 $6 } -; +/* Imports & Exports */ +import_kind : + | LPAR FUNC bind_var_opt type_use RPAR + { fun c -> $3 c anon_func bind_func; FuncImport ($4 c type_) } + | LPAR FUNC bind_var_opt func_sig RPAR /* Sugar */ + { let at4 = ati 4 in + fun c -> $3 c anon_func bind_func; FuncImport (inline_type c $4 at4) } + | LPAR TABLE bind_var_opt table_sig RPAR + { fun c -> $3 c anon_table bind_table; TableImport $4 } + | LPAR MEMORY bind_var_opt memory_sig RPAR + { fun c -> $3 c anon_memory bind_memory; MemoryImport $4 } + | LPAR GLOBAL bind_var_opt global_type RPAR + { fun c -> $3 c anon_global bind_global; GlobalImport $4 } +; import : - | LPAR IMPORT TEXT TEXT type_use RPAR + | LPAR IMPORT TEXT TEXT import_kind RPAR + { let at = at () and at5 = ati 5 in + fun c -> {module_name = $3; item_name = $4; ikind = $5 c @@ at5} @@ at } + | LPAR FUNC bind_var_opt inline_import type_use RPAR /* Sugar */ { let at = at () in - fun c -> anon_import c; let itype = explicit_decl c $5 empty_type at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT type_use RPAR /* Sugar */ + fun c -> $3 c anon_func bind_func; + {module_name = fst $4; item_name = snd $4; ikind = FuncImport ($5 c type_) @@ at} @@ at } + | LPAR FUNC bind_var_opt inline_import func_sig RPAR /* Sugar */ + { let at = at () and at5 = ati 5 in + fun c -> $3 c anon_func bind_func; + {module_name = fst $4; item_name = snd $4; ikind = FuncImport (inline_type c $5 at5) @@ at} @@ at } + | LPAR TABLE bind_var_opt inline_import table_sig RPAR /* Sugar */ { let at = at () in - fun c -> bind_import c $3; let itype = explicit_decl c $6 empty_type at in - {itype; module_name = $4; func_name = $5} @@ at } - | LPAR IMPORT TEXT TEXT func_type RPAR /* Sugar */ + fun c -> $3 c anon_table bind_table; + {module_name = fst $4; item_name = snd $4; ikind = TableImport $5 @@ at} @@ at } + | LPAR MEMORY bind_var_opt inline_import memory_sig RPAR /* Sugar */ { let at = at () in - fun c -> anon_import c; let itype = implicit_decl c $5 at in - {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT func_type RPAR /* Sugar */ + fun c -> $3 c anon_memory bind_memory; + {module_name = fst $4; item_name = snd $4; ikind = MemoryImport $5 @@ at} @@ at } + | LPAR GLOBAL bind_var_opt inline_import global_type RPAR /* Sugar */ { let at = at () in - fun c -> bind_import c $3; let itype = implicit_decl c $6 at in - {itype; module_name = $4; func_name = $5} @@ at } + fun c -> $3 c anon_global bind_global; + {module_name = fst $4; item_name = snd $4; ikind = GlobalImport $5 @@ at} @@ at } +; + +inline_import : + | LPAR IMPORT TEXT TEXT RPAR { $3, $4 } ; +export_kind : + | LPAR FUNC var RPAR { fun c -> FuncExport, $3 c func } + | LPAR TABLE var RPAR { fun c -> TableExport, $3 c table } + | LPAR MEMORY var RPAR { fun c -> MemoryExport, $3 c memory } + | LPAR GLOBAL var RPAR { fun c -> GlobalExport, $3 c global } +; export : - | LPAR EXPORT TEXT var RPAR - { let at = at () in fun c -> {name = $3; kind = `Func ($4 c func)} @@ at } - | LPAR EXPORT TEXT MEMORY RPAR - { let at = at () in fun c -> {name = $3; kind = `Memory} @@ at } + | LPAR EXPORT TEXT export_kind RPAR + { let at = at () and at4 = ati 4 in + fun c -> let k, x = $4 c in + {name = $3; ekind = k @@ at4; item = x} @@ at } ; -global : - | LPAR GLOBAL VALUE_TYPE const_expr RPAR - { let at = at () in - fun c -> anon_global c; fun () -> {gtype = $3; value = $4 c} @@ at } - | LPAR GLOBAL bind_var VALUE_TYPE const_expr RPAR /* Sugar */ +inline_export_opt : + | /* empty */ { fun k count c -> [] } + | inline_export { $1 } +; +inline_export : + | LPAR EXPORT TEXT RPAR { let at = at () in - fun c -> bind_global c $3; fun () -> {gtype = $4; value = $5 c} @@ at } + fun k count c -> + [{name = $3; ekind = k @@ at; item = count - 1 @@ at} @@ at] } +; + + +/* Modules */ + +type_def : + | LPAR TYPE func_type RPAR + { fun c -> anon_type c $3 } + | LPAR TYPE bind_var func_type RPAR /* Sugar */ + { fun c -> bind_type c $3 $4 } ; start : @@ -507,8 +606,8 @@ module_fields : { types = c.types.tlist; globals = []; - table = None; - memory = None; + tables = []; + memories = []; funcs = []; elems = []; data = []; @@ -519,20 +618,24 @@ module_fields : | type_def module_fields { fun c -> $1 c; $2 c } | global module_fields - { fun c -> let g = $1 c in let m = $2 c in - {m with globals = g () :: m.globals} } + { fun c -> let g, exs = $1 c in let m = $2 c in + if m.imports <> [] then + error (List.hd m.imports).at "import after global definition"; + {m with globals = g () :: m.globals; exports = exs @ m.exports} } | table module_fields - { fun c -> let m = $2 c in let tab, elems = $1 c in - match m.table with - | Some _ -> error tab.at "multiple table sections" - | None -> {m with table = Some tab; elems = elems @ m.elems} } + { fun c -> let m = $2 c in let tab, elems, exs = $1 c in + if m.imports <> [] then + error (List.hd m.imports).at "import after table definition"; + {m with tables = tab :: m.tables; elems = elems @ m.elems; exports = exs @ m.exports} } | memory module_fields - { fun c -> let m = $2 c in let mem, data = $1 c in - match m.memory with - | Some _ -> error mem.at "multiple memory sections" - | None -> {m with memory = Some mem; data = data @ m.data} } + { fun c -> let m = $2 c in let mem, data, exs = $1 c in + if m.imports <> [] then + error (List.hd m.imports).at "import after memory definition"; + {m with memories = mem :: m.memories; data = data @ m.data; exports = exs @ m.exports} } | func module_fields - { fun c -> let f = $1 c in let m = $2 c in let func, exs = f () in + { fun c -> let f, exs = $1 c in let m = $2 c in let func = f () in + if m.imports <> [] then + error (List.hd m.imports).at "import after function definition"; {m with funcs = func :: m.funcs; exports = exs @ m.exports} } | elem module_fields { fun c -> let m = $2 c in @@ -553,27 +656,39 @@ module_fields : {m with exports = $1 c :: m.exports} } ; module_ : - | LPAR MODULE module_fields RPAR - { Textual ($3 (empty_context ()) @@ at ()) @@ at() } - | LPAR MODULE TEXT text_list RPAR { Binary ($3 ^ $4) @@ at() } + | LPAR MODULE module_var_opt module_fields RPAR + { $3, Textual ($4 (empty_context ()) @@ at ()) @@ at () } + | LPAR MODULE module_var_opt TEXT text_list RPAR + { $3, Binary ($4 ^ $5) @@ at() } ; /* Scripts */ +module_var_opt : + | /* empty */ { None } + | VAR { Some ($1 @@ at ()) } /* Sugar */ +; +action : + | LPAR INVOKE module_var_opt TEXT const_list RPAR + { Invoke ($3, $4, $5) @@ at () } + | LPAR GET module_var_opt TEXT RPAR + { Get ($3, $4) @@ at() } +; cmd : - | module_ { Define $1 @@ at () } - | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () } - | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () } - | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_list RPAR - { AssertReturn ($5, $6, $8) @@ at () } - | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR - { AssertReturnNaN ($5, $6) @@ at () } - | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR - { AssertTrap ($5, $6, $8) @@ at () } + | module_ { Define (fst $1, snd $1) @@ at () } + | action { Action $1 @@ at () } + | LPAR REGISTER TEXT module_var_opt RPAR { Register ($3, $4) @@ at () } + | LPAR ASSERT_INVALID module_ TEXT RPAR + { AssertInvalid (snd $3, $4) @@ at () } + | LPAR ASSERT_UNLINKABLE module_ TEXT RPAR + { AssertUnlinkable (snd $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 () } - | LPAR OUTPUT TEXT RPAR { Output (Some $3) @@ at () } - | LPAR OUTPUT RPAR { Output None @@ at () } + | LPAR OUTPUT module_var_opt TEXT RPAR { Output ($3, Some $4) @@ at () } + | LPAR OUTPUT module_var_opt RPAR { Output ($3, None) @@ at () } ; cmd_list : | /* empty */ { [] } @@ -595,6 +710,6 @@ script1 : | cmd { [$1] } ; module1 : - | module_ EOF { $1 } + | module_ EOF { snd $1 } ; %% diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 68c29a47fc..664c9df8fa 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -1,47 +1,46 @@ open Ast open Source open Printf +open Types -(* Types *) - -open Types +(* Ast *) -let func_type m f = - List.nth m.it.types f.it.ftype.it +let print_sig prefix i string_of_type t = + printf "%s %d : %s\n" prefix i (string_of_type t) -let string_of_table_type = function - | None -> "()" - | Some t -> "(" ^ string_of_func_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 print_table m i tab = + print_sig "table" i string_of_table_type tab.it.ttype -let print_var_sig prefix i t = - printf "%s %d : %s\n" prefix i (string_of_value_type t.it) +let print_memory m i mem = + print_sig "memory" i string_of_memory_type mem.it.mtype -let print_func_sig m prefix i f = - printf "%s %d : %s\n" prefix i (string_of_func_type (func_type m f)) +let print_global m i glob = + print_sig "global" i string_of_global_type glob.it.gtype let print_export m i ex = - let {name; kind} = ex.it in - let ascription = - match kind with - | `Func x -> string_of_func_type (func_type m (List.nth m.it.funcs x.it)) - | `Memory -> "memory" - in printf "export \"%s\" : %s\n" name ascription + let {name; ekind; item} = ex.it in + let kind = + match ekind.it with + | FuncExport -> "func" + | TableExport -> "table" + | MemoryExport -> "memory" + | GlobalExport -> "global" + in printf "export \"%s\" = %s %d\n" name kind item.it let print_start start = Lib.Option.app (fun x -> printf "start = func %d\n" x.it) start - -(* Ast *) - -let print_func m i f = - print_func_sig m "func" i f - let print_module m = (* TODO: more complete print function *) - let {funcs; start; exports; table; _} = m.it in + let {funcs; globals; tables; memories; start; exports; _} = m.it in List.iteri (print_func m) funcs; + List.iteri (print_global m) globals; + List.iteri (print_table m) tables; + List.iteri (print_memory m) memories; List.iteri (print_export m) exports; print_start start; flush_all () diff --git a/ml-proto/host/run.ml b/ml-proto/host/run.ml index ba4b7b61a1..5ba8808607 100644 --- a/ml-proto/host/run.ml +++ b/ml-proto/host/run.ml @@ -30,6 +30,7 @@ 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 @@ -44,7 +45,7 @@ let run_binary name buf = run_from (fun _ -> let m = Decode.decode name buf in - [Script.Define (Script.Textual m @@ m.at) @@ m.at]) + [Script.Define (None, Script.Textual m @@ m.at) @@ m.at]) let run_sexpr_file file = Script.trace ("Loading (" ^ file ^ ")..."); diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index f54b9d9d50..74b1abe05a 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -1,23 +1,33 @@ open Source +open Instance (* Script representation *) +type var = string Source.phrase + type definition = definition' Source.phrase and definition' = | Textual of Ast.module_ | Binary of string +type action = action' Source.phrase +and action' = + | Invoke of var option * string * Ast.literal list + | Get of var option * string + type command = command' Source.phrase and command' = - | Define of definition - | Invoke of string * Ast.literal list + | Define of var option * definition + | Register of string * var option + | Action of action | AssertInvalid of definition * string - | AssertReturn of string * Ast.literal list * Ast.literal list - | AssertReturnNaN of string * Ast.literal list - | AssertTrap of string * Ast.literal list * string + | AssertUnlinkable of definition * string + | AssertReturn of action * Ast.literal list + | AssertReturnNaN of action + | AssertTrap of action * string | Input of string - | Output of string option + | Output of var option * string option type script = command list @@ -36,16 +46,40 @@ exception IO = IO.Error let trace name = if !Flags.trace then print_endline ("-- " ^ name) +module Map = Map.Make(String) + +let registry : Instance.instance Map.t ref = ref Map.empty + +let lookup module_name item_name _t = + match Instance.export (Map.find module_name !registry) item_name with + | Some ext -> ext + | None -> raise Not_found + +let modules : Ast.module_ Map.t ref = ref Map.empty +let instances : Instance.instance Map.t ref = ref Map.empty let current_module : Ast.module_ option ref = ref None -let current_instance : Eval.instance option ref = ref None +let current_instance : Instance.instance option ref = ref None + +let bind map x_opt y = + match x_opt with + | None -> () + | Some x -> map := Map.add x.it y !map -let get_module at = match !current_module with - | Some m -> m - | None -> raise (Eval.Crash (at, "no module defined")) +let get_module x_opt at = + match x_opt, !current_module with + | None, Some m -> m + | None, None -> raise (Eval.Crash (at, "no module defined")) + | Some x, _ -> + try Map.find x.it !modules with Not_found -> + raise (Eval.Crash (x.at, "unknown module " ^ x.it)) -let get_instance at = match !current_instance with - | Some m -> m - | None -> raise (Eval.Crash (at, "no module defined")) +let get_instance x_opt at = + match x_opt, !current_instance with + | None, Some inst -> inst + | None, None -> raise (Eval.Crash (at, "no module defined")) + | Some x, _ -> + try Map.find x.it !instances with Not_found -> + raise (Eval.Crash (x.at, "unknown module " ^ x.it)) let input_file = ref (fun _ -> assert false) let output_file = ref (fun _ -> assert false) @@ -56,27 +90,56 @@ 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 + | Invoke (x_opt, name, es) -> + trace ("Invoking function \"" ^ name ^ "\"..."); + let inst = get_instance x_opt act.at in + (match Instance.export inst name with + | Some (ExternalFunc f) -> Eval.invoke f (List.map it es) + | 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) -> [v] + | Some _ -> Assert.error act.at "export is not a global" + | None -> Assert.error act.at "undefined export" + ) let run_cmd cmd = match cmd.it with - | Define def -> + | Define (x_opt, def) -> let m = run_def def in - trace "Checking..."; - Check.check_module m; - if !Flags.print_sig then begin - trace "Signature:"; - Print.print_module_sig m + if not !Flags.unchecked then begin + trace "Checking..."; + Check.check_module m; + if !Flags.print_sig then begin + trace "Signature:"; + Print.print_module_sig m + end end; - current_module := Some m; trace "Initializing..."; let imports = Import.link m in - current_instance := Some (Eval.init m imports) + let inst = Eval.init m imports in + current_module := Some m; + current_instance := Some inst; + bind modules x_opt m; + bind instances x_opt inst - | Invoke (name, es) -> - trace ("Invoking \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let vs = Eval.invoke m name (List.map it es) in + | Register (name, x_opt) -> + trace ("Registering module \"" ^ name ^ "\"..."); + let inst = get_instance x_opt cmd.at in + registry := Map.add name inst !registry; + Import.register name (lookup name) + + | Action act -> + let vs = run_action act in if vs <> [] then Print.print_result vs | AssertInvalid (def, re) -> @@ -95,21 +158,37 @@ let run_cmd cmd = Assert.error cmd.at "expected validation error" ) - | AssertReturn (name, es, expect_es) -> - trace ("Asserting return \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let got_vs = Eval.invoke m name (List.map it es) in - let expect_vs = List.map it expect_es in + | AssertUnlinkable (def, re) -> + trace "Asserting unlinkable..."; + let m = run_def def in + if not !Flags.unchecked then Check.check_module m; + (match + 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 + print_endline ("Result: \"" ^ msg ^ "\""); + print_endline ("Expect: \"" ^ re ^ "\""); + Assert.error cmd.at "wrong linking error" + end + | _ -> + Assert.error cmd.at "expected linking error" + ) + + | AssertReturn (act, es) -> + trace ("Asserting return..."); + 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 (name, es) -> - trace ("Asserting return \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - let got_vs = Eval.invoke m name (List.map it es) in + | AssertReturnNaN act -> + trace ("Asserting return..."); + let got_vs = run_action act in if match got_vs with | [Values.F32 got_f32] -> @@ -123,10 +202,9 @@ let run_cmd cmd = Assert.error cmd.at "wrong return value" end - | AssertTrap (name, es, re) -> - trace ("Asserting trap \"" ^ name ^ "\"..."); - let m = get_instance cmd.at in - (match Eval.invoke m name (List.map it es) with + | AssertTrap (act, re) -> + trace ("Asserting trap..."); + (match run_action act with | exception Eval.Trap (_, msg) -> if not (Str.string_match (Str.regexp re) msg 0) then begin print_endline ("Result: \"" ^ msg ^ "\""); @@ -141,12 +219,12 @@ let run_cmd cmd = (try if not (!input_file file) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) - | Output (Some file) -> - (try !output_file file (get_module cmd.at) + | Output (x_opt, Some file) -> + (try !output_file file (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Output None -> - (try !output_stdout (get_module cmd.at) + | Output (x_opt, None) -> + (try !output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) let dry_def def = @@ -154,30 +232,35 @@ 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 def -> + | Define (x_opt, def) -> let m = dry_def def in - trace "Checking..."; - Check.check_module m; - if !Flags.print_sig then begin - trace "Signature:"; - Print.print_module_sig m + if not !Flags.unchecked then begin + trace "Checking..."; + Check.check_module m; + if !Flags.print_sig then begin + trace "Signature:"; + Print.print_module_sig m + end end; - current_module := Some m + current_module := Some m; + bind modules x_opt m | Input file -> (try if not (!input_file file) then Abort.error cmd.at "aborting" with Sys_error msg -> IO.error cmd.at msg) - | Output (Some file) -> - (try !output_file file (get_module cmd.at) + | Output (x_opt, Some file) -> + (try !output_file file (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Output None -> - (try !output_stdout (get_module cmd.at) + | Output (x_opt, None) -> + (try !output_stdout (get_module x_opt cmd.at) with Sys_error msg -> IO.error cmd.at msg) - | Invoke _ + | Register _ + | Action _ | AssertInvalid _ + | AssertUnlinkable _ | AssertReturn _ | AssertReturnNaN _ | AssertTrap _ -> () diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index 977e21a130..60e21182bf 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -1,18 +1,27 @@ +type var = string Source.phrase + type definition = definition' Source.phrase and definition' = | Textual of Ast.module_ | Binary of string +type action = action' Source.phrase +and action' = + | Invoke of var option * string * Ast.literal list + | Get of var option * string + type command = command' Source.phrase and command' = - | Define of definition - | Invoke of string * Ast.literal list + | Define of var option * definition + | Register of string * var option + | Action of action | AssertInvalid of definition * string - | AssertReturn of string * Ast.literal list * Ast.literal list - | AssertReturnNaN of string * Ast.literal list - | AssertTrap of string * Ast.literal list * string + | AssertUnlinkable of definition * string + | AssertReturn of action * Ast.literal list + | AssertReturnNaN of action + | AssertTrap of action * string | Input of string - | Output of string option + | Output of var option * string option type script = command list diff --git a/ml-proto/runtests.py b/ml-proto/runtests.py index 69823fcdf2..b235e892e1 100755 --- a/ml-proto/runtests.py +++ b/ml-proto/runtests.py @@ -44,28 +44,28 @@ 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: return - # Convert to binary and run again + # 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 %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 run again + # 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 %s ") % (interpreterPath, wastPath), logPath) + self._runCommand(("%s -d '%s' -o '%s'") % (interpreterPath, wasmPath, wastPath)) + self._runCommand(("%s -d '%s' ") % (interpreterPath, wastPath), logPath) # 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 %s") % (interpreterPath, wasm2Path), logPath) + 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) diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 26c4903e0f..9081b69205 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -16,14 +16,7 @@ * These conventions mostly follow standard practice in language semantics. *) - -open Values - - -(* Types *) - -type value_type = Types.value_type -type elem_type = Types.elem_type +open Types (* Operators *) @@ -56,11 +49,11 @@ 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 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} @@ -71,7 +64,7 @@ type storeop = Memory.mem_size memop (* Expressions *) type var = int Source.phrase -type literal = value Source.phrase +type literal = Values.value Source.phrase type instr = instr' Source.phrase and instr' = @@ -87,7 +80,6 @@ and instr' = | Return (* break from function body *) | If of instr list * instr list (* conditional *) | Call of var (* call function *) - | CallImport of var (* call imported function *) | CallIndirect of var (* call function through table *) | GetLocal of var (* read local variable *) | SetLocal of var (* write local variable *) @@ -113,7 +105,7 @@ type const = instr list Source.phrase type global = global' Source.phrase and global' = { - gtype : Types.value_type; + gtype : global_type; value : const; } @@ -128,29 +120,22 @@ and func' = (* Tables & Memories *) -type 'size limits = 'size limits' Source.phrase -and 'size limits' = -{ - min : 'size; - max : 'size option; -} - type table = table' Source.phrase and table' = { - tlimits : Table.size limits; - etype : elem_type; + ttype : table_type; } type memory = memory' Source.phrase and memory' = { - mlimits : Memory.size limits; + mtype : memory_type; } type 'data segment = 'data segment' Source.phrase and 'data segment' = { + index : var; offset : const; init : 'data; } @@ -161,19 +146,30 @@ 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; - kind : [`Func of var | `Memory] + 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' = { - itype : var; module_name : string; - func_name : string; + item_name : string; + ikind : import_kind; } type module_ = module_' Source.phrase @@ -181,8 +177,8 @@ and module_' = { types : Types.func_type list; globals : global list; - table : table option; - memory : memory option; + tables : table list; + memories : memory list; funcs : func list; start : var option; elems : var list segment list; diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 8f547b50a6..56d045c271 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -26,33 +26,30 @@ type context = module_ : module_; types : func_type list; funcs : func_type list; - imports : func_type list; + tables : table_type list; + memories : memory_type list; + globals : global_type list; locals : value_type list; - globals : value_type list; - return : value_type list; + results : value_type list; labels : result_type ref list; - table : Table.size option; - memory : Memory.size option; } +let context m = + { module_ = m; types = []; funcs = []; tables = []; memories = []; + 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) -let type_ types x = lookup "function type" types x +let type_ c x = lookup "type" c.types x let func c x = lookup "function" c.funcs x let import c x = lookup "import" c.imports x let local c x = lookup "local" c.locals x let global c x = lookup "global" c.globals x let label c x = lookup "label" c.labels x - -let lookup_size category opt at = - match opt with - | Some n -> n - | None -> error at ("no " ^ category ^ " defined") - -let table c at = lookup_size "table" c.table at -let memory c at = lookup_size "memory" c.memory at +let table c x = lookup "table" c.tables x +let memory c x = lookup "memory" c.memories x (* Join *) @@ -114,7 +111,7 @@ let type_cvtop at = function (* Expressions *) let check_memop (c : context) (memop : 'a memop) get_sz at = - ignore (memory c at); + ignore (memory c (0 @@ 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 @@ -202,7 +199,7 @@ let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = (ts @ [I32Type]) --> Bot | Return -> - c.return --> Bot + c.results --> Bot | If (es1, es2) -> let vr = unknown () in @@ -221,13 +218,9 @@ let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = let FuncType (ins, out) = func c x in ins --> Stack out - | CallImport x -> - let FuncType (ins, out) = import c x in - ins --> Stack out - | CallIndirect x -> - ignore (table c e.at); - let FuncType (ins, out) = type_ c.types x in + ignore (table c (0 @@ e.at)); + let FuncType (ins, out) = type_ c x in (ins @ [I32Type]) --> Stack out | GetLocal x -> @@ -240,10 +233,13 @@ let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = [local c x] --> Stack [local c x] | GetGlobal x -> - [] --> Stack [global c x] + let GlobalType (t, mut) = global c x in + [] --> Stack [t] | SetGlobal x -> - [global c x] --> Stack [] + let GlobalType (t, mut) = global c x in + require (mut = Mutable) x.at "global is immutable"; + [t] --> Stack [] | Load memop -> check_memop c memop (Lib.Option.map fst) e.at; @@ -278,11 +274,11 @@ let rec check_instr (c : context) (e : instr) (stack : stack_type) : op_type = [t1] --> Stack [t2] | CurrentMemory -> - ignore (memory c e.at); + ignore (memory c (0 @@ e.at)); [] --> Stack [I32Type] | GrowMemory -> - ignore (memory c e.at); + ignore (memory c (0 @@ e.at)); [I32Type] --> Stack [I32Type] and check_block (c : context) (es : instr list) : result_type = @@ -309,9 +305,6 @@ and check_block (c : context) (es : instr list) : result_type = (* Functions & Constants *) (* - * check_func : context -> func -> unit - * check_module : context -> module_ -> unit - * * Conventions: * c : context * m : module_ @@ -324,10 +317,10 @@ and check_block (c : context) (es : instr list) : result_type = let check_func (c : context) (f : func) = let {ftype; locals; body} = f.it in - let FuncType (ins, out) = type_ c.types ftype in + 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; return = out; labels = [vr]} 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) @@ -345,69 +338,73 @@ let check_const (c : context) (const : const) (t : value_type) = | r -> result_error const.at (Stack [t]) r -(* Tables & Memories *) +(* Tables, Memories, & Globals *) -let check_table_limits (lim : Table.size limits) = - let {min; max} = lim.it in +let check_table_type (t : table_type) at = + let TableType ({min; max}, _) = t in match max with | None -> () | Some max -> - require (I32.le_u min max) lim.at + require (I32.le_u min max) at "table size minimum must not be greater than maximum" let check_table (c : context) (tab : table) = - let {tlimits = lim; etype = t} = tab.it in - check_table_limits lim + let {ttype} = tab.it in + check_table_type ttype tab.at -let check_memory_limits (lim : Memory.size limits) = - let {min; max} = lim.it in - require (I32.lt_u min 65536l) lim.at +let check_memory_type (t : memory_type) at = + let MemoryType {min; max} = t in + require (I32.lt_u min 65536l) at "memory size must be less than 65536 pages (4GiB)"; match max with | None -> () | Some max -> - require (I32.lt_u max 65536l) lim.at + require (I32.lt_u max 65536l) at "memory size must be less than 65536 pages (4GiB)"; - require (I32.le_u min max) lim.at + require (I32.le_u min max) at "memory size minimum must not be greater than maximum" let check_memory (c : context) (mem : memory) = - let {mlimits = lim} = mem.it in - check_memory_limits lim + let {mtype} = mem.it in + check_memory_type mtype mem.at let check_table_segment c prev_end seg = - let {offset; init} = seg.it in + let {index; offset; init} = seg.it 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 require (I32.le_u prev_end start) seg.at "table segment not disjoint and ordered"; - require (I32.le_u end_ (table c seg.at)) seg.at - "table segment does not fit memory"; + require (I32.le_u end_ lim.min) seg.at + "table segment does not fit into table"; ignore (List.map (func c) init); end_ let check_memory_segment c prev_end seg = - let {offset; init} = seg.it in + let {index; offset; init} = seg.it in check_const c offset I32Type; let start = 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 limit = Int64.mul (Int64.of_int32 (memory c seg.at)) Memory.page_size in + let MemoryType lim = memory c index in + let limit = Int64.mul (Int64.of_int32 lim.min) Memory.page_size in require (I64.le_u prev_end start) seg.at "data segment not disjoint and ordered"; require (I64.le_u end_ limit) seg.at - "data segment does not fit memory"; + "data segment does not fit into memory"; end_ +let check_global c glob = + let {gtype; value} = glob.it in + let GlobalType (t, mut) = gtype in + check_const c value t; + {c with globals = c.globals @ [gtype]} -(* Modules *) -let check_global c g = - let {gtype; value} = g.it in - check_const c value gtype +(* Modules *) let check_start c start = Lib.Option.app (fun x -> @@ -415,42 +412,54 @@ let check_start c start = "start function must not have parameters or results" ) start +let check_import im c = + let {module_name = _; item_name = _; ikind} = im.it in + match ikind.it with + | FuncImport x -> + {c with funcs = type_ c x :: c.funcs} + | TableImport t -> + check_table_type t ikind.at; {c with tables = t :: c.tables} + | MemoryImport t -> + check_memory_type t ikind.at; {c with memories = t :: c.memories} + | GlobalImport t -> + let GlobalType (_, mut) = t in + require (mut = Immutable) ikind.at "mutable globals cannot be imported (yet)"; + {c with globals = t :: c.globals} + module NameSet = Set.Make(String) let check_export c set ex = - let {name; kind} = ex.it in - (match kind with - | `Func x -> ignore (func c x) - | `Memory -> ignore (memory c ex.at) + let {name; ekind; item} = ex.it in + (match ekind.it with + | FuncExport -> ignore (func c item) + | TableExport -> ignore (table c item) + | MemoryExport -> ignore (memory c item) + | GlobalExport -> + let GlobalType (_, mut) = global c item in + require (mut = Immutable) ekind.at "mutable globals cannot be exported (yet)" ); 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; table; memory; globals; funcs; start; elems; data; - imports; exports} = m.it in - let c = - { - module_ = m; - types; - funcs = List.map (fun f -> type_ types f.it.ftype) funcs; - imports = List.map (fun i -> type_ types i.it.itype) imports; - globals = []; - locals = []; - return = []; - labels = []; - table = Lib.Option.map (fun tab -> tab.it.tlimits.it.min) table; - memory = Lib.Option.map (fun mem -> mem.it.mlimits.it.min) memory; + {types; imports; tables; memories; globals; funcs; start; elems; data; + exports} = m.it 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; + memories = c.memories @ List.map (fun mem -> mem.it.mtype) memories; } in - List.iter (check_global c) globals; - let c' = {c with globals = List.map (fun g -> g.it.gtype) globals} in + require (List.length c'.tables <= 1) m.at "multiple tables"; + require (List.length c'.memories <= 1) m.at "multiple memories"; List.iter (check_func c') funcs; - Lib.Option.app (check_table c') table; - Lib.Option.app (check_memory c') memory; - ignore (List.fold_left (check_export c') NameSet.empty exports); + List.iter (check_table c') tables; + List.iter (check_memory c') memories; ignore (List.fold_left (check_table_segment c') 0l elems); ignore (List.fold_left (check_memory_segment c') 0L data); + ignore (List.fold_left (check_export c') NameSet.empty exports); check_start c' start diff --git a/ml-proto/spec/decode.ml b/ml-proto/spec/decode.ml index 5243852916..abe2f0dca8 100644 --- a/ml-proto/spec/decode.ml +++ b/ml-proto/spec/decode.ml @@ -114,7 +114,7 @@ let vec1 f s = let b = bool s in opt f b s open Types let value_type s = - match get s with + match u8 s with | 0x01 -> I32Type | 0x02 -> I64Type | 0x03 -> F32Type @@ -122,7 +122,7 @@ let value_type s = | _ -> error s (pos s - 1) "invalid value type" let elem_type s = - match get s with + match u8 s with | 0x20 -> AnyFuncType | _ -> error s (pos s - 1) "invalid element type" @@ -132,6 +132,32 @@ let func_type s = 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) + (* Decode instructions *) @@ -142,10 +168,10 @@ let op s = u8 s let arity s = vu s let memop s = - let align = vu s in - (*TODO: check flag bits*) + let align = vu32 s in + require (I32.lt_u align 32l) s (pos s - 1) "invalid memop flags"; let offset = vu64 s in - align, offset + 1 lsl Int32.to_int align, offset let var s = vu s let var32 s = Int32.to_int (vu32 s) @@ -217,7 +243,6 @@ let rec instr s = | 0x16 -> call (at var s) | 0x17 -> call_indirect (at var s) - | 0x18 -> call_import (at var s) | 0x19 -> tee_local (at var s) @@ -404,7 +429,7 @@ and instr_block' s es = let const s = let c = at instr_block s in - expect 0x0f s "`end` opcode expected"; + expect 0x0f s "END opcode expected"; c @@ -449,11 +474,19 @@ let type_section s = (* Import section *) +let import_kind s = + match u8 s with + | 0x00 -> FuncImport (at var s) + | 0x01 -> TableImport (table_type s) + | 0x02 -> MemoryImport (memory_type s) + | 0x03 -> GlobalImport (global_type s) + | _ -> error s (pos s - 1) "invalid import kind" + let import s = - let itype = at var s in let module_name = string s in - let func_name = string s in - {itype; module_name; func_name} + let item_name = string s in + let ikind = at import_kind s in + {module_name; item_name; ikind} let import_section s = section `ImportSection (vec (at import)) [] s @@ -467,35 +500,28 @@ let func_section s = (* Table section *) -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 s = - let t = elem_type s in - let lim = at (limits vu32) s in - {etype = t; tlimits = lim} + let ttype = table_type s in + {ttype} let table_section s = - section `TableSection (opt (at table) true) None s + section `TableSection (vec (at table)) [] s (* Memory section *) let memory s = - let lim = at (limits vu32) s in - {mlimits = lim} + let mtype = memory_type s in + {mtype} let memory_section s = - section `MemorySection (opt (at memory) true) None s + section `MemorySection (vec (at memory)) [] s (* Global section *) let global s = - let gtype = value_type s in + let gtype = global_type s in let value = const s in {gtype; value} @@ -505,10 +531,19 @@ let global_section s = (* Export section *) +let export_kind s = + match u8 s with + | 0x00 -> FuncExport + | 0x01 -> TableExport + | 0x02 -> MemoryExport + | 0x03 -> GlobalExport + | _ -> error s (pos s - 1) "invalid export kind" + let export s = - let x = at var s in let name = string s in - {name; kind = `Func x} (*TODO: pending resolution*) + let ekind = at export_kind s in + let item = at var s in + {name; ekind; item} let export_section s = section `ExportSection (vec (at export)) [] s @@ -528,9 +563,10 @@ let local s = Lib.List.make n t let code s = - let locals = List.flatten (vec local s) in let size = vu s in - let body = instr_block (substream s (pos s + size)) in + let pos = pos s in + let locals = List.flatten (vec local s) in + let body = instr_block (substream s (pos + size)) in {locals; body; ftype = Source.((-1) @@ Source.no_region)} let code_section s = @@ -540,9 +576,10 @@ let code_section s = (* Element section *) let segment dat s = + let index = at var s in let offset = const s in let init = dat s in - {offset; init} + {index; offset; init} let table_segment s = segment (vec (at var)) s @@ -582,9 +619,9 @@ let module_ s = iterate unknown_section s; let func_types = func_section s in iterate unknown_section s; - let table = table_section s in + let tables = table_section s in iterate unknown_section s; - let memory = memory_section s in + let memories = memory_section s in iterate unknown_section s; let globals = global_section s in iterate unknown_section s; @@ -606,7 +643,7 @@ let module_ s = let funcs = List.map2 Source.(fun t f -> {f.it with ftype = t} @@ f.at) func_types func_bodies - in {types; table; memory; globals; funcs; imports; exports; elems; data; start} + in {types; tables; memories; globals; funcs; imports; exports; elems; data; start} let decode name bs = at module_ (stream name bs) diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml index 6f5e514be3..d7b88195f9 100644 --- a/ml-proto/spec/desugar.ml +++ b/ml-proto/spec/desugar.ml @@ -27,7 +27,6 @@ and relabel' f n = function | 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) - | CallImport (x, es) -> CallImport (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 @@ -79,7 +78,6 @@ and expr' at = function | Ast.Select (e1, e2, e3) -> Select (expr e1, expr e2, expr e3) | Ast.Call (x, es) -> Call (x, List.map expr es) - | Ast.Call_import (x, es) -> CallImport (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 @@ -309,15 +307,15 @@ and func' = function let rec segment seg = segment' seg.it @@ seg.at and segment' = function - | {Ast.offset = e; init} -> {offset = expr e; init} + | {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; memory; types; imports; exports; table; elems; data} -> + | {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; memory; types; imports; exports; table; elems; data} + {funcs; start; globals; memories; types; imports; exports; tables; elems; data} let desugar = module_ diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index 438de0ee2a..e9dc9d10e0 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -1,34 +1,17 @@ open Values open Types +open Instance open Ast open Source -(* Module Instances *) - -type 'a stack = 'a list -type value = Values.value -type import = value stack -> value stack - -module Map = Map.Make(String) -type 'a map = 'a Map.t - -type instance = -{ - module_ : module_; - imports : (int * import) list; - exports : int map; - table : Table.t option; - memory : Memory.t option; - globals : value ref list; -} - - (* Errors *) +module Link = Error.Make () module Trap = Error.Make () module Crash = Error.Make () +exception Link = Link.Error exception Trap = Trap.Error exception Crash = Crash.Error (* failure that cannot happen in valid code *) @@ -77,16 +60,17 @@ let numeric_error at = function * instead avoids computing stack heights in the semantics. *) +type 'a stack = 'a 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 and block = {target : instr list; bcontext : block_context} -and call = {locals : value list; arity : int; ccontext : call_context} - -type config = {instance : instance} +and call = {instance : instance; locals : value list; arity : int; + ccontext : call_context} -let resource_limit = 1000 +let resource_limit = 100 let lookup category list x = try List.nth list x.it with Failure _ -> @@ -97,36 +81,33 @@ let update category list x y = with Failure _ -> Crash.error x.at ("undefined " ^ category ^ " " ^ string_of_int x.it) -let type_ c x = lookup "type" c.instance.module_.it.types x -let func c x = lookup "function" c.instance.module_.it.funcs x -let import c x = lookup "import" c.instance.imports x -let global c x = lookup "global" c.instance.globals x - let local c x = lookup "local" c.locals x let update_local c x v = {c with locals = update "local" c.locals x v} -let export inst name = - try Map.find name.it inst.exports with Not_found -> - Crash.error name.at ("undefined export \"" ^ name.it ^ "\"") - -let table c at = - match c.instance.table with - | Some tab -> tab - | _ -> Crash.error at "no table" - -let memory c at = - match c.instance.memory with - | Some mem -> mem - | _ -> Crash.error at "no memory" +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 c i t at = - match Table.load (table c at) i t with +let elem inst x i t at = + match Table.load (table inst x) i t with | Some j -> j | None -> - Trap.error at ("undefined element " ^ Int32.to_string i) + Trap.error at ("uninitialized element " ^ Int32.to_string i) | exception Table.Bounds -> Trap.error at ("undefined element " ^ Int32.to_string i) +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 = + match t with + | AstFunc (inst, f) -> lookup "type" (!inst).module_.it.types f.it.ftype + | HostFunc _ -> Link.error at "invalid use of host function" + let take n (vs : 'a stack) at = try Lib.List.take n vs with Failure _ -> Crash.error at "stack underflow" @@ -140,27 +121,37 @@ let drop n (vs : 'a stack) at = (* * Conventions: - * c : config * e : instr * v : value * es : instr list - * vs : value list + * vs : value stack + * bs : block stack + * cs : call stack *) -let length32 xs = Int32.of_int (List.length xs) -let nth32 xs n = List.nth xs (Int32.to_int n) +let i32 v at = + match v with + | I32 i -> i + | _ -> Crash.error at "type error: i32 value expected" -let eval_call (c : config) (f : func) (es, vs, bs, cs : eval_context) at = +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) = type_ c f.it.ftype in - let n = List.length ins in - let m = List.length out in - let args = List.rev (take n vs at) in - let locals = args @ List.map default_value f.it.locals in - [Block f.it.body @@ f.at], [], [], - {locals; arity = m; ccontext = es, drop n vs at, bs} :: cs - -let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_context = + match clos with + | AstFunc (inst, f) -> + let FuncType (ins, out) = func_type_of clos at in + let n = List.length ins in + let m = List.length out in + let args = List.rev (take n vs at) in + let locals = args @ List.map default_value f.it.locals in + [Block f.it.body @@ f.at], [], [], + {instance = !inst; locals; arity = m; ccontext = es, drop n vs at, bs} + :: cs + + | HostFunc f -> + try es, f vs, bs, cs (* TODO: consider import signature *) + with Crash (_, msg) -> Crash.error at msg + +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" @@ -188,11 +179,12 @@ let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_c | 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 (length32 xs) -> + | BrTable (n, xs, x), I32 i :: vs', _, _ + when I32.ge_u i (Lib.List.length32 xs) -> (Br (n, x) @@ e.at) :: es, vs', bs, cs | BrTable (n, xs, x), I32 i :: vs', _, _ -> - (Br (n, nth32 xs i) @@ e.at) :: es, vs', bs, cs + (Br (n, Lib.List.nth32 xs i) @@ e.at) :: es, vs', bs, cs | Return, vs, _, c :: cs' -> let es', vs', bs' = c.ccontext in @@ -210,23 +202,14 @@ let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_c | Select, I32 i :: v2 :: v1 :: vs', _, _ -> es, v1 :: vs', bs, cs - | Call x, _, _, _ -> - eval_call c (func c x) (es, vs, bs, cs) e.at + | Call x, _, _, c :: _ -> + eval_call (func c.instance x) (es, vs, bs, cs) e.at - | CallImport x, vs, _, _ -> - let x, f = import c x in - let FuncType (ins, out) = type_ c (x @@ e.at) in - let n = List.length ins in - (try - let vs' = List.rev (f (List.rev (take n vs e.at))) in - es, drop n vs e.at @ vs', bs, cs - with Crash (_, msg) -> Crash.error e.at msg) - - | CallIndirect x, I32 i :: vs, _, _ -> - let f = func c (elem c i AnyFuncType e.at @@ e.at) in - if type_ c x <> type_ c f.it.ftype then + | CallIndirect x, I32 i :: vs, _, c :: _ -> + let func = func_elem c.instance (0 @@ e.at) i e.at in + if type_ c.instance x <> func_type_of func e.at then Trap.error e.at "indirect call signature mismatch"; - eval_call c f (es, vs, bs, cs) e.at + eval_call func (es, vs, bs, cs) e.at | GetLocal x, vs, _, c :: _ -> es, (local c x) :: vs, bs, cs @@ -237,30 +220,31 @@ let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_c | TeeLocal x, v :: vs', _, c :: cs' -> es, v :: vs', bs, update_local c x v :: cs' - | GetGlobal x, vs, _, _ -> - es, !(global c x) :: vs, bs, cs + | GetGlobal x, vs, _, c :: _ -> + es, !(global c.instance x) :: vs, bs, cs - | SetGlobal x, v :: vs', _, _ -> - global c x := v; + | SetGlobal x, v :: vs', _, c :: _ -> + global c.instance x := v; es, vs', bs, cs - | Load {offset; ty; sz; _}, I32 i :: vs', _, _ -> + | Load {offset; ty; sz; _}, I32 i :: vs', _, c :: _ -> + let mem = memory c.instance (0 @@ e.at) in let addr = I64_convert.extend_u_i32 i in let v = try match sz with - | None -> Memory.load (memory c e.at) addr offset ty - | Some (sz, ext) -> - Memory.load_packed sz ext (memory c e.at) addr offset ty + | 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', _, _ -> + | Store {offset; sz; _}, v :: I32 i :: vs', _, c :: _ -> + let mem = memory c.instance (0 @@ e.at) in let addr = I64_convert.extend_u_i32 i in (try match sz with - | None -> Memory.store (memory c e.at) addr offset v - | Some sz -> Memory.store_packed sz (memory c e.at) addr offset v + | 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 @@ -287,12 +271,12 @@ let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_c (try es, Eval_numeric.eval_cvtop cvtop v :: vs', bs, cs with exn -> numeric_error e.at exn) - | CurrentMemory, vs, _, _ -> - let size = Memory.size (memory c e.at) in - es, I32 size :: vs, bs, cs + | CurrentMemory, vs, _, c :: _ -> + let mem = memory c.instance (0 @@ e.at) in + es, I32 (Memory.size mem) :: vs, bs, cs - | GrowMemory, I32 delta :: vs', _, _ -> - let mem = memory c e.at in + | GrowMemory, I32 delta :: vs', _, c :: _ -> + let mem = memory c.instance (0 @@ e.at) in let old_size = Memory.size mem in let result = try Memory.grow mem delta; old_size @@ -302,18 +286,20 @@ let eval_instr (c : config) (e : instr) (es, vs, bs, cs : eval_context) : eval_c | _ -> Crash.error e.at "type error: missing or ill-typed operand on stack" -let rec eval_seq (conf : config) (es, vs, bs, cs : eval_context) = +let rec eval_seq (es, vs, bs, cs : eval_context) = match es, bs, cs with | e :: es', _, _ -> - eval_seq conf (eval_instr conf e (es', vs, bs, cs)) + eval_seq (eval_instr e (es', vs, bs, cs)) | [], b :: bs', _ -> let es', vs' = b.bcontext in - eval_seq conf (es', vs @ vs', bs', cs) + eval_seq (es', vs @ vs', bs', cs) | [], [], c :: cs' -> + if List.length vs <> c.arity then + Crash.error no_region "type error: wrong number of values on stack"; let es', vs', bs' = c.ccontext in - eval_seq conf (es', vs @ vs', bs', cs') + eval_seq (es', vs @ vs', bs', cs') | [], [], [] -> vs @@ -321,76 +307,124 @@ let rec eval_seq (conf : config) (es, vs, bs, cs : eval_context) = (* Functions & Constants *) -let eval_func (inst : instance) (vs : value list) (x : var) : value list = - List.rev (eval_seq {instance = inst} ([Call x @@ x.at], List.rev vs, [], [])) +let eval_func (clos : closure) (vs : value list) at : value list = + List.rev (eval_seq (eval_call clos ([], List.rev vs, [], []) at)) let eval_const inst const = - match eval_seq {instance = inst} (const.it, [], [], []) with - | [v] -> v - | _ -> Crash.error const.at "type error: wrong number of values on stack" + let c = {instance = inst; locals = []; arity = 1; ccontext = [], [], []} in + List.hd (eval_seq (const.it, [], [], [c])) let const (m : module_) const = - let inst = - { module_ = m; imports = []; exports = Map.empty; - table = None; memory = None; globals = [] } - in eval_const inst const + eval_const (instance m) const (* Modules *) -let offset m seg = - (* TODO: allow referring to globals *) - let {offset; _} = seg.it in - try I32Value.of_value (const m offset) with Value _ -> - Crash.error offset.at "type error: ill-typed value on stack" - -let init_table m elems table = - let {tlimits = lim; _} = table.it in - let tab = Table.create lim.it.min lim.it.max in - let entries xs = List.map (fun x -> Some x.it) xs in - List.iter - (fun seg -> Table.blit tab (offset m seg) (entries seg.it.init)) - elems; - tab - -let init_memory m data memory = - let {mlimits = lim} = memory.it in - let mem = Memory.create lim.it.min lim.it.max in - List.iter - (fun seg -> Memory.blit mem (Int64.of_int32 (offset m seg)) seg.it.init) - data; - mem - -let init_global inst ref global = - let {value; _} = global.it in - (* TODO: allow referring to earlier globals *) - ref := eval_const inst value - -let add_export ex = - let {name; kind} = ex.it in - match kind with - | `Func x -> Map.add name x.it - | `Memory -> fun x -> x - -let init (m : module_) imports = - if (List.length imports <> List.length m.it.imports) then - Crash.error m.at "mismatch in number of imports"; - let {table; memory; globals; funcs; exports; elems; data; start; _} = m.it in +let create_closure m f = + AstFunc (ref (instance m), f) + +let create_table tab = + let {ttype = TableType (lim, t)} = tab.it in + Table.create lim (* TODO: elem_type *) + +let create_memory mem = + let {mtype = MemoryType lim} = mem.it in + Memory.create lim + +let create_global glob = + let {gtype = GlobalType (t, _); _} = glob.it in + ref (default_value t) + +let init_closure inst clos = + match clos with + | AstFunc (inst_ref, _) -> inst_ref := inst + | _ -> assert false + +let check_elem inst seg = + let {init; _} = seg.it in + List.iter (fun x -> ignore (func_type_of (func inst x) x.at)) init + +let init_table inst seg = + let {index; offset = e; init} = seg.it in + 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 inst seg = + let {index; offset = e; init} = seg.it 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 inst ref glob = + let {value = e; _} = glob.it in + ref := eval_const inst e + +let check_limits actual expected at = + if I32.lt_u actual.min expected.min then + Link.error at "actual size smaller than declared"; + if + match actual.max, expected.max with + | _, None -> false + | None, Some _ -> true + | Some i, Some j -> I32.gt_u i j + then Link.error at "maximum size larger than declared" + +let add_import (ext : extern) (imp : import) (inst : instance) : instance = + match ext, imp.it.ikind.it with + | ExternalFunc clos, FuncImport x -> + (match clos with + | AstFunc _ when func_type_of clos x.at <> type_ inst x -> + Link.error imp.it.ikind.at "type mismatch"; + | _ -> () + ); + {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} + | ExternalMemory mem, MemoryImport (MemoryType lim) -> + check_limits (Memory.limits mem) lim imp.it.ikind.at; + {inst with memories = mem :: inst.memories} + | ExternalGlobal v, GlobalImport (GlobalType _) -> + {inst with globals = ref v :: inst.globals} + | _ -> + Link.error imp.it.ikind.at "type mismatch" + +let add_export inst ex map = + let {name; ekind; item} = ex.it in + let ext = + match ekind.it with + | 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 = + let + { imports; tables; memories; globals; funcs; + exports; elems; data; start } = m.it + in + assert (List.length externals = List.length imports); (* TODO: better exception? *) + let fs = List.map (create_closure m) funcs in + let gs = List.map create_global globals in let inst = - { module_ = m; - imports = - List.combine (List.map (fun imp -> imp.it.itype.it) m.it.imports) - imports; - exports = List.fold_right add_export exports Map.empty; - table = Lib.Option.map (init_table m elems) table; - memory = Lib.Option.map (init_memory m data) memory; - globals = List.map (fun g -> ref (default_value g.it.gtype)) globals; - } + List.fold_right2 add_import externals imports + { (instance m) with + funcs = fs; + tables = List.map create_table tables; + memories = List.map create_memory memories; + globals = gs; + } in - List.iter2 (init_global inst) inst.globals globals; - Lib.Option.app (fun x -> ignore (eval_func inst [] x)) start; - inst - -let invoke (inst : instance) name (vs : value list) : value list = - eval_func inst vs (export inst (name @@ no_region) @@ 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") diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index 9898fe6bcc..d2d3242aa5 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -1,12 +1,12 @@ -type instance +open Values +open Instance + type 'a stack = 'a list -type value = Values.value -type import = value stack -> value stack +exception Link of Source.region * string exception Trap of Source.region * string exception Crash of Source.region * string -val init : Ast.module_ -> import list -> instance -val invoke : instance -> string -> value list -> value list - (* raises Trap, Crash *) +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/instance.ml b/ml-proto/spec/instance.ml new file mode 100644 index 0000000000..56b0f5d815 --- /dev/null +++ b/ml-proto/spec/instance.ml @@ -0,0 +1,34 @@ +open Values + +module ExportMap = Map.Make(String) + +type global = value ref + +type closure = + | AstFunc of instance ref * Ast.func + | HostFunc of (value list -> value list) + +and extern = + | ExternalFunc of closure + | ExternalTable of Table.t + | ExternalMemory of Memory.t + | ExternalGlobal of value + +and instance = +{ + module_ : Ast.module_; + funcs : closure list; + tables : Table.t list; + memories : Memory.t list; + globals : global list; + exports : extern ExportMap.t; +} + +exception Func of closure + +let instance m = + { module_ = m; funcs = []; tables = []; memories = []; globals = []; + exports = ExportMap.empty } + +let export inst name = + try Some (ExportMap.find name inst.exports) with Not_found -> None diff --git a/ml-proto/spec/memory.ml b/ml-proto/spec/memory.ml index 5b55fd8220..2e952d85e5 100644 --- a/ml-proto/spec/memory.ml +++ b/ml-proto/spec/memory.ml @@ -11,6 +11,7 @@ type extension = SX | ZX type value = Values.value type value_type = Types.value_type +type 'a limits = 'a Types.limits type memory' = (int, int8_unsigned_elt, c_layout) Array1.t type memory = {mutable content : memory'; max : size option} @@ -65,14 +66,17 @@ let create' n = mem with Out_of_memory -> raise OutOfMemory -let create n max = - assert (within_limits n max); - {content = create' n; max} +let create {min; max} = + assert (within_limits min max); + {content = create' min; max} let size mem = Int64.to_int32 (Int64.div (int64_of_host_size (Array1.dim mem.content)) page_size) +let limits mem = + {min = size mem; max = mem.max} + let grow mem delta = let host_old_size = Array1.dim mem.content in let old_size = size mem in diff --git a/ml-proto/spec/memory.mli b/ml-proto/spec/memory.mli index dab56c9a8b..c12b367421 100644 --- a/ml-proto/spec/memory.mli +++ b/ml-proto/spec/memory.mli @@ -10,6 +10,7 @@ type extension = SX | ZX type value = Values.value type value_type = Types.value_type +type 'a limits = 'a Types.limits exception Type exception Bounds @@ -18,11 +19,11 @@ exception SizeLimit exception OutOfMemory val page_size : offset - val mem_size : mem_size -> int -val create : size -> size option -> memory (* raise SizeOverflow, OutOfMemory *) +val create : size limits -> memory (* raise SizeOverflow, OutOfMemory *) val size : memory -> size +val limits : memory -> size limits val grow : memory -> size -> unit (* raise SizeOverflow, OutOfMemory *) val load : memory -> address -> offset -> value_type -> value diff --git a/ml-proto/spec/operators.ml b/ml-proto/spec/operators.ml index 54030cd61e..12b9a7d42d 100644 --- a/ml-proto/spec/operators.ml +++ b/ml-proto/spec/operators.ml @@ -23,7 +23,6 @@ let if_ es1 es2 = If (es1, es2) let select = Select let call x = Call x -let call_import x = CallImport x let call_indirect x = CallIndirect x let get_local x = GetLocal x diff --git a/ml-proto/spec/table.ml b/ml-proto/spec/table.ml index a2b96375a0..cb8af681ff 100644 --- a/ml-proto/spec/table.ml +++ b/ml-proto/spec/table.ml @@ -4,8 +4,9 @@ open Values type size = int32 type index = int32 -type elem = int option +type elem = exn option type elem_type = Types.elem_type +type 'a limits = 'a Types.limits type table' = elem array type table = {mutable content : table'; max : size option} @@ -41,13 +42,16 @@ let within_limits size = function let create' size = Array.make (host_size_of_int32 size) None -let create size max = - assert (within_limits size max); - {content = create' size; max} +let create {min; max} = + assert (within_limits min max); + {content = create' min; max} let size tab = int32_of_host_size (Array.length tab.content) +let limits tab = + {min = size tab; max = tab.max} + let grow tab delta = let old_size = size tab in let new_size = Int32.add old_size delta in @@ -70,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 579c917545..3b88e3d1be 100644 --- a/ml-proto/spec/table.mli +++ b/ml-proto/spec/table.mli @@ -4,15 +4,17 @@ type t = table type size = int32 type index = int32 -type elem = int option +type elem = exn option type elem_type = Types.elem_type +type 'a limits = 'a Types.limits exception Bounds exception SizeOverflow exception SizeLimit -val create : size -> size option -> table +val create : size limits -> table val size : table -> size +val limits : table -> size limits val grow : table -> size -> unit val load : table -> index -> elem_type -> elem diff --git a/ml-proto/spec/types.ml b/ml-proto/spec/types.ml index 6ffb8dafdd..4d25595b09 100644 --- a/ml-proto/spec/types.ml +++ b/ml-proto/spec/types.ml @@ -6,6 +6,17 @@ 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 +type table_type = TableType of Int32.t limits * elem_type +type memory_type = MemoryType of Int32.t limits +type global_type = GlobalType of value_type * mutability +type external_type = + | ExternalFuncType of func_type + | ExternalTableType of table_type + | ExternalMemoryType of memory_type + | ExternalGlobalType of global_type + (* Attributes *) @@ -29,6 +40,20 @@ let string_of_value_types = function let string_of_elem_type = function | AnyFuncType -> "anyfunc" +let string_of_limits {min; max} = + I32.to_string min ^ + (match max with None -> "" | Some n -> I32.to_string n) + +let string_of_memory_type = function + | MemoryType lim -> string_of_limits lim + +let string_of_table_type = function + | TableType (lim, t) -> string_of_limits lim ^ " " ^ string_of_elem_type t + +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_stack_type ts = "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" diff --git a/ml-proto/test/address.wast b/ml-proto/test/address.wast index 9007af064e..709c5798f7 100644 --- a/ml-proto/test/address.wast +++ b/ml-proto/test/address.wast @@ -1,35 +1,34 @@ (module + (import "spectest" "print" (func $print (param i32))) + (memory 1) (data (i32.const 0) "abcdefghijklmnopqrstuvwxyz") - (import $print "spectest" "print" (param i32)) - (func $good (param $i i32) - (call_import $print (i32.load8_u offset=0 (get_local $i))) ;; 97 'a' - (call_import $print (i32.load8_u offset=1 (get_local $i))) ;; 98 'b' - (call_import $print (i32.load8_u offset=2 (get_local $i))) ;; 99 'c' - (call_import $print (i32.load8_u offset=25 (get_local $i))) ;; 122 'z' + (func (export "good") (param $i i32) + (call $print (i32.load8_u offset=0 (get_local $i))) ;; 97 'a' + (call $print (i32.load8_u offset=1 (get_local $i))) ;; 98 'b' + (call $print (i32.load8_u offset=2 (get_local $i))) ;; 99 'c' + (call $print (i32.load8_u offset=25 (get_local $i))) ;; 122 'z' - (call_import $print (i32.load16_u offset=0 (get_local $i))) ;; 25185 'ab' - (call_import $print (i32.load16_u align=1 (get_local $i))) ;; 25185 'ab' - (call_import $print (i32.load16_u offset=1 align=1 (get_local $i))) ;; 25442 'bc' - (call_import $print (i32.load16_u offset=2 (get_local $i))) ;; 25699 'cd' - (call_import $print (i32.load16_u offset=25 align=1 (get_local $i))) ;; 122 'z\0' + (call $print (i32.load16_u offset=0 (get_local $i))) ;; 25185 'ab' + (call $print (i32.load16_u align=1 (get_local $i))) ;; 25185 'ab' + (call $print (i32.load16_u offset=1 align=1 (get_local $i))) ;; 25442 'bc' + (call $print (i32.load16_u offset=2 (get_local $i))) ;; 25699 'cd' + (call $print (i32.load16_u offset=25 align=1 (get_local $i))) ;; 122 'z\0' - (call_import $print (i32.load offset=0 (get_local $i))) ;; 1684234849 'abcd' - (call_import $print (i32.load offset=1 align=1 (get_local $i))) ;; 1701077858 'bcde' - (call_import $print (i32.load offset=2 align=2 (get_local $i))) ;; 1717920867 'cdef' - (call_import $print (i32.load offset=25 align=1 (get_local $i))) ;; 122 'z\0\0\0' + (call $print (i32.load offset=0 (get_local $i))) ;; 1684234849 'abcd' + (call $print (i32.load offset=1 align=1 (get_local $i))) ;; 1701077858 'bcde' + (call $print (i32.load offset=2 align=2 (get_local $i))) ;; 1717920867 'cdef' + (call $print (i32.load offset=25 align=1 (get_local $i))) ;; 122 'z\0\0\0' ) - (export "good" $good) - (func $bad2 (param $i i32) (drop (i32.load offset=4294967295 (get_local $i)))) - (export "bad2" $bad2) + (func (export "bad") (param $i i32) (drop (i32.load offset=4294967295 (get_local $i)))) ) (invoke "good" (i32.const 0)) (invoke "good" (i32.const 65507)) (assert_trap (invoke "good" (i32.const 65508)) "out of bounds memory access") -(assert_trap (invoke "bad2" (i32.const 0)) "out of bounds memory access") -(assert_trap (invoke "bad2" (i32.const 1)) "out of bounds memory access") +(assert_trap (invoke "bad" (i32.const 0)) "out of bounds memory access") +(assert_trap (invoke "bad" (i32.const 1)) "out of bounds memory access") -(assert_invalid (module (memory 1) (func $bad1 (param $i i32) (drop (i32.load offset=4294967296 (get_local $i))))) "offset too large") +(assert_invalid (module (memory 1) (func $bad (param $i i32) (drop (i32.load offset=4294967296 (get_local $i))))) "offset too large") diff --git a/ml-proto/test/binary.wast b/ml-proto/test/binary.wast index 0e16d05933..b2b7908cb3 100644 --- a/ml-proto/test/binary.wast +++ b/ml-proto/test/binary.wast @@ -1,5 +1,7 @@ (module "\00asm\0c\00\00\00") (module "\00asm" "\0c\00\00\00") +(module $M "\00asm\0c\00\00\00") +(module $M "\00asm" "\0c\00\00\00") (assert_invalid (module "") "unexpected end") (assert_invalid (module "\01") "unexpected end") diff --git a/ml-proto/test/block.wast b/ml-proto/test/block.wast index 6da741d2ed..763c693f45 100644 --- a/ml-proto/test/block.wast +++ b/ml-proto/test/block.wast @@ -4,29 +4,29 @@ ;; Auxiliary definition (func $dummy) - (func "empty" + (func (export "empty") (block) (block $l) ) - (func "singular" (result i32) + (func (export "singular") (result i32) (block (nop)) (block (i32.const 7)) ) - (func "multi" (result i32) + (func (export "multi") (result i32) (block (call $dummy) (call $dummy) (call $dummy) (call $dummy)) (block (call $dummy) (call $dummy) (call $dummy) (i32.const 8)) ) - (func "nested" (result i32) + (func (export "nested") (result i32) (block (block (call $dummy) (block) (nop)) (block (call $dummy) (i32.const 9)) ) ) - (func "deep" (result i32) + (func (export "deep") (result i32) (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block (block @@ -38,36 +38,36 @@ )))))))))) ) - (func "as-unary-operand" (result i32) + (func (export "as-unary-operand") (result i32) (i32.ctz (block (call $dummy) (i32.const 13))) ) - (func "as-binary-operand" (result i32) + (func (export "as-binary-operand") (result i32) (i32.mul (block (call $dummy) (i32.const 3)) (block (call $dummy) (i32.const 4)) ) ) - (func "as-test-operand" (result i32) + (func (export "as-test-operand") (result i32) (i32.eqz (block (call $dummy) (i32.const 13))) ) - (func "as-compare-operand" (result i32) + (func (export "as-compare-operand") (result i32) (f32.gt (block (call $dummy) (f32.const 3)) (block (call $dummy) (f32.const 3)) ) ) - (func "break-bare" (result i32) + (func (export "break-bare") (result i32) (block (br 0) (unreachable)) (block (br_if 0 (i32.const 1)) (unreachable)) (block (br_table 0 (i32.const 0)) (unreachable)) (block (br_table 0 0 0 (i32.const 1)) (unreachable)) (i32.const 19) ) - (func "break-value" (result i32) + (func (export "break-value") (result i32) (block (br 0 (i32.const 18)) (i32.const 19)) ) - (func "break-repeated" (result i32) + (func (export "break-repeated") (result i32) (block (br 0 (i32.const 18)) (br 0 (i32.const 19)) @@ -79,7 +79,7 @@ (i32.const 21) ) ) - (func "break-inner" (result i32) + (func (export "break-inner") (result i32) (local i32) (set_local 0 (i32.const 0)) (set_local 0 (i32.add (get_local 0) (block (block (br 1 (i32.const 0x1)))))) @@ -93,7 +93,7 @@ (get_local 0) ) - (func "effects" $fx (result i32) + (func (export "effects") (result i32) (local i32) (block (set_local 0 (i32.const 1)) diff --git a/ml-proto/test/br.wast b/ml-proto/test/br.wast index da7f1074dd..59f5e657c0 100644 --- a/ml-proto/test/br.wast +++ b/ml-proto/test/br.wast @@ -4,112 +4,101 @@ ;; Auxiliary definition (func $dummy) - (func "type-i32" (block (drop (i32.ctz (br 0))))) - (func "type-i64" (block (drop (i64.ctz (br 0))))) - (func "type-f32" (block (drop (f32.neg (br 0))))) - (func "type-f64" (block (drop (f64.neg (br 0))))) + (func (export "type-i32") (block (drop (i32.ctz (br 0))))) + (func (export "type-i64") (block (drop (i64.ctz (br 0))))) + (func (export "type-f32") (block (drop (f32.neg (br 0))))) + (func (export "type-f64") (block (drop (f64.neg (br 0))))) - (func "type-i32-value" (result i32) (block (i32.ctz (br 0 (i32.const 1))))) - (func "type-i64-value" (result i64) (block (i64.ctz (br 0 (i64.const 2))))) - (func "type-f32-value" (result f32) (block (f32.neg (br 0 (f32.const 3))))) - (func "type-f64-value" (result f64) (block (f64.neg (br 0 (f64.const 4))))) + (func (export "type-i32-value") (result i32) (block (i32.ctz (br 0 (i32.const 1))))) + (func (export "type-i64-value") (result i64) (block (i64.ctz (br 0 (i64.const 2))))) + (func (export "type-f32-value") (result f32) (block (f32.neg (br 0 (f32.const 3))))) + (func (export "type-f64-value") (result f64) (block (f64.neg (br 0 (f64.const 4))))) - (func "as-block-first" + (func (export "as-block-first") (block (br 0) (call $dummy)) ) - (func "as-block-mid" + (func (export "as-block-mid") (block (call $dummy) (br 0) (call $dummy)) ) - (func "as-block-last" + (func (export "as-block-last") (block (nop) (call $dummy) (br 0)) ) - (func "as-block-value" (result i32) + (func (export "as-block-value") (result i32) (block (nop) (call $dummy) (br 0 (i32.const 2))) ) - (func "as-loop-first" (result i32) + (func (export "as-loop-first") (result i32) (loop (br 1 (i32.const 3)) (i32.const 2)) ) - (func "as-loop-mid" (result i32) + (func (export "as-loop-mid") (result i32) (loop (call $dummy) (br 1 (i32.const 4)) (i32.const 2)) ) - (func "as-loop-last" (result i32) + (func (export "as-loop-last") (result i32) (loop (nop) (call $dummy) (br 1 (i32.const 5))) ) - (func "as-br-value" (result i32) + (func (export "as-br-value") (result i32) (block (br 0 (br 0 (i32.const 9)))) ) - (func "as-br_if-cond" + (func (export "as-br_if-cond") (block (br_if 0 (br 0))) ) - (func "as-br_if-value" (result i32) + (func (export "as-br_if-value") (result i32) (block (br_if 0 (br 0 (i32.const 8)) (i32.const 1)) (i32.const 7)) ) - (func "as-br_if-value-cond" (result i32) + (func (export "as-br_if-value-cond") (result i32) (block (br_if 0 (i32.const 6) (br 0 (i32.const 9))) (i32.const 7)) ) - (func "as-br_table-index" + (func (export "as-br_table-index") (block (br_table 0 0 0 (br 0))) ) - (func "as-br_table-value" (result i32) + (func (export "as-br_table-value") (result i32) (block (br_table 0 0 0 (br 0 (i32.const 10)) (i32.const 1)) (i32.const 7)) ) - (func "as-br_table-value-index" (result i32) + (func (export "as-br_table-value-index") (result i32) (block (br_table 0 0 (i32.const 6) (br 0 (i32.const 11))) (i32.const 7)) ) - (func "as-return-value" (result i64) + (func (export "as-return-value") (result i64) (block (return (br 0 (i64.const 7)))) ) - (func "as-if-cond" (result i32) + (func (export "as-if-cond") (result i32) (block (if (br 0 (i32.const 2)) (i32.const 0) (i32.const 1))) ) - (func "as-if-then" (param i32 i32) (result i32) + (func (export "as-if-then") (param i32 i32) (result i32) (block (if (get_local 0) (br 1 (i32.const 3)) (get_local 1))) ) - (func "as-if-else" (param i32 i32) (result i32) + (func (export "as-if-else") (param i32 i32) (result i32) (block (if (get_local 0) (get_local 1) (br 1 (i32.const 4)))) ) - (func "as-select-first" (param i32 i32) (result i32) + (func (export "as-select-first") (param i32 i32) (result i32) (block (select (br 0 (i32.const 5)) (get_local 0) (get_local 1))) ) - (func "as-select-second" (param i32 i32) (result i32) + (func (export "as-select-second") (param i32 i32) (result i32) (block (select (get_local 0) (br 0 (i32.const 6)) (get_local 1))) ) - (func "as-select-cond" (result i32) + (func (export "as-select-cond") (result i32) (block (select (i32.const 0) (i32.const 1) (br 0 (i32.const 7)))) ) (func $f (param i32 i32 i32) (result i32) (i32.const -1)) - (func "as-call-first" (result i32) + (func (export "as-call-first") (result i32) (block (call $f (br 0 (i32.const 12)) (i32.const 2) (i32.const 3))) ) - (func "as-call-mid" (result i32) + (func (export "as-call-mid") (result i32) (block (call $f (i32.const 1) (br 0 (i32.const 13)) (i32.const 3))) ) - (func "as-call-last" (result i32) + (func (export "as-call-last") (result i32) (block (call $f (i32.const 1) (i32.const 2) (br 0 (i32.const 14)))) ) - (import "spectest" "print" (param i32 i32 i32)) - (func "as-call_import-first" - (block (call_import 0 (br 0) (i32.const 2) (i32.const 3))) - ) - (func "as-call_import-mid" - (block (call_import 0 (i32.const 1) (br 0) (i32.const 3))) - ) - (func "as-call_import-last" - (block (call_import 0 (i32.const 1) (i32.const 2) (br 0))) - ) - (type $sig (func (param i32 i32 i32) (result i32))) (table anyfunc (elem $f)) - (func "as-call_indirect-func" (result i32) + (func (export "as-call_indirect-func") (result i32) (block (call_indirect $sig (br 0 (i32.const 20)) @@ -117,7 +106,7 @@ ) ) ) - (func "as-call_indirect-first" (result i32) + (func (export "as-call_indirect-first") (result i32) (block (call_indirect $sig (i32.const 0) @@ -125,7 +114,7 @@ ) ) ) - (func "as-call_indirect-mid" (result i32) + (func (export "as-call_indirect-mid") (result i32) (block (call_indirect $sig (i32.const 0) @@ -133,7 +122,7 @@ ) ) ) - (func "as-call_indirect-last" (result i32) + (func (export "as-call_indirect-last") (result i32) (block (call_indirect $sig (i32.const 0) @@ -142,63 +131,63 @@ ) ) - (func "as-set_local-value" (result i32) (local f32) + (func (export "as-set_local-value") (result i32) (local f32) (block (set_local 0 (br 0 (i32.const 17))) (i32.const -1)) ) (memory 1) - (func "as-load-address" (result f32) + (func (export "as-load-address") (result f32) (block (f32.load (br 0 (f32.const 1.7)))) ) - (func "as-loadN-address" (result i64) + (func (export "as-loadN-address") (result i64) (block (i64.load8_s (br 0 (i64.const 30)))) ) - (func "as-store-address" (result i32) + (func (export "as-store-address") (result i32) (block (f64.store (br 0 (i32.const 30)) (f64.const 7)) (i32.const -1)) ) - (func "as-store-value" (result i32) + (func (export "as-store-value") (result i32) (block (i64.store (i32.const 2) (br 0 (i32.const 31))) (i32.const -1)) ) - (func "as-storeN-address" (result i32) + (func (export "as-storeN-address") (result i32) (block (i32.store8 (br 0 (i32.const 32)) (i32.const 7)) (i32.const -1)) ) - (func "as-storeN-value" (result i32) + (func (export "as-storeN-value") (result i32) (block (i64.store16 (i32.const 2) (br 0 (i32.const 33))) (i32.const -1)) ) - (func "as-unary-operand" (result f32) + (func (export "as-unary-operand") (result f32) (block (f32.neg (br 0 (f32.const 3.4)))) ) - (func "as-binary-left" (result i32) + (func (export "as-binary-left") (result i32) (block (i32.add (br 0 (i32.const 3)) (i32.const 10))) ) - (func "as-binary-right" (result i64) + (func (export "as-binary-right") (result i64) (block (i64.sub (i64.const 10) (br 0 (i64.const 45)))) ) - (func "as-test-operand" (result i32) + (func (export "as-test-operand") (result i32) (block (i32.eqz (br 0 (i32.const 44)))) ) - (func "as-compare-left" (result i32) + (func (export "as-compare-left") (result i32) (block (f64.le (br 0 (i32.const 43)) (f64.const 10))) ) - (func "as-compare-right" (result i32) + (func (export "as-compare-right") (result i32) (block (f32.ne (f32.const 10) (br 0 (i32.const 42)))) ) - (func "as-convert-operand" (result i32) + (func (export "as-convert-operand") (result i32) (block (i32.wrap/i64 (br 0 (i32.const 41)))) ) - (func "as-grow_memory-size" (result i32) + (func (export "as-grow_memory-size") (result i32) (block (grow_memory (br 0 (i32.const 40)))) ) - (func "nested-block-value" (result i32) + (func (export "nested-block-value") (result i32) (i32.add (i32.const 1) (block @@ -208,7 +197,7 @@ ) ) - (func "nested-br-value" (result i32) + (func (export "nested-br-value") (result i32) (i32.add (i32.const 1) (block @@ -224,7 +213,7 @@ ) ) - (func "nested-br_if-value" (result i32) + (func (export "nested-br_if-value") (result i32) (i32.add (i32.const 1) (block @@ -241,7 +230,7 @@ ) ) - (func "nested-br_if-value-cond" (result i32) + (func (export "nested-br_if-value-cond") (result i32) (i32.add (i32.const 1) (block @@ -252,7 +241,7 @@ ) ) - (func "nested-br_table-value" (result i32) + (func (export "nested-br_table-value") (result i32) (i32.add (i32.const 1) (block @@ -268,7 +257,7 @@ ) ) - (func "nested-br_table-value-index" (result i32) + (func (export "nested-br_table-value-index") (result i32) (i32.add (i32.const 1) (block @@ -327,10 +316,6 @@ (assert_return (invoke "as-call-mid") (i32.const 13)) (assert_return (invoke "as-call-last") (i32.const 14)) -(assert_return (invoke "as-call_import-first")) -(assert_return (invoke "as-call_import-mid")) -(assert_return (invoke "as-call_import-last")) - (assert_return (invoke "as-call_indirect-func") (i32.const 20)) (assert_return (invoke "as-call_indirect-first") (i32.const 21)) (assert_return (invoke "as-call_indirect-mid") (i32.const 22)) diff --git a/ml-proto/test/br_if.wast b/ml-proto/test/br_if.wast index 957cec4a4b..6f60d50687 100644 --- a/ml-proto/test/br_if.wast +++ b/ml-proto/test/br_if.wast @@ -3,40 +3,40 @@ (module (func $dummy) - (func "as-block-first" (param i32) (result i32) + (func (export "as-block-first") (param i32) (result i32) (block (br_if 0 (get_local 0)) (return (i32.const 2))) (i32.const 3) ) - (func "as-block-mid" (param i32) (result i32) + (func (export "as-block-mid") (param i32) (result i32) (block (call $dummy) (br_if 0 (get_local 0)) (return (i32.const 2))) (i32.const 3) ) - (func "as-block-last" (param i32) + (func (export "as-block-last") (param i32) (block (call $dummy) (call $dummy) (br_if 0 (get_local 0))) ) - (func "as-block-first-value" (param i32) (result i32) + (func (export "as-block-first-value") (param i32) (result i32) (block (br_if 0 (i32.const 10) (get_local 0)) (i32.const 11)) ) - (func "as-block-mid-value" (param i32) (result i32) + (func (export "as-block-mid-value") (param i32) (result i32) (block (call $dummy) (br_if 0 (i32.const 20) (get_local 0)) (i32.const 21)) ) - (func "as-loop-first" (param i32) (result i32) + (func (export "as-loop-first") (param i32) (result i32) (loop (br_if 1 (i32.const 3) (get_local 0)) (i32.const 2)) ) - (func "as-loop-mid" (param i32) (result i32) + (func (export "as-loop-mid") (param i32) (result i32) (loop (call $dummy) (br_if 1 (i32.const 4) (get_local 0)) (i32.const 2)) ) - (func "as-loop-last" (param i32) + (func (export "as-loop-last") (param i32) (loop (call $dummy) (br_if 1 (get_local 0))) ) - (func "as-if-then" (param i32 i32) + (func (export "as-if-then") (param i32 i32) (block (if (get_local 0) (br_if 1 (get_local 1)) (call $dummy))) ) - (func "as-if-else" (param i32 i32) + (func (export "as-if-else") (param i32 i32) (block (if (get_local 0) (call $dummy) (br_if 1 (get_local 1)))) ) - (func "nested-block-value" (param i32) (result i32) + (func (export "nested-block-value") (param i32) (result i32) (i32.add (i32.const 1) (block @@ -49,7 +49,7 @@ ) ) - (func "nested-br-value" (param i32) (result i32) + (func (export "nested-br-value") (param i32) (result i32) (i32.add (i32.const 1) (block @@ -62,7 +62,7 @@ ) ) - (func "nested-br_if-value" (param i32) (result i32) + (func (export "nested-br_if-value") (param i32) (result i32) (i32.add (i32.const 1) (block @@ -76,7 +76,7 @@ ) ) - (func "nested-br_if-value-cond" (param i32) (result i32) + (func (export "nested-br_if-value-cond") (param i32) (result i32) (i32.add (i32.const 1) (block @@ -90,7 +90,7 @@ ) ) - (func "nested-br_table-value" (param i32) (result i32) + (func (export "nested-br_table-value") (param i32) (result i32) (i32.add (i32.const 1) (block @@ -104,7 +104,7 @@ ) ) - (func "nested-br_table-value-index" (param i32) (result i32) + (func (export "nested-br_table-value-index") (param i32) (result i32) (i32.add (i32.const 1) (block diff --git a/ml-proto/test/br_table.wast b/ml-proto/test/br_table.wast index ff46c57428..3fe0d34ccc 100644 --- a/ml-proto/test/br_table.wast +++ b/ml-proto/test/br_table.wast @@ -4,33 +4,33 @@ ;; Auxiliary definition (func $dummy) - (func "type-i32" (block (drop (i32.ctz (br_table 0 0 (i32.const 0)))))) - (func "type-i64" (block (drop (i64.ctz (br_table 0 0 (i32.const 0)))))) - (func "type-f32" (block (drop (f32.neg (br_table 0 0 (i32.const 0)))))) - (func "type-f64" (block (drop (f64.neg (br_table 0 0 (i32.const 0)))))) + (func (export "type-i32") (block (drop (i32.ctz (br_table 0 0 (i32.const 0)))))) + (func (export "type-i64") (block (drop (i64.ctz (br_table 0 0 (i32.const 0)))))) + (func (export "type-f32") (block (drop (f32.neg (br_table 0 0 (i32.const 0)))))) + (func (export "type-f64") (block (drop (f64.neg (br_table 0 0 (i32.const 0)))))) - (func "type-i32-value" (result i32) + (func (export "type-i32-value") (result i32) (block (i32.ctz (br_table 0 0 (i32.const 1) (i32.const 0)))) ) - (func "type-i64-value" (result i64) + (func (export "type-i64-value") (result i64) (block (i64.ctz (br_table 0 0 (i64.const 2) (i32.const 0)))) ) - (func "type-f32-value" (result f32) + (func (export "type-f32-value") (result f32) (block (f32.neg (br_table 0 0 (f32.const 3) (i32.const 0)))) ) - (func "type-f64-value" (result f64) + (func (export "type-f64-value") (result f64) (block (f64.neg (br_table 0 0 (f64.const 4) (i32.const 0)))) ) - (func "empty" (param i32) (result i32) + (func (export "empty") (param i32) (result i32) (block (br_table 0 (get_local 0)) (return (i32.const 21))) (i32.const 22) ) - (func "empty-value" (param i32) (result i32) + (func (export "empty-value") (param i32) (result i32) (block (br_table 0 (i32.const 33) (get_local 0)) (i32.const 31)) ) - (func "singleton" (param i32) (result i32) + (func (export "singleton") (param i32) (result i32) (block (block (br_table 1 0 (get_local 0)) @@ -41,7 +41,7 @@ (i32.const 22) ) - (func "singleton-value" (param i32) (result i32) + (func (export "singleton-value") (param i32) (result i32) (block (drop (block @@ -53,7 +53,7 @@ ) ) - (func "multiple" (param i32) (result i32) + (func (export "multiple") (param i32) (result i32) (block (block (block @@ -73,7 +73,7 @@ (i32.const 104) ) - (func "multiple-value" (param i32) (result i32) + (func (export "multiple-value") (param i32) (result i32) (local i32) (set_local 1 (block (set_local 1 (block @@ -94,7 +94,7 @@ (i32.add (get_local 1) (i32.const 14)) ) - (func "large" (param i32) (result i32) + (func (export "large") (param i32) (result i32) (block (block (br_table @@ -831,175 +831,164 @@ (return (i32.const 1)) ) - (func "as-block-first" + (func (export "as-block-first") (block (br_table 0 0 0 (i32.const 0)) (call $dummy)) ) - (func "as-block-mid" + (func (export "as-block-mid") (block (call $dummy) (br_table 0 0 0 (i32.const 0)) (call $dummy)) ) - (func "as-block-last" + (func (export "as-block-last") (block (nop) (call $dummy) (br_table 0 0 0 (i32.const 0))) ) - (func "as-block-value" (result i32) + (func (export "as-block-value") (result i32) (block (nop) (call $dummy) (br_table 0 0 0 (i32.const 2) (i32.const 0))) ) - (func "as-loop-first" (result i32) + (func (export "as-loop-first") (result i32) (loop (br_table 1 1 (i32.const 3) (i32.const 0)) (i32.const 1)) ) - (func "as-loop-mid" (result i32) + (func (export "as-loop-mid") (result i32) (loop (call $dummy) (br_table 1 1 1 (i32.const 4) (i32.const -1)) (i32.const 2) ) ) - (func "as-loop-last" (result i32) + (func (export "as-loop-last") (result i32) (loop (nop) (call $dummy) (br_table 1 1 1 (i32.const 5) (i32.const 1))) ) - (func "as-br-value" (result i32) + (func (export "as-br-value") (result i32) (block (br 0 (br 0 (i32.const 9)))) ) - (func "as-br_if-cond" + (func (export "as-br_if-cond") (block (br_if 0 (br_table 0 0 0 (i32.const 1)))) ) - (func "as-br_if-value" (result i32) + (func (export "as-br_if-value") (result i32) (block (br_if 0 (br_table 0 (i32.const 8) (i32.const 0)) (i32.const 1)) (i32.const 7)) ) - (func "as-br_if-value-cond" (result i32) + (func (export "as-br_if-value-cond") (result i32) (block (br_if 0 (i32.const 6) (br_table 0 0 (i32.const 9) (i32.const 0))) (i32.const 7)) ) - (func "as-br_table-index" + (func (export "as-br_table-index") (block (br_table 0 0 0 (br_table 0 (i32.const 1)))) ) - (func "as-br_table-value" (result i32) + (func (export "as-br_table-value") (result i32) (block (br_table 0 0 0 (br_table 0 (i32.const 10) (i32.const 0)) (i32.const 1)) (i32.const 7)) ) - (func "as-br_table-value-index" (result i32) + (func (export "as-br_table-value-index") (result i32) (block (br_table 0 0 (i32.const 6) (br_table 0 (i32.const 11) (i32.const 1))) (i32.const 7)) ) - (func "as-return-value" (result i64) + (func (export "as-return-value") (result i64) (block (return (br_table 0 (i64.const 7) (i32.const 0)))) ) - (func "as-if-cond" (result i32) + (func (export "as-if-cond") (result i32) (block (if (br_table 0 (i32.const 2) (i32.const 0)) (i32.const 0) (i32.const 1))) ) - (func "as-if-then" (param i32 i32) (result i32) + (func (export "as-if-then") (param i32 i32) (result i32) (block (if (get_local 0) (br_table 1 (i32.const 3) (i32.const 0)) (get_local 1))) ) - (func "as-if-else" (param i32 i32) (result i32) + (func (export "as-if-else") (param i32 i32) (result i32) (block (if (get_local 0) (get_local 1) (br_table 1 0 (i32.const 4) (i32.const 0)))) ) - (func "as-select-first" (param i32 i32) (result i32) + (func (export "as-select-first") (param i32 i32) (result i32) (block (select (br_table 0 (i32.const 5) (i32.const 0)) (get_local 0) (get_local 1))) ) - (func "as-select-second" (param i32 i32) (result i32) + (func (export "as-select-second") (param i32 i32) (result i32) (block (select (get_local 0) (br_table 0 (i32.const 6) (i32.const 1)) (get_local 1))) ) - (func "as-select-cond" (result i32) + (func (export "as-select-cond") (result i32) (block (select (i32.const 0) (i32.const 1) (br_table 0 (i32.const 7) (i32.const 1)))) ) (func $f (param i32 i32 i32) (result i32) (i32.const -1)) - (func "as-call-first" (result i32) + (func (export "as-call-first") (result i32) (block (call $f (br_table 0 (i32.const 12) (i32.const 1)) (i32.const 2) (i32.const 3))) ) - (func "as-call-mid" (result i32) + (func (export "as-call-mid") (result i32) (block (call $f (i32.const 1) (br_table 0 (i32.const 13) (i32.const 1)) (i32.const 3))) ) - (func "as-call-last" (result i32) + (func (export "as-call-last") (result i32) (block (call $f (i32.const 1) (i32.const 2) (br_table 0 (i32.const 14) (i32.const 1)))) ) - (import "spectest" "print" (param i32 i32 i32)) - (func "as-call_import-first" - (block (call_import 0 (br_table 0 (i32.const 1)) (i32.const 2) (i32.const 3))) - ) - (func "as-call_import-mid" - (block (call_import 0 (i32.const 1) (br_table 0 (i32.const 1)) (i32.const 3))) - ) - (func "as-call_import-last" - (block (call_import 0 (i32.const 1) (i32.const 2) (br_table 0 (i32.const 1)))) - ) - (type $sig (func (param i32 i32 i32) (result i32))) (table anyfunc (elem $f)) - (func "as-call_indirect-func" (result i32) + (func (export "as-call_indirect-func") (result i32) (block (call_indirect $sig (br_table 0 (i32.const 20) (i32.const 1)) (i32.const 1) (i32.const 2) (i32.const 3))) ) - (func "as-call_indirect-first" (result i32) + (func (export "as-call_indirect-first") (result i32) (block (call_indirect $sig (i32.const 0) (br_table 0 (i32.const 21) (i32.const 1)) (i32.const 2) (i32.const 3))) ) - (func "as-call_indirect-mid" (result i32) + (func (export "as-call_indirect-mid") (result i32) (block (call_indirect $sig (i32.const 0) (i32.const 1) (br_table 0 (i32.const 22) (i32.const 1)) (i32.const 3))) ) - (func "as-call_indirect-last" (result i32) + (func (export "as-call_indirect-last") (result i32) (block (call_indirect $sig (i32.const 0) (i32.const 1) (i32.const 2) (br_table 0 (i32.const 23) (i32.const 1)))) ) - (func "as-set_local-value" (result i32) (local f32) + (func (export "as-set_local-value") (result i32) (local f32) (block (set_local 0 (br_table 0 (i32.const 17) (i32.const 1))) (i32.const -1)) ) (memory 1) - (func "as-load-address" (result f32) + (func (export "as-load-address") (result f32) (block (f32.load (br_table 0 (f32.const 1.7) (i32.const 1)))) ) - (func "as-loadN-address" (result i64) + (func (export "as-loadN-address") (result i64) (block (i64.load8_s (br_table 0 (i64.const 30) (i32.const 1)))) ) - (func "as-store-address" (result i32) + (func (export "as-store-address") (result i32) (block (f64.store (br_table 0 (i32.const 30) (i32.const 1)) (f64.const 7)) (i32.const -1)) ) - (func "as-store-value" (result i32) + (func (export "as-store-value") (result i32) (block (i64.store (i32.const 2) (br_table 0 (i32.const 31) (i32.const 1))) (i32.const -1)) ) - (func "as-storeN-address" (result i32) + (func (export "as-storeN-address") (result i32) (block (i32.store8 (br_table 0 (i32.const 32) (i32.const 0)) (i32.const 7)) (i32.const -1)) ) - (func "as-storeN-value" (result i32) + (func (export "as-storeN-value") (result i32) (block (i64.store16 (i32.const 2) (br_table 0 (i32.const 33) (i32.const 0))) (i32.const -1)) ) - (func "as-unary-operand" (result f32) + (func (export "as-unary-operand") (result f32) (block (f32.neg (br_table 0 (f32.const 3.4) (i32.const 0)))) ) - (func "as-binary-left" (result i32) + (func (export "as-binary-left") (result i32) (block (i32.add (br_table 0 0 (i32.const 3) (i32.const 0)) (i32.const 10))) ) - (func "as-binary-right" (result i64) + (func (export "as-binary-right") (result i64) (block (i64.sub (i64.const 10) (br_table 0 (i64.const 45) (i32.const 0)))) ) - (func "as-test-operand" (result i32) + (func (export "as-test-operand") (result i32) (block (i32.eqz (br_table 0 (i32.const 44) (i32.const 0)))) ) - (func "as-compare-left" (result i32) + (func (export "as-compare-left") (result i32) (block (f64.le (br_table 0 0 (i32.const 43) (i32.const 0)) (f64.const 10))) ) - (func "as-compare-right" (result i32) + (func (export "as-compare-right") (result i32) (block (f32.ne (f32.const 10) (br_table 0 (i32.const 42) (i32.const 0)))) ) - (func "as-convert-operand" (result i32) + (func (export "as-convert-operand") (result i32) (block (i32.wrap/i64 (br_table 0 (i32.const 41) (i32.const 0)))) ) - (func "as-grow_memory-size" (result i32) + (func (export "as-grow_memory-size") (result i32) (block (grow_memory (br_table 0 (i32.const 40) (i32.const 0)))) ) - (func "nested-block-value" (param i32) (result i32) + (func (export "nested-block-value") (param i32) (result i32) (block (drop (i32.const -1)) (i32.add @@ -1020,7 +1009,7 @@ ) ) - (func "nested-br-value" (param i32) (result i32) + (func (export "nested-br-value") (param i32) (result i32) (block (i32.add (i32.const 1) @@ -1038,7 +1027,7 @@ ) ) - (func "nested-br_if-value" (param i32) (result i32) + (func (export "nested-br_if-value") (param i32) (result i32) (block (i32.add (i32.const 1) @@ -1057,7 +1046,7 @@ ) ) - (func "nested-br_if-value-cond" (param i32) (result i32) + (func (export "nested-br_if-value-cond") (param i32) (result i32) (block (i32.add (i32.const 1) @@ -1070,7 +1059,7 @@ ) ) - (func "nested-br_table-value" (param i32) (result i32) + (func (export "nested-br_table-value") (param i32) (result i32) (block (i32.add (i32.const 1) @@ -1089,7 +1078,7 @@ ) ) - (func "nested-br_table-value-index" (param i32) (result i32) + (func (export "nested-br_table-value-index") (param i32) (result i32) (block (i32.add (i32.const 1) @@ -1209,10 +1198,6 @@ (assert_return (invoke "as-call-mid") (i32.const 13)) (assert_return (invoke "as-call-last") (i32.const 14)) -(assert_return (invoke "as-call_import-first")) -(assert_return (invoke "as-call_import-mid")) -(assert_return (invoke "as-call_import-last")) - (assert_return (invoke "as-call_indirect-func") (i32.const 20)) (assert_return (invoke "as-call_indirect-first") (i32.const 21)) (assert_return (invoke "as-call_indirect-mid") (i32.const 22)) diff --git a/ml-proto/test/break-drop.wast b/ml-proto/test/break-drop.wast index 6ccd6982cd..a09f27148e 100644 --- a/ml-proto/test/break-drop.wast +++ b/ml-proto/test/break-drop.wast @@ -1,12 +1,7 @@ (module - (func $br (block (br 0))) - (export "br" $br) - - (func $br_if (block (br_if 0 (i32.const 1)))) - (export "br_if" $br_if) - - (func $br_table (block (br_table 0 (i32.const 0)))) - (export "br_table" $br_table) + (func (export "br") (block (br 0))) + (func (export "br_if") (block (br_if 0 (i32.const 1)))) + (func (export "br_table") (block (br_table 0 (i32.const 0)))) ) (assert_return (invoke "br")) diff --git a/ml-proto/test/call.wast b/ml-proto/test/call.wast index 056412bca0..68413f1819 100644 --- a/ml-proto/test/call.wast +++ b/ml-proto/test/call.wast @@ -19,39 +19,39 @@ ;; Typing - (func "type-i32" (result i32) (call $const-i32)) - (func "type-i64" (result i64) (call $const-i64)) - (func "type-f32" (result f32) (call $const-f32)) - (func "type-f64" (result f64) (call $const-f64)) + (func (export "type-i32") (result i32) (call $const-i32)) + (func (export "type-i64") (result i64) (call $const-i64)) + (func (export "type-f32") (result f32) (call $const-f32)) + (func (export "type-f64") (result f64) (call $const-f64)) - (func "type-first-i32" (result i32) (call $id-i32 (i32.const 32))) - (func "type-first-i64" (result i64) (call $id-i64 (i64.const 64))) - (func "type-first-f32" (result f32) (call $id-f32 (f32.const 1.32))) - (func "type-first-f64" (result f64) (call $id-f64 (f64.const 1.64))) + (func (export "type-first-i32") (result i32) (call $id-i32 (i32.const 32))) + (func (export "type-first-i64") (result i64) (call $id-i64 (i64.const 64))) + (func (export "type-first-f32") (result f32) (call $id-f32 (f32.const 1.32))) + (func (export "type-first-f64") (result f64) (call $id-f64 (f64.const 1.64))) - (func "type-second-i32" (result i32) + (func (export "type-second-i32") (result i32) (call $f32-i32 (f32.const 32.1) (i32.const 32)) ) - (func "type-second-i64" (result i64) + (func (export "type-second-i64") (result i64) (call $i32-i64 (i32.const 32) (i64.const 64)) ) - (func "type-second-f32" (result f32) + (func (export "type-second-f32") (result f32) (call $f64-f32 (f64.const 64) (f32.const 32)) ) - (func "type-second-f64" (result f64) + (func (export "type-second-f64") (result f64) (call $i64-f64 (i64.const 64) (f64.const 64.1)) ) ;; Recursion - (func "fac" $fac (param i64) (result i64) + (func $fac (export "fac") (param i64) (result i64) (if (i64.eqz (get_local 0)) (i64.const 1) (i64.mul (get_local 0) (call $fac (i64.sub (get_local 0) (i64.const 1)))) ) ) - (func "fac-acc" $fac-acc (param i64 i64) (result i64) + (func $fac-acc (export "fac-acc") (param i64 i64) (result i64) (if (i64.eqz (get_local 0)) (get_local 1) (call $fac-acc @@ -61,7 +61,7 @@ ) ) - (func "fib" $fib (param i64) (result i64) + (func $fib (export "fib") (param i64) (result i64) (if (i64.le_u (get_local 0) (i64.const 1)) (i64.const 1) (i64.add @@ -71,13 +71,13 @@ ) ) - (func "even" $even (param i64) (result i32) + (func $even (export "even") (param i64) (result i32) (if (i64.eqz (get_local 0)) (i32.const 44) (call $odd (i64.sub (get_local 0) (i64.const 1))) ) ) - (func "odd" $odd (param i64) (result i32) + (func $odd (export "odd") (param i64) (result i32) (if (i64.eqz (get_local 0)) (i32.const 99) (call $even (i64.sub (get_local 0) (i64.const 1))) @@ -93,9 +93,9 @@ ;; implementations and be incompatible with implementations that don't do ;; it (or don't do it under the same circumstances). - (func "runaway" $runaway (call $runaway)) + (func $runaway (export "runaway") (call $runaway)) - (func "mutual-runaway" $mutual-runaway1 (call $mutual-runaway2)) + (func $mutual-runaway1 (export "mutual-runaway") (call $mutual-runaway2)) (func $mutual-runaway2 (call $mutual-runaway1)) ) diff --git a/ml-proto/test/call_indirect.wast b/ml-proto/test/call_indirect.wast index 2b464d7f1a..272dc3d784 100644 --- a/ml-proto/test/call_indirect.wast +++ b/ml-proto/test/call_indirect.wast @@ -54,54 +54,54 @@ ;; Typing - (func "type-i32" (result i32) (call_indirect $out-i32 (i32.const 0))) - (func "type-i64" (result i64) (call_indirect $out-i64 (i32.const 1))) - (func "type-f32" (result f32) (call_indirect $out-f32 (i32.const 2))) - (func "type-f64" (result f64) (call_indirect $out-f64 (i32.const 3))) + (func (export "type-i32") (result i32) (call_indirect $out-i32 (i32.const 0))) + (func (export "type-i64") (result i64) (call_indirect $out-i64 (i32.const 1))) + (func (export "type-f32") (result f32) (call_indirect $out-f32 (i32.const 2))) + (func (export "type-f64") (result f64) (call_indirect $out-f64 (i32.const 3))) - (func "type-index" (result i64) + (func (export "type-index") (result i64) (call_indirect $over-i64 (i64.const 100) (i32.const 5)) ) - (func "type-first-i32" (result i32) + (func (export "type-first-i32") (result i32) (call_indirect $over-i32 (i32.const 32) (i32.const 4)) ) - (func "type-first-i64" (result i64) + (func (export "type-first-i64") (result i64) (call_indirect $over-i64 (i64.const 64) (i32.const 5)) ) - (func "type-first-f32" (result f32) + (func (export "type-first-f32") (result f32) (call_indirect $over-f32 (f32.const 1.32) (i32.const 6)) ) - (func "type-first-f64" (result f64) + (func (export "type-first-f64") (result f64) (call_indirect $over-f64 (f64.const 1.64) (i32.const 7)) ) - (func "type-second-i32" (result i32) + (func (export "type-second-i32") (result i32) (call_indirect $f32-i32 (f32.const 32.1) (i32.const 32) (i32.const 8)) ) - (func "type-second-i64" (result i64) + (func (export "type-second-i64") (result i64) (call_indirect $i32-i64 (i32.const 32) (i64.const 64) (i32.const 9)) ) - (func "type-second-f32" (result f32) + (func (export "type-second-f32") (result f32) (call_indirect $f64-f32 (f64.const 64) (f32.const 32) (i32.const 10)) ) - (func "type-second-f64" (result f64) + (func (export "type-second-f64") (result f64) (call_indirect $i64-f64 (i64.const 64) (f64.const 64.1) (i32.const 11)) ) ;; Dispatch - (func "dispatch" (param i32 i64) (result i64) + (func (export "dispatch") (param i32 i64) (result i64) (call_indirect $over-i64 (get_local 1) (get_local 0)) ) - (func "dispatch-structural" (param i32) (result i64) + (func (export "dispatch-structural") (param i32) (result i64) (call_indirect $over-i64-duplicate (i64.const 9) (get_local 0)) ) ;; Recursion - (func "fac" $fac (type $over-i64) + (func $fac (export "fac") (type $over-i64) (if (i64.eqz (get_local 0)) (i64.const 1) (i64.mul @@ -114,7 +114,7 @@ ) ) - (func "fib" $fib (type $over-i64) + (func $fib (export "fib") (type $over-i64) (if (i64.le_u (get_local 0) (i64.const 1)) (i64.const 1) (i64.add @@ -130,7 +130,7 @@ ) ) - (func "even" $even (param i32) (result i32) + (func $even (export "even") (param i32) (result i32) (if (i32.eqz (get_local 0)) (i32.const 44) (call_indirect $over-i32 @@ -139,7 +139,7 @@ ) ) ) - (func "odd" $odd (param i32) (result i32) + (func $odd (export "odd") (param i32) (result i32) (if (i32.eqz (get_local 0)) (i32.const 99) (call_indirect $over-i32 @@ -158,9 +158,9 @@ ;; implementations and be incompatible with implementations that don't do ;; it (or don't do it under the same circumstances). - (func "runaway" $runaway (call_indirect $proc (i32.const 16))) + (func $runaway (export "runaway") (call_indirect $proc (i32.const 16))) - (func "mutual-runaway" $mutual-runaway1 (call_indirect $proc (i32.const 18))) + (func $mutual-runaway1 (export "mutual-runaway") (call_indirect $proc (i32.const 18))) (func $mutual-runaway2 (call_indirect $proc (i32.const 17))) ) @@ -230,7 +230,7 @@ (type (func)) (func $no-table (call_indirect 0 (i32.const 0))) ) - "no table" + "unknown table" ) (assert_invalid @@ -366,12 +366,12 @@ (table 0 anyfunc) (func $unbound-type (call_indirect 1 (i32.const 0))) ) - "unknown function type" + "unknown type" ) (assert_invalid (module (table 0 anyfunc) (func $large-type (call_indirect 10001232130000 (i32.const 0))) ) - "unknown function type" + "unknown type" ) diff --git a/ml-proto/test/conversions.wast b/ml-proto/test/conversions.wast index a102f9bb68..17036a75ff 100644 --- a/ml-proto/test/conversions.wast +++ b/ml-proto/test/conversions.wast @@ -1,78 +1,29 @@ (module - (func $i64.extend_s_i32 (param $x i32) (result i64) (i64.extend_s/i32 (get_local $x))) - (export "i64.extend_s_i32" $i64.extend_s_i32) - - (func $i64.extend_u_i32 (param $x i32) (result i64) (i64.extend_u/i32 (get_local $x))) - (export "i64.extend_u_i32" $i64.extend_u_i32) - - (func $i32.wrap_i64 (param $x i64) (result i32) (i32.wrap/i64 (get_local $x))) - (export "i32.wrap_i64" $i32.wrap_i64) - - (func $i32.trunc_s_f32 (param $x f32) (result i32) (i32.trunc_s/f32 (get_local $x))) - (export "i32.trunc_s_f32" $i32.trunc_s_f32) - - (func $i32.trunc_u_f32 (param $x f32) (result i32) (i32.trunc_u/f32 (get_local $x))) - (export "i32.trunc_u_f32" $i32.trunc_u_f32) - - (func $i32.trunc_s_f64 (param $x f64) (result i32) (i32.trunc_s/f64 (get_local $x))) - (export "i32.trunc_s_f64" $i32.trunc_s_f64) - - (func $i32.trunc_u_f64 (param $x f64) (result i32) (i32.trunc_u/f64 (get_local $x))) - (export "i32.trunc_u_f64" $i32.trunc_u_f64) - - (func $i64.trunc_s_f32 (param $x f32) (result i64) (i64.trunc_s/f32 (get_local $x))) - (export "i64.trunc_s_f32" $i64.trunc_s_f32) - - (func $i64.trunc_u_f32 (param $x f32) (result i64) (i64.trunc_u/f32 (get_local $x))) - (export "i64.trunc_u_f32" $i64.trunc_u_f32) - - (func $i64.trunc_s_f64 (param $x f64) (result i64) (i64.trunc_s/f64 (get_local $x))) - (export "i64.trunc_s_f64" $i64.trunc_s_f64) - - (func $i64.trunc_u_f64 (param $x f64) (result i64) (i64.trunc_u/f64 (get_local $x))) - (export "i64.trunc_u_f64" $i64.trunc_u_f64) - - (func $f32.convert_s_i32 (param $x i32) (result f32) (f32.convert_s/i32 (get_local $x))) - (export "f32.convert_s_i32" $f32.convert_s_i32) - - (func $f32.convert_s_i64 (param $x i64) (result f32) (f32.convert_s/i64 (get_local $x))) - (export "f32.convert_s_i64" $f32.convert_s_i64) - - (func $f64.convert_s_i32 (param $x i32) (result f64) (f64.convert_s/i32 (get_local $x))) - (export "f64.convert_s_i32" $f64.convert_s_i32) - - (func $f64.convert_s_i64 (param $x i64) (result f64) (f64.convert_s/i64 (get_local $x))) - (export "f64.convert_s_i64" $f64.convert_s_i64) - - (func $f32.convert_u_i32 (param $x i32) (result f32) (f32.convert_u/i32 (get_local $x))) - (export "f32.convert_u_i32" $f32.convert_u_i32) - - (func $f32.convert_u_i64 (param $x i64) (result f32) (f32.convert_u/i64 (get_local $x))) - (export "f32.convert_u_i64" $f32.convert_u_i64) - - (func $f64.convert_u_i32 (param $x i32) (result f64) (f64.convert_u/i32 (get_local $x))) - (export "f64.convert_u_i32" $f64.convert_u_i32) - - (func $f64.convert_u_i64 (param $x i64) (result f64) (f64.convert_u/i64 (get_local $x))) - (export "f64.convert_u_i64" $f64.convert_u_i64) - - (func $f64.promote_f32 (param $x f32) (result f64) (f64.promote/f32 (get_local $x))) - (export "f64.promote_f32" $f64.promote_f32) - - (func $f32.demote_f64 (param $x f64) (result f32) (f32.demote/f64 (get_local $x))) - (export "f32.demote_f64" $f32.demote_f64) - - (func $f32.reinterpret_i32 (param $x i32) (result f32) (f32.reinterpret/i32 (get_local $x))) - (export "f32.reinterpret_i32" $f32.reinterpret_i32) - - (func $f64.reinterpret_i64 (param $x i64) (result f64) (f64.reinterpret/i64 (get_local $x))) - (export "f64.reinterpret_i64" $f64.reinterpret_i64) - - (func $i32.reinterpret_f32 (param $x f32) (result i32) (i32.reinterpret/f32 (get_local $x))) - (export "i32.reinterpret_f32" $i32.reinterpret_f32) - - (func $i64.reinterpret_f64 (param $x f64) (result i64) (i64.reinterpret/f64 (get_local $x))) - (export "i64.reinterpret_f64" $i64.reinterpret_f64) + (func (export "i64.extend_s_i32") (param $x i32) (result i64) (i64.extend_s/i32 (get_local $x))) + (func (export "i64.extend_u_i32") (param $x i32) (result i64) (i64.extend_u/i32 (get_local $x))) + (func (export "i32.wrap_i64") (param $x i64) (result i32) (i32.wrap/i64 (get_local $x))) + (func (export "i32.trunc_s_f32") (param $x f32) (result i32) (i32.trunc_s/f32 (get_local $x))) + (func (export "i32.trunc_u_f32") (param $x f32) (result i32) (i32.trunc_u/f32 (get_local $x))) + (func (export "i32.trunc_s_f64") (param $x f64) (result i32) (i32.trunc_s/f64 (get_local $x))) + (func (export "i32.trunc_u_f64") (param $x f64) (result i32) (i32.trunc_u/f64 (get_local $x))) + (func (export "i64.trunc_s_f32") (param $x f32) (result i64) (i64.trunc_s/f32 (get_local $x))) + (func (export "i64.trunc_u_f32") (param $x f32) (result i64) (i64.trunc_u/f32 (get_local $x))) + (func (export "i64.trunc_s_f64") (param $x f64) (result i64) (i64.trunc_s/f64 (get_local $x))) + (func (export "i64.trunc_u_f64") (param $x f64) (result i64) (i64.trunc_u/f64 (get_local $x))) + (func (export "f32.convert_s_i32") (param $x i32) (result f32) (f32.convert_s/i32 (get_local $x))) + (func (export "f32.convert_s_i64") (param $x i64) (result f32) (f32.convert_s/i64 (get_local $x))) + (func (export "f64.convert_s_i32") (param $x i32) (result f64) (f64.convert_s/i32 (get_local $x))) + (func (export "f64.convert_s_i64") (param $x i64) (result f64) (f64.convert_s/i64 (get_local $x))) + (func (export "f32.convert_u_i32") (param $x i32) (result f32) (f32.convert_u/i32 (get_local $x))) + (func (export "f32.convert_u_i64") (param $x i64) (result f32) (f32.convert_u/i64 (get_local $x))) + (func (export "f64.convert_u_i32") (param $x i32) (result f64) (f64.convert_u/i32 (get_local $x))) + (func (export "f64.convert_u_i64") (param $x i64) (result f64) (f64.convert_u/i64 (get_local $x))) + (func (export "f64.promote_f32") (param $x f32) (result f64) (f64.promote/f32 (get_local $x))) + (func (export "f32.demote_f64") (param $x f64) (result f32) (f32.demote/f64 (get_local $x))) + (func (export "f32.reinterpret_i32") (param $x i32) (result f32) (f32.reinterpret/i32 (get_local $x))) + (func (export "f64.reinterpret_i64") (param $x i64) (result f64) (f64.reinterpret/i64 (get_local $x))) + (func (export "i32.reinterpret_f32") (param $x f32) (result i32) (i32.reinterpret/f32 (get_local $x))) + (func (export "i64.reinterpret_f64") (param $x f64) (result i64) (i64.reinterpret/f64 (get_local $x))) ) (assert_return (invoke "i64.extend_s_i32" (i32.const 0)) (i64.const 0)) diff --git a/ml-proto/test/endianness.wast b/ml-proto/test/endianness.wast index 17a4b22c4b..8dc0c2e2eb 100644 --- a/ml-proto/test/endianness.wast +++ b/ml-proto/test/endianness.wast @@ -43,115 +43,91 @@ ) ) - (func $i32_load16_s (param $value i32) (result i32) + (func (export "i32_load16_s") (param $value i32) (result i32) (call $i16_store_little (i32.const 0) (get_local $value)) (i32.load16_s (i32.const 0)) ) - (func $i32_load16_u (param $value i32) (result i32) + (func (export "i32_load16_u") (param $value i32) (result i32) (call $i16_store_little (i32.const 0) (get_local $value)) (i32.load16_u (i32.const 0)) ) - (func $i32_load (param $value i32) (result i32) + (func (export "i32_load") (param $value i32) (result i32) (call $i32_store_little (i32.const 0) (get_local $value)) (i32.load (i32.const 0)) ) - (func $i64_load16_s (param $value i64) (result i64) + (func (export "i64_load16_s") (param $value i64) (result i64) (call $i16_store_little (i32.const 0) (i32.wrap/i64 (get_local $value))) (i64.load16_s (i32.const 0)) ) - (func $i64_load16_u (param $value i64) (result i64) + (func (export "i64_load16_u") (param $value i64) (result i64) (call $i16_store_little (i32.const 0) (i32.wrap/i64 (get_local $value))) (i64.load16_u (i32.const 0)) ) - (func $i64_load32_s (param $value i64) (result i64) + (func (export "i64_load32_s") (param $value i64) (result i64) (call $i32_store_little (i32.const 0) (i32.wrap/i64 (get_local $value))) (i64.load32_s (i32.const 0)) ) - (func $i64_load32_u (param $value i64) (result i64) + (func (export "i64_load32_u") (param $value i64) (result i64) (call $i32_store_little (i32.const 0) (i32.wrap/i64 (get_local $value))) (i64.load32_u (i32.const 0)) ) - (func $i64_load (param $value i64) (result i64) + (func (export "i64_load") (param $value i64) (result i64) (call $i64_store_little (i32.const 0) (get_local $value)) (i64.load (i32.const 0)) ) - (func $f32_load (param $value f32) (result f32) + (func (export "f32_load") (param $value f32) (result f32) (call $i32_store_little (i32.const 0) (i32.reinterpret/f32 (get_local $value))) (f32.load (i32.const 0)) ) - (func $f64_load (param $value f64) (result f64) + (func (export "f64_load") (param $value f64) (result f64) (call $i64_store_little (i32.const 0) (i64.reinterpret/f64 (get_local $value))) (f64.load (i32.const 0)) ) - (func $i32_store16 (param $value i32) (result i32) + (func (export "i32_store16") (param $value i32) (result i32) (i32.store16 (i32.const 0) (get_local $value)) (call $i16_load_little (i32.const 0)) ) - (func $i32_store (param $value i32) (result i32) + (func (export "i32_store") (param $value i32) (result i32) (i32.store (i32.const 0) (get_local $value)) (call $i32_load_little (i32.const 0)) ) - (func $i64_store16 (param $value i64) (result i64) + (func (export "i64_store16") (param $value i64) (result i64) (i64.store16 (i32.const 0) (get_local $value)) (i64.extend_u/i32 (call $i16_load_little (i32.const 0))) ) - (func $i64_store32 (param $value i64) (result i64) + (func (export "i64_store32") (param $value i64) (result i64) (i64.store32 (i32.const 0) (get_local $value)) (i64.extend_u/i32 (call $i32_load_little (i32.const 0))) ) - (func $i64_store (param $value i64) (result i64) + (func (export "i64_store") (param $value i64) (result i64) (i64.store (i32.const 0) (get_local $value)) (call $i64_load_little (i32.const 0)) ) - (func $f32_store (param $value f32) (result f32) + (func (export "f32_store") (param $value f32) (result f32) (f32.store (i32.const 0) (get_local $value)) (f32.reinterpret/i32 (call $i32_load_little (i32.const 0))) ) - (func $f64_store (param $value f64) (result f64) + (func (export "f64_store") (param $value f64) (result f64) (f64.store (i32.const 0) (get_local $value)) (f64.reinterpret/i64 (call $i64_load_little (i32.const 0))) ) - - (export "i32_load16_s" $i32_load16_s) - (export "i32_load16_u" $i32_load16_u) - (export "i32_load" $i32_load) - - (export "i64_load16_s" $i64_load16_s) - (export "i64_load16_u" $i64_load16_u) - (export "i64_load32_s" $i64_load32_s) - (export "i64_load32_u" $i64_load32_u) - (export "i64_load" $i64_load) - - (export "f32_load" $f32_load) - (export "f64_load" $f64_load) - - - (export "i32_store16" $i32_store16) - (export "i32_store" $i32_store) - - (export "i64_store16" $i64_store16) - (export "i64_store32" $i64_store32) - (export "i64_store" $i64_store) - - (export "f32_store" $f32_store) - (export "f64_store" $f64_store) ) (assert_return (invoke "i32_load16_s" (i32.const -1)) (i32.const -1)) diff --git a/ml-proto/test/expected-output/imports.wast.log b/ml-proto/test/expected-output/imports.wast.log index ed2f3784a6..cd34c23997 100644 --- a/ml-proto/test/expected-output/imports.wast.log +++ b/ml-proto/test/expected-output/imports.wast.log @@ -1,6 +1,10 @@ +13 : i32 14 : i32 42. : f32 13 : i32 +13 : i32 +24 : i64 25 : i64 53. : f64 24 : i64 +24 : i64 diff --git a/ml-proto/test/exports.wast b/ml-proto/test/exports.wast index 51d2b9a65c..d2098150d2 100644 --- a/ml-proto/test/exports.wast +++ b/ml-proto/test/exports.wast @@ -1,32 +1,172 @@ -(module (func) (export "a" 0)) -(module (func) (export "a" 0) (export "b" 0)) -(module (func) (func) (export "a" 0) (export "b" 1)) +;; Functions + +(module (func) (export "a" (func 0))) +(module (func) (export "a" (func 0)) (export "b" (func 0))) +(module (func) (func) (export "a" (func 0)) (export "b" (func 1))) + +(module (func (export "a"))) +(module (func $a (export "a"))) + +(module $Func + (export "e" (func $f)) + (func $f (param $n i32) (result i32) + (return (i32.add (get_local $n) (i32.const 1))) + ) +) +(assert_return (invoke "e" (i32.const 42)) (i32.const 43)) +(assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) +(module) +(module $Other) +(assert_return (invoke $Func "e" (i32.const 42)) (i32.const 43)) (assert_invalid - (module (func) (export "a" 1)) + (module (func) (export "a" (func 1))) "unknown function" ) (assert_invalid - (module (func) (func) (export "a" 0) (export "a" 1)) + (module (func) (export "a" (func 0)) (export "a" (func 0))) + "duplicate export name" +) +(assert_invalid + (module (func) (func) (export "a" (func 0)) (export "a" (func 1))) + "duplicate export name" +) +(assert_invalid + (module (func) (global i32 (i32.const 0)) (export "a" (func 0)) (export "a" (global 0))) + "duplicate export name" +) +(assert_invalid + (module (func) (table 0 anyfunc) (export "a" (func 0)) (export "a" (table 0))) "duplicate export name" ) (assert_invalid - (module (func) (export "a" 0) (export "a" 0)) + (module (func) (memory 0) (export "a" (func 0)) (export "a" (memory 0))) "duplicate export name" ) -(module - (func $f (param $n i32) (result i32) - (return (i32.add (get_local $n) (i32.const 1))) - ) - (export "e" $f) +;; Globals + +(module (global i32 (i32.const 0)) (export "a" (global 0))) +(module (global i32 (i32.const 0)) (export "a" (global 0)) (export "b" (global 0))) +(module (global i32 (i32.const 0)) (global i32 (i32.const 0)) (export "a" (global 0)) (export "b" (global 1))) + +(module (global (export "a") i32 (i32.const 0))) +(module (global $a (export "a") i32 (i32.const 0))) + +(module $Global + (export "e" (global $g)) + (global $g i32 (i32.const 42)) ) +(assert_return (get "e") (i32.const 42)) +(assert_return (get $Global "e") (i32.const 42)) +(module) +(module $Other) +(assert_return (get $Global "e") (i32.const 42)) -(assert_return (invoke "e" (i32.const 42)) (i32.const 43)) +(assert_invalid + (module (global i32 (i32.const 0)) (export "a" (global 1))) + "unknown global" +) +(assert_invalid + (module (global i32 (i32.const 0)) (export "a" (global 0)) (export "a" (global 0))) + "duplicate export name" +) +(assert_invalid + (module (global i32 (i32.const 0)) (global i32 (i32.const 0)) (export "a" (global 0)) (export "a" (global 1))) + "duplicate export name" +) +(assert_invalid + (module (global i32 (i32.const 0)) (func) (export "a" (global 0)) (export "a" (func 0))) + "duplicate export name" +) +(assert_invalid + (module (global i32 (i32.const 0)) (table 0 anyfunc) (export "a" (global 0)) (export "a" (table 0))) + "duplicate export name" +) +(assert_invalid + (module (global i32 (i32.const 0)) (memory 0) (export "a" (global 0)) (export "a" (memory 0))) + "duplicate export name" +) + + +;; Tables + +(module (table 0 anyfunc) (export "a" (table 0))) +(module (table 0 anyfunc) (export "a" (table 0)) (export "b" (table 0))) +;; No multiple tables yet. +;; (module (table 0 anyfunc) (table 0 anyfunc) (export "a" (table 0)) (export "b" (table 1))) -(module (memory 0 0) (export "a" memory)) -(module (memory 0 0) (export "a" memory) (export "b" memory)) +(module (table (export "a") 0 anyfunc)) +(module (table (export "a") 0 1 anyfunc)) +(module (table $a (export "a") 0 anyfunc)) +(module (table $a (export "a") 0 1 anyfunc)) -(assert_invalid (module (export "a" memory)) "no memory") +(; TODO: access table ;) + +(assert_invalid + (module (table 0 anyfunc) (export "a" (table 1))) + "unknown table" +) +(assert_invalid + (module (table 0 anyfunc) (export "a" (table 0)) (export "a" (table 0))) + "duplicate export name" +) +;; No multiple tables yet. +;; (assert_invalid +;; (module (table 0 anyfunc) (table 0 anyfunc) (export "a" (table 0)) (export "a" (table 1))) +;; "duplicate export name" +;; ) +(assert_invalid + (module (table 0 anyfunc) (func) (export "a" (table 0)) (export "a" (func 0))) + "duplicate export name" +) +(assert_invalid + (module (table 0 anyfunc) (global i32 (i32.const 0)) (export "a" (table 0)) (export "a" (global 0))) + "duplicate export name" +) +(assert_invalid + (module (table 0 anyfunc) (memory 0) (export "a" (table 0)) (export "a" (memory 0))) + "duplicate export name" +) + +;; Memories + +(module (memory 0) (export "a" (memory 0))) +(module (memory 0) (export "a" (memory 0)) (export "b" (memory 0))) +;; No multiple memories yet. +;; (module (memory 0) (memory 0) (export "a" (memory 0)) (export "b" (memory 1))) + +(module (memory (export "a") 0)) +(module (memory (export "a") 0 1)) +(module (memory $a (export "a") 0)) +(module (memory $a (export "a") 0 1)) + +(; TODO: access memory ;) + +(assert_invalid + (module (memory 0) (export "a" (memory 1))) + "unknown memory" +) +(assert_invalid + (module (memory 0) (export "a" (memory 0)) (export "a" (memory 0))) + "duplicate export name" +) +;; No multiple memories yet. +;; (assert_invalid +;; (module (memory 0) (memory 0) (export "a" (memory 0)) (export "a" (memory 1))) +;; "duplicate export name" +;; ) +(assert_invalid + (module (memory 0) (func) (export "a" (memory 0)) (export "a" (func 0))) + "duplicate export name" +) +(assert_invalid + (module (memory 0) (global i32 (i32.const 0)) (export "a" (memory 0)) (export "a" (global 0))) + "duplicate export name" +) +(assert_invalid + (module (memory 0) (table 0 anyfunc) (export "a" (memory 0)) (export "a" (table 0))) + "duplicate export name" +) diff --git a/ml-proto/test/f32.wast b/ml-proto/test/f32.wast index 9924f24fd2..9f58f9bd10 100644 --- a/ml-proto/test/f32.wast +++ b/ml-proto/test/f32.wast @@ -2,35 +2,20 @@ ;; values (except comparison operators, which are tested in f32_cmp.wast). (module - (func $add (param $x f32) (param $y f32) (result f32) (f32.add (get_local $x) (get_local $y))) - (func $sub (param $x f32) (param $y f32) (result f32) (f32.sub (get_local $x) (get_local $y))) - (func $mul (param $x f32) (param $y f32) (result f32) (f32.mul (get_local $x) (get_local $y))) - (func $div (param $x f32) (param $y f32) (result f32) (f32.div (get_local $x) (get_local $y))) - (func $sqrt (param $x f32) (result f32) (f32.sqrt (get_local $x))) - (func $min (param $x f32) (param $y f32) (result f32) (f32.min (get_local $x) (get_local $y))) - (func $max (param $x f32) (param $y f32) (result f32) (f32.max (get_local $x) (get_local $y))) - (func $ceil (param $x f32) (result f32) (f32.ceil (get_local $x))) - (func $floor (param $x f32) (result f32) (f32.floor (get_local $x))) - (func $trunc (param $x f32) (result f32) (f32.trunc (get_local $x))) - (func $nearest (param $x f32) (result f32) (f32.nearest (get_local $x))) - (func $abs (param $x f32) (result f32) (f32.abs (get_local $x))) - (func $neg (param $x f32) (result f32) (f32.neg (get_local $x))) - (func $copysign (param $x f32) (param $y f32) (result f32) (f32.copysign (get_local $x) (get_local $y))) - - (export "add" $add) - (export "sub" $sub) - (export "mul" $mul) - (export "div" $div) - (export "sqrt" $sqrt) - (export "min" $min) - (export "max" $max) - (export "ceil" $ceil) - (export "floor" $floor) - (export "trunc" $trunc) - (export "nearest" $nearest) - (export "abs" $abs) - (export "neg" $neg) - (export "copysign" $copysign) + (func (export "add") (param $x f32) (param $y f32) (result f32) (f32.add (get_local $x) (get_local $y))) + (func (export "sub") (param $x f32) (param $y f32) (result f32) (f32.sub (get_local $x) (get_local $y))) + (func (export "mul") (param $x f32) (param $y f32) (result f32) (f32.mul (get_local $x) (get_local $y))) + (func (export "div") (param $x f32) (param $y f32) (result f32) (f32.div (get_local $x) (get_local $y))) + (func (export "sqrt") (param $x f32) (result f32) (f32.sqrt (get_local $x))) + (func (export "min") (param $x f32) (param $y f32) (result f32) (f32.min (get_local $x) (get_local $y))) + (func (export "max") (param $x f32) (param $y f32) (result f32) (f32.max (get_local $x) (get_local $y))) + (func (export "ceil") (param $x f32) (result f32) (f32.ceil (get_local $x))) + (func (export "floor") (param $x f32) (result f32) (f32.floor (get_local $x))) + (func (export "trunc") (param $x f32) (result f32) (f32.trunc (get_local $x))) + (func (export "nearest") (param $x f32) (result f32) (f32.nearest (get_local $x))) + (func (export "abs") (param $x f32) (result f32) (f32.abs (get_local $x))) + (func (export "neg") (param $x f32) (result f32) (f32.neg (get_local $x))) + (func (export "copysign") (param $x f32) (param $y f32) (result f32) (f32.copysign (get_local $x) (get_local $y))) ) (assert_return (invoke "add" (f32.const -0x0p+0) (f32.const -0x0p+0)) (f32.const -0x0p+0)) diff --git a/ml-proto/test/f32_cmp.wast b/ml-proto/test/f32_cmp.wast index f4d4637cb0..9458069c30 100644 --- a/ml-proto/test/f32_cmp.wast +++ b/ml-proto/test/f32_cmp.wast @@ -2,19 +2,12 @@ ;; special values. (module - (func $eq (param $x f32) (param $y f32) (result i32) (f32.eq (get_local $x) (get_local $y))) - (func $ne (param $x f32) (param $y f32) (result i32) (f32.ne (get_local $x) (get_local $y))) - (func $lt (param $x f32) (param $y f32) (result i32) (f32.lt (get_local $x) (get_local $y))) - (func $le (param $x f32) (param $y f32) (result i32) (f32.le (get_local $x) (get_local $y))) - (func $gt (param $x f32) (param $y f32) (result i32) (f32.gt (get_local $x) (get_local $y))) - (func $ge (param $x f32) (param $y f32) (result i32) (f32.ge (get_local $x) (get_local $y))) - - (export "eq" $eq) - (export "ne" $ne) - (export "lt" $lt) - (export "le" $le) - (export "gt" $gt) - (export "ge" $ge) + (func (export "eq") (param $x f32) (param $y f32) (result i32) (f32.eq (get_local $x) (get_local $y))) + (func (export "ne") (param $x f32) (param $y f32) (result i32) (f32.ne (get_local $x) (get_local $y))) + (func (export "lt") (param $x f32) (param $y f32) (result i32) (f32.lt (get_local $x) (get_local $y))) + (func (export "le") (param $x f32) (param $y f32) (result i32) (f32.le (get_local $x) (get_local $y))) + (func (export "gt") (param $x f32) (param $y f32) (result i32) (f32.gt (get_local $x) (get_local $y))) + (func (export "ge") (param $x f32) (param $y f32) (result i32) (f32.ge (get_local $x) (get_local $y))) ) (assert_return (invoke "eq" (f32.const -0x0p+0) (f32.const -0x0p+0)) (i32.const 1)) diff --git a/ml-proto/test/f64.wast b/ml-proto/test/f64.wast index eb6e7da40a..26a058a253 100644 --- a/ml-proto/test/f64.wast +++ b/ml-proto/test/f64.wast @@ -2,35 +2,20 @@ ;; values (except comparison operators, which are tested in f64_cmp.wast). (module - (func $add (param $x f64) (param $y f64) (result f64) (f64.add (get_local $x) (get_local $y))) - (func $sub (param $x f64) (param $y f64) (result f64) (f64.sub (get_local $x) (get_local $y))) - (func $mul (param $x f64) (param $y f64) (result f64) (f64.mul (get_local $x) (get_local $y))) - (func $div (param $x f64) (param $y f64) (result f64) (f64.div (get_local $x) (get_local $y))) - (func $sqrt (param $x f64) (result f64) (f64.sqrt (get_local $x))) - (func $min (param $x f64) (param $y f64) (result f64) (f64.min (get_local $x) (get_local $y))) - (func $max (param $x f64) (param $y f64) (result f64) (f64.max (get_local $x) (get_local $y))) - (func $ceil (param $x f64) (result f64) (f64.ceil (get_local $x))) - (func $floor (param $x f64) (result f64) (f64.floor (get_local $x))) - (func $trunc (param $x f64) (result f64) (f64.trunc (get_local $x))) - (func $nearest (param $x f64) (result f64) (f64.nearest (get_local $x))) - (func $abs (param $x f64) (result f64) (f64.abs (get_local $x))) - (func $neg (param $x f64) (result f64) (f64.neg (get_local $x))) - (func $copysign (param $x f64) (param $y f64) (result f64) (f64.copysign (get_local $x) (get_local $y))) - - (export "add" $add) - (export "sub" $sub) - (export "mul" $mul) - (export "div" $div) - (export "sqrt" $sqrt) - (export "min" $min) - (export "max" $max) - (export "ceil" $ceil) - (export "floor" $floor) - (export "trunc" $trunc) - (export "nearest" $nearest) - (export "abs" $abs) - (export "neg" $neg) - (export "copysign" $copysign) + (func (export "add") (param $x f64) (param $y f64) (result f64) (f64.add (get_local $x) (get_local $y))) + (func (export "sub") (param $x f64) (param $y f64) (result f64) (f64.sub (get_local $x) (get_local $y))) + (func (export "mul") (param $x f64) (param $y f64) (result f64) (f64.mul (get_local $x) (get_local $y))) + (func (export "div") (param $x f64) (param $y f64) (result f64) (f64.div (get_local $x) (get_local $y))) + (func (export "sqrt") (param $x f64) (result f64) (f64.sqrt (get_local $x))) + (func (export "min") (param $x f64) (param $y f64) (result f64) (f64.min (get_local $x) (get_local $y))) + (func (export "max") (param $x f64) (param $y f64) (result f64) (f64.max (get_local $x) (get_local $y))) + (func (export "ceil") (param $x f64) (result f64) (f64.ceil (get_local $x))) + (func (export "floor") (param $x f64) (result f64) (f64.floor (get_local $x))) + (func (export "trunc") (param $x f64) (result f64) (f64.trunc (get_local $x))) + (func (export "nearest") (param $x f64) (result f64) (f64.nearest (get_local $x))) + (func (export "abs") (param $x f64) (result f64) (f64.abs (get_local $x))) + (func (export "neg") (param $x f64) (result f64) (f64.neg (get_local $x))) + (func (export "copysign") (param $x f64) (param $y f64) (result f64) (f64.copysign (get_local $x) (get_local $y))) ) (assert_return (invoke "add" (f64.const -0x0p+0) (f64.const -0x0p+0)) (f64.const -0x0p+0)) diff --git a/ml-proto/test/f64_cmp.wast b/ml-proto/test/f64_cmp.wast index 9d822deda2..f4958b8f98 100644 --- a/ml-proto/test/f64_cmp.wast +++ b/ml-proto/test/f64_cmp.wast @@ -2,19 +2,12 @@ ;; special values. (module - (func $eq (param $x f64) (param $y f64) (result i32) (f64.eq (get_local $x) (get_local $y))) - (func $ne (param $x f64) (param $y f64) (result i32) (f64.ne (get_local $x) (get_local $y))) - (func $lt (param $x f64) (param $y f64) (result i32) (f64.lt (get_local $x) (get_local $y))) - (func $le (param $x f64) (param $y f64) (result i32) (f64.le (get_local $x) (get_local $y))) - (func $gt (param $x f64) (param $y f64) (result i32) (f64.gt (get_local $x) (get_local $y))) - (func $ge (param $x f64) (param $y f64) (result i32) (f64.ge (get_local $x) (get_local $y))) - - (export "eq" $eq) - (export "ne" $ne) - (export "lt" $lt) - (export "le" $le) - (export "gt" $gt) - (export "ge" $ge) + (func (export "eq") (param $x f64) (param $y f64) (result i32) (f64.eq (get_local $x) (get_local $y))) + (func (export "ne") (param $x f64) (param $y f64) (result i32) (f64.ne (get_local $x) (get_local $y))) + (func (export "lt") (param $x f64) (param $y f64) (result i32) (f64.lt (get_local $x) (get_local $y))) + (func (export "le") (param $x f64) (param $y f64) (result i32) (f64.le (get_local $x) (get_local $y))) + (func (export "gt") (param $x f64) (param $y f64) (result i32) (f64.gt (get_local $x) (get_local $y))) + (func (export "ge") (param $x f64) (param $y f64) (result i32) (f64.ge (get_local $x) (get_local $y))) ) (assert_return (invoke "eq" (f64.const -0x0p+0) (f64.const -0x0p+0)) (i32.const 1)) diff --git a/ml-proto/test/fac.wast b/ml-proto/test/fac.wast index 125350ee1d..445dcfb012 100644 --- a/ml-proto/test/fac.wast +++ b/ml-proto/test/fac.wast @@ -1,6 +1,6 @@ (module ;; Recursive factorial - (func "fac-rec" (param i64) (result i64) + (func (export "fac-rec") (param i64) (result i64) (if (i64.eq (get_local 0) (i64.const 0)) (i64.const 1) (i64.mul (get_local 0) (call 0 (i64.sub (get_local 0) (i64.const 1)))) @@ -8,7 +8,7 @@ ) ;; Recursive factorial named - (func "fac-rec-named" $fac-rec-named (param $n i64) (result i64) + (func $fac-rec-named (export "fac-rec-named") (param $n i64) (result i64) (if (i64.eq (get_local $n) (i64.const 0)) (i64.const 1) (i64.mul @@ -19,7 +19,7 @@ ) ;; Iterative factorial - (func "fac-iter" (param i64) (result i64) + (func (export "fac-iter") (param i64) (result i64) (local i64 i64) (set_local 1 (get_local 0)) (set_local 2 (i64.const 1)) @@ -40,7 +40,7 @@ ) ;; Iterative factorial named - (func "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)) @@ -61,8 +61,8 @@ (get_local $res) ) - ;; Optimized factorial - (func "fac-opt" (param i64) (result i64) + ;; Optimized factorial. + (func (export "fac-opt") (param i64) (result i64) (local i64) (set_local 1 (i64.const 1)) (block diff --git a/ml-proto/test/float_exprs.wast b/ml-proto/test/float_exprs.wast index 570a79c2f4..f00d25ca52 100644 --- a/ml-proto/test/float_exprs.wast +++ b/ml-proto/test/float_exprs.wast @@ -4,9 +4,8 @@ ;; Test that x*y+z is not done with x87-style intermediate precision. (module - (func $f64.no_contraction (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_contraction") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.add (f64.mul (get_local $x) (get_local $y)) (get_local $z))) - (export "f64.no_contraction" $f64.no_contraction) ) (assert_return (invoke "f64.no_contraction" (f64.const -0x1.9e87ce14273afp-103) (f64.const 0x1.2515ad31db63ep+664) (f64.const 0x1.868c6685e6185p+533)) (f64.const -0x1.da94885b11493p+561)) @@ -18,13 +17,10 @@ ;; Test that x*y+z is not folded to fma. (module - (func $f32.no_fma (param $x f32) (param $y f32) (param $z f32) (result f32) + (func (export "f32.no_fma") (param $x f32) (param $y f32) (param $z f32) (result f32) (f32.add (f32.mul (get_local $x) (get_local $y)) (get_local $z))) - (export "f32.no_fma" $f32.no_fma) - - (func $f64.no_fma (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_fma") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.add (f64.mul (get_local $x) (get_local $y)) (get_local $z))) - (export "f64.no_fma" $f64.no_fma) ) (assert_return (invoke "f32.no_fma" (f32.const 0x1.a78402p+124) (f32.const 0x1.cf8548p-23) (f32.const 0x1.992adap+107)) (f32.const 0x1.a5262cp+107)) @@ -42,13 +38,10 @@ ;; See IEEE 754-2008 10.4 "Literal meaning and value-changing optimizations". (module - (func $f32.no_fold_add_zero (param $x f32) (result f32) + (func (export "f32.no_fold_add_zero") (param $x f32) (result f32) (f32.add (get_local $x) (f32.const 0.0))) - (export "f32.no_fold_add_zero" $f32.no_fold_add_zero) - - (func $f64.no_fold_add_zero (param $x f64) (result f64) + (func (export "f64.no_fold_add_zero") (param $x f64) (result f64) (f64.add (get_local $x) (f64.const 0.0))) - (export "f64.no_fold_add_zero" $f64.no_fold_add_zero) ) (assert_return (invoke "f32.no_fold_add_zero" (f32.const -0.0)) (f32.const 0.0)) @@ -59,13 +52,10 @@ ;; Test that 0.0 - x is not folded to -x. (module - (func $f32.no_fold_zero_sub (param $x f32) (result f32) + (func (export "f32.no_fold_zero_sub") (param $x f32) (result f32) (f32.sub (f32.const 0.0) (get_local $x))) - (export "f32.no_fold_zero_sub" $f32.no_fold_zero_sub) - - (func $f64.no_fold_zero_sub (param $x f64) (result f64) + (func (export "f64.no_fold_zero_sub") (param $x f64) (result f64) (f64.sub (f64.const 0.0) (get_local $x))) - (export "f64.no_fold_zero_sub" $f64.no_fold_zero_sub) ) (assert_return (invoke "f32.no_fold_zero_sub" (f32.const 0.0)) (f32.const 0.0)) @@ -76,13 +66,10 @@ ;; Test that x - 0.0 is not folded to x. (module - (func $f32.no_fold_sub_zero (param $x f32) (result f32) + (func (export "f32.no_fold_sub_zero") (param $x f32) (result f32) (f32.sub (get_local $x) (f32.const 0.0))) - (export "f32.no_fold_sub_zero" $f32.no_fold_sub_zero) - - (func $f64.no_fold_sub_zero (param $x f64) (result f64) + (func (export "f64.no_fold_sub_zero") (param $x f64) (result f64) (f64.sub (get_local $x) (f64.const 0.0))) - (export "f64.no_fold_sub_zero" $f64.no_fold_sub_zero) ) (assert_return (invoke "f32.no_fold_sub_zero" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -91,13 +78,10 @@ ;; Test that x*0.0 is not folded to 0.0. (module - (func $f32.no_fold_mul_zero (param $x f32) (result f32) + (func (export "f32.no_fold_mul_zero") (param $x f32) (result f32) (f32.mul (get_local $x) (f32.const 0.0))) - (export "f32.no_fold_mul_zero" $f32.no_fold_mul_zero) - - (func $f64.no_fold_mul_zero (param $x f64) (result f64) + (func (export "f64.no_fold_mul_zero") (param $x f64) (result f64) (f64.mul (get_local $x) (f64.const 0.0))) - (export "f64.no_fold_mul_zero" $f64.no_fold_mul_zero) ) (assert_return (invoke "f32.no_fold_mul_zero" (f32.const -0.0)) (f32.const -0.0)) @@ -113,13 +97,10 @@ ;; See IEEE 754-2008 10.4 "Literal meaning and value-changing optimizations". (module - (func $f32.no_fold_mul_one (param $x f32) (result f32) + (func (export "f32.no_fold_mul_one") (param $x f32) (result f32) (f32.mul (get_local $x) (f32.const 1.0))) - (export "f32.no_fold_mul_one" $f32.no_fold_mul_one) - - (func $f64.no_fold_mul_one (param $x f64) (result f64) + (func (export "f64.no_fold_mul_one") (param $x f64) (result f64) (f64.mul (get_local $x) (f64.const 1.0))) - (export "f64.no_fold_mul_one" $f64.no_fold_mul_one) ) (assert_return (invoke "f32.no_fold_mul_one" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -128,13 +109,10 @@ ;; Test that 0.0/x is not folded to 0.0. (module - (func $f32.no_fold_zero_div (param $x f32) (result f32) + (func (export "f32.no_fold_zero_div") (param $x f32) (result f32) (f32.div (f32.const 0.0) (get_local $x))) - (export "f32.no_fold_zero_div" $f32.no_fold_zero_div) - - (func $f64.no_fold_zero_div (param $x f64) (result f64) + (func (export "f64.no_fold_zero_div") (param $x f64) (result f64) (f64.div (f64.const 0.0) (get_local $x))) - (export "f64.no_fold_zero_div" $f64.no_fold_zero_div) ) (assert_return_nan (invoke "f32.no_fold_zero_div" (f32.const 0.0))) @@ -149,13 +127,10 @@ ;; Test that x/1.0 is not folded to x. (module - (func $f32.no_fold_div_one (param $x f32) (result f32) + (func (export "f32.no_fold_div_one") (param $x f32) (result f32) (f32.div (get_local $x) (f32.const 1.0))) - (export "f32.no_fold_div_one" $f32.no_fold_div_one) - - (func $f64.no_fold_div_one (param $x f64) (result f64) + (func (export "f64.no_fold_div_one") (param $x f64) (result f64) (f64.div (get_local $x) (f64.const 1.0))) - (export "f64.no_fold_div_one" $f64.no_fold_div_one) ) (assert_return (invoke "f32.no_fold_div_one" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -164,13 +139,10 @@ ;; Test that x/-1.0 is not folded to -x. (module - (func $f32.no_fold_div_neg1 (param $x f32) (result f32) + (func (export "f32.no_fold_div_neg1") (param $x f32) (result f32) (f32.div (get_local $x) (f32.const -1.0))) - (export "f32.no_fold_div_neg1" $f32.no_fold_div_neg1) - - (func $f64.no_fold_div_neg1 (param $x f64) (result f64) + (func (export "f64.no_fold_div_neg1") (param $x f64) (result f64) (f64.div (get_local $x) (f64.const -1.0))) - (export "f64.no_fold_div_neg1" $f64.no_fold_div_neg1) ) (assert_return (invoke "f32.no_fold_div_neg1" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -179,13 +151,10 @@ ;; Test that -0.0 - x is not folded to -x. (module - (func $f32.no_fold_neg0_sub (param $x f32) (result f32) + (func (export "f32.no_fold_neg0_sub") (param $x f32) (result f32) (f32.sub (f32.const -0.0) (get_local $x))) - (export "f32.no_fold_neg0_sub" $f32.no_fold_neg0_sub) - - (func $f64.no_fold_neg0_sub (param $x f64) (result f64) + (func (export "f64.no_fold_neg0_sub") (param $x f64) (result f64) (f64.sub (f64.const -0.0) (get_local $x))) - (export "f64.no_fold_neg0_sub" $f64.no_fold_neg0_sub) ) (assert_return (invoke "f32.no_fold_neg0_sub" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -194,13 +163,10 @@ ;; Test that -1.0 * x is not folded to -x. (module - (func $f32.no_fold_neg1_mul (param $x f32) (result f32) + (func (export "f32.no_fold_neg1_mul") (param $x f32) (result f32) (f32.mul (f32.const -1.0) (get_local $x))) - (export "f32.no_fold_neg1_mul" $f32.no_fold_neg1_mul) - - (func $f64.no_fold_neg1_mul (param $x f64) (result f64) + (func (export "f64.no_fold_neg1_mul") (param $x f64) (result f64) (f64.mul (f64.const -1.0) (get_local $x))) - (export "f64.no_fold_neg1_mul" $f64.no_fold_neg1_mul) ) (assert_return (invoke "f32.no_fold_neg1_mul" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -209,13 +175,10 @@ ;; Test that x == x is not folded to true. (module - (func $f32.no_fold_eq_self (param $x f32) (result i32) + (func (export "f32.no_fold_eq_self") (param $x f32) (result i32) (f32.eq (get_local $x) (get_local $x))) - (export "f32.no_fold_eq_self" $f32.no_fold_eq_self) - - (func $f64.no_fold_eq_self (param $x f64) (result i32) + (func (export "f64.no_fold_eq_self") (param $x f64) (result i32) (f64.eq (get_local $x) (get_local $x))) - (export "f64.no_fold_eq_self" $f64.no_fold_eq_self) ) (assert_return (invoke "f32.no_fold_eq_self" (f32.const nan)) (i32.const 0)) @@ -224,13 +187,10 @@ ;; Test that x != x is not folded to false. (module - (func $f32.no_fold_ne_self (param $x f32) (result i32) + (func (export "f32.no_fold_ne_self") (param $x f32) (result i32) (f32.ne (get_local $x) (get_local $x))) - (export "f32.no_fold_ne_self" $f32.no_fold_ne_self) - - (func $f64.no_fold_ne_self (param $x f64) (result i32) + (func (export "f64.no_fold_ne_self") (param $x f64) (result i32) (f64.ne (get_local $x) (get_local $x))) - (export "f64.no_fold_ne_self" $f64.no_fold_ne_self) ) (assert_return (invoke "f32.no_fold_ne_self" (f32.const nan)) (i32.const 1)) @@ -239,13 +199,10 @@ ;; Test that x - x is not folded to 0.0. (module - (func $f32.no_fold_sub_self (param $x f32) (result f32) + (func (export "f32.no_fold_sub_self") (param $x f32) (result f32) (f32.sub (get_local $x) (get_local $x))) - (export "f32.no_fold_sub_self" $f32.no_fold_sub_self) - - (func $f64.no_fold_sub_self (param $x f64) (result f64) + (func (export "f64.no_fold_sub_self") (param $x f64) (result f64) (f64.sub (get_local $x) (get_local $x))) - (export "f64.no_fold_sub_self" $f64.no_fold_sub_self) ) (assert_return_nan (invoke "f32.no_fold_sub_self" (f32.const infinity))) @@ -256,13 +213,10 @@ ;; Test that x/3 is not folded to x*(1/3). (module - (func $f32.no_fold_div_3 (param $x f32) (result f32) + (func (export "f32.no_fold_div_3") (param $x f32) (result f32) (f32.div (get_local $x) (f32.const 3.0))) - (export "f32.no_fold_div_3" $f32.no_fold_div_3) - - (func $f64.no_fold_div_3 (param $x f64) (result f64) + (func (export "f64.no_fold_div_3") (param $x f64) (result f64) (f64.div (get_local $x) (f64.const 3.0))) - (export "f64.no_fold_div_3" $f64.no_fold_div_3) ) (assert_return (invoke "f32.no_fold_div_3" (f32.const -0x1.359c26p+50)) (f32.const -0x1.9cd032p+48)) @@ -279,13 +233,10 @@ ;; Test that (x*z)+(y*z) is not folded to (x+y)*z (module - (func $f32.no_factor (param $x f32) (param $y f32) (param $z f32) (result f32) + (func (export "f32.no_factor") (param $x f32) (param $y f32) (param $z f32) (result f32) (f32.add (f32.mul (get_local $x) (get_local $z)) (f32.mul (get_local $y) (get_local $z)))) - (export "f32.no_factor" $f32.no_factor) - - (func $f64.no_factor (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_factor") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.add (f64.mul (get_local $x) (get_local $z)) (f64.mul (get_local $y) (get_local $z)))) - (export "f64.no_factor" $f64.no_factor) ) (assert_return (invoke "f32.no_factor" (f32.const -0x1.4e2352p+40) (f32.const -0x1.842e2cp+49) (f32.const 0x1.eea602p+59)) (f32.const -0x1.77a7dp+109)) @@ -302,13 +253,10 @@ ;; Test that (x+y)*z is not folded to (x*z)+(y*z) (module - (func $f32.no_distribute (param $x f32) (param $y f32) (param $z f32) (result f32) + (func (export "f32.no_distribute") (param $x f32) (param $y f32) (param $z f32) (result f32) (f32.mul (f32.add (get_local $x) (get_local $y)) (get_local $z))) - (export "f32.no_distribute" $f32.no_distribute) - - (func $f64.no_distribute (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_distribute") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.mul (f64.add (get_local $x) (get_local $y)) (get_local $z))) - (export "f64.no_distribute" $f64.no_distribute) ) (assert_return (invoke "f32.no_distribute" (f32.const -0x1.4e2352p+40) (f32.const -0x1.842e2cp+49) (f32.const 0x1.eea602p+59)) (f32.const -0x1.77a7d2p+109)) @@ -325,13 +273,10 @@ ;; Test that x*(y/z) is not folded to (x*y)/z (module - (func $f32.no_regroup_div_mul (param $x f32) (param $y f32) (param $z f32) (result f32) + (func (export "f32.no_regroup_div_mul") (param $x f32) (param $y f32) (param $z f32) (result f32) (f32.mul (get_local $x) (f32.div (get_local $y) (get_local $z)))) - (export "f32.no_regroup_div_mul" $f32.no_regroup_div_mul) - - (func $f64.no_regroup_div_mul (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_regroup_div_mul") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.mul (get_local $x) (f64.div (get_local $y) (get_local $z)))) - (export "f64.no_regroup_div_mul" $f64.no_regroup_div_mul) ) (assert_return (invoke "f32.no_regroup_div_mul" (f32.const -0x1.2d14a6p-115) (f32.const -0x1.575a6cp-64) (f32.const 0x1.5cee0ep-116)) (f32.const 0x1.2844cap-63)) @@ -348,13 +293,10 @@ ;; Test that (x*y)/z is not folded to x*(y/z) (module - (func $f32.no_regroup_mul_div (param $x f32) (param $y f32) (param $z f32) (result f32) + (func (export "f32.no_regroup_mul_div") (param $x f32) (param $y f32) (param $z f32) (result f32) (f32.div (f32.mul (get_local $x) (get_local $y)) (get_local $z))) - (export "f32.no_regroup_mul_div" $f32.no_regroup_mul_div) - - (func $f64.no_regroup_mul_div (param $x f64) (param $y f64) (param $z f64) (result f64) + (func (export "f64.no_regroup_mul_div") (param $x f64) (param $y f64) (param $z f64) (result f64) (f64.div (f64.mul (get_local $x) (get_local $y)) (get_local $z))) - (export "f64.no_regroup_mul_div" $f64.no_regroup_mul_div) ) (assert_return (invoke "f32.no_regroup_mul_div" (f32.const -0x1.2d14a6p-115) (f32.const -0x1.575a6cp-64) (f32.const 0x1.5cee0ep-116)) (f32.const 0x0p+0)) @@ -371,13 +313,10 @@ ;; Test that x+y+z+w is not reassociated. (module - (func $f32.no_reassociate_add (param $x f32) (param $y f32) (param $z f32) (param $w f32) (result f32) + (func (export "f32.no_reassociate_add") (param $x f32) (param $y f32) (param $z f32) (param $w f32) (result f32) (f32.add (f32.add (f32.add (get_local $x) (get_local $y)) (get_local $z)) (get_local $w))) - (export "f32.no_reassociate_add" $f32.no_reassociate_add) - - (func $f64.no_reassociate_add (param $x f64) (param $y f64) (param $z f64) (param $w f64) (result f64) + (func (export "f64.no_reassociate_add") (param $x f64) (param $y f64) (param $z f64) (param $w f64) (result f64) (f64.add (f64.add (f64.add (get_local $x) (get_local $y)) (get_local $z)) (get_local $w))) - (export "f64.no_reassociate_add" $f64.no_reassociate_add) ) (assert_return (invoke "f32.no_reassociate_add" (f32.const -0x1.5f7ddcp+44) (f32.const 0x1.854e1p+34) (f32.const -0x1.b2068cp+47) (f32.const -0x1.209692p+41)) (f32.const -0x1.e26c76p+47)) @@ -394,13 +333,10 @@ ;; Test that x*y*z*w is not reassociated. (module - (func $f32.no_reassociate_mul (param $x f32) (param $y f32) (param $z f32) (param $w f32) (result f32) + (func (export "f32.no_reassociate_mul") (param $x f32) (param $y f32) (param $z f32) (param $w f32) (result f32) (f32.mul (f32.mul (f32.mul (get_local $x) (get_local $y)) (get_local $z)) (get_local $w))) - (export "f32.no_reassociate_mul" $f32.no_reassociate_mul) - - (func $f64.no_reassociate_mul (param $x f64) (param $y f64) (param $z f64) (param $w f64) (result f64) + (func (export "f64.no_reassociate_mul") (param $x f64) (param $y f64) (param $z f64) (param $w f64) (result f64) (f64.mul (f64.mul (f64.mul (get_local $x) (get_local $y)) (get_local $z)) (get_local $w))) - (export "f64.no_reassociate_mul" $f64.no_reassociate_mul) ) (assert_return (invoke "f32.no_reassociate_mul" (f32.const 0x1.950ba8p-116) (f32.const 0x1.efdacep-33) (f32.const -0x1.5f9bcp+102) (f32.const 0x1.f04508p-56)) (f32.const -0x1.ff356ep-101)) @@ -417,13 +353,10 @@ ;; Test that x/0 is not folded away. (module - (func $f32.no_fold_div_0 (param $x f32) (result f32) + (func (export "f32.no_fold_div_0") (param $x f32) (result f32) (f32.div (get_local $x) (f32.const 0.0))) - (export "f32.no_fold_div_0" $f32.no_fold_div_0) - - (func $f64.no_fold_div_0 (param $x f64) (result f64) + (func (export "f64.no_fold_div_0") (param $x f64) (result f64) (f64.div (get_local $x) (f64.const 0.0))) - (export "f64.no_fold_div_0" $f64.no_fold_div_0) ) (assert_return (invoke "f32.no_fold_div_0" (f32.const 1.0)) (f32.const infinity)) @@ -446,13 +379,10 @@ ;; Test that x/-0 is not folded away. (module - (func $f32.no_fold_div_neg0 (param $x f32) (result f32) + (func (export "f32.no_fold_div_neg0") (param $x f32) (result f32) (f32.div (get_local $x) (f32.const -0.0))) - (export "f32.no_fold_div_neg0" $f32.no_fold_div_neg0) - - (func $f64.no_fold_div_neg0 (param $x f64) (result f64) + (func (export "f64.no_fold_div_neg0") (param $x f64) (result f64) (f64.div (get_local $x) (f64.const -0.0))) - (export "f64.no_fold_div_neg0" $f64.no_fold_div_neg0) ) (assert_return (invoke "f32.no_fold_div_neg0" (f32.const 1.0)) (f32.const -infinity)) @@ -475,15 +405,12 @@ ;; Test that sqrt(x*x+y*y) is not folded to hypot. (module - (func $f32.no_fold_to_hypot (param $x f32) (param $y f32) (result f32) + (func (export "f32.no_fold_to_hypot") (param $x f32) (param $y f32) (result f32) (f32.sqrt (f32.add (f32.mul (get_local $x) (get_local $x)) (f32.mul (get_local $y) (get_local $y))))) - (export "f32.no_fold_to_hypot" $f32.no_fold_to_hypot) - - (func $f64.no_fold_to_hypot (param $x f64) (param $y f64) (result f64) + (func (export "f64.no_fold_to_hypot") (param $x f64) (param $y f64) (result f64) (f64.sqrt (f64.add (f64.mul (get_local $x) (get_local $x)) (f64.mul (get_local $y) (get_local $y))))) - (export "f64.no_fold_to_hypot" $f64.no_fold_to_hypot) ) (assert_return (invoke "f32.no_fold_to_hypot" (f32.const 0x1.c2f338p-81) (f32.const 0x1.401b5ep-68)) (f32.const 0x1.401cccp-68)) @@ -500,9 +427,8 @@ ;; Test that 1.0/x isn't approximated. (module - (func $f32.no_approximate_reciprocal (param $x f32) (result f32) + (func (export "f32.no_approximate_reciprocal") (param $x f32) (result f32) (f32.div (f32.const 1.0) (get_local $x))) - (export "f32.no_approximate_reciprocal" $f32.no_approximate_reciprocal) ) (assert_return (invoke "f32.no_approximate_reciprocal" (f32.const -0x1.2900b6p-10)) (f32.const -0x1.b950d4p+9)) @@ -514,13 +440,10 @@ ;; Test that 1.0/sqrt(x) isn't approximated or fused. (module - (func $f32.no_approximate_reciprocal_sqrt (param $x f32) (result f32) + (func (export "f32.no_approximate_reciprocal_sqrt") (param $x f32) (result f32) (f32.div (f32.const 1.0) (f32.sqrt (get_local $x)))) - (export "f32.no_approximate_reciprocal_sqrt" $f32.no_approximate_reciprocal_sqrt) - - (func $f64.no_fuse_reciprocal_sqrt (param $x f64) (result f64) + (func (export "f64.no_fuse_reciprocal_sqrt") (param $x f64) (result f64) (f64.div (f64.const 1.0) (f64.sqrt (get_local $x)))) - (export "f64.no_fuse_reciprocal_sqrt" $f64.no_fuse_reciprocal_sqrt) ) (assert_return (invoke "f32.no_approximate_reciprocal_sqrt" (f32.const 0x1.6af12ap-43)) (f32.const 0x1.300ed4p+21)) @@ -538,9 +461,8 @@ ;; Test that sqrt(1.0/x) isn't approximated. (module - (func $f32.no_approximate_sqrt_reciprocal (param $x f32) (result f32) + (func (export "f32.no_approximate_sqrt_reciprocal") (param $x f32) (result f32) (f32.sqrt (f32.div (f32.const 1.0) (get_local $x)))) - (export "f32.no_approximate_sqrt_reciprocal" $f32.no_approximate_sqrt_reciprocal) ) (assert_return (invoke "f32.no_approximate_sqrt_reciprocal" (f32.const 0x1.a4c986p+60)) (f32.const 0x1.8f5ac6p-31)) @@ -552,21 +474,14 @@ ;; Test that converting i32/i64 to f32/f64 and back isn't folded away (module - (func $i32.no_fold_f32_s (param i32) (result i32) + (func (export "i32.no_fold_f32_s") (param i32) (result i32) (i32.trunc_s/f32 (f32.convert_s/i32 (get_local 0)))) - (export "i32.no_fold_f32_s" $i32.no_fold_f32_s) - - (func $i32.no_fold_f32_u (param i32) (result i32) + (func (export "i32.no_fold_f32_u") (param i32) (result i32) (i32.trunc_u/f32 (f32.convert_u/i32 (get_local 0)))) - (export "i32.no_fold_f32_u" $i32.no_fold_f32_u) - - (func $i64.no_fold_f64_s (param i64) (result i64) + (func (export "i64.no_fold_f64_s") (param i64) (result i64) (i64.trunc_s/f64 (f64.convert_s/i64 (get_local 0)))) - (export "i64.no_fold_f64_s" $i64.no_fold_f64_s) - - (func $i64.no_fold_f64_u (param i64) (result i64) + (func (export "i64.no_fold_f64_u") (param i64) (result i64) (i64.trunc_u/f64 (f64.convert_u/i64 (get_local 0)))) - (export "i64.no_fold_f64_u" $i64.no_fold_f64_u) ) (assert_return (invoke "i32.no_fold_f32_s" (i32.const 0x1000000)) (i32.const 0x1000000)) @@ -588,13 +503,10 @@ ;; Test that x+y-y is not folded to x. (module - (func $f32.no_fold_add_sub (param $x f32) (param $y f32) (result f32) + (func (export "f32.no_fold_add_sub") (param $x f32) (param $y f32) (result f32) (f32.sub (f32.add (get_local $x) (get_local $y)) (get_local $y))) - (export "f32.no_fold_add_sub" $f32.no_fold_add_sub) - - (func $f64.no_fold_add_sub (param $x f64) (param $y f64) (result f64) + (func (export "f64.no_fold_add_sub") (param $x f64) (param $y f64) (result f64) (f64.sub (f64.add (get_local $x) (get_local $y)) (get_local $y))) - (export "f64.no_fold_add_sub" $f64.no_fold_add_sub) ) (assert_return (invoke "f32.no_fold_add_sub" (f32.const 0x1.b553e4p-47) (f32.const -0x1.67db2cp-26)) (f32.const 0x1.cp-47)) @@ -612,13 +524,10 @@ ;; Test that x-y+y is not folded to x. (module - (func $f32.no_fold_sub_add (param $x f32) (param $y f32) (result f32) + (func (export "f32.no_fold_sub_add") (param $x f32) (param $y f32) (result f32) (f32.add (f32.sub (get_local $x) (get_local $y)) (get_local $y))) - (export "f32.no_fold_sub_add" $f32.no_fold_sub_add) - - (func $f64.no_fold_sub_add (param $x f64) (param $y f64) (result f64) + (func (export "f64.no_fold_sub_add") (param $x f64) (param $y f64) (result f64) (f64.add (f64.sub (get_local $x) (get_local $y)) (get_local $y))) - (export "f64.no_fold_sub_add" $f64.no_fold_sub_add) ) (assert_return (invoke "f32.no_fold_sub_add" (f32.const -0x1.523cb8p+9) (f32.const 0x1.93096cp+8)) (f32.const -0x1.523cbap+9)) @@ -636,13 +545,10 @@ ;; Test that x*y/y is not folded to x. (module - (func $f32.no_fold_mul_div (param $x f32) (param $y f32) (result f32) + (func (export "f32.no_fold_mul_div") (param $x f32) (param $y f32) (result f32) (f32.div (f32.mul (get_local $x) (get_local $y)) (get_local $y))) - (export "f32.no_fold_mul_div" $f32.no_fold_mul_div) - - (func $f64.no_fold_mul_div (param $x f64) (param $y f64) (result f64) + (func (export "f64.no_fold_mul_div") (param $x f64) (param $y f64) (result f64) (f64.div (f64.mul (get_local $x) (get_local $y)) (get_local $y))) - (export "f64.no_fold_mul_div" $f64.no_fold_mul_div) ) (assert_return (invoke "f32.no_fold_mul_div" (f32.const -0x1.cd859ap+54) (f32.const 0x1.6ca936p-47)) (f32.const -0x1.cd8598p+54)) @@ -660,13 +566,10 @@ ;; Test that x/y*y is not folded to x. (module - (func $f32.no_fold_div_mul (param $x f32) (param $y f32) (result f32) + (func (export "f32.no_fold_div_mul") (param $x f32) (param $y f32) (result f32) (f32.mul (f32.div (get_local $x) (get_local $y)) (get_local $y))) - (export "f32.no_fold_div_mul" $f32.no_fold_div_mul) - - (func $f64.no_fold_div_mul (param $x f64) (param $y f64) (result f64) + (func (export "f64.no_fold_div_mul") (param $x f64) (param $y f64) (result f64) (f64.mul (f64.div (get_local $x) (get_local $y)) (get_local $y))) - (export "f64.no_fold_div_mul" $f64.no_fold_div_mul) ) (assert_return (invoke "f32.no_fold_div_mul" (f32.const -0x1.dc6364p+38) (f32.const 0x1.d630ecp+29)) (f32.const -0x1.dc6362p+38)) @@ -684,9 +587,8 @@ ;; Test that promote(demote(x)) is not folded to x. (module - (func $no_fold_demote_promote (param $x f64) (result f64) + (func (export "no_fold_demote_promote") (param $x f64) (result f64) (f64.promote/f32 (f32.demote/f64 (get_local $x)))) - (export "no_fold_demote_promote" $no_fold_demote_promote) ) (assert_return (invoke "no_fold_demote_promote" (f64.const -0x1.dece272390f5dp-133)) (f64.const -0x1.decep-133)) @@ -699,9 +601,8 @@ ;; bit-preserving. (module - (func $no_fold_promote_demote (param $x f32) (result f32) + (func (export "no_fold_promote_demote") (param $x f32) (result f32) (f32.demote/f64 (f64.promote/f32 (get_local $x)))) - (export "no_fold_promote_demote" $no_fold_promote_demote) ) (assert_return (invoke "no_fold_promote_demote" (f32.const nan:0x200000)) (f32.const nan:0x600000)) @@ -721,13 +622,10 @@ ;; Test that demote(x+promote(y)) is not folded to demote(x)+y. (module - (func $no_demote_mixed_add (param $x f64) (param $y f32) (result f32) + (func (export "no_demote_mixed_add") (param $x f64) (param $y f32) (result f32) (f32.demote/f64 (f64.add (get_local $x) (f64.promote/f32 (get_local $y))))) - (export "no_demote_mixed_add" $no_demote_mixed_add) - - (func $no_demote_mixed_add_commuted (param $y f32) (param $x f64) (result f32) + (func (export "no_demote_mixed_add_commuted") (param $y f32) (param $x f64) (result f32) (f32.demote/f64 (f64.add (f64.promote/f32 (get_local $y)) (get_local $x)))) - (export "no_demote_mixed_add_commuted" $no_demote_mixed_add_commuted) ) (assert_return (invoke "no_demote_mixed_add" (f64.const 0x1.f51a9d04854f9p-95) (f32.const 0x1.3f4e9cp-119)) (f32.const 0x1.f51a9ep-95)) @@ -745,9 +643,8 @@ ;; Test that demote(x-promote(y)) is not folded to demote(x)-y. (module - (func $no_demote_mixed_sub (param $x f64) (param $y f32) (result f32) + (func (export "no_demote_mixed_sub") (param $x f64) (param $y f32) (result f32) (f32.demote/f64 (f64.sub (get_local $x) (f64.promote/f32 (get_local $y))))) - (export "no_demote_mixed_sub" $no_demote_mixed_sub) ) (assert_return (invoke "no_demote_mixed_sub" (f64.const 0x1.a0a183220e9b1p+82) (f32.const 0x1.c5acf8p+61)) (f32.const 0x1.a0a174p+82)) @@ -759,69 +656,38 @@ ;; Test that converting between integer and float and back isn't folded away. (module - (func $f32.i32.no_fold_trunc_s_convert_s (param $x f32) (result f32) + (func (export "f32.i32.no_fold_trunc_s_convert_s") (param $x f32) (result f32) (f32.convert_s/i32 (i32.trunc_s/f32 (get_local $x)))) - (export "f32.i32.no_fold_trunc_s_convert_s" $f32.i32.no_fold_trunc_s_convert_s) - - (func $f32.i32.no_fold_trunc_u_convert_s (param $x f32) (result f32) + (func (export "f32.i32.no_fold_trunc_u_convert_s") (param $x f32) (result f32) (f32.convert_s/i32 (i32.trunc_u/f32 (get_local $x)))) - (export "f32.i32.no_fold_trunc_u_convert_s" $f32.i32.no_fold_trunc_u_convert_s) - - (func $f32.i32.no_fold_trunc_s_convert_u (param $x f32) (result f32) + (func (export "f32.i32.no_fold_trunc_s_convert_u") (param $x f32) (result f32) (f32.convert_u/i32 (i32.trunc_s/f32 (get_local $x)))) - (export "f32.i32.no_fold_trunc_s_convert_u" $f32.i32.no_fold_trunc_s_convert_u) - - (func $f32.i32.no_fold_trunc_u_convert_u (param $x f32) (result f32) + (func (export "f32.i32.no_fold_trunc_u_convert_u") (param $x f32) (result f32) (f32.convert_u/i32 (i32.trunc_u/f32 (get_local $x)))) - (export "f32.i32.no_fold_trunc_u_convert_u" $f32.i32.no_fold_trunc_u_convert_u) - - (func $f64.i32.no_fold_trunc_s_convert_s (param $x f64) (result f64) + (func (export "f64.i32.no_fold_trunc_s_convert_s") (param $x f64) (result f64) (f64.convert_s/i32 (i32.trunc_s/f64 (get_local $x)))) - (export "f64.i32.no_fold_trunc_s_convert_s" $f64.i32.no_fold_trunc_s_convert_s) - - (func $f64.i32.no_fold_trunc_u_convert_s (param $x f64) (result f64) + (func (export "f64.i32.no_fold_trunc_u_convert_s") (param $x f64) (result f64) (f64.convert_s/i32 (i32.trunc_u/f64 (get_local $x)))) - (export "f64.i32.no_fold_trunc_u_convert_s" $f64.i32.no_fold_trunc_u_convert_s) - - (func $f64.i32.no_fold_trunc_s_convert_u (param $x f64) (result f64) + (func (export "f64.i32.no_fold_trunc_s_convert_u") (param $x f64) (result f64) (f64.convert_u/i32 (i32.trunc_s/f64 (get_local $x)))) - (export "f64.i32.no_fold_trunc_s_convert_u" $f64.i32.no_fold_trunc_s_convert_u) - - (func $f64.i32.no_fold_trunc_u_convert_u (param $x f64) (result f64) + (func (export "f64.i32.no_fold_trunc_u_convert_u") (param $x f64) (result f64) (f64.convert_u/i32 (i32.trunc_u/f64 (get_local $x)))) - (export "f64.i32.no_fold_trunc_u_convert_u" $f64.i32.no_fold_trunc_u_convert_u) - - (func $f32.i64.no_fold_trunc_s_convert_s (param $x f32) (result f32) + (func (export "f32.i64.no_fold_trunc_s_convert_s") (param $x f32) (result f32) (f32.convert_s/i64 (i64.trunc_s/f32 (get_local $x)))) - (export "f32.i64.no_fold_trunc_s_convert_s" $f32.i64.no_fold_trunc_s_convert_s) - - (func $f32.i64.no_fold_trunc_u_convert_s (param $x f32) (result f32) + (func (export "f32.i64.no_fold_trunc_u_convert_s") (param $x f32) (result f32) (f32.convert_s/i64 (i64.trunc_u/f32 (get_local $x)))) - (export "f32.i64.no_fold_trunc_u_convert_s" $f32.i64.no_fold_trunc_u_convert_s) - - (func $f32.i64.no_fold_trunc_s_convert_u (param $x f32) (result f32) + (func (export "f32.i64.no_fold_trunc_s_convert_u") (param $x f32) (result f32) (f32.convert_u/i64 (i64.trunc_s/f32 (get_local $x)))) - (export "f32.i64.no_fold_trunc_s_convert_u" $f32.i64.no_fold_trunc_s_convert_u) - - (func $f32.i64.no_fold_trunc_u_convert_u (param $x f32) (result f32) + (func (export "f32.i64.no_fold_trunc_u_convert_u") (param $x f32) (result f32) (f32.convert_u/i64 (i64.trunc_u/f32 (get_local $x)))) - (export "f32.i64.no_fold_trunc_u_convert_u" $f32.i64.no_fold_trunc_u_convert_u) - - (func $f64.i64.no_fold_trunc_s_convert_s (param $x f64) (result f64) + (func (export "f64.i64.no_fold_trunc_s_convert_s") (param $x f64) (result f64) (f64.convert_s/i64 (i64.trunc_s/f64 (get_local $x)))) - (export "f64.i64.no_fold_trunc_s_convert_s" $f64.i64.no_fold_trunc_s_convert_s) - - (func $f64.i64.no_fold_trunc_u_convert_s (param $x f64) (result f64) + (func (export "f64.i64.no_fold_trunc_u_convert_s") (param $x f64) (result f64) (f64.convert_s/i64 (i64.trunc_u/f64 (get_local $x)))) - (export "f64.i64.no_fold_trunc_u_convert_s" $f64.i64.no_fold_trunc_u_convert_s) - - (func $f64.i64.no_fold_trunc_s_convert_u (param $x f64) (result f64) + (func (export "f64.i64.no_fold_trunc_s_convert_u") (param $x f64) (result f64) (f64.convert_u/i64 (i64.trunc_s/f64 (get_local $x)))) - (export "f64.i64.no_fold_trunc_s_convert_u" $f64.i64.no_fold_trunc_s_convert_u) - - (func $f64.i64.no_fold_trunc_u_convert_u (param $x f64) (result f64) + (func (export "f64.i64.no_fold_trunc_u_convert_u") (param $x f64) (result f64) (f64.convert_u/i64 (i64.trunc_u/f64 (get_local $x)))) - (export "f64.i64.no_fold_trunc_u_convert_u" $f64.i64.no_fold_trunc_u_convert_u) ) (assert_return (invoke "f32.i32.no_fold_trunc_s_convert_s" (f32.const 1.5)) (f32.const 1.0)) @@ -866,10 +732,9 @@ (module (memory 1 1) - (func $init (param $i i32) (param $x f32) (f32.store (get_local $i) (get_local $x))) - (export "init" $init) + (func (export "init") (param $i i32) (param $x f32) (f32.store (get_local $i) (get_local $x))) - (func $run (param $n i32) (param $z f32) + (func (export "run") (param $n i32) (param $z f32) (local $i i32) (block $exit (loop $cont @@ -882,10 +747,8 @@ ) ) ) - (export "run" $run) - (func $check (param $i i32) (result f32) (f32.load (get_local $i))) - (export "check" $check) + (func (export "check") (param $i i32) (result f32) (f32.load (get_local $i))) ) (invoke "init" (i32.const 0) (f32.const 15.1)) @@ -904,10 +767,9 @@ (module (memory 1 1) - (func $init (param $i i32) (param $x f64) (f64.store (get_local $i) (get_local $x))) - (export "init" $init) + (func (export "init") (param $i i32) (param $x f64) (f64.store (get_local $i) (get_local $x))) - (func $run (param $n i32) (param $z f64) + (func (export "run") (param $n i32) (param $z f64) (local $i i32) (block $exit (loop $cont @@ -920,10 +782,8 @@ ) ) ) - (export "run" $run) - (func $check (param $i i32) (result f64) (f64.load (get_local $i))) - (export "check" $check) + (func (export "check") (param $i i32) (result f64) (f64.load (get_local $i))) ) (invoke "init" (i32.const 0) (f64.const 15.1)) @@ -943,24 +803,15 @@ ;; Test that ult/ugt/etc. aren't folded to olt/ogt/etc. (module - (func $f32.ult (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.ge (get_local $x) (get_local $y)))) - (func $f32.ule (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.gt (get_local $x) (get_local $y)))) - (func $f32.ugt (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.le (get_local $x) (get_local $y)))) - (func $f32.uge (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.lt (get_local $x) (get_local $y)))) - - (func $f64.ult (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.ge (get_local $x) (get_local $y)))) - (func $f64.ule (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.gt (get_local $x) (get_local $y)))) - (func $f64.ugt (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.le (get_local $x) (get_local $y)))) - (func $f64.uge (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.lt (get_local $x) (get_local $y)))) + (func (export "f32.ult") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.ge (get_local $x) (get_local $y)))) + (func (export "f32.ule") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.gt (get_local $x) (get_local $y)))) + (func (export "f32.ugt") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.le (get_local $x) (get_local $y)))) + (func (export "f32.uge") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.lt (get_local $x) (get_local $y)))) - (export "f32.ult" $f32.ult) - (export "f32.ule" $f32.ule) - (export "f32.ugt" $f32.ugt) - (export "f32.uge" $f32.uge) - (export "f64.ult" $f64.ult) - (export "f64.ule" $f64.ule) - (export "f64.ugt" $f64.ugt) - (export "f64.uge" $f64.uge) + (func (export "f64.ult") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.ge (get_local $x) (get_local $y)))) + (func (export "f64.ule") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.gt (get_local $x) (get_local $y)))) + (func (export "f64.ugt") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.le (get_local $x) (get_local $y)))) + (func (export "f64.uge") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.lt (get_local $x) (get_local $y)))) ) (assert_return (invoke "f32.ult" (f32.const 3.0) (f32.const 2.0)) (i32.const 0)) @@ -999,23 +850,15 @@ ;; Test that x= y and friends. (module - (func $f32.not_lt (param $x f32) (param $y f32) (result i32) + (func (export "f32.not_lt") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.lt (get_local $x) (get_local $y)))) - (export "f32.not_lt" $f32.not_lt) - (func $f32.not_le (param $x f32) (param $y f32) (result i32) + (func (export "f32.not_le") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.le (get_local $x) (get_local $y)))) - (export "f32.not_le" $f32.not_le) - (func $f32.not_gt (param $x f32) (param $y f32) (result i32) + (func (export "f32.not_gt") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.gt (get_local $x) (get_local $y)))) - (export "f32.not_gt" $f32.not_gt) - (func $f32.not_ge (param $x f32) (param $y f32) (result i32) + (func (export "f32.not_ge") (param $x f32) (param $y f32) (result i32) (i32.eqz (f32.ge (get_local $x) (get_local $y)))) - (export "f32.not_ge" $f32.not_ge) - (func $f64.not_lt (param $x f64) (param $y f64) (result i32) + (func (export "f64.not_lt") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.lt (get_local $x) (get_local $y)))) - (export "f64.not_lt" $f64.not_lt) - (func $f64.not_le (param $x f64) (param $y f64) (result i32) + (func (export "f64.not_le") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.le (get_local $x) (get_local $y)))) - (export "f64.not_le" $f64.not_le) - (func $f64.not_gt (param $x f64) (param $y f64) (result i32) + (func (export "f64.not_gt") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.gt (get_local $x) (get_local $y)))) - (export "f64.not_gt" $f64.not_gt) - (func $f64.not_ge (param $x f64) (param $y f64) (result i32) + (func (export "f64.not_ge") (param $x f64) (param $y f64) (result i32) (i32.eqz (f64.ge (get_local $x) (get_local $y)))) - (export "f64.not_ge" $f64.not_ge) ) (assert_return (invoke "f32.not_lt" (f32.const nan) (f32.const 0.0)) (i32.const 1)) @@ -2199,13 +1936,11 @@ ;; http://blogs.mathworks.com/cleve/2014/07/07/floating-point-numbers/#24cb4f4d-b8a9-4c19-b22b-9d2a9f7f3812 (module - (func $f32.epsilon (result f32) + (func (export "f32.epsilon") (result f32) (f32.sub (f32.const 1.0) (f32.mul (f32.const 3.0) (f32.sub (f32.div (f32.const 4.0) (f32.const 3.0)) (f32.const 1.0))))) - (export "f32.epsilon" $f32.epsilon) - (func $f64.epsilon (result f64) + (func (export "f64.epsilon") (result f64) (f64.sub (f64.const 1.0) (f64.mul (f64.const 3.0) (f64.sub (f64.div (f64.const 4.0) (f64.const 3.0)) (f64.const 1.0))))) - (export "f64.epsilon" $f64.epsilon) ) (assert_return (invoke "f32.epsilon") (f32.const -0x1p-23)) @@ -2215,31 +1950,23 @@ ;; trichotomy. (module - (func $f32.no_trichotomy_lt (param $x f32) (param $y f32) (result i32) + (func (export "f32.no_trichotomy_lt") (param $x f32) (param $y f32) (result i32) (i32.or (f32.lt (get_local $x) (get_local $y)) (f32.ge (get_local $x) (get_local $y)))) - (export "f32.no_trichotomy_lt" $f32.no_trichotomy_lt) - (func $f32.no_trichotomy_le (param $x f32) (param $y f32) (result i32) + (func (export "f32.no_trichotomy_le") (param $x f32) (param $y f32) (result i32) (i32.or (f32.le (get_local $x) (get_local $y)) (f32.gt (get_local $x) (get_local $y)))) - (export "f32.no_trichotomy_le" $f32.no_trichotomy_le) - (func $f32.no_trichotomy_gt (param $x f32) (param $y f32) (result i32) + (func (export "f32.no_trichotomy_gt") (param $x f32) (param $y f32) (result i32) (i32.or (f32.gt (get_local $x) (get_local $y)) (f32.le (get_local $x) (get_local $y)))) - (export "f32.no_trichotomy_gt" $f32.no_trichotomy_gt) - (func $f32.no_trichotomy_ge (param $x f32) (param $y f32) (result i32) + (func (export "f32.no_trichotomy_ge") (param $x f32) (param $y f32) (result i32) (i32.or (f32.ge (get_local $x) (get_local $y)) (f32.lt (get_local $x) (get_local $y)))) - (export "f32.no_trichotomy_ge" $f32.no_trichotomy_ge) - (func $f64.no_trichotomy_lt (param $x f64) (param $y f64) (result i32) + (func (export "f64.no_trichotomy_lt") (param $x f64) (param $y f64) (result i32) (i32.or (f64.lt (get_local $x) (get_local $y)) (f64.ge (get_local $x) (get_local $y)))) - (export "f64.no_trichotomy_lt" $f64.no_trichotomy_lt) - (func $f64.no_trichotomy_le (param $x f64) (param $y f64) (result i32) + (func (export "f64.no_trichotomy_le") (param $x f64) (param $y f64) (result i32) (i32.or (f64.le (get_local $x) (get_local $y)) (f64.gt (get_local $x) (get_local $y)))) - (export "f64.no_trichotomy_le" $f64.no_trichotomy_le) - (func $f64.no_trichotomy_gt (param $x f64) (param $y f64) (result i32) + (func (export "f64.no_trichotomy_gt") (param $x f64) (param $y f64) (result i32) (i32.or (f64.gt (get_local $x) (get_local $y)) (f64.le (get_local $x) (get_local $y)))) - (export "f64.no_trichotomy_gt" $f64.no_trichotomy_gt) - (func $f64.no_trichotomy_ge (param $x f64) (param $y f64) (result i32) + (func (export "f64.no_trichotomy_ge") (param $x f64) (param $y f64) (result i32) (i32.or (f64.ge (get_local $x) (get_local $y)) (f64.lt (get_local $x) (get_local $y)))) - (export "f64.no_trichotomy_ge" $f64.no_trichotomy_ge) ) (assert_return (invoke "f32.no_trichotomy_lt" (f32.const 0.0) (f32.const nan)) (i32.const 0)) diff --git a/ml-proto/test/float_literals.wast b/ml-proto/test/float_literals.wast index 8c95e35b6f..c69d81fb7d 100644 --- a/ml-proto/test/float_literals.wast +++ b/ml-proto/test/float_literals.wast @@ -2,138 +2,76 @@ (module ;; f32 special values - (func $f32.nan (result i32) (i32.reinterpret/f32 (f32.const nan))) - (func $f32.positive_nan (result i32) (i32.reinterpret/f32 (f32.const +nan))) - (func $f32.negative_nan (result i32) (i32.reinterpret/f32 (f32.const -nan))) - (func $f32.plain_nan (result i32) (i32.reinterpret/f32 (f32.const nan:0x400000))) - (func $f32.informally_known_as_plain_snan (result i32) (i32.reinterpret/f32 (f32.const nan:0x200000))) - (func $f32.allones_nan (result i32) (i32.reinterpret/f32 (f32.const -nan:0x7fffff))) - (func $f32.misc_nan (result i32) (i32.reinterpret/f32 (f32.const nan:0x012345))) - (func $f32.misc_positive_nan (result i32) (i32.reinterpret/f32 (f32.const +nan:0x304050))) - (func $f32.misc_negative_nan (result i32) (i32.reinterpret/f32 (f32.const -nan:0x2abcde))) - (func $f32.infinity (result i32) (i32.reinterpret/f32 (f32.const infinity))) - (func $f32.positive_infinity (result i32) (i32.reinterpret/f32 (f32.const +infinity))) - (func $f32.negative_infinity (result i32) (i32.reinterpret/f32 (f32.const -infinity))) + (func (export "f32.nan") (result i32) (i32.reinterpret/f32 (f32.const nan))) + (func (export "f32.positive_nan") (result i32) (i32.reinterpret/f32 (f32.const +nan))) + (func (export "f32.negative_nan") (result i32) (i32.reinterpret/f32 (f32.const -nan))) + (func (export "f32.plain_nan") (result i32) (i32.reinterpret/f32 (f32.const nan:0x400000))) + (func (export "f32.informally_known_as_plain_snan") (result i32) (i32.reinterpret/f32 (f32.const nan:0x200000))) + (func (export "f32.all_ones_nan") (result i32) (i32.reinterpret/f32 (f32.const -nan:0x7fffff))) + (func (export "f32.misc_nan") (result i32) (i32.reinterpret/f32 (f32.const nan:0x012345))) + (func (export "f32.misc_positive_nan") (result i32) (i32.reinterpret/f32 (f32.const +nan:0x304050))) + (func (export "f32.misc_negative_nan") (result i32) (i32.reinterpret/f32 (f32.const -nan:0x2abcde))) + (func (export "f32.infinity") (result i32) (i32.reinterpret/f32 (f32.const infinity))) + (func (export "f32.positive_infinity") (result i32) (i32.reinterpret/f32 (f32.const +infinity))) + (func (export "f32.negative_infinity") (result i32) (i32.reinterpret/f32 (f32.const -infinity))) ;; f32 numbers - (func $f32.zero (result i32) (i32.reinterpret/f32 (f32.const 0x0.0p0))) - (func $f32.positive_zero (result i32) (i32.reinterpret/f32 (f32.const +0x0.0p0))) - (func $f32.negative_zero (result i32) (i32.reinterpret/f32 (f32.const -0x0.0p0))) - (func $f32.misc (result i32) (i32.reinterpret/f32 (f32.const 0x1.921fb6p+2))) - (func $f32.min_positive (result i32) (i32.reinterpret/f32 (f32.const 0x1p-149))) - (func $f32.min_normal (result i32) (i32.reinterpret/f32 (f32.const 0x1p-126))) - (func $f32.max_finite (result i32) (i32.reinterpret/f32 (f32.const 0x1.fffffep+127))) - (func $f32.max_subnormal (result i32) (i32.reinterpret/f32 (f32.const 0x1.fffffcp-127))) - (func $f32.trailing_dot (result i32) (i32.reinterpret/f32 (f32.const 0x1.p10))) + (func (export "f32.zero") (result i32) (i32.reinterpret/f32 (f32.const 0x0.0p0))) + (func (export "f32.positive_zero") (result i32) (i32.reinterpret/f32 (f32.const +0x0.0p0))) + (func (export "f32.negative_zero") (result i32) (i32.reinterpret/f32 (f32.const -0x0.0p0))) + (func (export "f32.misc") (result i32) (i32.reinterpret/f32 (f32.const 0x1.921fb6p+2))) + (func (export "f32.min_positive") (result i32) (i32.reinterpret/f32 (f32.const 0x1p-149))) + (func (export "f32.min_normal") (result i32) (i32.reinterpret/f32 (f32.const 0x1p-126))) + (func (export "f32.max_finite") (result i32) (i32.reinterpret/f32 (f32.const 0x1.fffffep+127))) + (func (export "f32.max_subnormal") (result i32) (i32.reinterpret/f32 (f32.const 0x1.fffffcp-127))) + (func (export "f32.trailing_dot") (result i32) (i32.reinterpret/f32 (f32.const 0x1.p10))) ;; f32 in decimal format - (func $f32_dec.zero (result i32) (i32.reinterpret/f32 (f32.const 0.0e0))) - (func $f32_dec.positive_zero (result i32) (i32.reinterpret/f32 (f32.const +0.0e0))) - (func $f32_dec.negative_zero (result i32) (i32.reinterpret/f32 (f32.const -0.0e0))) - (func $f32_dec.misc (result i32) (i32.reinterpret/f32 (f32.const 6.28318548202514648))) - (func $f32_dec.min_positive (result i32) (i32.reinterpret/f32 (f32.const 1.4013e-45))) - (func $f32_dec.min_normal (result i32) (i32.reinterpret/f32 (f32.const 1.1754944e-38))) - (func $f32_dec.max_subnormal (result i32) (i32.reinterpret/f32 (f32.const 1.1754942e-38))) - (func $f32_dec.max_finite (result i32) (i32.reinterpret/f32 (f32.const 3.4028234e+38))) - (func $f32_dec.trailing_dot (result i32) (i32.reinterpret/f32 (f32.const 1.e10))) + (func (export "f32_dec.zero") (result i32) (i32.reinterpret/f32 (f32.const 0.0e0))) + (func (export "f32_dec.positive_zero") (result i32) (i32.reinterpret/f32 (f32.const +0.0e0))) + (func (export "f32_dec.negative_zero") (result i32) (i32.reinterpret/f32 (f32.const -0.0e0))) + (func (export "f32_dec.misc") (result i32) (i32.reinterpret/f32 (f32.const 6.28318548202514648))) + (func (export "f32_dec.min_positive") (result i32) (i32.reinterpret/f32 (f32.const 1.4013e-45))) + (func (export "f32_dec.min_normal") (result i32) (i32.reinterpret/f32 (f32.const 1.1754944e-38))) + (func (export "f32_dec.max_subnormal") (result i32) (i32.reinterpret/f32 (f32.const 1.1754942e-38))) + (func (export "f32_dec.max_finite") (result i32) (i32.reinterpret/f32 (f32.const 3.4028234e+38))) + (func (export "f32_dec.trailing_dot") (result i32) (i32.reinterpret/f32 (f32.const 1.e10))) ;; f64 special values - (func $f64.nan (result i64) (i64.reinterpret/f64 (f64.const nan))) - (func $f64.positive_nan (result i64) (i64.reinterpret/f64 (f64.const +nan))) - (func $f64.negative_nan (result i64) (i64.reinterpret/f64 (f64.const -nan))) - (func $f64.plain_nan (result i64) (i64.reinterpret/f64 (f64.const nan:0x8000000000000))) - (func $f64.informally_known_as_plain_snan (result i64) (i64.reinterpret/f64 (f64.const nan:0x4000000000000))) - (func $f64.allones_nan (result i64) (i64.reinterpret/f64 (f64.const -nan:0xfffffffffffff))) - (func $f64.misc_nan (result i64) (i64.reinterpret/f64 (f64.const nan:0x0123456789abc))) - (func $f64.misc_positive_nan (result i64) (i64.reinterpret/f64 (f64.const +nan:0x3040506070809))) - (func $f64.misc_negative_nan (result i64) (i64.reinterpret/f64 (f64.const -nan:0x2abcdef012345))) - (func $f64.infinity (result i64) (i64.reinterpret/f64 (f64.const infinity))) - (func $f64.positive_infinity (result i64) (i64.reinterpret/f64 (f64.const +infinity))) - (func $f64.negative_infinity (result i64) (i64.reinterpret/f64 (f64.const -infinity))) + (func (export "f64.nan") (result i64) (i64.reinterpret/f64 (f64.const nan))) + (func (export "f64.positive_nan") (result i64) (i64.reinterpret/f64 (f64.const +nan))) + (func (export "f64.negative_nan") (result i64) (i64.reinterpret/f64 (f64.const -nan))) + (func (export "f64.plain_nan") (result i64) (i64.reinterpret/f64 (f64.const nan:0x8000000000000))) + (func (export "f64.informally_known_as_plain_snan") (result i64) (i64.reinterpret/f64 (f64.const nan:0x4000000000000))) + (func (export "f64.all_ones_nan") (result i64) (i64.reinterpret/f64 (f64.const -nan:0xfffffffffffff))) + (func (export "f64.misc_nan") (result i64) (i64.reinterpret/f64 (f64.const nan:0x0123456789abc))) + (func (export "f64.misc_positive_nan") (result i64) (i64.reinterpret/f64 (f64.const +nan:0x3040506070809))) + (func (export "f64.misc_negative_nan") (result i64) (i64.reinterpret/f64 (f64.const -nan:0x2abcdef012345))) + (func (export "f64.infinity") (result i64) (i64.reinterpret/f64 (f64.const infinity))) + (func (export "f64.positive_infinity") (result i64) (i64.reinterpret/f64 (f64.const +infinity))) + (func (export "f64.negative_infinity") (result i64) (i64.reinterpret/f64 (f64.const -infinity))) ;; f64 numbers - (func $f64.zero (result i64) (i64.reinterpret/f64 (f64.const 0x0.0p0))) - (func $f64.positive_zero (result i64) (i64.reinterpret/f64 (f64.const +0x0.0p0))) - (func $f64.negative_zero (result i64) (i64.reinterpret/f64 (f64.const -0x0.0p0))) - (func $f64.misc (result i64) (i64.reinterpret/f64 (f64.const 0x1.921fb54442d18p+2))) - (func $f64.min_positive (result i64) (i64.reinterpret/f64 (f64.const 0x0.0000000000001p-1022))) - (func $f64.min_normal (result i64) (i64.reinterpret/f64 (f64.const 0x1p-1022))) - (func $f64.max_subnormal (result i64) (i64.reinterpret/f64 (f64.const 0x0.fffffffffffffp-1022))) - (func $f64.max_finite (result i64) (i64.reinterpret/f64 (f64.const 0x1.fffffffffffffp+1023))) - (func $f64.trailing_dot (result i64) (i64.reinterpret/f64 (f64.const 0x1.p100))) + (func (export "f64.zero") (result i64) (i64.reinterpret/f64 (f64.const 0x0.0p0))) + (func (export "f64.positive_zero") (result i64) (i64.reinterpret/f64 (f64.const +0x0.0p0))) + (func (export "f64.negative_zero") (result i64) (i64.reinterpret/f64 (f64.const -0x0.0p0))) + (func (export "f64.misc") (result i64) (i64.reinterpret/f64 (f64.const 0x1.921fb54442d18p+2))) + (func (export "f64.min_positive") (result i64) (i64.reinterpret/f64 (f64.const 0x0.0000000000001p-1022))) + (func (export "f64.min_normal") (result i64) (i64.reinterpret/f64 (f64.const 0x1p-1022))) + (func (export "f64.max_subnormal") (result i64) (i64.reinterpret/f64 (f64.const 0x0.fffffffffffffp-1022))) + (func (export "f64.max_finite") (result i64) (i64.reinterpret/f64 (f64.const 0x1.fffffffffffffp+1023))) + (func (export "f64.trailing_dot") (result i64) (i64.reinterpret/f64 (f64.const 0x1.p100))) ;; f64 numbers in decimal format - (func $f64_dec.zero (result i64) (i64.reinterpret/f64 (f64.const 0.0e0))) - (func $f64_dec.positive_zero (result i64) (i64.reinterpret/f64 (f64.const +0.0e0))) - (func $f64_dec.negative_zero (result i64) (i64.reinterpret/f64 (f64.const -0.0e0))) - (func $f64_dec.misc (result i64) (i64.reinterpret/f64 (f64.const 6.28318530717958623))) - (func $f64_dec.min_positive (result i64) (i64.reinterpret/f64 (f64.const 4.94066e-324))) - (func $f64_dec.min_normal (result i64) (i64.reinterpret/f64 (f64.const 2.2250738585072012e-308))) - (func $f64_dec.max_subnormal (result i64) (i64.reinterpret/f64 (f64.const 2.2250738585072011e-308))) - (func $f64_dec.max_finite (result i64) (i64.reinterpret/f64 (f64.const 1.7976931348623157e+308))) - (func $f64_dec.trailing_dot (result i64) (i64.reinterpret/f64 (f64.const 1.e100))) - - (export "f32.nan" $f32.nan) - (export "f32.positive_nan" $f32.positive_nan) - (export "f32.negative_nan" $f32.negative_nan) - (export "f32.plain_nan" $f32.plain_nan) - (export "f32.informally_known_as_plain_snan" $f32.informally_known_as_plain_snan) - (export "f32.allones_nan" $f32.allones_nan) - (export "f32.misc_nan" $f32.misc_nan) - (export "f32.misc_positive_nan" $f32.misc_positive_nan) - (export "f32.misc_negative_nan" $f32.misc_negative_nan) - (export "f32.infinity" $f32.infinity) - (export "f32.positive_infinity" $f32.positive_infinity) - (export "f32.negative_infinity" $f32.negative_infinity) - (export "f32.zero" $f32.zero) - (export "f32.positive_zero" $f32.positive_zero) - (export "f32.negative_zero" $f32.negative_zero) - (export "f32.misc" $f32.misc) - (export "f32.min_positive" $f32.min_positive) - (export "f32.min_normal" $f32.min_normal) - (export "f32.max_subnormal" $f32.max_subnormal) - (export "f32.max_finite" $f32.max_finite) - (export "f32.trailing_dot" $f32.trailing_dot) - (export "f32_dec.zero" $f32_dec.zero) - (export "f32_dec.positive_zero" $f32_dec.positive_zero) - (export "f32_dec.negative_zero" $f32_dec.negative_zero) - (export "f32_dec.misc" $f32_dec.misc) - (export "f32_dec.min_positive" $f32_dec.min_positive) - (export "f32_dec.min_normal" $f32_dec.min_normal) - (export "f32_dec.max_subnormal" $f32_dec.max_subnormal) - (export "f32_dec.max_finite" $f32_dec.max_finite) - (export "f32_dec.trailing_dot" $f32_dec.trailing_dot) - - (export "f64.nan" $f64.nan) - (export "f64.positive_nan" $f64.positive_nan) - (export "f64.negative_nan" $f64.negative_nan) - (export "f64.plain_nan" $f64.plain_nan) - (export "f64.informally_known_as_plain_snan" $f64.informally_known_as_plain_snan) - (export "f64.allones_nan" $f64.allones_nan) - (export "f64.misc_nan" $f64.misc_nan) - (export "f64.misc_positive_nan" $f64.misc_positive_nan) - (export "f64.misc_negative_nan" $f64.misc_negative_nan) - (export "f64.infinity" $f64.infinity) - (export "f64.positive_infinity" $f64.positive_infinity) - (export "f64.negative_infinity" $f64.negative_infinity) - (export "f64.zero" $f64.zero) - (export "f64.positive_zero" $f64.positive_zero) - (export "f64.negative_zero" $f64.negative_zero) - (export "f64.misc" $f64.misc) - (export "f64.min_positive" $f64.min_positive) - (export "f64.min_normal" $f64.min_normal) - (export "f64.max_subnormal" $f64.max_subnormal) - (export "f64.max_finite" $f64.max_finite) - (export "f64.trailing_dot" $f64.trailing_dot) - (export "f64_dec.zero" $f64_dec.zero) - (export "f64_dec.positive_zero" $f64_dec.positive_zero) - (export "f64_dec.negative_zero" $f64_dec.negative_zero) - (export "f64_dec.misc" $f64_dec.misc) - (export "f64_dec.min_positive" $f64_dec.min_positive) - (export "f64_dec.min_normal" $f64_dec.min_normal) - (export "f64_dec.max_subnormal" $f64_dec.max_subnormal) - (export "f64_dec.max_finite" $f64_dec.max_finite) - (export "f64_dec.trailing_dot" $f64_dec.trailing_dot) + (func (export "f64_dec.zero") (result i64) (i64.reinterpret/f64 (f64.const 0.0e0))) + (func (export "f64_dec.positive_zero") (result i64) (i64.reinterpret/f64 (f64.const +0.0e0))) + (func (export "f64_dec.negative_zero") (result i64) (i64.reinterpret/f64 (f64.const -0.0e0))) + (func (export "f64_dec.misc") (result i64) (i64.reinterpret/f64 (f64.const 6.28318530717958623))) + (func (export "f64_dec.min_positive") (result i64) (i64.reinterpret/f64 (f64.const 4.94066e-324))) + (func (export "f64_dec.min_normal") (result i64) (i64.reinterpret/f64 (f64.const 2.2250738585072012e-308))) + (func (export "f64_dec.max_subnormal") (result i64) (i64.reinterpret/f64 (f64.const 2.2250738585072011e-308))) + (func (export "f64_dec.max_finite") (result i64) (i64.reinterpret/f64 (f64.const 1.7976931348623157e+308))) + (func (export "f64_dec.trailing_dot") (result i64) (i64.reinterpret/f64 (f64.const 1.e100))) ) (assert_return (invoke "f32.nan") (i32.const 0x7fc00000)) @@ -141,7 +79,7 @@ (assert_return (invoke "f32.negative_nan") (i32.const 0xffc00000)) (assert_return (invoke "f32.plain_nan") (i32.const 0x7fc00000)) (assert_return (invoke "f32.informally_known_as_plain_snan") (i32.const 0x7fa00000)) -(assert_return (invoke "f32.allones_nan") (i32.const 0xffffffff)) +(assert_return (invoke "f32.all_ones_nan") (i32.const 0xffffffff)) (assert_return (invoke "f32.misc_nan") (i32.const 0x7f812345)) (assert_return (invoke "f32.misc_positive_nan") (i32.const 0x7fb04050)) (assert_return (invoke "f32.misc_negative_nan") (i32.const 0xffaabcde)) @@ -172,7 +110,7 @@ (assert_return (invoke "f64.negative_nan") (i64.const 0xfff8000000000000)) (assert_return (invoke "f64.plain_nan") (i64.const 0x7ff8000000000000)) (assert_return (invoke "f64.informally_known_as_plain_snan") (i64.const 0x7ff4000000000000)) -(assert_return (invoke "f64.allones_nan") (i64.const 0xffffffffffffffff)) +(assert_return (invoke "f64.all_ones_nan") (i64.const 0xffffffffffffffff)) (assert_return (invoke "f64.misc_nan") (i64.const 0x7ff0123456789abc)) (assert_return (invoke "f64.misc_positive_nan") (i64.const 0x7ff3040506070809)) (assert_return (invoke "f64.misc_negative_nan") (i64.const 0xfff2abcdef012345)) diff --git a/ml-proto/test/float_memory.wast b/ml-proto/test/float_memory.wast index 6a4f014152..3801158f92 100644 --- a/ml-proto/test/float_memory.wast +++ b/ml-proto/test/float_memory.wast @@ -5,20 +5,11 @@ (module (memory (data "\00\00\a0\7f")) - (func $f32.load (result f32) (f32.load (i32.const 0))) - (export "f32.load" $f32.load) - - (func $i32.load (result i32) (i32.load (i32.const 0))) - (export "i32.load" $i32.load) - - (func $f32.store (f32.store (i32.const 0) (f32.const nan:0x200000))) - (export "f32.store" $f32.store) - - (func $i32.store (i32.store (i32.const 0) (i32.const 0x7fa00000))) - (export "i32.store" $i32.store) - - (func $reset (i32.store (i32.const 0) (i32.const 0))) - (export "reset" $reset) + (func (export "f32.load") (result f32) (f32.load (i32.const 0))) + (func (export "i32.load") (result i32) (i32.load (i32.const 0))) + (func (export "f32.store") (f32.store (i32.const 0) (f32.const nan:0x200000))) + (func (export "i32.store") (i32.store (i32.const 0) (i32.const 0x7fa00000))) + (func (export "reset") (i32.store (i32.const 0) (i32.const 0))) ) (assert_return (invoke "i32.load") (i32.const 0x7fa00000)) @@ -39,20 +30,11 @@ (module (memory (data "\00\00\00\00\00\00\f4\7f")) - (func $f64.load (result f64) (f64.load (i32.const 0))) - (export "f64.load" $f64.load) - - (func $i64.load (result i64) (i64.load (i32.const 0))) - (export "i64.load" $i64.load) - - (func $f64.store (f64.store (i32.const 0) (f64.const nan:0x4000000000000))) - (export "f64.store" $f64.store) - - (func $i64.store (i64.store (i32.const 0) (i64.const 0x7ff4000000000000))) - (export "i64.store" $i64.store) - - (func $reset (i64.store (i32.const 0) (i64.const 0))) - (export "reset" $reset) + (func (export "f64.load") (result f64) (f64.load (i32.const 0))) + (func (export "i64.load") (result i64) (i64.load (i32.const 0))) + (func (export "f64.store") (f64.store (i32.const 0) (f64.const nan:0x4000000000000))) + (func (export "i64.store") (i64.store (i32.const 0) (i64.const 0x7ff4000000000000))) + (func (export "reset") (i64.store (i32.const 0) (i64.const 0))) ) (assert_return (invoke "i64.load") (i64.const 0x7ff4000000000000)) @@ -75,20 +57,11 @@ (module (memory (data "\00\00\00\a0\7f")) - (func $f32.load (result f32) (f32.load (i32.const 1))) - (export "f32.load" $f32.load) - - (func $i32.load (result i32) (i32.load (i32.const 1))) - (export "i32.load" $i32.load) - - (func $f32.store (f32.store (i32.const 1) (f32.const nan:0x200000))) - (export "f32.store" $f32.store) - - (func $i32.store (i32.store (i32.const 1) (i32.const 0x7fa00000))) - (export "i32.store" $i32.store) - - (func $reset (i32.store (i32.const 1) (i32.const 0))) - (export "reset" $reset) + (func (export "f32.load") (result f32) (f32.load (i32.const 1))) + (func (export "i32.load") (result i32) (i32.load (i32.const 1))) + (func (export "f32.store") (f32.store (i32.const 1) (f32.const nan:0x200000))) + (func (export "i32.store") (i32.store (i32.const 1) (i32.const 0x7fa00000))) + (func (export "reset") (i32.store (i32.const 1) (i32.const 0))) ) (assert_return (invoke "i32.load") (i32.const 0x7fa00000)) @@ -109,20 +82,11 @@ (module (memory (data "\00\00\00\00\00\00\00\f4\7f")) - (func $f64.load (result f64) (f64.load (i32.const 1))) - (export "f64.load" $f64.load) - - (func $i64.load (result i64) (i64.load (i32.const 1))) - (export "i64.load" $i64.load) - - (func $f64.store (f64.store (i32.const 1) (f64.const nan:0x4000000000000))) - (export "f64.store" $f64.store) - - (func $i64.store (i64.store (i32.const 1) (i64.const 0x7ff4000000000000))) - (export "i64.store" $i64.store) - - (func $reset (i64.store (i32.const 1) (i64.const 0))) - (export "reset" $reset) + (func (export "f64.load") (result f64) (f64.load (i32.const 1))) + (func (export "i64.load") (result i64) (i64.load (i32.const 1))) + (func (export "f64.store") (f64.store (i32.const 1) (f64.const nan:0x4000000000000))) + (func (export "i64.store") (i64.store (i32.const 1) (i64.const 0x7ff4000000000000))) + (func (export "reset") (i64.store (i32.const 1) (i64.const 0))) ) (assert_return (invoke "i64.load") (i64.const 0x7ff4000000000000)) @@ -145,20 +109,11 @@ (module (memory (data "\01\00\d0\7f")) - (func $f32.load (result f32) (f32.load (i32.const 0))) - (export "f32.load" $f32.load) - - (func $i32.load (result i32) (i32.load (i32.const 0))) - (export "i32.load" $i32.load) - - (func $f32.store (f32.store (i32.const 0) (f32.const nan:0x500001))) - (export "f32.store" $f32.store) - - (func $i32.store (i32.store (i32.const 0) (i32.const 0x7fd00001))) - (export "i32.store" $i32.store) - - (func $reset (i32.store (i32.const 0) (i32.const 0))) - (export "reset" $reset) + (func (export "f32.load") (result f32) (f32.load (i32.const 0))) + (func (export "i32.load") (result i32) (i32.load (i32.const 0))) + (func (export "f32.store") (f32.store (i32.const 0) (f32.const nan:0x500001))) + (func (export "i32.store") (i32.store (i32.const 0) (i32.const 0x7fd00001))) + (func (export "reset") (i32.store (i32.const 0) (i32.const 0))) ) (assert_return (invoke "i32.load") (i32.const 0x7fd00001)) @@ -179,20 +134,11 @@ (module (memory (data "\01\00\00\00\00\00\fc\7f")) - (func $f64.load (result f64) (f64.load (i32.const 0))) - (export "f64.load" $f64.load) - - (func $i64.load (result i64) (i64.load (i32.const 0))) - (export "i64.load" $i64.load) - - (func $f64.store (f64.store (i32.const 0) (f64.const nan:0xc000000000001))) - (export "f64.store" $f64.store) - - (func $i64.store (i64.store (i32.const 0) (i64.const 0x7ffc000000000001))) - (export "i64.store" $i64.store) - - (func $reset (i64.store (i32.const 0) (i64.const 0))) - (export "reset" $reset) + (func (export "f64.load") (result f64) (f64.load (i32.const 0))) + (func (export "i64.load") (result i64) (i64.load (i32.const 0))) + (func (export "f64.store") (f64.store (i32.const 0) (f64.const nan:0xc000000000001))) + (func (export "i64.store") (i64.store (i32.const 0) (i64.const 0x7ffc000000000001))) + (func (export "reset") (i64.store (i32.const 0) (i64.const 0))) ) (assert_return (invoke "i64.load") (i64.const 0x7ffc000000000001)) diff --git a/ml-proto/test/float_misc.wast b/ml-proto/test/float_misc.wast index b01fb37f4d..41e29321d5 100644 --- a/ml-proto/test/float_misc.wast +++ b/ml-proto/test/float_misc.wast @@ -15,65 +15,35 @@ ;; interesting cases. (module - (func $f32.add (param $x f32) (param $y f32) (result f32) (f32.add (get_local $x) (get_local $y))) - (func $f32.sub (param $x f32) (param $y f32) (result f32) (f32.sub (get_local $x) (get_local $y))) - (func $f32.mul (param $x f32) (param $y f32) (result f32) (f32.mul (get_local $x) (get_local $y))) - (func $f32.div (param $x f32) (param $y f32) (result f32) (f32.div (get_local $x) (get_local $y))) - (func $f32.sqrt (param $x f32) (result f32) (f32.sqrt (get_local $x))) - (func $f32.abs (param $x f32) (result f32) (f32.abs (get_local $x))) - (func $f32.neg (param $x f32) (result f32) (f32.neg (get_local $x))) - (func $f32.copysign (param $x f32) (param $y f32) (result f32) (f32.copysign (get_local $x) (get_local $y))) - (func $f32.ceil (param $x f32) (result f32) (f32.ceil (get_local $x))) - (func $f32.floor (param $x f32) (result f32) (f32.floor (get_local $x))) - (func $f32.trunc (param $x f32) (result f32) (f32.trunc (get_local $x))) - (func $f32.nearest (param $x f32) (result f32) (f32.nearest (get_local $x))) - (func $f32.min (param $x f32) (param $y f32) (result f32) (f32.min (get_local $x) (get_local $y))) - (func $f32.max (param $x f32) (param $y f32) (result f32) (f32.max (get_local $x) (get_local $y))) - - (func $f64.add (param $x f64) (param $y f64) (result f64) (f64.add (get_local $x) (get_local $y))) - (func $f64.sub (param $x f64) (param $y f64) (result f64) (f64.sub (get_local $x) (get_local $y))) - (func $f64.mul (param $x f64) (param $y f64) (result f64) (f64.mul (get_local $x) (get_local $y))) - (func $f64.div (param $x f64) (param $y f64) (result f64) (f64.div (get_local $x) (get_local $y))) - (func $f64.sqrt (param $x f64) (result f64) (f64.sqrt (get_local $x))) - (func $f64.abs (param $x f64) (result f64) (f64.abs (get_local $x))) - (func $f64.neg (param $x f64) (result f64) (f64.neg (get_local $x))) - (func $f64.copysign (param $x f64) (param $y f64) (result f64) (f64.copysign (get_local $x) (get_local $y))) - (func $f64.ceil (param $x f64) (result f64) (f64.ceil (get_local $x))) - (func $f64.floor (param $x f64) (result f64) (f64.floor (get_local $x))) - (func $f64.trunc (param $x f64) (result f64) (f64.trunc (get_local $x))) - (func $f64.nearest (param $x f64) (result f64) (f64.nearest (get_local $x))) - (func $f64.min (param $x f64) (param $y f64) (result f64) (f64.min (get_local $x) (get_local $y))) - (func $f64.max (param $x f64) (param $y f64) (result f64) (f64.max (get_local $x) (get_local $y))) - - (export "f32.add" $f32.add) - (export "f32.sub" $f32.sub) - (export "f32.mul" $f32.mul) - (export "f32.div" $f32.div) - (export "f32.sqrt" $f32.sqrt) - (export "f32.abs" $f32.abs) - (export "f32.neg" $f32.neg) - (export "f32.copysign" $f32.copysign) - (export "f32.ceil" $f32.ceil) - (export "f32.floor" $f32.floor) - (export "f32.trunc" $f32.trunc) - (export "f32.nearest" $f32.nearest) - (export "f32.min" $f32.min) - (export "f32.max" $f32.max) - - (export "f64.add" $f64.add) - (export "f64.sub" $f64.sub) - (export "f64.mul" $f64.mul) - (export "f64.div" $f64.div) - (export "f64.sqrt" $f64.sqrt) - (export "f64.abs" $f64.abs) - (export "f64.neg" $f64.neg) - (export "f64.copysign" $f64.copysign) - (export "f64.ceil" $f64.ceil) - (export "f64.floor" $f64.floor) - (export "f64.trunc" $f64.trunc) - (export "f64.nearest" $f64.nearest) - (export "f64.min" $f64.min) - (export "f64.max" $f64.max) + (func (export "f32.add") (param $x f32) (param $y f32) (result f32) (f32.add (get_local $x) (get_local $y))) + (func (export "f32.sub") (param $x f32) (param $y f32) (result f32) (f32.sub (get_local $x) (get_local $y))) + (func (export "f32.mul") (param $x f32) (param $y f32) (result f32) (f32.mul (get_local $x) (get_local $y))) + (func (export "f32.div") (param $x f32) (param $y f32) (result f32) (f32.div (get_local $x) (get_local $y))) + (func (export "f32.sqrt") (param $x f32) (result f32) (f32.sqrt (get_local $x))) + (func (export "f32.abs") (param $x f32) (result f32) (f32.abs (get_local $x))) + (func (export "f32.neg") (param $x f32) (result f32) (f32.neg (get_local $x))) + (func (export "f32.copysign") (param $x f32) (param $y f32) (result f32) (f32.copysign (get_local $x) (get_local $y))) + (func (export "f32.ceil") (param $x f32) (result f32) (f32.ceil (get_local $x))) + (func (export "f32.floor") (param $x f32) (result f32) (f32.floor (get_local $x))) + (func (export "f32.trunc") (param $x f32) (result f32) (f32.trunc (get_local $x))) + (func (export "f32.nearest") (param $x f32) (result f32) (f32.nearest (get_local $x))) + (func (export "f32.min") (param $x f32) (param $y f32) (result f32) (f32.min (get_local $x) (get_local $y))) + (func (export "f32.max") (param $x f32) (param $y f32) (result f32) (f32.max (get_local $x) (get_local $y))) + + (func (export "f64.add") (param $x f64) (param $y f64) (result f64) (f64.add (get_local $x) (get_local $y))) + (func (export "f64.sub") (param $x f64) (param $y f64) (result f64) (f64.sub (get_local $x) (get_local $y))) + (func (export "f64.mul") (param $x f64) (param $y f64) (result f64) (f64.mul (get_local $x) (get_local $y))) + (func (export "f64.div") (param $x f64) (param $y f64) (result f64) (f64.div (get_local $x) (get_local $y))) + (func (export "f64.sqrt") (param $x f64) (result f64) (f64.sqrt (get_local $x))) + (func (export "f64.abs") (param $x f64) (result f64) (f64.abs (get_local $x))) + (func (export "f64.neg") (param $x f64) (result f64) (f64.neg (get_local $x))) + (func (export "f64.copysign") (param $x f64) (param $y f64) (result f64) (f64.copysign (get_local $x) (get_local $y))) + (func (export "f64.ceil") (param $x f64) (result f64) (f64.ceil (get_local $x))) + (func (export "f64.floor") (param $x f64) (result f64) (f64.floor (get_local $x))) + (func (export "f64.trunc") (param $x f64) (result f64) (f64.trunc (get_local $x))) + (func (export "f64.nearest") (param $x f64) (result f64) (f64.nearest (get_local $x))) + (func (export "f64.min") (param $x f64) (param $y f64) (result f64) (f64.min (get_local $x) (get_local $y))) + (func (export "f64.max") (param $x f64) (param $y f64) (result f64) (f64.max (get_local $x) (get_local $y))) ) ;; Miscellaneous values. diff --git a/ml-proto/test/forward.wast b/ml-proto/test/forward.wast index d5ba73b72b..644eb38047 100644 --- a/ml-proto/test/forward.wast +++ b/ml-proto/test/forward.wast @@ -1,15 +1,12 @@ (module - (export "even" $even) - (export "odd" $odd) - - (func $even (param $n i32) (result i32) + (func $even (export "even") (param $n i32) (result i32) (if (i32.eq (get_local $n) (i32.const 0)) (i32.const 1) (call $odd (i32.sub (get_local $n) (i32.const 1))) ) ) - (func $odd (param $n i32) (result i32) + (func $odd (export "odd") (param $n i32) (result i32) (if (i32.eq (get_local $n) (i32.const 0)) (i32.const 0) (call $even (i32.sub (get_local $n) (i32.const 1))) diff --git a/ml-proto/test/func.wast b/ml-proto/test/func.wast index 5bbb40077e..a9fadbac8a 100644 --- a/ml-proto/test/func.wast +++ b/ml-proto/test/func.wast @@ -8,9 +8,9 @@ ;; Syntax (func) - (func "f") + (func (export "f")) (func $f) - (func "g" $h) + (func $h (export "g")) (func (local)) (func (local) (local)) @@ -47,15 +47,15 @@ ;; Typing of locals - (func "local-first-i32" (result i32) (local i32 i32) (get_local 0)) - (func "local-first-i64" (result i64) (local i64 i64) (get_local 0)) - (func "local-first-f32" (result f32) (local f32 f32) (get_local 0)) - (func "local-first-f64" (result f64) (local f64 f64) (get_local 0)) - (func "local-second-i32" (result i32) (local i32 i32) (get_local 1)) - (func "local-second-i64" (result i64) (local i64 i64) (get_local 1)) - (func "local-second-f32" (result f32) (local f32 f32) (get_local 1)) - (func "local-second-f64" (result f64) (local f64 f64) (get_local 1)) - (func "local-mixed" (result f64) + (func (export "local-first-i32") (result i32) (local i32 i32) (get_local 0)) + (func (export "local-first-i64") (result i64) (local i64 i64) (get_local 0)) + (func (export "local-first-f32") (result f32) (local f32 f32) (get_local 0)) + (func (export "local-first-f64") (result f64) (local f64 f64) (get_local 0)) + (func (export "local-second-i32") (result i32) (local i32 i32) (get_local 1)) + (func (export "local-second-i64") (result i64) (local i64 i64) (get_local 1)) + (func (export "local-second-f32") (result f32) (local f32 f32) (get_local 1)) + (func (export "local-second-f64") (result f64) (local f64 f64) (get_local 1)) + (func (export "local-mixed") (result f64) (local f32) (local $x i32) (local i64 i32) (local) (local f64 i32) (drop (f32.neg (get_local 0))) (drop (i32.eqz (get_local 1))) @@ -68,15 +68,15 @@ ;; Typing of parameters - (func "param-first-i32" (param i32 i32) (result i32) (get_local 0)) - (func "param-first-i64" (param i64 i64) (result i64) (get_local 0)) - (func "param-first-f32" (param f32 f32) (result f32) (get_local 0)) - (func "param-first-f64" (param f64 f64) (result f64) (get_local 0)) - (func "param-second-i32" (param i32 i32) (result i32) (get_local 1)) - (func "param-second-i64" (param i64 i64) (result i64) (get_local 1)) - (func "param-second-f32" (param f32 f32) (result f32) (get_local 1)) - (func "param-second-f64" (param f64 f64) (result f64) (get_local 1)) - (func "param-mixed" (param f32 i32) (param) (param $x i64) (param i32 f64 i32) + (func (export "param-first-i32") (param i32 i32) (result i32) (get_local 0)) + (func (export "param-first-i64") (param i64 i64) (result i64) (get_local 0)) + (func (export "param-first-f32") (param f32 f32) (result f32) (get_local 0)) + (func (export "param-first-f64") (param f64 f64) (result f64) (get_local 0)) + (func (export "param-second-i32") (param i32 i32) (result i32) (get_local 1)) + (func (export "param-second-i64") (param i64 i64) (result i64) (get_local 1)) + (func (export "param-second-f32") (param f32 f32) (result f32) (get_local 1)) + (func (export "param-second-f64") (param f64 f64) (result f64) (get_local 1)) + (func (export "param-mixed") (param f32 i32) (param) (param $x i64) (param i32 f64 i32) (result f64) (drop (f32.neg (get_local 0))) (drop (i32.eqz (get_local 1))) @@ -89,50 +89,50 @@ ;; Typing of result - (func "empty") - (func "value-void" (call $dummy)) - (func "value-i32" (result i32) (i32.const 77)) - (func "value-i64" (result i64) (i64.const 7777)) - (func "value-f32" (result f32) (f32.const 77.7)) - (func "value-f64" (result f64) (f64.const 77.77)) - (func "value-block-void" (block (call $dummy) (call $dummy))) - (func "value-block-i32" (result i32) (block (call $dummy) (i32.const 77))) - - (func "return-empty" (return)) - (func "return-i32" (result i32) (return (i32.const 78))) - (func "return-i64" (result i64) (return (i64.const 7878))) - (func "return-f32" (result f32) (return (f32.const 78.7))) - (func "return-f64" (result f64) (return (f64.const 78.78))) - (func "return-block-i32" (result i32) + (func (export "empty")) + (func (export "value-void") (call $dummy)) + (func (export "value-i32") (result i32) (i32.const 77)) + (func (export "value-i64") (result i64) (i64.const 7777)) + (func (export "value-f32") (result f32) (f32.const 77.7)) + (func (export "value-f64") (result f64) (f64.const 77.77)) + (func (export "value-block-void") (block (call $dummy) (call $dummy))) + (func (export "value-block-i32") (result i32) (block (call $dummy) (i32.const 77))) + + (func (export "return-empty") (return)) + (func (export "return-i32") (result i32) (return (i32.const 78))) + (func (export "return-i64") (result i64) (return (i64.const 7878))) + (func (export "return-f32") (result f32) (return (f32.const 78.7))) + (func (export "return-f64") (result f64) (return (f64.const 78.78))) + (func (export "return-block-i32") (result i32) (return (block (call $dummy) (i32.const 77))) ) - (func "break-empty" (br 0)) - (func "break-i32" (result i32) (br 0 (i32.const 79))) - (func "break-i64" (result i64) (br 0 (i64.const 7979))) - (func "break-f32" (result f32) (br 0 (f32.const 79.9))) - (func "break-f64" (result f64) (br 0 (f64.const 79.79))) - (func "break-block-i32" (result i32) + (func (export "break-empty") (br 0)) + (func (export "break-i32") (result i32) (br 0 (i32.const 79))) + (func (export "break-i64") (result i64) (br 0 (i64.const 7979))) + (func (export "break-f32") (result f32) (br 0 (f32.const 79.9))) + (func (export "break-f64") (result f64) (br 0 (f64.const 79.79))) + (func (export "break-block-i32") (result i32) (br 0 (block (call $dummy) (i32.const 77))) ) - (func "break-br_if-empty" (param i32) + (func (export "break-br_if-empty") (param i32) (br_if 0 (get_local 0)) ) - (func "break-br_if-num" (param i32) (result i32) + (func (export "break-br_if-num") (param i32) (result i32) (br_if 0 (i32.const 50) (get_local 0)) (i32.const 51) ) - (func "break-br_table-empty" (param i32) + (func (export "break-br_table-empty") (param i32) (br_table 0 0 0 (get_local 0)) ) - (func "break-br_table-num" (param i32) (result i32) + (func (export "break-br_table-num") (param i32) (result i32) (br_table 0 0 (i32.const 50) (get_local 0)) (i32.const 51) ) - (func "break-br_table-nested-empty" (param i32) + (func (export "break-br_table-nested-empty") (param i32) (block (br_table 0 1 0 (get_local 0))) ) - (func "break-br_table-nested-num" (param i32) (result i32) + (func (export "break-br_table-nested-num") (param i32) (result i32) (i32.add (block (br_table 0 1 0 (i32.const 50) (get_local 0)) (i32.const 51)) (i32.const 2) @@ -141,10 +141,10 @@ ;; Default initialization of locals - (func "init-local-i32" (result i32) (local i32) (get_local 0)) - (func "init-local-i64" (result i64) (local i64) (get_local 0)) - (func "init-local-f32" (result f32) (local f32) (get_local 0)) - (func "init-local-f64" (result f64) (local f64) (get_local 0)) + (func (export "init-local-i32") (result i32) (local i32) (get_local 0)) + (func (export "init-local-i64") (result i64) (local i64) (get_local 0)) + (func (export "init-local-f32") (result f32) (local f32) (get_local 0)) + (func (export "init-local-f64") (result f64) (local f64) (get_local 0)) ;; Desugaring of implicit type signature @@ -162,12 +162,12 @@ ) ) - (func "signature-explicit-reused" + (func (export "signature-explicit-reused") (call_indirect $sig (i32.const 1)) (call_indirect $sig (i32.const 4)) ) - (func "signature-implicit-reused" + (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 @@ -187,11 +187,11 @@ ) ) - (func "signature-explicit-duplicate" + (func (export "signature-explicit-duplicate") (call_indirect $empty-sig-duplicate (i32.const 1)) ) - (func "signature-implicit-duplicate" + (func (export "signature-implicit-duplicate") (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) diff --git a/ml-proto/test/func_ptrs.wast b/ml-proto/test/func_ptrs.wast index 841c74ecbf..f7edd9f448 100644 --- a/ml-proto/test/func_ptrs.wast +++ b/ml-proto/test/func_ptrs.wast @@ -7,28 +7,29 @@ (type $T (func (param i32) (result i32))) ;; 5: i32 -> i32 (type $U (func (param i32))) ;; 6: i32 -> void + (func $print (import "spectest" "print") (type 6)) + (func (type 0)) (func (type $S)) - (func "one" (type 4) (i32.const 13)) - (func "two" (type $T) (i32.add (get_local 0) (i32.const 1))) + (func (export "one") (type 4) (i32.const 13)) + (func (export "two") (type $T) (i32.add (get_local 0) (i32.const 1))) ;; Both signature and parameters are allowed (and required to match) ;; since this allows the naming of parameters. - (func "three" (type $T) (param $a i32) (result i32) + (func (export "three") (type $T) (param $a i32) (result i32) (i32.sub (get_local 0) (i32.const 2)) ) - (import $print "spectest" "print" (type 6)) - (func "four" (type $U) (call_import $print (get_local 0))) + (func (export "four") (type $U) (call $print (get_local 0))) ) (assert_return (invoke "one") (i32.const 13)) (assert_return (invoke "two" (i32.const 13)) (i32.const 14)) (assert_return (invoke "three" (i32.const 13)) (i32.const 11)) (invoke "four" (i32.const 83)) -(assert_invalid (module (elem (i32.const 0))) "no table defined") -(assert_invalid (module (elem (i32.const 0) 0) (func)) "no table defined") +(assert_invalid (module (elem (i32.const 0))) "unknown table") +(assert_invalid (module (elem (i32.const 0) 0) (func)) "unknown table") (assert_invalid (module (table 1 anyfunc) (elem (i64.const 0))) @@ -43,8 +44,8 @@ "constant expression required" ) -(assert_invalid (module (func (type 42))) "unknown function type 42") -(assert_invalid (module (import "spectest" "print" (type 43))) "unknown function type 43") +(assert_invalid (module (func (type 42))) "unknown type") +(assert_invalid (module (import "spectest" "print" (func (type 43)))) "unknown type") (module (type $T (func (param) (result i32))) @@ -57,11 +58,11 @@ (func $u1 (type $U) (i32.const 4)) (func $u2 (type $U) (i32.const 5)) - (func "callt" (param $i i32) (result i32) + (func (export "callt") (param $i i32) (result i32) (call_indirect $T (get_local $i)) ) - (func "callu" (param $i i32) (result i32) + (func (export "callu") (param $i i32) (result i32) (call_indirect $U (get_local $i)) ) ) @@ -92,12 +93,10 @@ (type $T (func (result i32))) (table anyfunc (elem 0 1)) - (import $print_i32 "spectest" "print" (param i32)) - (func $t1 (type $T) (i32.const 1)) (func $t2 (type $T) (i32.const 2)) - (func "callt" (param $i i32) (result i32) + (func (export "callt") (param $i i32) (result i32) (call_indirect $T (get_local $i)) ) ) diff --git a/ml-proto/test/get_local.wast b/ml-proto/test/get_local.wast index a5d09833df..e1f9625b96 100644 --- a/ml-proto/test/get_local.wast +++ b/ml-proto/test/get_local.wast @@ -3,17 +3,17 @@ (module ;; Typing - (func "type-local-i32" (result i32) (local i32) (get_local 0)) - (func "type-local-i64" (result i64) (local i64) (get_local 0)) - (func "type-local-f32" (result f32) (local f32) (get_local 0)) - (func "type-local-f64" (result f64) (local f64) (get_local 0)) + (func (export "type-local-i32") (result i32) (local i32) (get_local 0)) + (func (export "type-local-i64") (result i64) (local i64) (get_local 0)) + (func (export "type-local-f32") (result f32) (local f32) (get_local 0)) + (func (export "type-local-f64") (result f64) (local f64) (get_local 0)) - (func "type-param-i32" (param i32) (result i32) (get_local 0)) - (func "type-param-i64" (param i64) (result i64) (get_local 0)) - (func "type-param-f32" (param f32) (result f32) (get_local 0)) - (func "type-param-f64" (param f64) (result f64) (get_local 0)) + (func (export "type-param-i32") (param i32) (result i32) (get_local 0)) + (func (export "type-param-i64") (param i64) (result i64) (get_local 0)) + (func (export "type-param-f32") (param f32) (result f32) (get_local 0)) + (func (export "type-param-f64") (param f64) (result f64) (get_local 0)) - (func "type-mixed" (param i64 f32 f64 i32 i32) + (func (export "type-mixed") (param i64 f32 f64 i32 i32) (local f32 i64 i64 f64) (drop (i64.eqz (get_local 0))) (drop (f32.neg (get_local 1))) @@ -28,7 +28,7 @@ ;; Reading - (func "read" (param i64 f32 f64 i32 i32) (result f64) + (func (export "read") (param i64 f32 f64 i32 i32) (result f64) (local f32 i64 i64 f64) (set_local 5 (f32.const 5.5)) (set_local 6 (i64.const 6)) diff --git a/ml-proto/test/globals.wast b/ml-proto/test/globals.wast index 1459233b37..58cc51b6b1 100644 --- a/ml-proto/test/globals.wast +++ b/ml-proto/test/globals.wast @@ -1,36 +1,75 @@ -;; TODO: more tests +;; Test globals (module - (global $x i32 (i32.const -2)) - (global f32 (f32.const -3)) - (global f64 (f64.const -4)) - (global $y i64 (i64.const -5)) + (global $a i32 (i32.const -2)) + (global (;1;) f32 (f32.const -3)) + (global (;2;) f64 (f64.const -4)) + (global $b i64 (i64.const -5)) - (func "get-x" (result i32) (get_global $x)) - (func "get-y" (result i64) (get_global $y)) - (func "set-x" (param i32) (set_global $x (get_local 0))) - (func "set-y" (param i64) (set_global $y (get_local 0))) + (global $x (mut i32) (i32.const -12)) + (global (;5;) (mut f32) (f32.const -13)) + (global (;6;) (mut f64) (f64.const -14)) + (global $y (mut i64) (i64.const -15)) - (func "get-1" (result f32) (get_global 1)) - (func "get-2" (result f64) (get_global 2)) - (func "set-1" (param f32) (set_global 1 (get_local 0))) - (func "set-2" (param f64) (set_global 2 (get_local 0))) + (func (export "get-a") (result i32) (get_global $a)) + (func (export "get-b") (result i64) (get_global $b)) + (func (export "get-x") (result i32) (get_global $x)) + (func (export "get-y") (result i64) (get_global $y)) + (func (export "set-x") (param i32) (set_global $x (get_local 0))) + (func (export "set-y") (param i64) (set_global $y (get_local 0))) + + (func (export "get-1") (result f32) (get_global 1)) + (func (export "get-2") (result f64) (get_global 2)) + (func (export "get-5") (result f32) (get_global 5)) + (func (export "get-6") (result f64) (get_global 6)) + (func (export "set-5") (param f32) (set_global 5 (get_local 0))) + (func (export "set-6") (param f64) (set_global 6 (get_local 0))) ) -(assert_return (invoke "get-x") (i32.const -2)) -(assert_return (invoke "get-y") (i64.const -5)) +(assert_return (invoke "get-a") (i32.const -2)) +(assert_return (invoke "get-b") (i64.const -5)) +(assert_return (invoke "get-x") (i32.const -12)) +(assert_return (invoke "get-y") (i64.const -15)) + (assert_return (invoke "get-1") (f32.const -3)) (assert_return (invoke "get-2") (f64.const -4)) +(assert_return (invoke "get-5") (f32.const -13)) +(assert_return (invoke "get-6") (f64.const -14)) (assert_return (invoke "set-x" (i32.const 6))) (assert_return (invoke "set-y" (i64.const 7))) -(assert_return (invoke "set-1" (f32.const 8))) -(assert_return (invoke "set-2" (f64.const 9))) +(assert_return (invoke "set-5" (f32.const 8))) +(assert_return (invoke "set-6" (f64.const 9))) (assert_return (invoke "get-x") (i32.const 6)) (assert_return (invoke "get-y") (i64.const 7)) -(assert_return (invoke "get-1") (f32.const 8)) -(assert_return (invoke "get-2") (f64.const 9)) +(assert_return (invoke "get-5") (f32.const 8)) +(assert_return (invoke "get-6") (f64.const 9)) + +(assert_invalid + (module (global f32 (f32.const 0)) (func (set_global 0 (i32.const 1)))) + "global is immutable" +) + +(assert_invalid + (module (import "m" "a" (global (mut i32)))) + "mutable globals cannot be imported" +) + +(assert_invalid + (module (global (import "m" "a") (mut i32))) + "mutable globals cannot be imported" +) + +(assert_invalid + (module (global (mut f32) (f32.const 0)) (export "a" (global 0))) + "mutable globals cannot be exported" +) + +(assert_invalid + (module (global (export "a") (mut f32) (f32.const 0))) + "mutable globals cannot be exported" +) (assert_invalid (module (global f32 (f32.neg (f32.const 0)))) diff --git a/ml-proto/test/i32.wast b/ml-proto/test/i32.wast index f77dff24de..ba28d7c090 100644 --- a/ml-proto/test/i32.wast +++ b/ml-proto/test/i32.wast @@ -1,65 +1,35 @@ ;; i32 operations (module - (func $add (param $x i32) (param $y i32) (result i32) (i32.add (get_local $x) (get_local $y))) - (func $sub (param $x i32) (param $y i32) (result i32) (i32.sub (get_local $x) (get_local $y))) - (func $mul (param $x i32) (param $y i32) (result i32) (i32.mul (get_local $x) (get_local $y))) - (func $div_s (param $x i32) (param $y i32) (result i32) (i32.div_s (get_local $x) (get_local $y))) - (func $div_u (param $x i32) (param $y i32) (result i32) (i32.div_u (get_local $x) (get_local $y))) - (func $rem_s (param $x i32) (param $y i32) (result i32) (i32.rem_s (get_local $x) (get_local $y))) - (func $rem_u (param $x i32) (param $y i32) (result i32) (i32.rem_u (get_local $x) (get_local $y))) - (func $and (param $x i32) (param $y i32) (result i32) (i32.and (get_local $x) (get_local $y))) - (func $or (param $x i32) (param $y i32) (result i32) (i32.or (get_local $x) (get_local $y))) - (func $xor (param $x i32) (param $y i32) (result i32) (i32.xor (get_local $x) (get_local $y))) - (func $shl (param $x i32) (param $y i32) (result i32) (i32.shl (get_local $x) (get_local $y))) - (func $shr_s (param $x i32) (param $y i32) (result i32) (i32.shr_s (get_local $x) (get_local $y))) - (func $shr_u (param $x i32) (param $y i32) (result i32) (i32.shr_u (get_local $x) (get_local $y))) - (func $rotl (param $x i32) (param $y i32) (result i32) (i32.rotl (get_local $x) (get_local $y))) - (func $rotr (param $x i32) (param $y i32) (result i32) (i32.rotr (get_local $x) (get_local $y))) - (func $clz (param $x i32) (result i32) (i32.clz (get_local $x))) - (func $ctz (param $x i32) (result i32) (i32.ctz (get_local $x))) - (func $popcnt (param $x i32) (result i32) (i32.popcnt (get_local $x))) - (func $eqz (param $x i32) (result i32) (i32.eqz (get_local $x))) - (func $eq (param $x i32) (param $y i32) (result i32) (i32.eq (get_local $x) (get_local $y))) - (func $ne (param $x i32) (param $y i32) (result i32) (i32.ne (get_local $x) (get_local $y))) - (func $lt_s (param $x i32) (param $y i32) (result i32) (i32.lt_s (get_local $x) (get_local $y))) - (func $lt_u (param $x i32) (param $y i32) (result i32) (i32.lt_u (get_local $x) (get_local $y))) - (func $le_s (param $x i32) (param $y i32) (result i32) (i32.le_s (get_local $x) (get_local $y))) - (func $le_u (param $x i32) (param $y i32) (result i32) (i32.le_u (get_local $x) (get_local $y))) - (func $gt_s (param $x i32) (param $y i32) (result i32) (i32.gt_s (get_local $x) (get_local $y))) - (func $gt_u (param $x i32) (param $y i32) (result i32) (i32.gt_u (get_local $x) (get_local $y))) - (func $ge_s (param $x i32) (param $y i32) (result i32) (i32.ge_s (get_local $x) (get_local $y))) - (func $ge_u (param $x i32) (param $y i32) (result i32) (i32.ge_u (get_local $x) (get_local $y))) - - (export "add" $add) - (export "sub" $sub) - (export "mul" $mul) - (export "div_s" $div_s) - (export "div_u" $div_u) - (export "rem_s" $rem_s) - (export "rem_u" $rem_u) - (export "and" $and) - (export "or" $or) - (export "xor" $xor) - (export "shl" $shl) - (export "shr_s" $shr_s) - (export "shr_u" $shr_u) - (export "rotl" $rotl) - (export "rotr" $rotr) - (export "clz" $clz) - (export "ctz" $ctz) - (export "popcnt" $popcnt) - (export "eqz" $eqz) - (export "eq" $eq) - (export "ne" $ne) - (export "lt_s" $lt_s) - (export "lt_u" $lt_u) - (export "le_s" $le_s) - (export "le_u" $le_u) - (export "gt_s" $gt_s) - (export "gt_u" $gt_u) - (export "ge_s" $ge_s) - (export "ge_u" $ge_u) + (func (export "add") (param $x i32) (param $y i32) (result i32) (i32.add (get_local $x) (get_local $y))) + (func (export "sub") (param $x i32) (param $y i32) (result i32) (i32.sub (get_local $x) (get_local $y))) + (func (export "mul") (param $x i32) (param $y i32) (result i32) (i32.mul (get_local $x) (get_local $y))) + (func (export "div_s") (param $x i32) (param $y i32) (result i32) (i32.div_s (get_local $x) (get_local $y))) + (func (export "div_u") (param $x i32) (param $y i32) (result i32) (i32.div_u (get_local $x) (get_local $y))) + (func (export "rem_s") (param $x i32) (param $y i32) (result i32) (i32.rem_s (get_local $x) (get_local $y))) + (func (export "rem_u") (param $x i32) (param $y i32) (result i32) (i32.rem_u (get_local $x) (get_local $y))) + (func (export "and") (param $x i32) (param $y i32) (result i32) (i32.and (get_local $x) (get_local $y))) + (func (export "or") (param $x i32) (param $y i32) (result i32) (i32.or (get_local $x) (get_local $y))) + (func (export "xor") (param $x i32) (param $y i32) (result i32) (i32.xor (get_local $x) (get_local $y))) + (func (export "shl") (param $x i32) (param $y i32) (result i32) (i32.shl (get_local $x) (get_local $y))) + (func (export "shr_s") (param $x i32) (param $y i32) (result i32) (i32.shr_s (get_local $x) (get_local $y))) + (func (export "shr_u") (param $x i32) (param $y i32) (result i32) (i32.shr_u (get_local $x) (get_local $y))) + (func (export "rotl") (param $x i32) (param $y i32) (result i32) (i32.rotl (get_local $x) (get_local $y))) + (func (export "rotr") (param $x i32) (param $y i32) (result i32) (i32.rotr (get_local $x) (get_local $y))) + (func (export "clz") (param $x i32) (result i32) (i32.clz (get_local $x))) + (func (export "ctz") (param $x i32) (result i32) (i32.ctz (get_local $x))) + (func (export "popcnt") (param $x i32) (result i32) (i32.popcnt (get_local $x))) + (func (export "eqz") (param $x i32) (result i32) (i32.eqz (get_local $x))) + (func (export "eq") (param $x i32) (param $y i32) (result i32) (i32.eq (get_local $x) (get_local $y))) + (func (export "ne") (param $x i32) (param $y i32) (result i32) (i32.ne (get_local $x) (get_local $y))) + (func (export "lt_s") (param $x i32) (param $y i32) (result i32) (i32.lt_s (get_local $x) (get_local $y))) + (func (export "lt_u") (param $x i32) (param $y i32) (result i32) (i32.lt_u (get_local $x) (get_local $y))) + (func (export "le_s") (param $x i32) (param $y i32) (result i32) (i32.le_s (get_local $x) (get_local $y))) + (func (export "le_u") (param $x i32) (param $y i32) (result i32) (i32.le_u (get_local $x) (get_local $y))) + (func (export "gt_s") (param $x i32) (param $y i32) (result i32) (i32.gt_s (get_local $x) (get_local $y))) + (func (export "gt_u") (param $x i32) (param $y i32) (result i32) (i32.gt_u (get_local $x) (get_local $y))) + (func (export "ge_s") (param $x i32) (param $y i32) (result i32) (i32.ge_s (get_local $x) (get_local $y))) + (func (export "ge_u") (param $x i32) (param $y i32) (result i32) (i32.ge_u (get_local $x) (get_local $y))) ) (assert_return (invoke "add" (i32.const 1) (i32.const 1)) (i32.const 2)) diff --git a/ml-proto/test/i64.wast b/ml-proto/test/i64.wast index f8b9621839..54b28c4609 100644 --- a/ml-proto/test/i64.wast +++ b/ml-proto/test/i64.wast @@ -1,65 +1,35 @@ ;; i64 operations (module - (func $add (param $x i64) (param $y i64) (result i64) (i64.add (get_local $x) (get_local $y))) - (func $sub (param $x i64) (param $y i64) (result i64) (i64.sub (get_local $x) (get_local $y))) - (func $mul (param $x i64) (param $y i64) (result i64) (i64.mul (get_local $x) (get_local $y))) - (func $div_s (param $x i64) (param $y i64) (result i64) (i64.div_s (get_local $x) (get_local $y))) - (func $div_u (param $x i64) (param $y i64) (result i64) (i64.div_u (get_local $x) (get_local $y))) - (func $rem_s (param $x i64) (param $y i64) (result i64) (i64.rem_s (get_local $x) (get_local $y))) - (func $rem_u (param $x i64) (param $y i64) (result i64) (i64.rem_u (get_local $x) (get_local $y))) - (func $and (param $x i64) (param $y i64) (result i64) (i64.and (get_local $x) (get_local $y))) - (func $or (param $x i64) (param $y i64) (result i64) (i64.or (get_local $x) (get_local $y))) - (func $xor (param $x i64) (param $y i64) (result i64) (i64.xor (get_local $x) (get_local $y))) - (func $shl (param $x i64) (param $y i64) (result i64) (i64.shl (get_local $x) (get_local $y))) - (func $shr_s (param $x i64) (param $y i64) (result i64) (i64.shr_s (get_local $x) (get_local $y))) - (func $shr_u (param $x i64) (param $y i64) (result i64) (i64.shr_u (get_local $x) (get_local $y))) - (func $rotl (param $x i64) (param $y i64) (result i64) (i64.rotl (get_local $x) (get_local $y))) - (func $rotr (param $x i64) (param $y i64) (result i64) (i64.rotr (get_local $x) (get_local $y))) - (func $clz (param $x i64) (result i64) (i64.clz (get_local $x))) - (func $ctz (param $x i64) (result i64) (i64.ctz (get_local $x))) - (func $popcnt (param $x i64) (result i64) (i64.popcnt (get_local $x))) - (func $eqz (param $x i64) (result i32) (i64.eqz (get_local $x))) - (func $eq (param $x i64) (param $y i64) (result i32) (i64.eq (get_local $x) (get_local $y))) - (func $ne (param $x i64) (param $y i64) (result i32) (i64.ne (get_local $x) (get_local $y))) - (func $lt_s (param $x i64) (param $y i64) (result i32) (i64.lt_s (get_local $x) (get_local $y))) - (func $lt_u (param $x i64) (param $y i64) (result i32) (i64.lt_u (get_local $x) (get_local $y))) - (func $le_s (param $x i64) (param $y i64) (result i32) (i64.le_s (get_local $x) (get_local $y))) - (func $le_u (param $x i64) (param $y i64) (result i32) (i64.le_u (get_local $x) (get_local $y))) - (func $gt_s (param $x i64) (param $y i64) (result i32) (i64.gt_s (get_local $x) (get_local $y))) - (func $gt_u (param $x i64) (param $y i64) (result i32) (i64.gt_u (get_local $x) (get_local $y))) - (func $ge_s (param $x i64) (param $y i64) (result i32) (i64.ge_s (get_local $x) (get_local $y))) - (func $ge_u (param $x i64) (param $y i64) (result i32) (i64.ge_u (get_local $x) (get_local $y))) - - (export "add" $add) - (export "sub" $sub) - (export "mul" $mul) - (export "div_s" $div_s) - (export "div_u" $div_u) - (export "rem_s" $rem_s) - (export "rem_u" $rem_u) - (export "and" $and) - (export "or" $or) - (export "xor" $xor) - (export "shl" $shl) - (export "shr_s" $shr_s) - (export "shr_u" $shr_u) - (export "rotl" $rotl) - (export "rotr" $rotr) - (export "clz" $clz) - (export "ctz" $ctz) - (export "popcnt" $popcnt) - (export "eqz" $eqz) - (export "eq" $eq) - (export "ne" $ne) - (export "lt_s" $lt_s) - (export "lt_u" $lt_u) - (export "le_s" $le_s) - (export "le_u" $le_u) - (export "gt_s" $gt_s) - (export "gt_u" $gt_u) - (export "ge_s" $ge_s) - (export "ge_u" $ge_u) + (func (export "add") (param $x i64) (param $y i64) (result i64) (i64.add (get_local $x) (get_local $y))) + (func (export "sub") (param $x i64) (param $y i64) (result i64) (i64.sub (get_local $x) (get_local $y))) + (func (export "mul") (param $x i64) (param $y i64) (result i64) (i64.mul (get_local $x) (get_local $y))) + (func (export "div_s") (param $x i64) (param $y i64) (result i64) (i64.div_s (get_local $x) (get_local $y))) + (func (export "div_u") (param $x i64) (param $y i64) (result i64) (i64.div_u (get_local $x) (get_local $y))) + (func (export "rem_s") (param $x i64) (param $y i64) (result i64) (i64.rem_s (get_local $x) (get_local $y))) + (func (export "rem_u") (param $x i64) (param $y i64) (result i64) (i64.rem_u (get_local $x) (get_local $y))) + (func (export "and") (param $x i64) (param $y i64) (result i64) (i64.and (get_local $x) (get_local $y))) + (func (export "or") (param $x i64) (param $y i64) (result i64) (i64.or (get_local $x) (get_local $y))) + (func (export "xor") (param $x i64) (param $y i64) (result i64) (i64.xor (get_local $x) (get_local $y))) + (func (export "shl") (param $x i64) (param $y i64) (result i64) (i64.shl (get_local $x) (get_local $y))) + (func (export "shr_s") (param $x i64) (param $y i64) (result i64) (i64.shr_s (get_local $x) (get_local $y))) + (func (export "shr_u") (param $x i64) (param $y i64) (result i64) (i64.shr_u (get_local $x) (get_local $y))) + (func (export "rotl") (param $x i64) (param $y i64) (result i64) (i64.rotl (get_local $x) (get_local $y))) + (func (export "rotr") (param $x i64) (param $y i64) (result i64) (i64.rotr (get_local $x) (get_local $y))) + (func (export "clz") (param $x i64) (result i64) (i64.clz (get_local $x))) + (func (export "ctz") (param $x i64) (result i64) (i64.ctz (get_local $x))) + (func (export "popcnt") (param $x i64) (result i64) (i64.popcnt (get_local $x))) + (func (export "eqz") (param $x i64) (result i32) (i64.eqz (get_local $x))) + (func (export "eq") (param $x i64) (param $y i64) (result i32) (i64.eq (get_local $x) (get_local $y))) + (func (export "ne") (param $x i64) (param $y i64) (result i32) (i64.ne (get_local $x) (get_local $y))) + (func (export "lt_s") (param $x i64) (param $y i64) (result i32) (i64.lt_s (get_local $x) (get_local $y))) + (func (export "lt_u") (param $x i64) (param $y i64) (result i32) (i64.lt_u (get_local $x) (get_local $y))) + (func (export "le_s") (param $x i64) (param $y i64) (result i32) (i64.le_s (get_local $x) (get_local $y))) + (func (export "le_u") (param $x i64) (param $y i64) (result i32) (i64.le_u (get_local $x) (get_local $y))) + (func (export "gt_s") (param $x i64) (param $y i64) (result i32) (i64.gt_s (get_local $x) (get_local $y))) + (func (export "gt_u") (param $x i64) (param $y i64) (result i32) (i64.gt_u (get_local $x) (get_local $y))) + (func (export "ge_s") (param $x i64) (param $y i64) (result i32) (i64.ge_s (get_local $x) (get_local $y))) + (func (export "ge_u") (param $x i64) (param $y i64) (result i32) (i64.ge_u (get_local $x) (get_local $y))) ) (assert_return (invoke "add" (i64.const 1) (i64.const 1)) (i64.const 2)) diff --git a/ml-proto/test/import-after-func.fail.wast b/ml-proto/test/import-after-func.fail.wast new file mode 100644 index 0000000000..ece33a72c9 --- /dev/null +++ b/ml-proto/test/import-after-func.fail.wast @@ -0,0 +1 @@ +(module (func) (import "" "" (memory 0))) diff --git a/ml-proto/test/import-after-global.fail.wast b/ml-proto/test/import-after-global.fail.wast new file mode 100644 index 0000000000..09cece1a01 --- /dev/null +++ b/ml-proto/test/import-after-global.fail.wast @@ -0,0 +1 @@ +(module (global i64) (import "" "" (table 0 anyfunc))) diff --git a/ml-proto/test/import-after-memory.fail.wast b/ml-proto/test/import-after-memory.fail.wast new file mode 100644 index 0000000000..fbe582a934 --- /dev/null +++ b/ml-proto/test/import-after-memory.fail.wast @@ -0,0 +1 @@ +(module (memory 0) (import "" "" (global i32))) diff --git a/ml-proto/test/import-after-table.fail.wast b/ml-proto/test/import-after-table.fail.wast new file mode 100644 index 0000000000..bcd747a997 --- /dev/null +++ b/ml-proto/test/import-after-table.fail.wast @@ -0,0 +1 @@ +(module (table 0 anyfunc) (import "" "" (func))) diff --git a/ml-proto/test/imports.wast b/ml-proto/test/imports.wast index daea04831b..4b032b1209 100644 --- a/ml-proto/test/imports.wast +++ b/ml-proto/test/imports.wast @@ -1,26 +1,224 @@ +;; Functions + (module - (import $print_i32 "spectest" "print" (param i32)) - (import $print_i64 "spectest" "print" (param i64)) - (import $print_i32_f32 "spectest" "print" (param i32 f32)) - (import $print_i64_f64 "spectest" "print" (param i64 f64)) - (func $print32 (param $i i32) - (call_import $print_i32_f32 - (i32.add (get_local $i) (i32.const 1)) - (f32.const 42) - ) - (call_import $print_i32 (get_local $i)) + (import "spectest" "print" (func (param i32))) + (func (import "spectest" "print") (param i64)) + + (import "spectest" "print" (func $print_i32 (param i32))) + (import "spectest" "print" (func $print_i64 (param i64))) + (import "spectest" "print" (func $print_i32_f32 (param i32 f32))) + (import "spectest" "print" (func $print_i64_f64 (param i64 f64))) + + (func $print_i32-2 (import "spectest" "print") (param i32)) + (func $print_i64-2 (import "spectest" "print") (param i64)) + + (func (export "print32") (param $i i32) + (call 0 (get_local $i)) + (call $print_i32_f32 + (i32.add (get_local $i) (i32.const 1)) + (f32.const 42) ) - (func $print64 (param $i i64) - (call_import $print_i64_f64 - (i64.add (get_local $i) (i64.const 1)) - (f64.const 53) - ) - (call_import $print_i64 (get_local $i)) + (call $print_i32 (get_local $i)) + (call $print_i32-2 (get_local $i)) + ) + + (func (export "print64") (param $i i64) + (call 1 (get_local $i)) + (call $print_i64_f64 + (i64.add (get_local $i) (i64.const 1)) + (f64.const 53) ) - (export "print32" $print32) - (export "print64" $print64) + (call $print_i64 (get_local $i)) + (call $print_i64-2 (get_local $i)) + ) ) (assert_return (invoke "print32" (i32.const 13))) (assert_return (invoke "print64" (i64.const 24))) +(assert_unlinkable + (module (import "spectest" "unknown" (func))) + "unknown import" +) +(assert_unlinkable + (module (import "spectest" "table" (func))) + "type mismatch" +) + +(assert_unlinkable + (module (import "spectest" "print" (func)) (table anyfunc (elem 0))) + "invalid use of host function" +) + + +;; Globals + +(module + (import "spectest" "global" (global i32)) + (global (import "spectest" "global") i32) + + (import "spectest" "global" (global $x i32)) + (global $y (import "spectest" "global") i32) + + (func (export "get-0") (result i32) (get_global 0)) + (func (export "get-1") (result i32) (get_global 1)) + (func (export "get-x") (result i32) (get_global $x)) + (func (export "get-y") (result i32) (get_global $y)) + + ;; TODO: mutable globals + ;; (func (export "set-0") (param i32) (set_global 0 (get_local 0))) + ;; (func (export "set-1") (param i32) (set_global 1 (get_local 0))) + ;; (func (export "set-x") (param i32) (set_global $x (get_local 0))) + ;; (func (export "set-y") (param i32) (set_global $y (get_local 0))) +) + +(assert_return (invoke "get-0") (i32.const 666)) +(assert_return (invoke "get-1") (i32.const 666)) +(assert_return (invoke "get-x") (i32.const 666)) +(assert_return (invoke "get-y") (i32.const 666)) + +(assert_unlinkable + (module (import "spectest" "unknown" (global i32))) + "unknown import" +) +(assert_unlinkable + (module (import "spectest" "print" (global i32))) + "type mismatch" +) + +(module (import "spectest" "global" (global i64))) +(module (import "spectest" "global" (global f32))) +(module (import "spectest" "global" (global f64))) + + +;; Tables + +(module + (type (func (result i32))) + (import "spectest" "table" (table 10 20 anyfunc)) + (elem 0 (i32.const 1) $f $g) + + (func (export "call") (param i32) (result i32) (call_indirect 0 (get_local 0))) + (func $f (result i32) (i32.const 11)) + (func $g (result i32) (i32.const 22)) +) + +(assert_trap (invoke "call" (i32.const 0)) "uninitialized element") +(assert_return (invoke "call" (i32.const 1)) (i32.const 11)) +(assert_return (invoke "call" (i32.const 2)) (i32.const 22)) +(assert_trap (invoke "call" (i32.const 3)) "uninitialized element") +(assert_trap (invoke "call" (i32.const 100)) "undefined element") + + +(module + (type (func (result i32))) + (table (import "spectest" "table") 10 20 anyfunc) + (elem 0 (i32.const 1) $f $g) + + (func (export "call") (param i32) (result i32) (call_indirect 0 (get_local 0))) + (func $f (result i32) (i32.const 11)) + (func $g (result i32) (i32.const 22)) +) + +(assert_trap (invoke "call" (i32.const 0)) "uninitialized element") +(assert_return (invoke "call" (i32.const 1)) (i32.const 11)) +(assert_return (invoke "call" (i32.const 2)) (i32.const 22)) +(assert_trap (invoke "call" (i32.const 3)) "uninitialized element") +(assert_trap (invoke "call" (i32.const 100)) "undefined element") + + +(assert_invalid + (module (import "" "" (table 10 anyfunc)) (import "" "" (table 10 anyfunc))) + "multiple tables" +) +(assert_invalid + (module (import "" "" (table 10 anyfunc)) (table 10 anyfunc)) + "multiple tables" +) +(assert_invalid + (module (table 10 anyfunc) (table 10 anyfunc)) + "multiple tables" +) + +(assert_unlinkable + (module (import "spectest" "unknown" (table 10 anyfunc))) + "unknown import" +) +(assert_unlinkable + (module (import "spectest" "print" (table 10 anyfunc))) + "type mismatch" +) +(assert_unlinkable + (module (import "spectest" "table" (table 12 anyfunc))) + "actual size smaller than declared" +) +(assert_unlinkable + (module (import "spectest" "table" (table 10 15 anyfunc))) + "maximum size larger than declared" +) + + +;; Memories + +(module + (import "spectest" "memory" (memory 1 2)) + (data 0 (i32.const 10) "\10") + + (func (export "load") (param i32) (result i32) (i32.load (get_local 0))) +) + +(assert_return (invoke "load" (i32.const 0)) (i32.const 0)) +(assert_return (invoke "load" (i32.const 10)) (i32.const 16)) +(assert_return (invoke "load" (i32.const 8)) (i32.const 0x100000)) +(assert_trap (invoke "load" (i32.const 1000000)) "out of bounds memory access") + +(module + (memory (import "spectest" "memory") 1 2) + (data 0 (i32.const 10) "\10") + + (func (export "load") (param i32) (result i32) (i32.load (get_local 0))) +) +(assert_return (invoke "load" (i32.const 0)) (i32.const 0)) +(assert_return (invoke "load" (i32.const 10)) (i32.const 16)) +(assert_return (invoke "load" (i32.const 8)) (i32.const 0x100000)) +(assert_trap (invoke "load" (i32.const 1000000)) "out of bounds memory access") + +(assert_invalid + (module (import "" "" (memory 1)) (import "" "" (memory 1))) + "multiple memories" +) +(assert_invalid + (module (import "" "" (memory 1)) (memory 0)) + "multiple memories" +) +(assert_invalid + (module (memory 0) (memory 0)) + "multiple memories" +) + +(assert_unlinkable + (module (import "spectest" "unknown" (memory 1))) + "unknown import" +) +(assert_unlinkable + (module (import "spectest" "print" (memory 1))) + "type mismatch" +) +(assert_unlinkable + (module (import "spectest" "memory" (memory 2))) + "actual size smaller than declared" +) +(assert_unlinkable + (module (import "spectest" "memory" (memory 1 1))) + "maximum size larger than declared" +) + +(module + (import "spectest" "memory" (memory 0 3)) ;; actual has max size 2 + (func (export "grow") (param i32) (result i32) (grow_memory (get_local 0))) +) +(assert_return (invoke "grow" (i32.const 0)) (i32.const 1)) +(assert_return (invoke "grow" (i32.const 1)) (i32.const 1)) +(assert_return (invoke "grow" (i32.const 0)) (i32.const 2)) +(assert_return (invoke "grow" (i32.const 1)) (i32.const -1)) +(assert_return (invoke "grow" (i32.const 0)) (i32.const 2)) diff --git a/ml-proto/test/int_exprs.wast b/ml-proto/test/int_exprs.wast index ac05baf984..d8272fa7f4 100644 --- a/ml-proto/test/int_exprs.wast +++ b/ml-proto/test/int_exprs.wast @@ -4,19 +4,15 @@ ;; Test that x+1>n is not folded to x (module - (func $i32.no_fold_shl_shr_s (param $x i32) (result i32) + (func (export "i32.no_fold_shl_shr_s") (param $x i32) (result i32) (i32.shr_s (i32.shl (get_local $x) (i32.const 1)) (i32.const 1))) - (export "i32.no_fold_shl_shr_s" $i32.no_fold_shl_shr_s) - (func $i32.no_fold_shl_shr_u (param $x i32) (result i32) + (func (export "i32.no_fold_shl_shr_u") (param $x i32) (result i32) (i32.shr_u (i32.shl (get_local $x) (i32.const 1)) (i32.const 1))) - (export "i32.no_fold_shl_shr_u" $i32.no_fold_shl_shr_u) - (func $i64.no_fold_shl_shr_s (param $x i64) (result i64) + (func (export "i64.no_fold_shl_shr_s") (param $x i64) (result i64) (i64.shr_s (i64.shl (get_local $x) (i64.const 1)) (i64.const 1))) - (export "i64.no_fold_shl_shr_s" $i64.no_fold_shl_shr_s) - (func $i64.no_fold_shl_shr_u (param $x i64) (result i64) + (func (export "i64.no_fold_shl_shr_u") (param $x i64) (result i64) (i64.shr_u (i64.shl (get_local $x) (i64.const 1)) (i64.const 1))) - (export "i64.no_fold_shl_shr_u" $i64.no_fold_shl_shr_u) ) (assert_return (invoke "i32.no_fold_shl_shr_s" (i32.const 0x80000000)) (i32.const 0)) @@ -71,19 +61,15 @@ ;; Test that x>>n<