diff --git a/ml-proto/host/builtins.ml b/ml-proto/host/builtins.ml index 61619cbdb7..ae7528b0ea 100644 --- a/ml-proto/host/builtins.ml +++ b/ml-proto/host/builtins.ml @@ -1,6 +1,6 @@ open Source +open Kernel open Types -open Ast module Unknown = Error.Make () exception Unknown = Unknown.Error (* indicates unknown import name *) diff --git a/ml-proto/host/builtins.mli b/ml-proto/host/builtins.mli index 36d8d9db71..87057790a9 100644 --- a/ml-proto/host/builtins.mli +++ b/ml-proto/host/builtins.mli @@ -1,3 +1,3 @@ exception Unknown of Source.region * string -val match_imports : Ast.module_ -> Eval.import list (* raises Unknown *) +val match_imports : Kernel.module_ -> Eval.import list (* raises Unknown *) diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index f8d6e2c3e8..1539274b23 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -1,6 +1,6 @@ { open Parser -open Ast +open Kernel let convert_pos pos = { Source.file = pos.Lexing.pos_fname; diff --git a/ml-proto/host/main.ml b/ml-proto/host/main.ml index 3a484f8ffb..0c4302a208 100644 --- a/ml-proto/host/main.ml +++ b/ml-proto/host/main.ml @@ -33,8 +33,10 @@ let process file source = try Script.trace "Parsing..."; let script = parse file source in + Script.trace "Desugaring..."; + let script' = Script.desugar script in Script.trace "Running..."; - Script.run script; + Script.run script'; true with | Script.Syntax (at, msg) -> error at "syntax error" msg diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 11e1dd95e6..5bbda9c55d 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -1,8 +1,8 @@ %{ open Source -open Ast -open Sugar open Types +open Kernel +open Ast open Script @@ -171,15 +171,15 @@ let implicit_decl c t at = %token VAR %token VALUE_TYPE %token CONST -%token UNARY -%token BINARY -%token SELECT -%token COMPARE -%token CONVERT -%token LOAD -%token STORE -%token LOAD_EXTEND -%token STORE_WRAP +%token UNARY +%token BINARY +%token SELECT +%token COMPARE +%token CONVERT +%token LOAD +%token STORE +%token LOAD_EXTEND +%token STORE_WRAP %token OFFSET %token ALIGN @@ -246,52 +246,52 @@ expr : | LPAR expr1 RPAR { let at = at () in fun c -> $2 c @@ at } ; expr1 : - | NOP { fun c -> nop } + | NOP { fun c -> Nop } | BLOCK labeling expr expr_list - { fun c -> let c', l = $2 c in block (l, $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) } + { fun c -> let c', l = $2 c in Block (l, $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 let c''' = if l1.it = Unlabelled then anon_label c'' else c'' in - loop (l1, l2, $4 c''') } + 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'') } - | BR var expr_opt { fun c -> br ($2 c label, $3 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) } + fun c -> Return (label c ("return" @@ at1) @@ at1, $2 c) } | TABLESWITCH labeling expr LPAR TABLE target_list RPAR target case_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) } + 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 - { fun c -> call_indirect ($2 c type_, $3 c, $4 c) } - | GET_LOCAL var { fun c -> get_local ($2 c local) } - | SET_LOCAL var expr { fun c -> set_local ($2 c local, $3 c) } + { fun c -> Call_indirect ($2 c type_, $3 c, $4 c) } + | GET_LOCAL var { fun c -> Get_local ($2 c local) } + | SET_LOCAL var expr { fun c -> Set_local ($2 c local, $3 c) } | LOAD offset align expr - { fun c -> load (memop $1 $2 $3, $4 c) } + { fun c -> Load (memop $1 $2 $3, $4 c) } | STORE offset align expr expr - { fun c -> store (memop $1 $2 $3, $4 c, $5 c) } + { fun c -> Store (memop $1 $2 $3, $4 c, $5 c) } | LOAD_EXTEND offset align expr - { fun c -> load_extend (extop $1 $2 $3, $4 c) } + { fun c -> Load_extend (extop $1 $2 $3, $4 c) } | STORE_WRAP offset align expr expr - { fun c -> store_wrap (wrapop $1 $2 $3, $4 c, $5 c) } - | 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) } - | UNREACHABLE { fun c -> unreachable } - | MEMORY_SIZE { fun c -> host (MemorySize, []) } - | GROW_MEMORY expr { fun c -> host (GrowMemory, [$2 c]) } - | HAS_FEATURE TEXT { fun c -> host (HasFeature $2, []) } + { fun c -> Store_wrap (wrapop $1 $2 $3, $4 c, $5 c) } + | 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) } + | UNREACHABLE { fun c -> Unreachable } + | MEMORY_SIZE { fun c -> Host (MemorySize, []) } + | GROW_MEMORY expr { fun c -> Host (GrowMemory, [$2 c]) } + | HAS_FEATURE TEXT { fun c -> Host (HasFeature $2, []) } ; expr_opt : | /* empty */ { fun c -> None } @@ -324,10 +324,8 @@ case_list : func_fields : | expr_list - { let at = at () in - empty_type, - fun c -> let body = Sugar.func_body ($1 c) @@ at in - {ftype = -1 @@ at; locals = []; body} } + { empty_type, + fun c -> {ftype = -1 @@ at(); locals = []; body = $1 c} } | LPAR PARAM value_type_list RPAR func_fields { {(fst $5) with ins = $3 @ (fst $5).ins}, fun c -> anon_locals c $3; (snd $5) c } diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 7ed206a9eb..74ec2df49e 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -1,4 +1,4 @@ -open Ast +open Kernel open Source open Printf diff --git a/ml-proto/host/print.mli b/ml-proto/host/print.mli index bf2f74d3d4..1e2903b036 100644 --- a/ml-proto/host/print.mli +++ b/ml-proto/host/print.mli @@ -1,4 +1,4 @@ -val print_module : Ast.module_ -> unit -val print_module_sig : Ast.module_ -> unit +val print_module : Kernel.module_ -> unit +val print_module_sig : Kernel.module_ -> unit val print_value : Values.value option -> unit diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index ab223c34a0..d37494d61f 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -3,16 +3,31 @@ open Source (* Script representation *) -type command = command' phrase -and command' = - | Define of Ast.module_ - | Invoke of string * Ast.literal list - | AssertInvalid of Ast.module_ * string - | AssertReturn of string * Ast.literal list * Ast.literal option - | AssertReturnNaN of string * Ast.literal list - | AssertTrap of string * Ast.literal list * string +type 'm command = 'm command' Source.phrase +and 'm command' = + | Define of 'm + | Invoke of string * Kernel.literal list + | AssertInvalid of 'm * string + | AssertReturn of string * Kernel.literal list * Kernel.literal option + | AssertReturnNaN of string * Kernel.literal list + | AssertTrap of string * Kernel.literal list * string -type script = command list +type script = Ast.module_ command list +type script' = Kernel.module_ command list + + +(* Desugaring *) + +let rec desugar_cmd c = desugar_cmd' c.it @@ c.at +and desugar_cmd' = function + | Define m -> Define (Desugar.desugar m) + | Invoke (s, ls) -> Invoke (s, ls) + | AssertInvalid (m, r) -> AssertInvalid (Desugar.desugar m, r) + | AssertReturn (s, ls, lo) -> AssertReturn (s, ls, lo) + | AssertReturnNaN (s, ls) -> AssertReturnNaN (s, ls) + | AssertTrap (s, ls, r) -> AssertTrap (s, ls, r) + +let desugar = List.map desugar_cmd (* Execution *) @@ -32,7 +47,7 @@ let get_module at = match !current_module with | None -> raise (Eval.Crash (at, "no module defined to invoke")) -let run_command cmd = +let run_cmd cmd = match cmd.it with | Define m -> trace "Checking..."; @@ -107,7 +122,7 @@ let run_command cmd = AssertFailure.error cmd.at "expected runtime trap" ) -let dry_command cmd = +let dry_cmd cmd = match cmd.it with | Define m -> Check.check_module m; @@ -119,4 +134,4 @@ let dry_command cmd = | AssertTrap _ -> () let run script = - List.iter (if !Flags.dry then dry_command else run_command) script + List.iter (if !Flags.dry then dry_cmd else run_cmd) script diff --git a/ml-proto/host/script.mli b/ml-proto/host/script.mli index ae65c9c215..d941636522 100644 --- a/ml-proto/host/script.mli +++ b/ml-proto/host/script.mli @@ -1,18 +1,21 @@ -type command = command' Source.phrase -and command' = - | Define of Ast.module_ - | Invoke of string * Ast.literal list - | AssertInvalid of Ast.module_ * string - | AssertReturn of string * Ast.literal list * Ast.literal option - | AssertReturnNaN of string * Ast.literal list - | AssertTrap of string * Ast.literal list * string +type 'm command = 'm command' Source.phrase +and 'm command' = + | Define of 'm + | Invoke of string * Kernel.literal list + | AssertInvalid of 'm * string + | AssertReturn of string * Kernel.literal list * Kernel.literal option + | AssertReturnNaN of string * Kernel.literal list + | AssertTrap of string * Kernel.literal list * string -type script = command list +type script = Ast.module_ command list +type script' = Kernel.module_ command list + +val desugar : script -> script' exception Syntax of Source.region * string exception AssertFailure of Source.region * string -val run : script -> unit +val run : script' -> unit (* raises Check.Invalid, Eval.Trap, Eval.Crash, Failure *) val trace : string -> unit diff --git a/ml-proto/spec/arithmetic.ml b/ml-proto/spec/arithmetic.ml index a662b35842..521a67a2ad 100644 --- a/ml-proto/spec/arithmetic.ml +++ b/ml-proto/spec/arithmetic.ml @@ -26,7 +26,7 @@ let f64_of_value n = module Int32Op = struct - open Ast.Int32Op + open Kernel.Int32Op let unop op = let f = match op with @@ -88,7 +88,7 @@ end module Int64Op = struct - open Ast.Int64Op + open Kernel.Int64Op let unop op = let f = match op with @@ -153,7 +153,7 @@ end module Float32Op = struct - open Ast.Float32Op + open Kernel.Float32Op let unop op = let f = match op with @@ -207,7 +207,7 @@ end module Float64Op = struct - open Ast.Float64Op + open Kernel.Float64Op let unop op = let f = match op with diff --git a/ml-proto/spec/arithmetic.mli b/ml-proto/spec/arithmetic.mli index fce5039818..677c8f474e 100644 --- a/ml-proto/spec/arithmetic.mli +++ b/ml-proto/spec/arithmetic.mli @@ -2,7 +2,7 @@ open Values exception TypeError of int * value * Types.value_type -val eval_unop : Ast.unop -> value -> value -val eval_binop : Ast.binop -> value -> value -> value -val eval_relop : Ast.relop -> value -> value -> bool -val eval_cvt : Ast.cvt -> value -> value +val eval_unop : Kernel.unop -> value -> value +val eval_binop : Kernel.binop -> value -> value -> value +val eval_relop : Kernel.relop -> value -> value -> bool +val eval_cvt : Kernel.cvt -> value -> value diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index e3aaa7240d..36f5ac63d1 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -1,145 +1,64 @@ -(* - * Throughout the implementation we use consistent naming conventions for - * syntactic elements, associated with the types defined here and in a few - * other places: - * - * x : var - * v : value - * e : expr - * f : func - * m : module_ - * - * t : value_type - * s : func_type - * c : context / config - * - * These conventions mostly follow standard practice in language semantics. - *) - - -open Values - - -(* Types *) - -type value_type = Types.value_type - - -(* Operators *) - -module IntOp () = -struct - type unop = Clz | Ctz | Popcnt - type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU - | And | Or | Xor | Shl | 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 -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 -end - -module Int32Op = IntOp () -module Int64Op = IntOp () -module Float32Op = FloatOp () -module Float64Op = FloatOp () - -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 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} -type wrapop = {memop : memop; sz : Memory.mem_size} -type hostop = - | MemorySize (* inquire current size of linear memory *) - | GrowMemory (* grow linear memory *) - | HasFeature of string (* test for feature availability *) +(* Expressions *) +type var = Kernel.var -(* Expressions *) +type labeling = labeling' Source.phrase +and labeling' = Unlabelled | Labelled -type var = int Source.phrase -type literal = value Source.phrase +type target = target' Source.phrase +and target' = Case of var | Case_br of var 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 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 *) - - -(* Functions and Modules *) - -type memory = memory' Source.phrase -and memory' = -{ - initial : Memory.size; - max : Memory.size; - segments : segment list; -} -and segment = Memory.segment Source.phrase + | Nop + | Block of labeling * expr list + | If of expr * expr + | If_else of expr * expr * expr + | Br_if of expr * var + | Loop of labeling * labeling * expr list + | Label of expr + | Br of var * expr option + | Return of var * expr option + | Tableswitch of labeling * expr * target list * target * expr list list + | Call of var * expr list + | Call_import of var * expr list + | Call_indirect of var * expr * expr list + | Get_local of var + | Set_local of var * expr + | Load of Kernel.memop * expr + | Store of Kernel.memop * expr * expr + | Load_extend of Kernel.extop * expr + | Store_wrap of Kernel.wrapop * expr * expr + | Const of Kernel.literal + | Unary of Kernel.unop * expr + | Binary of Kernel.binop * expr * expr + | Select of Kernel.selop * expr * expr * expr + | Compare of Kernel.relop * expr * expr + | Convert of Kernel.cvt * expr + | Unreachable + | Host of Kernel.hostop * expr list + + +(* Functions *) type func = func' Source.phrase and func' = { ftype : var; - locals : value_type list; - body : expr; + locals :Types.value_type list; + body : expr list; } -type export = export' Source.phrase -and export' = {name : string; func : var} -type import = import' Source.phrase -and import' = -{ - itype : var; - module_name : string; - func_name : string; -} +(* Modules *) -type module_ = module_' Source.phrase -and module_' = +type module_ = module' Source.phrase +and module' = { - memory : memory option; + memory : Kernel.memory option; types : Types.func_type list; funcs : func list; - imports : import list; - exports : export list; + imports : Kernel.import list; + exports : Kernel.export list; table : var list; } diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index bf29cb5ce4..e9de483ef0 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -1,4 +1,4 @@ -open Ast +open Kernel open Source open Types @@ -217,9 +217,8 @@ let rec check_expr c et e = () | Host (hostop, es) -> - let ({ins; out}, hasmem) = type_hostop hostop in - if hasmem then - check_has_memory c e.at; + let {ins; out}, has_mem = type_hostop hostop in + if has_mem then check_has_memory c e.at; check_exprs c ins es; check_type out et e.at diff --git a/ml-proto/spec/check.mli b/ml-proto/spec/check.mli index 3db17e284d..06b8f0969f 100644 --- a/ml-proto/spec/check.mli +++ b/ml-proto/spec/check.mli @@ -1,3 +1,3 @@ exception Invalid of Source.region * string -val check_module : Ast.module_ -> unit (* raise Invalid *) +val check_module : Kernel.module_ -> unit (* raise Invalid *) diff --git a/ml-proto/spec/desugar.ml b/ml-proto/spec/desugar.ml new file mode 100644 index 0000000000..35789d4803 --- /dev/null +++ b/ml-proto/spec/desugar.ml @@ -0,0 +1,78 @@ +open Source + +module A = Ast +module K = Kernel + + +(* Expressions *) + +let labeling l e' = + match l.it with + | A.Unlabelled -> e' + | A.Labelled -> K.Label (e' @@ l.at) + + +let rec expr e = expr' e.it @@ e.at +and expr' = function + | A.Nop -> K.Nop + | A.Block (l, es) -> labeling l (K.Block (List.map expr es)) + | A.If (e1, e2) -> K.If (expr e1, expr e2, K.Nop @@ Source.after e2.at) + | A.If_else (e1, e2, e3) -> K.If (expr e1, expr e2, expr e3) + | A.Br_if (e, x) -> expr' (A.If (e, A.Br (x, None) @@ x.at)) + | A.Loop (l1, l2, es) when l2.it = A.Unlabelled -> K.Loop (seq es) + | A.Loop (l1, l2, es) -> labeling l1 (K.Loop (seq es)) + | A.Label e -> K.Label (expr e) + | A.Br (x, eo) -> K.Break (x, Lib.Option.map expr eo) + | A.Return (x, eo) -> K.Break (x, Lib.Option.map expr eo) + | A.Tableswitch (l, e, ts, t, es) -> + let target t (xs, es') = + match t.it with + | A.Case x -> x :: xs, es' + | A.Case_br x -> + (List.length es' @@ t.at) :: xs, (K.Break (x, None) @@ t.at) :: es' + in + let xs, es' = List.fold_right target (t :: ts) ([], []) in + let es'' = List.map 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 + (K.Switch (expr e, List.map sh (List.tl xs), sh (List.hd xs), es' @ es'')) + | A.Call (x, es) -> K.Call (x, List.map expr es) + | A.Call_import (x, es) -> K.CallImport (x, List.map expr es) + | A.Call_indirect (x, e, es) -> K.CallIndirect (x, expr e, List.map expr es) + | A.Get_local x -> K.GetLocal x + | A.Set_local (x, e) -> K.SetLocal (x, expr e) + | A.Load (memop, e) -> K.Load (memop, expr e) + | A.Store (memop, e1, e2) -> K.Store (memop, expr e1, expr e2) + | A.Load_extend (extop, e) -> K.LoadExtend (extop, expr e) + | A.Store_wrap (wrapop, e1, e2) -> K.StoreWrap (wrapop, expr e1, expr e2) + | A.Const c -> K.Const c + | A.Unary (unop, e) -> K.Unary (unop, expr e) + | A.Binary (binop, e1, e2) -> K.Binary (binop, expr e1, expr e2) + | A.Select (selop, e1, e2, e3) -> K.Select (selop, expr e1, expr e2, expr e3) + | A.Compare (relop, e1, e2) -> K.Compare (relop, expr e1, expr e2) + | A.Convert (cvt, e) -> K.Convert (cvt, expr e) + | A.Unreachable -> K.Unreachable + | A.Host (hostop, es) -> K.Host (hostop, List.map expr es) + +and seq = function + | [] -> K.Nop @@ Source.no_region + | [e] -> expr e + | es -> K.Block (List.map expr es) @@@ List.map Source.at es + + +(* Functions and Modules *) + +let rec func f = func' f.it @@ f.at +and func' = function + | {A.body = []; ftype; locals} -> + {K.body = K.Nop @@ no_region; ftype; locals} + | {A.body = es; ftype; locals} -> + {K.body = K.Label (seq es) @@@ List.map at es; ftype; locals} + +let rec module_ m = module' m.it @@ m.at +and module' = function + | {A.funcs = fs; memory; types; imports; exports; table} -> + {K.funcs = List.map func fs; memory; types; imports; exports; table} + +let desugar = module_ diff --git a/ml-proto/spec/desugar.mli b/ml-proto/spec/desugar.mli new file mode 100644 index 0000000000..b3abdf41e9 --- /dev/null +++ b/ml-proto/spec/desugar.mli @@ -0,0 +1 @@ +val desugar : Ast.module_ -> Kernel.module_ diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index a6e9d3c292..12cf6da8eb 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -1,6 +1,6 @@ open Values open Types -open Ast +open Kernel open Source @@ -313,7 +313,7 @@ let add_export funcs ex = ExportMap.add ex.it.name (List.nth funcs ex.it.func.it) let init m imports host = - assert (List.length imports = List.length m.it.Ast.imports); + assert (List.length imports = List.length m.it.Kernel.imports); let {memory; funcs; exports; _} = m.it in {module_ = m; imports; diff --git a/ml-proto/spec/eval.mli b/ml-proto/spec/eval.mli index ae856b9663..1c0e029f53 100644 --- a/ml-proto/spec/eval.mli +++ b/ml-proto/spec/eval.mli @@ -8,7 +8,7 @@ type host_params = { exception Trap of Source.region * string exception Crash of Source.region * string -val init : Ast.module_ -> import list -> host_params -> instance +val init : Kernel.module_ -> import list -> host_params -> instance val invoke : instance -> string -> value list -> value option (* raises Trap, Crash *) diff --git a/ml-proto/spec/kernel.ml b/ml-proto/spec/kernel.ml new file mode 100644 index 0000000000..bcc7bbffe7 --- /dev/null +++ b/ml-proto/spec/kernel.ml @@ -0,0 +1,145 @@ +(* + * Throughout the implementation we use consistent naming conventions for + * syntactic elements, associated with the types defined here and in a few + * other places: + * + * x : var + * v : value + * e : expr + * f : func + * m : module_ + * + * t : value_type + * s : func_type + * c : context / config + * + * These conventions mostly follow standard practice in language semantics. + *) + + +open Values + + +(* Types *) + +type value_type = Types.value_type + + +(* Operators *) + +module IntOp () = +struct + type unop = Clz | Ctz | Popcnt + type binop = Add | Sub | Mul | DivS | DivU | RemS | RemU + | And | Or | Xor | Shl | 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 +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 +end + +module Int32Op = IntOp () +module Int64Op = IntOp () +module Float32Op = FloatOp () +module Float64Op = FloatOp () + +type unop = (Int32Op.unop, Int64Op.unop, Float32Op.unop, Float64Op.unop) op +type binop = (Int32Op.binop, Int64Op.binop, Float32Op.binop, Float64Op.binop) op +type selop = (Int32Op.selop, Int64Op.selop, Float32Op.selop, Float64Op.selop) op +type relop = (Int32Op.relop, Int64Op.relop, Float32Op.relop, Float64Op.relop) op +type cvt = (Int32Op.cvt, Int64Op.cvt, Float32Op.cvt, Float64Op.cvt) op + +type memop = {ty : value_type; offset : Memory.offset; align : int option} +type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} +type wrapop = {memop : memop; sz : Memory.mem_size} +type hostop = + | MemorySize (* inquire current size of linear memory *) + | GrowMemory (* grow linear memory *) + | HasFeature of string (* test for feature availability *) + + +(* Expressions *) + +type var = int Source.phrase +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 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 *) + + +(* Functions and Modules *) + +type memory = memory' Source.phrase +and memory' = +{ + initial : Memory.size; + max : Memory.size; + segments : segment list; +} +and segment = Memory.segment Source.phrase + +type func = func' Source.phrase +and func' = +{ + ftype : var; + locals : value_type list; + body : expr; +} + +type export = export' Source.phrase +and export' = {name : string; func : var} + +type import = import' Source.phrase +and import' = +{ + itype : var; + module_name : string; + func_name : string; +} + +type module_ = module_' Source.phrase +and module_' = +{ + memory : memory option; + types : Types.func_type list; + funcs : func list; + imports : import list; + exports : export list; + table : var list; +} diff --git a/ml-proto/spec/sugar.ml b/ml-proto/spec/sugar.ml deleted file mode 100644 index 2e65b8831a..0000000000 --- a/ml-proto/spec/sugar.ml +++ /dev/null @@ -1,118 +0,0 @@ -open Source -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 - | Labelled -> Label (e @@ l.at) - -let expr_seq es = - match es with - | [] -> Nop @@ Source.no_region - | [e] -> e - | es -> Block es @@@ List.map Source.at es - - -let nop = - Nop - -let block (l, es) = - labeling l (Block es) - -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 - if l2.it = Unlabelled then Loop e else labeling l1 (Loop e) - -let label e = - Label e - -let br (x, e) = - Break (x, e) - -let return (x, eo) = - Break (x, eo) - -let tableswitch (l, e, ts, t, es) = - let translate_target t (xs, es') = - match t.it with - | Case x -> x :: xs, es' - | Case_br x -> - (List.length es' @@ t.at) :: xs, (Break (x, None) @@ t.at) :: es' - in - let xs, es' = List.fold_right translate_target (t :: ts) ([], []) 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) - -let call_import (x, es) = - CallImport (x, es) - -let call_indirect (x, e, es) = - CallIndirect (x, e, es) - -let get_local x = - GetLocal x - -let set_local (x, e) = - SetLocal (x, e) - -let load (memop, e) = - Load (memop, e) - -let store (memop, e1, e2) = - Store (memop, e1, e2) - -let load_extend (extop, e) = - LoadExtend (extop, e) - -let store_wrap (wrapop, e1, e2) = - StoreWrap (wrapop, e1, e2) - -let const c = - Const c - -let unary (unop, e) = - 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 unreachable = - Unreachable - -let host (hostop, es) = - Host (hostop, es) - - -let func_body es = - Label (expr_seq es) diff --git a/ml-proto/spec/sugar.mli b/ml-proto/spec/sugar.mli deleted file mode 100644 index 4666e831b3..0000000000 --- a/ml-proto/spec/sugar.mli +++ /dev/null @@ -1,37 +0,0 @@ -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_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 br : var * expr option -> expr' -val return : var * expr option -> 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' -val get_local : var -> expr' -val set_local : var * expr -> expr' -val load : memop * expr -> expr' -val store : memop * expr * expr -> expr' -val load_extend : extop * expr -> expr' -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 unreachable : expr' -val host : hostop * expr list -> expr' - -val func_body : expr list -> expr'