From afc295bd7c89ecc72474adc595743d3c7e5a6784 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 9 Sep 2015 22:34:44 -0500 Subject: [PATCH 1/4] Rename module_instance to instance to match design repo --- ml-proto/src/host/script.ml | 2 +- ml-proto/src/spec/eval.ml | 4 ++-- ml-proto/src/spec/eval.mli | 6 +++--- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ml-proto/src/host/script.ml b/ml-proto/src/host/script.ml index 92bcc602f7..9144f169b6 100644 --- a/ml-proto/src/host/script.ml +++ b/ml-proto/src/host/script.ml @@ -20,7 +20,7 @@ type script = command list let trace name = if !Flags.trace then print_endline ("-- " ^ name) -let current_module : Eval.module_instance option ref = ref None +let current_module : Eval.instance option ref = ref None let run_command cmd = match cmd.it with diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index 08931c8853..d824d7d3a9 100644 --- a/ml-proto/src/spec/eval.ml +++ b/ml-proto/src/spec/eval.ml @@ -17,7 +17,7 @@ type func = Ast.func module ExportMap = Map.Make(String) type export_map = func ExportMap.t -type module_instance = +type instance = { funcs : func list; exports : export_map; @@ -33,7 +33,7 @@ type label = value list -> exn type config = { - modul : module_instance; + modul : instance; locals : value ref list; labels : label list; return : label diff --git a/ml-proto/src/spec/eval.mli b/ml-proto/src/spec/eval.mli index 4b76101ae6..a5a43997c4 100644 --- a/ml-proto/src/spec/eval.mli +++ b/ml-proto/src/spec/eval.mli @@ -2,10 +2,10 @@ * (c) 2015 Andreas Rossberg *) -type module_instance +type instance type value = Values.value -val init : Ast.modul -> module_instance -val invoke : module_instance -> string -> value list -> value list +val init : Ast.modul -> instance +val invoke : instance -> string -> value list -> value list (* raise Error.Error *) val eval : Ast.expr -> value (* raise Error.Error *) From dc582c3995743c87f7930f4d1514df1d34df75cd Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 9 Sep 2015 12:00:26 -0500 Subject: [PATCH 2/4] Remove multiple-return-type support --- ml-proto/README.md | 20 ++--- ml-proto/src/given/source.ml | 1 + ml-proto/src/given/source.mli | 1 + ml-proto/src/host/lexer.mll | 1 - ml-proto/src/host/parser.mly | 26 +++--- ml-proto/src/host/print.ml | 19 +++-- ml-proto/src/host/print.mli | 2 +- ml-proto/src/host/script.ml | 29 ++++--- ml-proto/src/host/script.mli | 2 +- ml-proto/src/spec/ast.ml | 8 +- ml-proto/src/spec/check.ml | 147 +++++++++++++++++----------------- ml-proto/src/spec/eval.ml | 145 +++++++++++++++------------------ ml-proto/src/spec/eval.mli | 5 +- ml-proto/src/spec/types.ml | 14 ++-- ml-proto/test/multivalue.wasm | 93 --------------------- ml-proto/test/unsigned.wasm | 133 ++++++++++++++++++++---------- 16 files changed, 300 insertions(+), 346 deletions(-) delete mode 100644 ml-proto/test/multivalue.wasm diff --git a/ml-proto/README.md b/ml-proto/README.md index 5401399380..ad8c4e5824 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -88,8 +88,6 @@ For most part, the language understood by the interpreter is based on Ben's V8 p * *Expression Language.* There is no distinction between statements and expressions, everything is an expression. Some have an empty return type. Consequently, there is no need for a comma operator or ternary operator. -* *Multiple Values.* Functions can return multiple values. These can be destructured with a dedicated expression. They can also be returned from a caller (e.g. for tail-calls). Parameters and results are treated fully symmetrically. - * *Simple Loops*. Like in Ben's prototype, there is only one sort of loop, the infinite one, which can only be terminated by an explicit `break`. In such a language, a `continue` statement actually is completely redundant, because it equivalent to a `break` to a label on the loop's *body*. So I dropped `continue`. * *Break with Arguments.* In the spirit of a true expression language, `break` can carry arguments, which then become the result of the labelled expression it cuts to. @@ -119,12 +117,11 @@ type expr = | If of expr * expr * expr (* conditional | Loop of expr (* infinite loop | Label of expr (* labelled expression - | Break of int * expr list (* break to n-th surrounding label + | Break of int * expr (* break to n-th surrounding label | Switch of expr * arm list * expr (* switch, latter expr is default | Call of var * expr list (* call function | CallIndirect of var * expr * expr list (* call function through table - | Return of expr list (* return 0 to many value - | Destruct of var list * expr (* destructure multi-value into locals + | Return of expr (* return 0 to many value | GetParam of var (* read parameter | GetLocal of var (* read local variable | SetLocal of var * expr (* write local variable @@ -143,8 +140,6 @@ and arm = {value : value; expr : expr; fallthru : bool} See the code for more details on the auxiliary types. It also contains ASTs for functions and modules. -As currently implemented, multiple values can be *produced* by either `Call`/`Dispatch` or `Break`/`Label`, and *consumed* by `Destruct`, `Return` or `Call`/`Dispatch`. They pass through `Block`, `Loop`, `Label` and `Switch`. This may be considered too rich, or not rich enough. - ## External Syntax @@ -172,13 +167,12 @@ expr: ( if ) ;; = (if (nop)) ( loop * ) ;; = (loop (block *)) ( label ? * ) ;; = (label (block *)) - ( break * ) + ( break ) ( break ) ;; = (break 0) ( .switch * ) ( call * ) ( call_indirect * ) - ( return * ) - ( destruct * ) + ( return ) ( get_local ) ( set_local ) ( load_global ) @@ -195,9 +189,9 @@ case: ( case * fallthrough? ) ;; = (case (block *) fallthrough?) ( case ) ;; = (case (nop) fallthrough) -func: ( func ? * * * * ) +func: ( func ? * ? * * ) param: ( param * ) | ( param ) -result: ( result * ) +result: ( result ) local: ( local * ) | ( local ) module: ( module * * * * ? * ) @@ -233,7 +227,7 @@ script: * cmd: ;; define, validate, and initialize module ( invoke * ) ;; invoke export and print result - ( asserteq (invoke * ) * ) ;; assert expected results of invocation + ( asserteq (invoke * ) ) ;; assert expected results of invocation ( assertinvalid ) ;; assert invalid module with given failure string ``` diff --git a/ml-proto/src/given/source.ml b/ml-proto/src/given/source.ml index 83bccea9ad..f715483367 100644 --- a/ml-proto/src/given/source.ml +++ b/ml-proto/src/given/source.ml @@ -34,5 +34,6 @@ let (@@) phrase' region = {at = region; it = phrase'} let (@@@) phrase' regions = phrase'@@(span regions) let it phrase = phrase.it +let ito o = match o with Some phrase -> (Some phrase.it) | None -> None let at phrase = phrase.at let ats phrases = span (List.map at phrases) diff --git a/ml-proto/src/given/source.mli b/ml-proto/src/given/source.mli index 3ee1467c24..957f20a08d 100644 --- a/ml-proto/src/given/source.mli +++ b/ml-proto/src/given/source.mli @@ -20,5 +20,6 @@ val (@@) : 'a -> region -> 'a phrase val (@@@) : 'a -> region list -> 'a phrase val it : 'a phrase -> 'a +val ito : 'a phrase option -> 'a option val at : 'a phrase -> region val ats : 'a phrase list -> region diff --git a/ml-proto/src/host/lexer.mll b/ml-proto/src/host/lexer.mll index 30b090c886..cd0954de1a 100644 --- a/ml-proto/src/host/lexer.mll +++ b/ml-proto/src/host/lexer.mll @@ -131,7 +131,6 @@ rule token = parse | "call" { CALL } | "call_indirect" { CALLINDIRECT } | "return" { RETURN } - | "destruct" { DESTRUCT } | "get_local" { GETLOCAL } | "set_local" { SETLOCAL } diff --git a/ml-proto/src/host/parser.mly b/ml-proto/src/host/parser.mly index 78dfe98895..125923cb84 100644 --- a/ml-proto/src/host/parser.mly +++ b/ml-proto/src/host/parser.mly @@ -95,7 +95,7 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} %token INT FLOAT TEXT VAR TYPE LPAR RPAR %token NOP BLOCK IF LOOP LABEL BREAK SWITCH CASE FALLTHROUGH -%token CALL CALLINDIRECT RETURN DESTRUCT +%token CALL CALLINDIRECT RETURN %token GETLOCAL SETLOCAL LOADGLOBAL STOREGLOBAL LOAD STORE %token CONST UNARY BINARY COMPARE CONVERT %token FUNC PARAM RESULT LOCAL MODULE MEMORY SEGMENT GLOBAL IMPORT EXPORT TABLE @@ -164,8 +164,9 @@ oper : | LABEL expr_block { fun c -> Label ($2 (anon_label c)) } | LABEL bind_var expr_block /* Sugar */ { fun c -> Label ($3 (bind_label c $2)) } - | BREAK var expr_list { fun c -> Break ($2 c label, $3 c) } - | BREAK { let at = at() in fun c -> Break (0 @@ at, []) } /* Sugar */ + | BREAK var expr { fun c -> Break ($2 c label, Some ($3 c)) } + | BREAK var { fun c -> Break ($2 c label, None) } + | BREAK { let at = at() in fun c -> Break (0 @@ at, None) } | SWITCH expr arms { let at1 = ati 1 in fun c -> let x, y = $3 c in @@ -173,8 +174,8 @@ oper : | CALL var expr_list { fun c -> Call ($2 c func, $3 c) } | CALLINDIRECT var expr expr_list { fun c -> CallIndirect ($2 c table, $3 c, $4 c) } - | RETURN expr_list { fun c -> Return ($2 c) } - | DESTRUCT var_list expr { fun c -> Destruct ($2 c local, $3 c) } + | RETURN expr { fun c -> Return (Some ($2 c)) } + | RETURN { fun c -> Return None } | GETLOCAL var { fun c -> GetLocal ($2 c local) } | SETLOCAL var expr { fun c -> SetLocal ($2 c local, $3 c) } | LOADGLOBAL var { fun c -> LoadGlobal ($2 c global) } @@ -222,18 +223,21 @@ arms : func_fields : | /* empty */ /* Sugar */ { let at = at() in - fun c -> {params = []; results = []; locals = []; body = Nop @@ at} } + fun c -> {params = []; result = None; locals = []; body = Nop @@ at} } | expr_block - { fun c -> {params = []; results = []; locals = []; body = $1 c} } + { fun c -> {params = []; result = None; locals = []; body = $1 c} } | LPAR PARAM value_type_list RPAR func_fields { fun c -> anon_locals c $3; let f = $5 c in {f with params = $3 @ f.params} } | LPAR PARAM bind_var value_type RPAR func_fields /* Sugar */ { fun c -> bind_local c $3; let f = $6 c in {f with params = $4 :: f.params} } - | LPAR RESULT value_type_list RPAR func_fields - { fun c -> let f = $5 c in - {f with results = $3 @ f.results} } + | LPAR RESULT value_type RPAR func_fields + { let at = at() in + fun c -> let f = $5 c in + match f.result with + | Some _ -> Error.error at "more than one return type" + | None -> {f with result = Some $3} } | LPAR LOCAL value_type_list RPAR func_fields { fun c -> anon_locals c $3; let f = $5 c in {f with locals = $3 @ f.locals} } @@ -313,7 +317,7 @@ cmd : | LPAR ASSERTINVALID modul TEXT RPAR { AssertInvalid ($3, $4) @@ at() } | LPAR INVOKE TEXT expr_list RPAR { Invoke ($3, $4 (c0 ())) @@ at() } - | LPAR ASSERTEQ LPAR INVOKE TEXT expr_list RPAR expr_list RPAR + | LPAR ASSERTEQ LPAR INVOKE TEXT expr_list RPAR expr RPAR { AssertEq ($5, $6 (c0 ()), $8 (c0 ())) @@ at() } ; cmd_list : diff --git a/ml-proto/src/host/print.ml b/ml-proto/src/host/print.ml index 14a228202a..57c5d3767a 100644 --- a/ml-proto/src/host/print.ml +++ b/ml-proto/src/host/print.ml @@ -12,8 +12,8 @@ open Printf open Types let func_type f = - let {Ast.params; results; _} = f.it in - {ins = List.map Source.it params; outs = List.map Source.it results} + let {Ast.params; result; _} = f.it in + {ins = List.map Source.it params; out = ito result} let string_of_table_type = function | None -> "()" @@ -65,9 +65,14 @@ let print_module_sig m = flush_all () -let print_values vs = - let ts = List.map Values.type_of vs in - printf "%s : %s\n" - (Values.string_of_values vs) (Types.string_of_expr_type ts); - 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 "()"; + flush_all () diff --git a/ml-proto/src/host/print.mli b/ml-proto/src/host/print.mli index d190d8d660..25da6cc0ce 100644 --- a/ml-proto/src/host/print.mli +++ b/ml-proto/src/host/print.mli @@ -4,5 +4,5 @@ val print_module : Ast.modul -> unit val print_module_sig : Ast.modul -> unit -val print_values : Values.value list -> unit +val print_value : Values.value option -> unit diff --git a/ml-proto/src/host/script.ml b/ml-proto/src/host/script.ml index 9144f169b6..c068d2fe7c 100644 --- a/ml-proto/src/host/script.ml +++ b/ml-proto/src/host/script.ml @@ -11,7 +11,7 @@ and command' = | Define of Ast.modul | AssertInvalid of Ast.modul * string | Invoke of string * Ast.expr list - | AssertEq of string * Ast.expr list * Ast.expr list + | AssertEq of string * Ast.expr list * Ast.expr type script = command list @@ -22,6 +22,13 @@ let trace name = if !Flags.trace then print_endline ("-- " ^ name) let current_module : Eval.instance option ref = ref None +let eval_args es at = + let evs = List.map Eval.eval es in + let reject_none = function + | Some v -> v + | None -> Error.error at "unexpected () value" in + List.map reject_none evs + let run_command cmd = match cmd.it with | Define m -> @@ -50,24 +57,24 @@ let run_command cmd = | Some m -> m | None -> Error.error cmd.at "no module defined to invoke" in - let vs = List.map Eval.eval es in - let vs' = Eval.invoke m name vs in - if vs' <> [] then Print.print_values vs' + let vs = eval_args es cmd.at in + let v = Eval.invoke m name vs in + if v <> None then Print.print_value v - | AssertEq (name, arg_es, expect_es) -> + | AssertEq (name, arg_es, expect_e) -> trace "Assert invoking..."; let m = match !current_module with | Some m -> m | None -> Error.error cmd.at "no module defined to invoke" in - let arg_vs = List.map Eval.eval arg_es in - let got_vs = Eval.invoke m name arg_vs in - let expect_vs = List.map Eval.eval expect_es in - if got_vs <> expect_vs then begin + let arg_vs = eval_args arg_es cmd.at in + let got_v = Eval.invoke m name arg_vs in + let expect_v = Eval.eval expect_e in + if got_v <> expect_v then begin print_string "Result: "; - Print.print_values got_vs; + Print.print_value got_v; print_string "Expect: "; - Print.print_values expect_vs; + Print.print_value expect_v; Error.error cmd.at "assertion failed" end diff --git a/ml-proto/src/host/script.mli b/ml-proto/src/host/script.mli index e4ada117f7..18ddf5cc70 100644 --- a/ml-proto/src/host/script.mli +++ b/ml-proto/src/host/script.mli @@ -7,7 +7,7 @@ and command' = | Define of Ast.modul | AssertInvalid of Ast.modul * string | Invoke of string * Ast.expr list - | AssertEq of string * Ast.expr list * Ast.expr list + | AssertEq of string * Ast.expr list * Ast.expr type script = command list diff --git a/ml-proto/src/spec/ast.ml b/ml-proto/src/spec/ast.ml index e9c0eeb313..69c1f7b3fc 100644 --- a/ml-proto/src/spec/ast.ml +++ b/ml-proto/src/spec/ast.ml @@ -27,6 +27,7 @@ open Values (* Types *) type value_type = Types.value_type Source.phrase +type expr_type = value_type option (* Operators *) @@ -77,12 +78,11 @@ and expr' = | If of expr * expr * expr | Loop of expr | Label of expr - | Break of var * expr list + | Break of var * expr option | Switch of value_type * expr * arm list * expr | Call of var * expr list | CallIndirect of var * expr * expr list - | Return of expr list - | Destruct of var list * expr + | Return of expr option | GetLocal of var | SetLocal of var * expr | LoadGlobal of var @@ -119,7 +119,7 @@ type func = func' Source.phrase and func' = { params : value_type list; - results : value_type list; + result : expr_type; locals : value_type list; body : expr } diff --git a/ml-proto/src/spec/check.ml b/ml-proto/src/spec/check.ml index 92fe065651..3b684b44b7 100644 --- a/ml-proto/src/spec/check.ml +++ b/ml-proto/src/spec/check.ml @@ -21,13 +21,13 @@ type context = globals : value_type list; tables : func_type list; locals : value_type list; - returns : expr_type; + return : expr_type; labels : expr_type list } let c0 = {funcs = []; globals = []; tables = []; - locals = []; returns = []; labels = []} + locals = []; return = None; labels = []} let lookup category list x = try List.nth list x.it with Failure _ -> @@ -43,15 +43,13 @@ let label c x = lookup "label" c.labels x (* Type comparison *) let check_type actual expected at = - require (expected = [] || actual = expected) at + require (expected = None || actual = expected) at ("type mismatch: expression has type " ^ string_of_expr_type actual ^ " but the context requires " ^ string_of_expr_type expected) let check_func_type actual expected at = require (actual = expected) at "inconsistent function type in table" -let nary = List.map (fun ty -> [ty]) - (* Type Synthesis *) @@ -107,137 +105,138 @@ let type_cvt at = function ), Float64Type let type_func f = - let {params; results; _} = f.it in - {ins = List.map it params; outs = List.map it results} + let {params; result; _} = f.it in + {ins = List.map it params; out = ito result} (* Type Analysis *) (* - * check_expr : context -> expr -> expr_type -> unit + * check_expr : context -> expr_type -> expr -> unit * * Conventions: - * c : context - * e : expr - * v : value - * t : value_type + * c : context + * e : expr + * eo : expr option + * v : value + * t : value_type + * et : expr_type *) -let rec check_expr c ts e = +let rec check_expr c et e = match e.it with | Nop -> - check_type [] ts e.at + check_type None et e.at | Block es -> require (es <> []) e.at "invalid block"; let es', eN = Lib.List.split_last es in - List.iter (check_expr c []) es'; - check_expr c ts eN + List.iter (check_expr c None) es'; + check_expr c et eN | If (e1, e2, e3) -> - check_expr c [Int32Type] e1; - check_expr c ts e2; - check_expr c ts e3 + check_expr c (Some Int32Type) e1; + check_expr c et e2; + check_expr c et e3 | Loop e1 -> - check_expr c [] e1 + check_expr c None e1 | Label e1 -> - let c' = {c with labels = ts :: c.labels} in - check_expr c' ts e1 + let c' = {c with labels = et :: c.labels} in + check_expr c' et e1 - | Break (x, es) -> - check_exprs c (label c x) es + | Break (x, eo) -> + check_expr_option c (label c x) eo e.at | Switch (t, e1, arms, e2) -> require (t.it = Int32Type || t.it = Int64Type) t.at "invalid switch type"; (* TODO: Check that cases are unique. *) - check_expr c [t.it] e1; - List.iter (check_arm c t.it ts) arms; - check_expr c ts e2 + check_expr c (Some t.it) e1; + List.iter (check_arm c t.it et) arms; + check_expr c et e2 | Call (x, es) -> - let {ins; outs} = func c x in + let {ins; out} = func c x in check_exprs c ins es; - check_type outs ts e.at + check_type out et e.at | CallIndirect (x, e1, es) -> - let {ins; outs} = table c x in - check_expr c [Int32Type] e1; + let {ins; out} = table c x in + check_expr c (Some Int32Type) e1; check_exprs c ins es; - check_type outs ts e.at - - | Return es -> - check_exprs c c.returns es + check_type out et e.at - | Destruct (xs, e1) -> - check_expr c (List.map (local c) xs) e1; - check_type [] ts e.at + | Return eo -> + check_expr_option c c.return eo e.at | GetLocal x -> - check_type [local c x] ts e.at + check_type (Some (local c x)) et e.at | SetLocal (x, e1) -> - check_expr c [local c x] e1; - check_type [] ts e.at + check_expr c (Some (local c x)) e1; + check_type None et e.at | LoadGlobal x -> - check_type [global c x] ts e.at + check_type (Some (global c x)) et e.at | StoreGlobal (x, e1) -> - check_expr c [global c x] e1; - check_type [] ts e.at + check_expr c (Some (global c x)) e1; + check_type None et e.at | Load (memop, e1) -> check_memop memop e.at; - check_expr c [Int32Type] e1; - check_type [type_mem memop.mem] ts e.at + check_expr c (Some Int32Type) e1; + check_type (Some (type_mem memop.mem)) et e.at | Store (memop, e1, e2) -> check_memop memop e.at; - check_expr c [Int32Type] e1; - check_expr c [memop.ty] e2; - check_type [] ts e.at + check_expr c (Some Int32Type) e1; + check_expr c (Some memop.ty) e2; + check_type None et e.at | Const v -> - check_literal c ts v + check_literal c et v | Unary (unop, e1) -> let t = type_unop unop in - check_expr c [t] e1; - check_type [t] ts e.at + check_expr c (Some t) e1; + check_type (Some t) et e.at | Binary (binop, e1, e2) -> let t = type_binop binop in - check_expr c [t] e1; - check_expr c [t] e2; - check_type [t] ts e.at + check_expr c (Some t) e1; + check_expr c (Some t) e2; + check_type (Some t) et e.at | Compare (relop, e1, e2) -> let t = type_relop relop in - check_expr c [t] e1; - check_expr c [t] e2; - check_type [Int32Type] ts e.at + check_expr c (Some t) e1; + check_expr c (Some t) e2; + check_type (Some Int32Type) et e.at | Convert (cvt, e1) -> let t1, t = type_cvt e.at cvt in - check_expr c [t1] e1; - check_type [t] ts e.at + check_expr c (Some t1) e1; + check_type (Some t) et e.at + +and check_exprs c ts es = + let ets = List.map (fun x -> Some x) ts in + try List.iter2 (check_expr c) ets es + with Invalid_argument _ -> error (Source.ats es) "arity mismatch" -and check_exprs c ts = function - | [e] -> - check_expr c ts e - | es -> - try List.iter2 (check_expr c) (nary ts) es - with Invalid_argument _ -> error (Source.ats es) "arity mismatch" +and check_expr_option c et eo at = + match eo with + | Some e -> check_expr c et e + | None -> check_type None et at -and check_literal c ts l = - check_type [type_value l.it] ts l.at +and check_literal c et l = + check_type (Some (type_value l.it)) et l.at -and check_arm c t ts arm = +and check_arm c t et arm = let {value = l; expr = e; fallthru} = arm.it in - check_literal c [t] l; - check_expr c (if fallthru then [] else ts) e + check_literal c (Some t) l; + check_expr c (if fallthru then None else et) e and check_memop {ty; mem; align} at = require (Lib.Int.is_power_of_two align) at "non-power-of-two alignment"; @@ -267,10 +266,10 @@ and check_memop {ty; mem; align} at = *) let check_func c f = - let {params; results; locals; body = e} = f.it in + let {params; result; locals; body = e} = f.it in let c' = {c with locals = List.map it params @ List.map it locals; - returns = List.map it results} in - check_expr c' (List.map it results) e + return = ito result} in + check_expr c' (ito result) e let check_table c tab = match tab.it with diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index d824d7d3a9..f1dd8d6b1e 100644 --- a/ml-proto/src/spec/eval.ml +++ b/ml-proto/src/spec/eval.ml @@ -12,6 +12,7 @@ let error = Error.error (* Module Instances *) type value = Values.value +type expr_value = value option type func = Ast.func module ExportMap = Map.Make(String) @@ -29,7 +30,7 @@ type instance = (* Configurations *) -type label = value list -> exn +type label = expr_value -> exn type config = { @@ -56,8 +57,8 @@ let export m x = module MakeLabel () = struct - exception Label of value list - let label vs = Label vs + exception Label of expr_value + let label v = Label v end @@ -73,14 +74,13 @@ let type_error at v t = ("runtime: type error, expected " ^ Types.string_of_value_type t ^ ", got " ^ Types.string_of_value_type (type_of v)) -let unary vs at = - match vs with - | [v] -> v - | [] -> error at "runtime: expression produced no value" - | _ -> error at "runtime: expression produced multiple values" +let some v at = + match v with + | Some v -> v + | None -> error at "runtime: expression produced no value" let int32 v at = - match unary v at with + match some v at with | Int32 i -> i | v -> type_error at v Types.Int32Type @@ -88,18 +88,18 @@ let int32 v at = (* Evaluation *) (* - * eval_expr : config -> expr -> value list - * * Conventions: - * c : config - * e : expr - * v : value + * c : config + * e : expr + * eo : expr option + * v : value + * ev : expr_value *) -let rec eval_expr c e = +let rec eval_expr (c : config) (e : expr) = match e.it with | Nop -> - [] + None | Block es -> let es', eN = Lib.List.split_last es in @@ -117,99 +117,95 @@ let rec eval_expr c e = | Label e1 -> let module L = MakeLabel () in let c' = {c with labels = L.label :: c.labels} in - (try eval_expr c' e1 with L.Label vs -> vs) + (try eval_expr c' e1 with L.Label ev -> ev) - | Break (x, es) -> - raise (label c x (eval_exprs c es)) + | Break (x, eo) -> + raise (label c x (eval_expr_option c eo)) | Switch (_t, e1, arms, e2) -> - let v = unary (eval_expr c e1) e1.at in - (match List.fold_left (eval_arm c v) `Seek arms with + let ev = some (eval_expr c e1) e1.at in + (match List.fold_left (eval_arm c ev) `Seek arms with | `Seek | `Fallthru -> eval_expr c e2 | `Done vs -> vs ) | Call (x, es) -> - let vs = eval_exprs c es in - eval_func c.modul (func c x) vs + let vs = List.map (eval_expr c) es in + eval_func c.modul (func c x) vs e.at | CallIndirect (x, e1, es) -> let i = int32 (eval_expr c e1) e1.at in - let vs = eval_exprs c es in - eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs + let vs = List.map (eval_expr c) es in + eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs e.at - | Return es -> - raise (c.return (eval_exprs c es)) - - | Destruct (xs, e1) -> - let vs = eval_expr c e1 in - List.iter2 (fun x v -> local c x := v) xs vs; - [] + | Return eo -> + raise (c.return (eval_expr_option c eo)) | GetLocal x -> - [!(local c x)] + Some !(local c x) | SetLocal (x, e1) -> - let v1 = unary (eval_expr c e1) e1.at in + let v1 = some (eval_expr c e1) e1.at in local c x := v1; - [] + None | LoadGlobal x -> - [!(global c x)] + Some !(global c x) | StoreGlobal (x, e1) -> - let v1 = unary (eval_expr c e1) e1.at in + let v1 = some (eval_expr c e1) e1.at in global c x := v1; - [] + None | Load ({mem; ty; _}, e1) -> - let v1 = unary (eval_expr c e1) e1.at in - (try [Memory.load c.modul.memory (Memory.address_of_value v1) mem ty] + let v1 = some (eval_expr c e1) e1.at in + (try Some (Memory.load c.modul.memory (Memory.address_of_value v1) mem ty) with exn -> memory_error e.at exn) | Store ({mem; _}, e1, e2) -> - let v1 = unary (eval_expr c e1) e1.at in - let v2 = unary (eval_expr c e2) e2.at in + let v1 = some (eval_expr c e1) e1.at in + let v2 = some (eval_expr c e2) e2.at in (try Memory.store c.modul.memory (Memory.address_of_value v1) mem v2 with exn -> memory_error e.at exn); - [] + None | Const v -> - [v.it] + Some v.it | Unary (unop, e1) -> - let v1 = unary (eval_expr c e1) e1.at in - (try [Arithmetic.eval_unop unop v1] + let v1 = some (eval_expr c e1) e1.at in + (try Some (Arithmetic.eval_unop unop v1) with Arithmetic.TypeError (_, v, t) -> type_error e1.at v t) | Binary (binop, e1, e2) -> - let v1 = unary (eval_expr c e1) e1.at in - let v2 = unary (eval_expr c e2) e2.at in - (try [Arithmetic.eval_binop binop v1 v2] + 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 Arithmetic.TypeError (i, v, t) -> type_error (if i = 1 then e1 else e2).at v t) | Compare (relop, e1, e2) -> - let v1 = unary (eval_expr c e1) e1.at in - let v2 = unary (eval_expr c e2) e2.at in - (try [Int32 Int32.(if Arithmetic.eval_relop relop v1 v2 then one else zero)] + let v1 = some (eval_expr c e1) e1.at in + let v2 = some (eval_expr c e2) e2.at in + (try + let b = Arithmetic.eval_relop relop v1 v2 in + Some (Int32 Int32.(if b then one else zero)) with Arithmetic.TypeError (i, v, t) -> type_error (if i = 1 then e1 else e2).at v t) | Convert (cvt, e1) -> - let v1 = unary (eval_expr c e1) e1.at in - (try [Arithmetic.eval_cvt cvt v1] + let v1 = some (eval_expr c e1) e1.at in + (try Some (Arithmetic.eval_cvt cvt v1) with Arithmetic.TypeError (_, v, t) -> type_error e1.at v t) -and eval_exprs c = function - | [e] -> - eval_expr c e - | es -> - List.concat (List.map (eval_expr c) es) +and eval_expr_option c eo = + match eo with + | Some e -> eval_expr c e + | None -> None -and eval_arm c v stage arm = +and eval_arm c ev stage arm = let {value; expr = e; fallthru} = arm.it in - match stage, v = value.it with + match stage, ev = value.it with | `Seek, true | `Fallthru, _ -> if fallthru then (ignore (eval_expr c e); `Fallthru) @@ -217,27 +213,17 @@ and eval_arm c v stage arm = | `Seek, false | `Done _, _ -> stage - -(* - * eval_func : modul -> func -> value list -> value list - * - * Conventions: - * c : config - * m : modul - * f : func - * e : expr - * v : value - *) - and eval_decl t = ref (default_value t.it) -and eval_func m f vs = +and eval_func (m : instance) (f : func) (evs : expr_value list) (at : region) = let module Return = MakeLabel () in - let locals = List.map (fun v -> ref v) vs @ List.map eval_decl f.it.locals in + let args = List.map (fun ev -> ref (some ev at)) evs in + let vars = List.map eval_decl f.it.locals in + let locals = args @ vars in let c = {modul = m; locals; labels = []; return = Return.label} in try eval_expr c f.it.body - with Return.Label vs -> vs + with Return.Label ev -> ev (* Modules *) @@ -260,12 +246,13 @@ let init m = {funcs; exports; tables; globals; memory = mem} let invoke m name vs = + let evs = List.map (fun v -> Some v) vs in let f = export m (name @@ no_region) in - eval_func m f vs + eval_func m f evs no_region let eval e = - let f = {params = []; results = []; locals = []; body = e} @@ no_region in + let f = {params = []; result = None; locals = []; body = e} @@ no_region in let memory = Memory.create 0 in let exports = ExportMap.singleton "eval" f in let m = {funcs = [f]; exports; tables = []; globals = []; memory} in - unary (eval_func m f []) e.at + eval_func m f [] e.at diff --git a/ml-proto/src/spec/eval.mli b/ml-proto/src/spec/eval.mli index a5a43997c4..99ed16ed8a 100644 --- a/ml-proto/src/spec/eval.mli +++ b/ml-proto/src/spec/eval.mli @@ -4,8 +4,9 @@ type instance type value = Values.value +type expr_value = value option val init : Ast.modul -> instance -val invoke : instance -> string -> value list -> value list +val invoke : instance -> string -> value list -> expr_value (* raise Error.Error *) -val eval : Ast.expr -> value (* raise Error.Error *) +val eval : Ast.expr -> expr_value (* raise Error.Error *) diff --git a/ml-proto/src/spec/types.ml b/ml-proto/src/spec/types.ml index 2a325e7411..548e1cc859 100644 --- a/ml-proto/src/spec/types.ml +++ b/ml-proto/src/spec/types.ml @@ -13,8 +13,8 @@ type float64 = float (* Types *) type value_type = Int32Type | Int64Type | Float32Type | Float64Type -type expr_type = value_type list -type func_type = {ins : expr_type; outs : expr_type} +type expr_type = value_type option +type func_type = {ins : value_type list; out : expr_type} (* String conversion *) @@ -24,9 +24,13 @@ let string_of_value_type = function | Float32Type -> "f32" | Float64Type -> "f64" -let string_of_expr_type = function +let string_of_value_type_list = function | [t] -> string_of_value_type t | ts -> "(" ^ String.concat " " (List.map string_of_value_type ts) ^ ")" -let string_of_func_type {ins; outs} = - string_of_expr_type ins ^ " -> " ^ string_of_expr_type outs +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 diff --git a/ml-proto/test/multivalue.wasm b/ml-proto/test/multivalue.wasm deleted file mode 100644 index ed54ddc506..0000000000 --- a/ml-proto/test/multivalue.wasm +++ /dev/null @@ -1,93 +0,0 @@ -;; (c) 2015 Andreas Rossberg - -(module - ;; Swap - (func $swap (param i32 i32) (result i32 i32) - (return (get_local 1) (get_local 0)) - ) - - ;; Test - (func $test (param $case i32) (result i32 i32) - (local $x1 i32) - (local $x2 i32) - (set_local $x1 (i32.const 1)) - (set_local $x2 (i32.const 2)) - (i32.switch (get_local $case) - ;; Destructure - (case 1 - (destruct $x1 $x2 (call $swap (get_local $x1) (get_local $x2))) - (return (get_local $x1) (get_local $x2)) - ) - ;; Return directly - (case 2 - (return (call $swap (get_local $x1) (get_local $x2))) - ) - ;; Pass on to other call - (case 3 - (return (call $swap (call $swap (get_local $x1) (get_local $x2)))) - ) - ;; Break - (case 4 - (destruct $x1 $x2 - (label $l (call $swap (break $l (get_local $x1) (get_local $x2)))) - ) - (return (get_local $x1) (get_local $x2)) - ) - ;; Pass on to break - (case 5 - (return - (label $l - (call $swap (break $l (call $swap (get_local $x1) (get_local $x2)))) - ) - ) - ) - ;; Pass through block - (case 6 - (return - (block - (set_local $x2 (i32.const 3)) - (call $swap (get_local $x1) (get_local $x2)) - ) - ) - ) - ;; Pass through conditional - (case 7) - (case 8 - (return - (if (i32.eq (i32.rem_s (get_local $case) (i32.const 2)) (i32.const 0)) - (call $swap (get_local $x1) (get_local $x2)) - (call $swap (get_local $x2) (get_local $x1)) - ) - ) - ) - ;; Pass through switch - (case 9) - (case 10) - (case 11 - (return - (i32.switch (get_local $case) - (case 9 (call $swap (get_local $x1) (get_local $x2))) - (case 10 (call $swap (get_local $x2) (get_local $x1))) - (label $l (break $l (get_local $x1) (get_local $x1))) - ) - ) - ) - ;; Dummy default - (return (get_local $x1) (get_local $x2)) - ) - ) - - (export "test" $test) -) - -(assert_eq (invoke "test" (i32.const 1)) (i32.const 2) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 2)) (i32.const 2) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 3)) (i32.const 1) (i32.const 2)) -(assert_eq (invoke "test" (i32.const 4)) (i32.const 1) (i32.const 2)) -(assert_eq (invoke "test" (i32.const 5)) (i32.const 2) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 6)) (i32.const 3) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 7)) (i32.const 1) (i32.const 2)) -(assert_eq (invoke "test" (i32.const 8)) (i32.const 2) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 9)) (i32.const 2) (i32.const 1)) -(assert_eq (invoke "test" (i32.const 10)) (i32.const 1) (i32.const 2)) -(assert_eq (invoke "test" (i32.const 11)) (i32.const 1) (i32.const 1)) diff --git a/ml-proto/test/unsigned.wasm b/ml-proto/test/unsigned.wasm index f350aaf642..bc17d658d5 100644 --- a/ml-proto/test/unsigned.wasm +++ b/ml-proto/test/unsigned.wasm @@ -1,75 +1,120 @@ (module - (func $divmod (param $i i64) (param $j i64) (result i64 i64 i64 i64) - (return - (i64.div_s (get_local $i) (get_local $j)) - (i64.div_u (get_local $i) (get_local $j)) - (i64.rem_s (get_local $i) (get_local $j)) - (i64.rem_u (get_local $i) (get_local $j)) - ) + (func $div_s (param $i i64) (param $j i64) (result i64) + (return (i64.div_s (get_local $i) (get_local $j))) + ) + (func $div_u (param $i i64) (param $j i64) (result i64) + (return (i64.div_u (get_local $i) (get_local $j))) + ) + (func $rem_s (param $i i64) (param $j i64) (result i64) + (return (i64.rem_s (get_local $i) (get_local $j))) + ) + (func $rem_u (param $i i64) (param $j i64) (result i64) + (return (i64.rem_u (get_local $i) (get_local $j))) ) - (func $compare (param $i i64) (param $j i64) (result i32 i32 i32 i32) - (return - (i64.lt_s (get_local $i) (get_local $j)) - (i64.lt_u (get_local $i) (get_local $j)) - (i64.ge_s (get_local $i) (get_local $j)) - (i64.ge_u (get_local $i) (get_local $j)) - ) + (func $lt_s (param $i i64) (param $j i64) (result i32) + (return (i64.lt_s (get_local $i) (get_local $j))) + ) + (func $lt_u (param $i i64) (param $j i64) (result i32) + (return (i64.lt_u (get_local $i) (get_local $j))) + ) + (func $ge_s (param $i i64) (param $j i64) (result i32) + (return (i64.ge_s (get_local $i) (get_local $j))) + ) + (func $ge_u (param $i i64) (param $j i64) (result i32) + (return (i64.ge_u (get_local $i) (get_local $j))) ) - (func $cvt_float (param $x f64) (result i32 i64) - (return (i32.trunc_u/f64 (get_local $x)) (i64.trunc_u/f64 (get_local $x))) + (func $i32_trunc_u (param $x f64) (result i32) + (return (i32.trunc_u/f64 (get_local $x))) + ) + (func $i64_trunc_u (param $x f64) (result i64) + (return (i64.trunc_u/f64 (get_local $x))) ) - (export "divmod" $divmod) - (export "compare" $compare) - (export "cvt_float" $cvt_float) + (export "div_s" $div_s) + (export "div_u" $div_u) + (export "rem_s" $rem_s) + (export "rem_u" $rem_u) + (export "lt_s" $lt_s) + (export "lt_u" $lt_u) + (export "ge_s" $ge_s) + (export "ge_u" $ge_u) + (export "i32.trunc_u" $i32_trunc_u) + (export "i64.trunc_u" $i64_trunc_u) ) (assert_eq - (invoke "divmod" + (invoke "div_s" (i64.add (i64.const 9223372036854775807) (i64.const 2)) ;; max_int64+2 (i64.const 1000) ) (i64.const -9223372036854775) ;; div_s +) +(assert_eq + (invoke "div_u" + (i64.add (i64.const 9223372036854775807) (i64.const 2)) ;; max_int64+2 + (i64.const 1000) + ) (i64.const 9223372036854775) ;; div_u - (i64.const -807) ;; div_s - (i64.const 809) ;; div_u +) +(assert_eq + (invoke "rem_s" + (i64.add (i64.const 9223372036854775807) (i64.const 2)) ;; max_int64+2 + (i64.const 1000) + ) + (i64.const -807) ;; rem_s +) +(assert_eq + (invoke "rem_u" + (i64.add (i64.const 9223372036854775807) (i64.const 2)) ;; max_int64+2 + (i64.const 1000) + ) + (i64.const 809) ;; rem_u ) (assert_eq - (invoke "compare" + (invoke "lt_s" (i64.add (i64.const 9223372036854775807) (i64.const 1)) ;; max_int64+1 (i64.const 9223372036854775807) ) (i32.const 1) ;; lt_s +) +(assert_eq + (invoke "lt_u" + (i64.add (i64.const 9223372036854775807) (i64.const 1)) ;; max_int64+1 + (i64.const 9223372036854775807) + ) (i32.const 0) ;; lt_u +) +(assert_eq + (invoke "ge_s" + (i64.add (i64.const 9223372036854775807) (i64.const 1)) ;; max_int64+1 + (i64.const 9223372036854775807) + ) (i32.const 0) ;; ge_s - (i32.const 1) ;; ge_u ) - -(assert_eq (invoke "cvt_float" (f64.const 1e8)) - (i32.const 100000000) (i64.const 100000000) +(assert_eq + (invoke "ge_u" + (i64.add (i64.const 9223372036854775807) (i64.const 1)) ;; max_int64+1 + (i64.const 9223372036854775807) + ) + (i32.const 1) ;; ge_u ) -(assert_eq (invoke "cvt_float" (f64.const 1e16)) - (i32.const 0) (i64.const 10000000000000000) -) +(assert_eq (invoke "i32.trunc_u" (f64.const 1e8)) (i32.const 100000000)) +(assert_eq (invoke "i64.trunc_u" (f64.const 1e8)) (i64.const 100000000)) -(assert_eq (invoke "cvt_float" (f64.const 1e30)) - (i32.const 0) (i64.const 0) -) +(assert_eq (invoke "i32.trunc_u" (f64.const 1e16)) (i32.const 0)) +(assert_eq (invoke "i64.trunc_u" (f64.const 1e16)) (i64.const 10000000000000000)) -(assert_eq (invoke "cvt_float" (f64.const -1)) - (i32.const 0) (i64.const 0) -) +(assert_eq (invoke "i32.trunc_u" (f64.const 1e30)) (i32.const 0)) +(assert_eq (invoke "i64.trunc_u" (f64.const -1)) (i64.const 0)) -(assert_eq - (invoke "cvt_float" (f64.const 4294967295)) ;; max_uint32 - (i32.const -1) (i64.const 4294967295) -) +;; max_uint32 +(assert_eq (invoke "i32.trunc_u" (f64.const 4294967295)) (i32.const -1)) +(assert_eq (invoke "i64.trunc_u" (f64.const 4294967295)) (i64.const 4294967295)) -(assert_eq - (invoke "cvt_float" (f64.const 9223372036854775808)) ;; max_int64+1 - (i32.const 0) (i64.const -9223372036854775808) -) +;; max_int64+1 +(assert_eq (invoke "i32.trunc_u" (f64.const 9223372036854775808)) (i32.const 0)) +(assert_eq (invoke "i64.trunc_u" (f64.const 9223372036854775808)) (i64.const -9223372036854775808)) From 5145ec019c1bd2dadb981e2c995802b5b4e2e3dd Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Mon, 14 Sep 2015 11:44:19 -0500 Subject: [PATCH 3/4] Address comments --- ml-proto/README.md | 8 ++++---- ml-proto/src/given/source.ml | 1 - ml-proto/src/given/source.mli | 1 - ml-proto/src/host/parser.mly | 12 +++++++----- ml-proto/src/host/print.ml | 2 +- ml-proto/src/spec/check.ml | 6 +++--- ml-proto/src/spec/eval.ml | 24 +++++++++++------------- ml-proto/src/spec/eval.mli | 5 ++--- 8 files changed, 28 insertions(+), 31 deletions(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index ad8c4e5824..4841d572de 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -117,11 +117,11 @@ type expr = | If of expr * expr * expr (* conditional | Loop of expr (* infinite loop | Label of expr (* labelled expression - | Break of int * expr (* break to n-th surrounding label + | Break of int * expr option (* break to n-th surrounding label | Switch of expr * arm list * expr (* switch, latter expr is default | Call of var * expr list (* call function | CallIndirect of var * expr * expr list (* call function through table - | Return of expr (* return 0 to many value + | Return of expr option (* return 0 to many value | GetParam of var (* read parameter | GetLocal of var (* read local variable | SetLocal of var * expr (* write local variable @@ -167,12 +167,12 @@ expr: ( if ) ;; = (if (nop)) ( loop * ) ;; = (loop (block *)) ( label ? * ) ;; = (label (block *)) - ( break ) + ( break ? ) ( break ) ;; = (break 0) ( .switch * ) ( call * ) ( call_indirect * ) - ( return ) + ( return ? ) ( get_local ) ( set_local ) ( load_global ) diff --git a/ml-proto/src/given/source.ml b/ml-proto/src/given/source.ml index f715483367..83bccea9ad 100644 --- a/ml-proto/src/given/source.ml +++ b/ml-proto/src/given/source.ml @@ -34,6 +34,5 @@ let (@@) phrase' region = {at = region; it = phrase'} let (@@@) phrase' regions = phrase'@@(span regions) let it phrase = phrase.it -let ito o = match o with Some phrase -> (Some phrase.it) | None -> None let at phrase = phrase.at let ats phrases = span (List.map at phrases) diff --git a/ml-proto/src/given/source.mli b/ml-proto/src/given/source.mli index 957f20a08d..3ee1467c24 100644 --- a/ml-proto/src/given/source.mli +++ b/ml-proto/src/given/source.mli @@ -20,6 +20,5 @@ val (@@) : 'a -> region -> 'a phrase val (@@@) : 'a -> region list -> 'a phrase val it : 'a phrase -> 'a -val ito : 'a phrase option -> 'a option val at : 'a phrase -> region val ats : 'a phrase list -> region diff --git a/ml-proto/src/host/parser.mly b/ml-proto/src/host/parser.mly index 125923cb84..64e0466611 100644 --- a/ml-proto/src/host/parser.mly +++ b/ml-proto/src/host/parser.mly @@ -164,9 +164,8 @@ oper : | LABEL expr_block { fun c -> Label ($2 (anon_label c)) } | LABEL bind_var expr_block /* Sugar */ { fun c -> Label ($3 (bind_label c $2)) } - | BREAK var expr { fun c -> Break ($2 c label, Some ($3 c)) } - | BREAK var { fun c -> Break ($2 c label, None) } - | BREAK { let at = at() in fun c -> Break (0 @@ at, None) } + | BREAK var expr_opt { fun c -> Break ($2 c label, $3 c) } + | BREAK { let at = at() in fun c -> Break (0 @@ at, None) } /* Sugar */ | SWITCH expr arms { let at1 = ati 1 in fun c -> let x, y = $3 c in @@ -174,8 +173,7 @@ oper : | CALL var expr_list { fun c -> Call ($2 c func, $3 c) } | CALLINDIRECT var expr expr_list { fun c -> CallIndirect ($2 c table, $3 c, $4 c) } - | RETURN expr { fun c -> Return (Some ($2 c)) } - | RETURN { fun c -> Return None } + | RETURN expr_opt { fun c -> Return ($2 c) } | GETLOCAL var { fun c -> GetLocal ($2 c local) } | SETLOCAL var expr { fun c -> SetLocal ($2 c local, $3 c) } | LOADGLOBAL var { fun c -> LoadGlobal ($2 c global) } @@ -188,6 +186,10 @@ oper : | COMPARE expr expr { fun c -> Compare ($1, $2 c, $3 c) } | CONVERT expr { fun c -> Convert ($1, $2 c) } ; +expr_opt : + | /* empty */ { fun c -> None } + | expr { fun c -> Some ($1 c) } +; expr_list : | /* empty */ { fun c -> [] } | expr expr_list { fun c -> $1 c :: $2 c } diff --git a/ml-proto/src/host/print.ml b/ml-proto/src/host/print.ml index 57c5d3767a..a97ecf0586 100644 --- a/ml-proto/src/host/print.ml +++ b/ml-proto/src/host/print.ml @@ -13,7 +13,7 @@ open Types let func_type f = let {Ast.params; result; _} = f.it in - {ins = List.map Source.it params; out = ito result} + {ins = List.map Source.it params; out = Lib.Option.map it result} let string_of_table_type = function | None -> "()" diff --git a/ml-proto/src/spec/check.ml b/ml-proto/src/spec/check.ml index 3b684b44b7..756afe1793 100644 --- a/ml-proto/src/spec/check.ml +++ b/ml-proto/src/spec/check.ml @@ -106,7 +106,7 @@ let type_cvt at = function let type_func f = let {params; result; _} = f.it in - {ins = List.map it params; out = ito result} + {ins = List.map it params; out = Lib.Option.map it result} (* Type Analysis *) @@ -268,8 +268,8 @@ and check_memop {ty; mem; align} at = let check_func c f = let {params; result; locals; body = e} = f.it in let c' = {c with locals = List.map it params @ List.map it locals; - return = ito result} in - check_expr c' (ito result) e + return = Lib.Option.map it result} in + check_expr c' (Lib.Option.map it result) e let check_table c tab = match tab.it with diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index f1dd8d6b1e..bc5f3ed8cb 100644 --- a/ml-proto/src/spec/eval.ml +++ b/ml-proto/src/spec/eval.ml @@ -12,7 +12,6 @@ let error = Error.error (* Module Instances *) type value = Values.value -type expr_value = value option type func = Ast.func module ExportMap = Map.Make(String) @@ -30,7 +29,7 @@ type instance = (* Configurations *) -type label = expr_value -> exn +type label = value option -> exn type config = { @@ -57,7 +56,7 @@ let export m x = module MakeLabel () = struct - exception Label of expr_value + exception Label of value option let label v = Label v end @@ -93,7 +92,7 @@ let int32 v at = * e : expr * eo : expr option * v : value - * ev : expr_value + * ev : value option *) let rec eval_expr (c : config) (e : expr) = @@ -130,13 +129,13 @@ let rec eval_expr (c : config) (e : expr) = ) | Call (x, es) -> - let vs = List.map (eval_expr c) es in - eval_func c.modul (func c x) vs e.at + let vs = List.map (fun ev -> some (eval_expr c ev) ev.at) es in + eval_func c.modul (func c x) vs | CallIndirect (x, e1, es) -> let i = int32 (eval_expr c e1) e1.at in - let vs = List.map (eval_expr c) es in - eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs e.at + let vs = List.map (fun ev -> some (eval_expr c ev) ev.at) es in + eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs | Return eo -> raise (c.return (eval_expr_option c eo)) @@ -216,9 +215,9 @@ and eval_arm c ev stage arm = and eval_decl t = ref (default_value t.it) -and eval_func (m : instance) (f : func) (evs : expr_value list) (at : region) = +and eval_func (m : instance) (f : func) (evs : value list) = let module Return = MakeLabel () in - let args = List.map (fun ev -> ref (some ev at)) evs in + let args = List.map (fun v -> ref v) evs in let vars = List.map eval_decl f.it.locals in let locals = args @ vars in let c = {modul = m; locals; labels = []; return = Return.label} in @@ -246,13 +245,12 @@ let init m = {funcs; exports; tables; globals; memory = mem} let invoke m name vs = - let evs = List.map (fun v -> Some v) vs in let f = export m (name @@ no_region) in - eval_func m f evs no_region + eval_func m f vs let eval e = let f = {params = []; result = None; locals = []; body = e} @@ no_region in let memory = Memory.create 0 in let exports = ExportMap.singleton "eval" f in let m = {funcs = [f]; exports; tables = []; globals = []; memory} in - eval_func m f [] e.at + eval_func m f [] diff --git a/ml-proto/src/spec/eval.mli b/ml-proto/src/spec/eval.mli index 99ed16ed8a..145343b888 100644 --- a/ml-proto/src/spec/eval.mli +++ b/ml-proto/src/spec/eval.mli @@ -4,9 +4,8 @@ type instance type value = Values.value -type expr_value = value option val init : Ast.modul -> instance -val invoke : instance -> string -> value list -> expr_value +val invoke : instance -> string -> value list -> value option (* raise Error.Error *) -val eval : Ast.expr -> expr_value (* raise Error.Error *) +val eval : Ast.expr -> value option (* raise Error.Error *) From a4ab03b3ae193a9ce9f6e963e2c073f772e35362 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Mon, 14 Sep 2015 12:25:28 -0500 Subject: [PATCH 4/4] Addressed second round of comments --- ml-proto/src/host/print.ml | 2 +- ml-proto/src/spec/eval.ml | 20 ++++++++++---------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/ml-proto/src/host/print.ml b/ml-proto/src/host/print.ml index a97ecf0586..cf69068628 100644 --- a/ml-proto/src/host/print.ml +++ b/ml-proto/src/host/print.ml @@ -13,7 +13,7 @@ open Types let func_type f = let {Ast.params; result; _} = f.it in - {ins = List.map Source.it params; out = Lib.Option.map it result} + {ins = List.map it params; out = Lib.Option.map it result} let string_of_table_type = function | None -> "()" diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index bc5f3ed8cb..32394ac3ad 100644 --- a/ml-proto/src/spec/eval.ml +++ b/ml-proto/src/spec/eval.ml @@ -92,7 +92,7 @@ let int32 v at = * e : expr * eo : expr option * v : value - * ev : value option + * vo : value option *) let rec eval_expr (c : config) (e : expr) = @@ -116,25 +116,25 @@ let rec eval_expr (c : config) (e : expr) = | Label e1 -> let module L = MakeLabel () in let c' = {c with labels = L.label :: c.labels} in - (try eval_expr c' e1 with L.Label ev -> ev) + (try eval_expr c' e1 with L.Label vo -> vo) | Break (x, eo) -> raise (label c x (eval_expr_option c eo)) | Switch (_t, e1, arms, e2) -> - let ev = some (eval_expr c e1) e1.at in - (match List.fold_left (eval_arm c ev) `Seek arms with + let vo = some (eval_expr c e1) e1.at in + (match List.fold_left (eval_arm c vo) `Seek arms with | `Seek | `Fallthru -> eval_expr c e2 | `Done vs -> vs ) | Call (x, es) -> - let vs = List.map (fun ev -> some (eval_expr c ev) ev.at) es in + let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in eval_func c.modul (func c x) vs | CallIndirect (x, e1, es) -> let i = int32 (eval_expr c e1) e1.at in - let vs = List.map (fun ev -> some (eval_expr c ev) ev.at) es in + let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs | Return eo -> @@ -202,9 +202,9 @@ and eval_expr_option c eo = | Some e -> eval_expr c e | None -> None -and eval_arm c ev stage arm = +and eval_arm c vo stage arm = let {value; expr = e; fallthru} = arm.it in - match stage, ev = value.it with + match stage, vo = value.it with | `Seek, true | `Fallthru, _ -> if fallthru then (ignore (eval_expr c e); `Fallthru) @@ -217,12 +217,12 @@ and eval_decl t = and eval_func (m : instance) (f : func) (evs : value list) = let module Return = MakeLabel () in - let args = List.map (fun v -> ref v) evs in + let args = List.map ref evs in let vars = List.map eval_decl f.it.locals in let locals = args @ vars in let c = {modul = m; locals; labels = []; return = Return.label} in try eval_expr c f.it.body - with Return.Label ev -> ev + with Return.Label vo -> vo (* Modules *)