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/host/lexer.mll b/ml-proto/host/lexer.mll index c2c4ca94d2..57ae850f7c 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 a5bdd9fc91..8d8ec1c134 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -80,16 +80,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 +104,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 +124,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 +136,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 +159,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 +175,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 +253,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 +289,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) } | UNREACHABLE { fun c -> unreachable } | PAGE_SIZE { fun c -> host (PageSize, []) } | MEMORY_SIZE { fun c -> host (MemorySize, []) } @@ -298,23 +307,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 } +; +case_list : + | /* empty */ { fun c -> [] } + | case case_list { fun c -> $1 c :: $2 c } ; -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) } +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 } ; -cases : - | expr { fun c -> [], $1 c } - | case cases { fun c -> let x, y = $2 c in $1 c :: x, y } +target_list : + | /* empty */ { fun c -> [] } + | target target_list { fun c -> let e = $1 c in let es = $2 c in e :: es } ; @@ -450,7 +457,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 155e577930..72f56ee085 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,38 +82,30 @@ 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 *) + | 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 *) | Unreachable (* trap *) - | Host of hostop * expr list (* host interaction *) - -and case = case' Source.phrase -and case' = -{ - value : literal; - expr : expr; - fallthru : bool -} + | 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 a82c92717f..0dc2e29ddb 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -53,8 +53,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 +133,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 +143,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 +201,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 +218,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 - | Unreachable -> () @@ -241,11 +241,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 c079e61659..ebf43e3e74 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) - | Unreachable -> Trap.error e.at "unreachable executed" @@ -261,16 +264,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..0568f8625a 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 = diff --git a/ml-proto/spec/sugar.ml b/ml-proto/spec/sugar.ml index ff0cef20bb..da02fcbb84 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,26 +98,21 @@ 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 unreachable = Unreachable 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 721790e781..4666e831b3 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,12 +28,10 @@ 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 unreachable : 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") diff --git a/ml-proto/test/unreachable.wast b/ml-proto/test/unreachable.wast index a895aec37a..89dcfb160f 100644 --- a/ml-proto/test/unreachable.wast +++ b/ml-proto/test/unreachable.wast @@ -5,7 +5,7 @@ (unreachable)) (func $if (param i32) (result f32) - (if (get_local 0) (unreachable) (f32.const 0))) + (if_else (get_local 0) (unreachable) (f32.const 0))) (func $block (block (i32.const 1) (unreachable) (i32.const 2)))