From 8bc9465566dd63640ef0880b21972115776db6b0 Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Mon, 26 Oct 2015 15:35:34 +0100 Subject: [PATCH 1/2] Implement changes to control flow operators --- ml-proto/README.md | 44 ++++++++----------- ml-proto/given/lib.ml | 7 +++ ml-proto/given/lib.mli | 1 + ml-proto/host/lexer.mll | 7 +-- ml-proto/host/parser.mly | 68 +++++++++++++++++------------ ml-proto/spec/ast.ml | 60 +++++++++++--------------- ml-proto/spec/check.ml | 39 +++++++++-------- ml-proto/spec/eval.ml | 43 ++++++++----------- ml-proto/spec/int.ml | 8 +++- ml-proto/spec/sugar.ml | 42 ++++++++++++------ ml-proto/spec/sugar.mli | 15 ++++--- ml-proto/test/fac.wast | 16 ++++--- ml-proto/test/forward.wast | 4 +- ml-proto/test/labels.wast | 44 +++++++++++-------- ml-proto/test/memory.wast | 6 ++- ml-proto/test/switch.wast | 88 ++++++++++++++++++++++++++++++-------- 16 files changed, 289 insertions(+), 203 deletions(-) diff --git a/ml-proto/README.md b/ml-proto/README.md index e0076549d5..3e3c5b3190 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -82,24 +82,11 @@ Note however that the REPL currently is too dumb to allow multi-line input. :) See `wasm -h` for (the few) options. -## Language - -For most part, the language understood by the interpreter is based on Ben's V8 prototype, but I took the liberty to try out a few simplifications and generalisations: - -* *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. - -* *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. - -* *Switch with Explicit Fallthru*. By default, a switch arm is well-behaved in that it does *not* fall through to the next case. However, it can be marked as fallthru explicitly. - - ## Core Language vs External Language The implementation tries to separate the concern of what is the language (and its semantics) from what is its external encoding. In that spirit, the actual AST is regular and minimal, while certain abbreviations are considered "syntactic sugar" of an external representation optimised for compactness. -For example, `if` always has an else-branch in the AST, but in the external format an else-less conditional is allowed as an abbreviation for one with `nop`. Similarly, blocks can sometimes be left implicit in sub-expressions. Furthermore, fallthru is a flag on each `switch` arm in the AST, but an explicit "opcode" in the external form. +For example, `if` always has an else-branch in the AST, but in the external format an else-less conditional is allowed as an abbreviation for one with `nop`. Similarly, blocks can sometimes be left implicit in sub-expressions. Here, the external format is S-expressions, but similar considerations would apply to a binary encoding. That is, there would be codes for certain abbreviations, but these are just a matter of the encoding. @@ -132,18 +119,19 @@ expr: ( nop ) ( block + ) ( block + ) ;; = (label (block +)) - ( if ) - ( if ) ;; = (if (nop)) - ( loop * ) ;; = (loop (block *)) - ( loop ? * ) ;; = (label (loop (block ? *))) + ( if_else ) + ( if ) ;; = (if_else (nop)) + ( br_if ) ;; = (if_else (br ) (nop)) + ( loop ? * ) ;; = (loop ? (block *)) + ( loop * ) ;; = (label (loop (block *))) ( label ? ) - ( break ? ) - ( .switch * ) - ( .switch * ) ;; = (label (.switch * )) + ( br ? ) + ( return ? ) ;; = (br ?) + ( tableswitch * ) + ( tableswitch * ) ;; = (label (tableswitch *)) ( call * ) ( call_import * ) ( call_indirect * ) - ( return ? ) ;; = (break ?) ( get_local ) ( set_local ) ( .load((8|16)_)? ? ? ) @@ -157,9 +145,15 @@ expr: ( memory_size ) ( grow_memory ) +switch: + ( table * ) + +target: + ( case ) + ( br ) ;; = (case ) with (case (br )) + case: - ( case * fallthrough? ) ;; = (case (block *) fallthrough?) - ( case ) ;; = (case (nop) fallthrough) + ( case ? * ) ;; = (case ? (block *)) func: ( func ? ? * ? * * ) type: ( type ) @@ -225,7 +219,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 (or rather, a list thereof, because of multi-values), and checking each expression against that. An expected empty list of types 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]`, `memory.ml[i]`). Evaluation of control transfer (`break` 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`, `arithmetic.ml[i]`, `memory.ml[i]`). 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`, `script.ml[i]`, `error.ml`, `print.ml[i]`, `flags.ml`). Executes scripts, reports results or errors, etc. diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index c8b82e24cd..7414fe5928 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -50,6 +50,13 @@ struct let app f = function | Some x -> f x | None -> () + + let compare cmp_a o1 o2 = + match o1, o2 with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some x1, Some x2 -> cmp_a x1 x2 end module Int = diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 6818d46939..7a9e770f65 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -20,6 +20,7 @@ sig val get : 'a option -> 'a -> 'a val map : ('a -> 'b) -> 'a option -> 'b option val app : ('a -> unit) -> 'a option -> unit + val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int end module Int : diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 357678418a..228aef0f4d 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -134,11 +134,13 @@ rule token = parse | "nop" { NOP } | "block" { BLOCK } | "if" { IF } + | "if_else" { IF_ELSE } | "loop" { LOOP } | "label" { LABEL } - | "break" { BREAK } + | "br" { BR } + | "br_if" { BR_IF } + | "tableswitch" { TABLESWITCH } | "case" { CASE } - | "fallthrough" { FALLTHROUGH } | "call" { CALL } | "call_import" { CALL_IMPORT } | "call_indirect" { CALL_INDIRECT } @@ -158,7 +160,6 @@ rule token = parse | "offset="(digits as s) { OFFSET (Int64.of_string s) } | "align="(digits as s) { ALIGN (int_of_string s) } - | (nxx as t)".switch" { SWITCH (value_type t) } | (nxx as t)".const" { CONST (value_type t) } | (ixx as t)".clz" { UNARY (intop t Int32Op.Clz Int64Op.Clz) } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 8f097b94bb..84ae7d1611 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -49,6 +49,11 @@ let literal s t = | Failure msg -> error s.at ("constant out of range: " ^ msg) | _ -> error s.at "constant out of range" +let int32 s = + try I32.of_string s.it with + | Failure msg -> error s.at ("constant out of range: " ^ msg) + | _ -> error s.at "constant out of range" + (* Memory operands *) @@ -80,16 +85,19 @@ let empty_types () = {tmap = VarMap.empty; tlist = []} type context = {types : types; funcs : space; imports : space; locals : space; - labels : int VarMap.t} + labels : int VarMap.t; cases : space} -let c0 () = +let empty_context () = {types = empty_types (); funcs = empty (); imports = empty (); - locals = empty (); labels = VarMap.empty} + locals = empty (); labels = VarMap.empty; cases = empty ()} let enter_func c = assert (VarMap.is_empty c.labels); {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()} +let enter_switch c = + {c with cases = empty ()} + let type_ c x = try VarMap.find x.it c.types.tmap with Not_found -> error x.at ("unknown type " ^ x.it) @@ -101,6 +109,7 @@ let lookup category space 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 case c x = lookup "case" c.cases x let label c x = try VarMap.find x.it c.labels with Not_found -> error x.at ("unknown label " ^ x.it) @@ -120,6 +129,7 @@ let bind category space x = 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_case c x = bind "case" c.cases x let bind_label c x = {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} @@ -131,6 +141,7 @@ 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_case c = anon c.cases 1 let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} let empty_type = {ins = []; out = None} @@ -153,7 +164,7 @@ let implicit_decl c t at = %} %token INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR -%token NOP BLOCK IF LOOP LABEL BREAK SWITCH CASE FALLTHROUGH +%token NOP BLOCK IF IF_ELSE LOOP LABEL BR BR_IF TABLESWITCH CASE %token CALL CALL_IMPORT CALL_INDIRECT RETURN %token GET_LOCAL SET_LOCAL LOAD STORE LOAD_EXTEND STORE_WRAP OFFSET ALIGN %token CONST UNARY BINARY COMPARE CONVERT @@ -169,12 +180,11 @@ let implicit_decl c t at = %token VAR %token VALUE_TYPE %token CONST -%token SWITCH %token UNARY %token BINARY +%token SELECT %token COMPARE %token CONVERT -%token SELECT %token LOAD %token STORE %token LOAD_EXTEND @@ -248,21 +258,25 @@ expr1 : | NOP { fun c -> nop } | BLOCK labeling expr expr_list { fun c -> let c', l = $2 c in block (l, $3 c' :: $4 c') } - | IF expr expr expr_opt { fun c -> if_ ($2 c, $3 c, $4 c) } + | IF_ELSE expr expr expr { fun c -> if_else ($2 c, $3 c, $4 c) } + | IF expr expr { fun c -> if_ ($2 c, $3 c) } + | BR_IF expr var { fun c -> br_if ($2 c, $3 c label) } | LOOP labeling labeling expr_list { fun c -> let c', l1 = $2 c in let c'', l2 = $3 c' in - loop (l1, l2, $4 c'') } + let c''' = if l1.it = Unlabelled then anon_label c'' else c'' in + loop (l1, l2, $4 c''') } | LABEL labeling expr { fun c -> let c', l = $2 c in let c'' = if l.it = Unlabelled then anon_label c' else c' in Sugar.label ($3 c'') } - | BREAK var expr_opt { fun c -> break ($2 c label, $3 c) } + | BR var expr_opt { fun c -> br ($2 c label, $3 c) } | RETURN expr_opt { let at1 = ati 1 in fun c -> return (label c ("return" @@ at1) @@ at1, $2 c) } - | SWITCH labeling expr cases - { fun c -> let c', l = $2 c in let cs, e = $4 c' in - switch (l, $1, $3 c', List.map (fun a -> a $1) cs, e) } + | TABLESWITCH labeling expr LPAR TABLE case_list RPAR case target_list + { fun c -> let c', l = $2 c in let e = $3 c' in + let c'' = enter_switch c' in let es = $9 c'' in + tableswitch (l, e, $6 c'', $8 c'', es) } | 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 @@ -280,9 +294,9 @@ expr1 : | CONST literal { fun c -> const (literal $2 $1) } | UNARY expr { fun c -> unary ($1, $2 c) } | BINARY expr expr { fun c -> binary ($1, $2 c, $3 c) } + | SELECT expr expr expr { fun c -> select ($1, $2 c, $3 c, $4 c) } | COMPARE expr expr { fun c -> compare ($1, $2 c, $3 c) } | CONVERT expr { fun c -> convert ($1, $2 c) } - | SELECT expr expr expr { fun c -> select ($1, $2 c, $3 c, $4 c) } | PAGE_SIZE { fun c -> host (PageSize, []) } | MEMORY_SIZE { fun c -> host (MemorySize, []) } | GROW_MEMORY expr { fun c -> host (GrowMemory, [$2 c]) } @@ -297,23 +311,21 @@ expr_list : | expr expr_list { fun c -> $1 c :: $2 c } ; -fallthrough : - | /* empty */ { false } - | FALLTHROUGH { true } -; - case : - | LPAR case1 RPAR { let at = at () in fun c t -> $2 c t @@ at } + | LPAR CASE var RPAR { let at = at () in fun c -> Case ($3 c case) @@ at } + | LPAR BR var RPAR { let at = at () in fun c -> Case_br ($3 c label) @@ at } ; -case1 : - | CASE literal expr expr_list fallthrough - { fun c t -> case (literal $2 t, Some ($3 c :: $4 c, $5)) } - | CASE literal - { fun c t -> case (literal $2 t, None) } +case_list : + | /* empty */ { fun c -> [] } + | case case_list { fun c -> $1 c :: $2 c } ; -cases : - | expr { fun c -> [], $1 c } - | case cases { fun c -> let x, y = $2 c in $1 c :: x, y } +target : + | LPAR CASE expr_list RPAR { fun c -> anon_case c; $3 c } + | LPAR CASE bind_var expr_list RPAR { fun c -> bind_case c $3; $4 c } +; +target_list : + | /* empty */ { fun c -> [] } + | target target_list { fun c -> let e = $1 c in let es = $2 c in e :: es } ; @@ -449,7 +461,7 @@ module_fields : | None -> {m with memory = Some $1} } ; module_ : - | LPAR MODULE module_fields RPAR { $3 (c0 ()) @@ at () } + | LPAR MODULE module_fields RPAR { $3 (empty_context ()) @@ at () } ; diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index f153a25c13..0b1bf7bddb 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -36,22 +36,22 @@ struct type unop = Clz | Ctz | Popcnt type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU | And | Or | Xor | Shl | ShrU | ShrS + type selop = Select type relop = Eq | Ne | LtS | LtU | LeS | LeU | GtS | GtU | GeS | GeU type cvt = ExtendSInt32 | ExtendUInt32 | WrapInt64 | TruncSFloat32 | TruncUFloat32 | TruncSFloat64 | TruncUFloat64 | ReinterpretFloat - type selectop = Select end module FloatOp () = struct type unop = Neg | Abs | Ceil | Floor | Trunc | Nearest | Sqrt type binop = Add | Sub | Mul | Div | CopySign | Min | Max + type selop = Select type relop = Eq | Ne | Lt | Le | Gt | Ge type cvt = ConvertSInt32 | ConvertUInt32 | ConvertSInt64 | ConvertUInt64 | PromoteFloat32 | DemoteFloat64 | ReinterpretInt - type selectop = Select end module Int32Op = IntOp () @@ -63,7 +63,7 @@ type unop = (Int32Op.unop, Int64Op.unop, Float32Op.unop, Float64Op.unop) op type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op -type selectop = (Int32Op.selectop, Int64Op.selectop, Float32Op.selectop, Float64Op.selectop) op +type selop = (Int32Op.selop, Int64Op.selop, Float32Op.selop, Float64Op.selop) op type memop = {ty : value_type; offset : Memory.offset; align : int option} type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} @@ -82,37 +82,29 @@ type literal = value Source.phrase type expr = expr' Source.phrase and expr' = - | Nop (* do nothing *) - | Block of expr list (* execute in sequence *) - | If of expr * expr * expr (* conditional *) - | Loop of expr (* infinite loop *) - | Label of expr (* labelled expression *) - | Break of var * expr option (* break to n-th surrounding label *) - | Switch of value_type * expr * case list * expr (* switch, latter expr is default *) - | 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 *) - | 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 *) - | Compare of relop * expr * expr (* arithmetic comparison *) - | Convert of cvt * expr (* conversion *) - | Select of selectop * expr * expr * expr (* branchless conditional *) - | Host of hostop * expr list (* host interaction *) - -and case = case' Source.phrase -and case' = -{ - value : literal; - expr : expr; - fallthru : bool -} + | Nop (* do nothing *) + | Block of expr list (* execute in sequence *) + | If of expr * expr * expr (* conditional *) + | Loop of expr (* infinite loop *) + | Label of expr (* labelled expression *) + | Break of var * expr option (* break to n-th surrounding label *) + | Switch of expr * var list * var * expr list (* table switch *) + | 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 *) + | 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 *) + | Select of selop * expr * expr * expr (* branchless conditional *) + | Compare of relop * expr * expr (* arithmetic comparison *) + | Convert of cvt * expr (* conversion *) + | Host of hostop * expr list (* host interaction *) (* Functions and Modules *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 574e877eba..9e855d5668 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -39,6 +39,12 @@ let import c x = lookup "import" c.imports x let local c x = lookup "local" c.locals x let label c x = lookup "label" c.labels x +module CaseSet = Set.Make( + struct + type t = I32.t option + let compare = Lib.Option.compare I32.compare_u + end) + (* Type comparison *) @@ -53,8 +59,8 @@ let check_type actual expected at = let type_value = Values.type_of let type_unop = Values.type_of let type_binop = Values.type_of +let type_selop = Values.type_of let type_relop = Values.type_of -let type_selectop = Values.type_of let type_cvt at = function | Values.Int32 cvt -> @@ -133,7 +139,8 @@ let rec check_expr c et e = check_expr c et e3 | Loop e1 -> - check_expr c None e1 + let c' = {c with labels = None :: c.labels} in + check_expr c' et e1 | Label e1 -> let c' = {c with labels = et :: c.labels} in @@ -142,12 +149,11 @@ let rec check_expr c et e = | Break (x, eo) -> check_expr_opt c (label c x) eo e.at - | Switch (t, e1, cs, e2) -> - require (t = Int32Type || t = Int64Type) e.at "invalid switch type"; - (* TODO: Check that cases are unique. *) - check_expr c (Some t) e1; - List.iter (check_case c t et) cs; - check_expr c et e2 + | Switch (e1, xs, x, es) -> + List.iter (fun x -> require (x.it < List.length es) x.at "invalid target") + (x :: xs); + check_expr c (Some Int32Type) e1; + ignore (List.fold_right (fun e et -> check_expr c et e; None) es et) | Call (x, es) -> let {ins; out} = func c x in @@ -201,6 +207,12 @@ let rec check_expr c et e = check_expr c (Some t) e2; check_type (Some t) et e.at + | Select (selop, e1, e2, e3) -> + let t = type_selop selop in + check_expr c (Some Int32Type) e1; + check_expr c (Some t) e2; + check_expr c (Some t) e3 + | Compare (relop, e1, e2) -> let t = type_relop relop in check_expr c (Some t) e1; @@ -212,12 +224,6 @@ let rec check_expr c et e = check_expr c (Some t1) e1; check_type (Some t) et e.at - | Select (selectop, e1, e2, e3) -> - let t = type_selectop selectop in - check_expr c (Some Int32Type) e1; - check_expr c (Some t) e2; - check_expr c (Some t) e3 - | Host (hostop, es) -> let ({ins; out}, hasmem) = type_hostop hostop in if hasmem then @@ -238,11 +244,6 @@ and check_expr_opt c et eo at = and check_literal c et l = check_type (Some (type_value l.it)) et l.at -and check_case c t et case = - let {value = l; expr = e; fallthru} = case.it in - check_literal c (Some t) l; - check_expr c (if fallthru then None else et) e - and check_load c et memop e1 at = check_has_memory c at; check_memop memop at; diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index efe9e7caf8..cb9cb25f33 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -146,11 +146,12 @@ let rec eval_expr (c : config) (e : expr) = | If (e1, e2, e3) -> let i = int32 (eval_expr c e1) e1.at in - eval_expr c (if i <> Int32.zero then e2 else e3) + eval_expr c (if i <> 0l then e2 else e3) | Loop e1 -> - ignore (eval_expr c e1); - eval_expr c e + 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) | Label e1 -> let module L = MakeLabel () in @@ -160,12 +161,14 @@ let rec eval_expr (c : config) (e : expr) = | Break (x, eo) -> raise (label c x (eval_expr_opt c eo)) - | Switch (_t, e1, cs, e2) -> - let vo = some (eval_expr c e1) e1.at in - (match List.fold_left (eval_case c vo) `Seek cs with - | `Seek | `Fallthru -> eval_expr c e2 - | `Done vs -> vs - ) + | Switch (e1, xs, x, es) -> + let i = int32 (eval_expr c e1) e1.at in + let x' = + if I32.ge_u i (Int32.of_int (List.length xs)) then x + else List.nth xs (Int32.to_int i) + in + if x'.it >= List.length es then Crash.error e.at "invalid switch target"; + List.fold_left (fun vo e -> eval_expr c e) None (Lib.List.drop x'.it es) | Call (x, es) -> let vs = List.map (fun vo -> some (eval_expr c vo) vo.at) es in @@ -233,6 +236,12 @@ let rec eval_expr (c : config) (e : expr) = (try Some (Arithmetic.eval_binop binop v1 v2) with exn -> arithmetic_error e.at e1.at e2.at exn) + | Select (selop, e1, e2, e3) -> + let cond = int32 (eval_expr c e1) e1.at in + let v1 = some (eval_expr c e2) e2.at in + let v2 = some (eval_expr c e3) e3.at in + Some (if cond <> 0l then v1 else v2) + | Compare (relop, e1, e2) -> let v1 = some (eval_expr c e1) e1.at in let v2 = some (eval_expr c e2) e2.at in @@ -244,12 +253,6 @@ let rec eval_expr (c : config) (e : expr) = (try Some (Arithmetic.eval_cvt cvt v1) with exn -> arithmetic_error e.at e1.at e1.at exn) - | Select (selectop, e1, e2, e3) -> - let cond = int32 (eval_expr c e1) e1.at in - let v1 = some (eval_expr c e2) e2.at in - let v2 = some (eval_expr c e3) e3.at in - Some (if cond <> Int32.zero then v1 else v2) - | Host (hostop, es) -> let vs = List.map (eval_expr c) es in eval_hostop c hostop vs e.at @@ -258,16 +261,6 @@ and eval_expr_opt c = function | Some e -> eval_expr c e | None -> None -and eval_case c vo stage case = - let {value; expr = e; fallthru} = case.it in - match stage, vo = value.it with - | `Seek, true | `Fallthru, _ -> - if fallthru - then (ignore (eval_expr c e); `Fallthru) - else `Done (eval_expr c e) - | `Seek, false | `Done _, _ -> - stage - 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 diff --git a/ml-proto/spec/int.ml b/ml-proto/spec/int.ml index 3618d48f3f..7fbac65c4c 100644 --- a/ml-proto/spec/int.ml +++ b/ml-proto/spec/int.ml @@ -24,7 +24,7 @@ sig val of_string : string -> t val to_string : t -> string - val bitwidth : int + val bitwidth : int end module type S = @@ -64,6 +64,9 @@ sig val ge_s : t -> t -> bool val ge_u : t -> t -> bool + val compare_s : t -> t -> int + val compare_u : t -> t -> int + val of_int : int -> t val of_string : string -> t val to_string : t -> string @@ -194,4 +197,7 @@ struct let to_string = Rep.to_string let of_int = Rep.of_int + + let compare_s = compare + let compare_u x y = compare (Rep.add x Rep.min_int) (Rep.add y Rep.min_int) end diff --git a/ml-proto/spec/sugar.ml b/ml-proto/spec/sugar.ml index 7e0ad43c55..db136a3bfc 100644 --- a/ml-proto/spec/sugar.ml +++ b/ml-proto/spec/sugar.ml @@ -5,6 +5,10 @@ open Ast type labeling = labeling' phrase and labeling' = Unlabelled | Labelled +type case = case' phrase +and case' = Case of var | Case_br of var + + let labeling l e = match l.it with | Unlabelled -> e @@ -23,25 +27,40 @@ let nop = let block (l, es) = labeling l (Block es) -let if_ (e1, e2, eo) = - let e3 = Lib.Option.get eo (Nop @@ Source.after e2.at) in +let if_else (e1, e2, e3) = If (e1, e2, e3) +let if_ (e1, e2) = + If (e1, e2, Nop @@ Source.after e2.at) + +let br_if (e, x) = + if_ (e, Break (x, None) @@ x.at) + let loop (l1, l2, es) = let e = expr_seq es in - labeling l1 (Loop (labeling l2 e.it @@ e.at)) + if l2.it = Unlabelled then Loop e else labeling l1 (Loop e) let label e = Label e -let break (x, e) = +let br (x, e) = Break (x, e) let return (x, eo) = Break (x, eo) -let switch (l, t, e1, cs, e2) = - labeling l (Switch (t, e1, cs, e2)) +let tableswitch (l, e, cs, c, es) = + let case c (xs, es') = + match c.it with + | Case x -> x :: xs, es' + | Case_br x -> + (List.length es' @@ c.at) :: xs, (Break (x, None) @@ c.at) :: es' + in + let xs, es' = List.fold_right case (c :: cs) ([], []) in + let es'' = List.map expr_seq es in + let n = List.length es' in + let sh x = (if x.it >= n then x.it + n else x.it) @@ x.at in + labeling l (Switch (e, List.map sh (List.tl xs), sh (List.hd xs), es' @ es'')) let call (x, es) = Call (x, es) @@ -79,23 +98,18 @@ let unary (unop, e) = let binary (binop, e1, e2) = Binary (binop, e1, e2) +let select (selop, cond, e1, e2) = + Select (selop, cond, e1, e2) + let compare (relop, e1, e2) = Compare (relop, e1, e2) let convert (cvt, e) = Convert (cvt, e) -let select (selectop, cond, e1, e2) = - Select (selectop, cond, e1, e2) - let host (hostop, es) = Host (hostop, es) -let case (c, br) = - match br with - | Some (es, fallthru) -> {value = c; expr = expr_seq es; fallthru} - | None -> {value = c; expr = Nop @@ Source.after c.at; fallthru = true} - let func_body es = Label (expr_seq es) diff --git a/ml-proto/spec/sugar.mli b/ml-proto/spec/sugar.mli index c3bc82a0a8..91789a65d3 100644 --- a/ml-proto/spec/sugar.mli +++ b/ml-proto/spec/sugar.mli @@ -3,14 +3,19 @@ open Ast type labeling = labeling' Source.phrase and labeling' = Unlabelled | Labelled +type case = case' Source.phrase +and case' = Case of var | Case_br of var + val nop : expr' val block : labeling * expr list -> expr' -val if_ : expr * expr * expr option -> expr' +val if_else : expr * expr * expr -> expr' +val if_ : expr * expr -> expr' +val br_if : expr * var -> expr' val loop : labeling * labeling * expr list -> expr' val label : expr -> expr' -val break : var * expr option -> expr' +val br : var * expr option -> expr' val return : var * expr option -> expr' -val switch : labeling * value_type * expr * case list * expr -> expr' +val tableswitch : labeling * expr * case list * case * expr list list -> expr' val call : var * expr list -> expr' val call_import : var * expr list -> expr' val call_indirect : var * expr * expr list -> expr' @@ -23,11 +28,9 @@ val store_wrap : wrapop * expr * expr -> expr' val const : literal -> expr' val unary : unop * expr -> expr' val binary : binop * expr * expr -> expr' +val select : selop * expr * expr * expr -> expr' val compare : relop * expr * expr -> expr' val convert : cvt * expr -> expr' -val select : selectop * expr * expr * expr -> expr' val host : hostop * expr list -> expr' -val case : literal * (expr list * bool) option -> case' - val func_body : expr list -> expr' diff --git a/ml-proto/test/fac.wast b/ml-proto/test/fac.wast index 8808c97f79..d5ab0abd3f 100644 --- a/ml-proto/test/fac.wast +++ b/ml-proto/test/fac.wast @@ -3,7 +3,7 @@ (module ;; Recursive factorial (func (param i64) (result i64) - (if (i64.eq (get_local 0) (i64.const 0)) + (if_else (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)))) ) @@ -11,7 +11,7 @@ ;; Recursive factorial named (func $fac-rec (param $n i64) (result i64) - (if (i64.eq (get_local $n) (i64.const 0)) + (if_else (i64.eq (get_local $n) (i64.const 0)) (i64.const 1) (i64.mul (get_local $n) @@ -27,14 +27,15 @@ (set_local 2 (i64.const 1)) (label (loop - (if + (if_else (i64.eq (get_local 1) (i64.const 0)) - (break 0) + (br 1) (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) ) ) (return (get_local 2)) @@ -47,15 +48,16 @@ (set_local $i (get_local $n)) (set_local $res (i64.const 1)) (label $done - (loop - (if + (loop $loop + (if_else (i64.eq (get_local $i) (i64.const 0)) - (break $done) + (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) ) ) (return (get_local $res)) diff --git a/ml-proto/test/forward.wast b/ml-proto/test/forward.wast index 9c49228344..944954abaf 100644 --- a/ml-proto/test/forward.wast +++ b/ml-proto/test/forward.wast @@ -5,14 +5,14 @@ (export "odd" $odd) (func $even (param $n i32) (result i32) - (if (i32.eq (get_local $n) (i32.const 0)) + (if_else (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) - (if (i32.eq (get_local $n) (i32.const 0)) + (if_else (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/labels.wast b/ml-proto/test/labels.wast index e4ca34d9c2..bdfde276a7 100644 --- a/ml-proto/test/labels.wast +++ b/ml-proto/test/labels.wast @@ -1,7 +1,7 @@ (module (func $block (result i32) (block $exit - (break $exit (i32.const 1)) + (br $exit (i32.const 1)) (i32.const 0) ) ) @@ -9,11 +9,12 @@ (func $loop1 (result i32) (local $i i32) (set_local $i (i32.const 0)) - (loop $exit + (loop $exit $cont (set_local $i (i32.add (get_local $i) (i32.const 1))) (if (i32.eq (get_local $i) (i32.const 5)) - (break $exit (get_local $i)) + (br $exit (get_local $i)) ) + (br $cont) ) ) @@ -23,33 +24,37 @@ (loop $exit $cont (set_local $i (i32.add (get_local $i) (i32.const 1))) (if (i32.eq (get_local $i) (i32.const 5)) - (break $cont (i32.const -1)) + (br $cont (i32.const -1)) ) (if (i32.eq (get_local $i) (i32.const 8)) - (break $exit (get_local $i)) + (br $exit (get_local $i)) ) (set_local $i (i32.add (get_local $i) (i32.const 1))) + (br $cont) ) ) (func $switch (param i32) (result i32) (label $ret (i32.mul (i32.const 10) - (i32.switch $exit (get_local 0) - (case 1 (i32.const 1)) - (case 2 (break $exit (i32.const 2))) - (case 3 (break $ret (i32.const 3))) - (i32.const 4) + (tableswitch $exit (get_local 0) + (table (case $0) (case $1) (case $2) (case $3)) (case $default) + (case $1 (i32.const 1)) + (case $2 (br $exit (i32.const 2))) + (case $3 (br $ret (i32.const 3))) + (case $default (i32.const 4)) + (case $0 (i32.const 5)) ) ) ) ) (func $return (param i32) (result i32) - (i32.switch (get_local 0) - (case 1 (return (i32.const 1))) - (case 2 (i32.const 2)) - (i32.const 3) + (tableswitch (get_local 0) + (table (case $0) (case $1)) (case $default) + (case $0 (return (i32.const 0))) + (case $1 (i32.const 1)) + (case $default (i32.const 2)) ) ) @@ -63,12 +68,13 @@ (assert_return (invoke "block") (i32.const 1)) (assert_return (invoke "loop1") (i32.const 5)) (assert_return (invoke "loop2") (i32.const 8)) -(assert_return (invoke "switch" (i32.const 1)) (i32.const 10)) +(assert_return (invoke "switch" (i32.const 0)) (i32.const 50)) +(assert_return (invoke "switch" (i32.const 1)) (i32.const 20)) (assert_return (invoke "switch" (i32.const 2)) (i32.const 20)) (assert_return (invoke "switch" (i32.const 3)) (i32.const 3)) -(assert_return (invoke "switch" (i32.const 4)) (i32.const 40)) -(assert_return (invoke "switch" (i32.const 5)) (i32.const 40)) -(assert_return (invoke "return" (i32.const 1)) (i32.const 1)) +(assert_return (invoke "switch" (i32.const 4)) (i32.const 50)) +(assert_return (invoke "switch" (i32.const 5)) (i32.const 50)) +(assert_return (invoke "return" (i32.const 0)) (i32.const 0)) +(assert_return (invoke "return" (i32.const 1)) (i32.const 2)) (assert_return (invoke "return" (i32.const 2)) (i32.const 2)) -(assert_return (invoke "return" (i32.const 3)) (i32.const 3)) diff --git a/ml-proto/test/memory.wast b/ml-proto/test/memory.wast index b09cd1488e..7ddc338307 100644 --- a/ml-proto/test/memory.wast +++ b/ml-proto/test/memory.wast @@ -98,7 +98,7 @@ (loop (if (i32.eq (get_local 0) (i32.const 0)) - (break 0) + (br 1) ) (set_local 2 (i32.mul (get_local 0) (i32.const 4))) (i32.store (get_local 2) (get_local 0)) @@ -108,6 +108,7 @@ (return (i32.const 0)) ) (set_local 0 (i32.sub (get_local 0) (i32.const 1))) + (br 0) ) ) (return (i32.const 1)) @@ -121,7 +122,7 @@ (loop (if (i32.eq (get_local 0) (i32.const 0)) - (break 0) + (br 1) ) (set_local 2 (f64.convert_s/i32 (get_local 0))) (f64.store align=1 (get_local 0) (get_local 2)) @@ -131,6 +132,7 @@ (return (i32.const 0)) ) (set_local 0 (i32.sub (get_local 0) (i32.const 1))) + (br 0) ) ) (return (i32.const 1)) diff --git a/ml-proto/test/switch.wast b/ml-proto/test/switch.wast index 9a13fec3b5..6e0961556c 100644 --- a/ml-proto/test/switch.wast +++ b/ml-proto/test/switch.wast @@ -6,15 +6,18 @@ (local $j i32) (set_local $j (i32.const 100)) (label - (i32.switch (get_local $i) - (case 0 (return (get_local $i))) - (case 1 (nop) fallthrough) - (case 2) ;; implicit fallthrough - (case 3 (set_local $j (i32.sub (i32.const 0) (get_local $i))) (break 0)) - (case 4 (break 0)) - (case 5 (set_local $j (i32.const 101))) - (case 6 (set_local $j (i32.const 101)) fallthrough) - (;default;) (set_local $j (i32.const 102)) + (tableswitch (get_local $i) + (table (case $0) (case $1) (case $2) (case $3) (case $4) + (case $5) (case $6) (case $7)) (case $default) + (case $0 (return (get_local $i))) + (case $1 (nop)) ;; fallthrough + (case $2) ;; fallthrough + (case $3 (set_local $j (i32.sub (i32.const 0) (get_local $i))) (br 0)) + (case $4 (br 0)) + (case $5 (br 0 (set_local $j (i32.const 101)))) + (case $6 (set_local $j (i32.const 101))) ;; fallthrough + (case $default (set_local $j (i32.const 102))) + (case $7) ) ) (return (get_local $j)) @@ -26,20 +29,63 @@ (set_local $j (i64.const 100)) (return (label $l - (i64.switch (get_local $i) - (case 0 (return (get_local $i))) - (case 1 (nop) fallthrough) - (case 2) ;; implicit fallthrough - (case 3 (break $l (i64.sub (i64.const 0) (get_local $i)))) - (case 6 (set_local $j (i64.const 101)) fallthrough) - (;default;) (get_local $j) + (tableswitch (i32.wrap/i64 (get_local $i)) + (table (case $0) (case $1) (case $2) (case $3) (case $4) + (case $5) (case $6) (case $7)) (case $default) + (case $0 (return (get_local $i))) + (case $1 (nop)) ;; fallthrough + (case $2) ;; fallthrough + (case $3 (br $l (i64.sub (i64.const 0) (get_local $i)))) + (case $6 (set_local $j (i64.const 101))) ;; fallthrough + (case $4) ;; fallthrough + (case $5) ;; fallthrough + (case $default (br $l (get_local $j))) + (case $7 (i64.const -5)) ) ) ) ) + ;; Corner cases + (func $corner (result i32) + (local $x i32) + (tableswitch (i32.const 0) + (table) (case $default) + (case $default) + ) + (tableswitch (i32.const 0) + (table) (case $default) + (case $default (set_local $x (i32.add (get_local $x) (i32.const 1)))) + ) + (tableswitch (i32.const 1) + (table (case $0)) (case $default) + (case $default (set_local $x (i32.add (get_local $x) (i32.const 2)))) + (case $0 (set_local $x (i32.add (get_local $x) (i32.const 4)))) + ) + (get_local $x) + ) + + ;; Break + (func $break (result i32) + (local $x i32) + (tableswitch $l (i32.const 0) + (table) (br $l) + ) + (tableswitch $l (i32.const 0) + (table (br $l)) (case $default) + (case $default (set_local $x (i32.add (get_local $x) (i32.const 1)))) + ) + (tableswitch $l (i32.const 1) + (table (case $0)) (br $l) + (case $0 (set_local $x (i32.add (get_local $x) (i32.const 2)))) + ) + (get_local $x) + ) + (export "stmt" $stmt) (export "expr" $expr) + (export "corner" $corner) + (export "break" $break) ) (assert_return (invoke "stmt" (i32.const 0)) (i32.const 0)) @@ -49,7 +95,7 @@ (assert_return (invoke "stmt" (i32.const 4)) (i32.const 100)) (assert_return (invoke "stmt" (i32.const 5)) (i32.const 101)) (assert_return (invoke "stmt" (i32.const 6)) (i32.const 102)) -(assert_return (invoke "stmt" (i32.const 7)) (i32.const 102)) +(assert_return (invoke "stmt" (i32.const 7)) (i32.const 100)) (assert_return (invoke "stmt" (i32.const -10)) (i32.const 102)) (assert_return (invoke "expr" (i64.const 0)) (i64.const 0)) @@ -57,5 +103,11 @@ (assert_return (invoke "expr" (i64.const 2)) (i64.const -2)) (assert_return (invoke "expr" (i64.const 3)) (i64.const -3)) (assert_return (invoke "expr" (i64.const 6)) (i64.const 101)) -(assert_return (invoke "expr" (i64.const 7)) (i64.const 100)) +(assert_return (invoke "expr" (i64.const 7)) (i64.const -5)) (assert_return (invoke "expr" (i64.const -10)) (i64.const 100)) + +(assert_return (invoke "corner") (i32.const 7)) +(assert_return (invoke "break") (i32.const 0)) + +(assert_invalid (module (func (tableswitch (i32.const 0) (table) (case 0)))) "invalid target") +(assert_invalid (module (func (tableswitch (i32.const 0) (table) (case 1) (case)))) "invalid target") From 9ceec9dc805e697c00d7ce3a698d2269e7a801ee Mon Sep 17 00:00:00 2001 From: Andreas Rossberg Date: Fri, 6 Nov 2015 08:09:19 +0100 Subject: [PATCH 2/2] Remove dead code --- ml-proto/given/lib.ml | 7 ------- ml-proto/given/lib.mli | 1 - ml-proto/host/parser.mly | 5 ----- ml-proto/spec/check.ml | 6 ------ ml-proto/spec/int.ml | 6 ------ 5 files changed, 25 deletions(-) diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index 7414fe5928..c8b82e24cd 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -50,13 +50,6 @@ struct let app f = function | Some x -> f x | None -> () - - let compare cmp_a o1 o2 = - match o1, o2 with - | None, None -> 0 - | None, Some _ -> -1 - | Some _, None -> 1 - | Some x1, Some x2 -> cmp_a x1 x2 end module Int = diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 7a9e770f65..6818d46939 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -20,7 +20,6 @@ sig val get : 'a option -> 'a -> 'a val map : ('a -> 'b) -> 'a option -> 'b option val app : ('a -> unit) -> 'a option -> unit - val compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int end module Int : diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 84ae7d1611..36f8b673fc 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -49,11 +49,6 @@ let literal s t = | Failure msg -> error s.at ("constant out of range: " ^ msg) | _ -> error s.at "constant out of range" -let int32 s = - try I32.of_string s.it with - | Failure msg -> error s.at ("constant out of range: " ^ msg) - | _ -> error s.at "constant out of range" - (* Memory operands *) diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index 9e855d5668..f979020928 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -39,12 +39,6 @@ let import c x = lookup "import" c.imports x let local c x = lookup "local" c.locals x let label c x = lookup "label" c.labels x -module CaseSet = Set.Make( - struct - type t = I32.t option - let compare = Lib.Option.compare I32.compare_u - end) - (* Type comparison *) diff --git a/ml-proto/spec/int.ml b/ml-proto/spec/int.ml index 7fbac65c4c..0568f8625a 100644 --- a/ml-proto/spec/int.ml +++ b/ml-proto/spec/int.ml @@ -64,9 +64,6 @@ sig val ge_s : t -> t -> bool val ge_u : t -> t -> bool - val compare_s : t -> t -> int - val compare_u : t -> t -> int - val of_int : int -> t val of_string : string -> t val to_string : t -> string @@ -197,7 +194,4 @@ struct let to_string = Rep.to_string let of_int = Rep.of_int - - let compare_s = compare - let compare_u x y = compare (Rep.add x Rep.min_int) (Rep.add y Rep.min_int) end