From cd5c8db5745314f36cc1ff13acfcf78fdc055380 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 7 Oct 2015 18:23:17 -0500 Subject: [PATCH 1/5] Move signatures into module types table --- ml-proto/given/lib.ml | 9 + ml-proto/given/lib.mli | 2 + ml-proto/host/builtins.ml | 13 +- ml-proto/host/builtins.mli | 2 +- ml-proto/host/lexer.mll | 10 +- ml-proto/host/parser.mly | 186 ++++++++++++------ ml-proto/host/print.ml | 25 ++- ml-proto/host/script.ml | 2 +- ml-proto/spec/ast.ml | 14 +- ml-proto/spec/check.ml | 37 ++-- ml-proto/spec/eval.ml | 36 ++-- .../test/expected-output/func_ptrs.wast.log | 1 + ml-proto/test/func_ptrs.wast | 27 +++ 13 files changed, 239 insertions(+), 125 deletions(-) create mode 100644 ml-proto/test/expected-output/func_ptrs.wast.log create mode 100644 ml-proto/test/func_ptrs.wast diff --git a/ml-proto/given/lib.ml b/ml-proto/given/lib.ml index 1258cd30dc..c8b82e24cd 100644 --- a/ml-proto/given/lib.ml +++ b/ml-proto/given/lib.ml @@ -25,6 +25,15 @@ struct | x::[] -> [], x | x::xs -> let ys, y = split_last xs in x::ys, y | [] -> failwith "split_last" + + let rec index_of x xs = + index_of' x xs 0 + + and index_of' x xs i = + match xs with + | [] -> None + | y::xs' when x = y -> Some i + | y::xs' -> index_of' x xs' (i+1) end module Option = diff --git a/ml-proto/given/lib.mli b/ml-proto/given/lib.mli index 702f8038fd..6818d46939 100644 --- a/ml-proto/given/lib.mli +++ b/ml-proto/given/lib.mli @@ -11,6 +11,8 @@ sig val last : 'a list -> 'a (* raise Failure *) val split_last : 'a list -> 'a list * 'a (* raise Failure *) + + val index_of : 'a -> 'a list -> int option end module Option : diff --git a/ml-proto/host/builtins.ml b/ml-proto/host/builtins.ml index e44f3489ca..922472a750 100644 --- a/ml-proto/host/builtins.ml +++ b/ml-proto/host/builtins.ml @@ -1,20 +1,23 @@ open Source +open Types +open Ast let print vs = List.iter Print.print_value (List.map (fun v -> Some v) vs); None -let match_import i = - let {Ast.module_name; func_name; func_params; func_result} = i.it in +let match_import m i = + let {module_name; func_name; itype} = i.it in + let {ins; out} = List.nth m.it.types itype.it in if module_name <> "stdio" then Error.error i.at ("no builtin module \"" ^ module_name ^ "\""); match func_name with | "print" -> - if func_result <> None then + if out <> None then Error.error i.at "stdio.print has no result"; print | _ -> Error.error i.at ("no \"stdio." ^ func_name ^ "\"") -let match_imports (is : Ast.import list) = - List.map match_import is +let match_imports m = + List.map (match_import m) m.it.imports diff --git a/ml-proto/host/builtins.mli b/ml-proto/host/builtins.mli index 90815b9170..9794db4d7c 100644 --- a/ml-proto/host/builtins.mli +++ b/ml-proto/host/builtins.mli @@ -1 +1 @@ -val match_imports : Ast.import list -> Eval.import list +val match_imports : Ast.module_ -> Eval.import list diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index 7dc6b40b4a..d193d82448 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -122,10 +122,10 @@ rule token = parse | '"'character*'\\'_ { error_nest (Lexing.lexeme_end_p lexbuf) lexbuf "illegal escape" } - | "i32" { TYPE Types.Int32Type } - | "i64" { TYPE Types.Int64Type } - | "f32" { TYPE Types.Float32Type } - | "f64" { TYPE Types.Float64Type } + | "i32" { VALUE_TYPE Types.Int32Type } + | "i64" { VALUE_TYPE Types.Int64Type } + | "f32" { VALUE_TYPE Types.Float32Type } + | "f64" { VALUE_TYPE Types.Float64Type } | "nop" { NOP } | "block" { BLOCK } @@ -241,6 +241,8 @@ rule token = parse | "memory_size" { MEMORY_SIZE } | "grow_memory" { GROW_MEMORY } + | "type" { TYPE } + | "types" { TYPES } | "func" { FUNC } | "param" { PARAM } | "result" { RESULT } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 5e90197d74..9d3a07405f 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -6,6 +6,7 @@ open Source open Ast open Sugar +open Types open Script @@ -35,10 +36,10 @@ let parse_error s = Error.error Source.no_region s let literal s t = try match t with - | Types.Int32Type -> Values.Int32 (I32.of_string s.it) @@ s.at - | Types.Int64Type -> Values.Int64 (I64.of_string s.it) @@ s.at - | Types.Float32Type -> Values.Float32 (F32.of_string s.it) @@ s.at - | Types.Float64Type -> Values.Float64 (F64.of_string s.it) @@ s.at + | Int32Type -> Values.Int32 (I32.of_string s.it) @@ s.at + | Int64Type -> Values.Int64 (I64.of_string s.it) @@ s.at + | Float32Type -> Values.Float32 (F32.of_string s.it) @@ s.at + | Float64Type -> Values.Float64 (F64.of_string s.it) @@ s.at with | Failure reason -> Error.error s.at ("constant out of range: " ^ reason) | _ -> Error.error s.at "constant out of range" @@ -47,19 +48,31 @@ let literal s t = (* Symbolic variables *) module VarMap = Map.Make(String) + type space = {mutable map : int VarMap.t; mutable count : int} +let empty () = {map = VarMap.empty; count = 0} + +type types = {mutable tmap : int VarMap.t; mutable tlist : Types.func_type list} +let empty_types () = {tmap = VarMap.empty; tlist = []} type context = - {funcs : space; imports : space; locals : space; labels : int VarMap.t} + {types : types; funcs : space; imports : space; locals : space; + labels : int VarMap.t} -let empty () = {map = VarMap.empty; count = 0} let c0 () = - {funcs = empty (); imports = empty (); + {types = empty_types (); funcs = empty (); imports = empty (); locals = empty (); labels = VarMap.empty} -let enter_func c = +let do_func c ftype f at = + assert (VarMap.is_empty c.labels); + let c' = {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()} in + let func = f c' in assert (VarMap.is_empty c.labels); - {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()} + {func with ftype} @@ at + +let lookup_type c x = + try VarMap.find x.it c.types.tmap + with Not_found -> Error.error x.at ("unknown type " ^ x.it) let lookup category space x = try VarMap.find x.it space.map @@ -73,6 +86,12 @@ let label c x = try VarMap.find x.it c.labels with Not_found -> Error.error x.at ("unknown label " ^ x.it) +let bind_type c x ty = + if VarMap.mem x.it c.types.tmap then + Error.error x.at ("duplicate type " ^ x.it); + c.types.tmap <- VarMap.add x.it (List.length c.types.tlist) c.types.tmap; + c.types.tlist <- c.types.tlist @ [ty] + let bind category space x = if VarMap.mem x.it space.map then Error.error x.at ("duplicate " ^ category ^ " " ^ x.it); @@ -85,20 +104,41 @@ let bind_local c x = bind "local" c.locals x let bind_label c x = {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)} +let anon_type c ty = + c.types.tlist <- c.types.tlist @ [ty] + let anon space n = space.count <- space.count + n let anon_func c = anon c.funcs 1 let anon_import c = anon c.imports 1 let anon_locals c ts = anon c.locals (List.length ts) let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} + +let empty_type = {ins = []; out = None} + +let explicit_decl c name t at = + let i = name c lookup_type in + if i.it < List.length c.types.tlist && + t <> empty_type && + t <> List.nth c.types.tlist i.it then + Error.error at "signature mismatch"; + i + +let implicit_decl c t at = + match Lib.List.index_of t c.types.tlist with + | None -> let i = List.length c.types.tlist in anon_type c t; i @@ at + | Some i -> i @@ at + + %} -%token INT FLOAT TEXT VAR TYPE LPAR RPAR +%token INT FLOAT TEXT VAR VALUE_TYPE LPAR RPAR %token NOP BLOCK IF LOOP LABEL BREAK SWITCH CASE FALLTHROUGH %token CALL CALL_IMPORT CALL_INDIRECT RETURN %token GET_LOCAL SET_LOCAL LOAD STORE %token CONST UNARY BINARY COMPARE CONVERT -%token FUNC PARAM RESULT LOCAL MODULE MEMORY SEGMENT IMPORT EXPORT TABLE +%token FUNC TYPE PARAM RESULT LOCAL +%token MODULE MEMORY TYPES SEGMENT IMPORT EXPORT TABLE %token PAGE_SIZE MEMORY_SIZE GROW_MEMORY %token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE %token EOF @@ -107,7 +147,7 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} %token FLOAT %token TEXT %token VAR -%token TYPE +%token VALUE_TYPE %token CONST %token SWITCH %token UNARY @@ -129,12 +169,19 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} /* Types */ -value_type : - | TYPE { $1 @@ at () } -; value_type_list : | /* empty */ { [] } - | value_type value_type_list { $1 :: $2 } + | VALUE_TYPE value_type_list { $1 :: $2 } +; +func_params : + | LPAR PARAM value_type_list RPAR { $3 } +; +func_result : + | /* empty */ { None } + | LPAR RESULT VALUE_TYPE RPAR { Some $3 } +; +func_type : + | func_params func_result { {ins = $1; out = $2} } ; @@ -182,9 +229,8 @@ expr1 : { let at1 = ati 1 in fun c -> return (label c ("return" @@ at1) @@ at1, $2 c) } | SWITCH labeling expr cases - { let at1 = ati 1 in - fun c -> let c', l = $2 c in let cs, e = $4 c' in - switch (l, $1 @@ at1, $3 c', List.map (fun a -> a $1) cs, e) } + { 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) } | 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 @@ -238,35 +284,49 @@ cases : func_fields : | expr_list { let at = at () in - fun c -> - {params = []; result = None; locals = []; - body = Sugar.func_body ($1 c) @@ at} } + empty_type, + fun c -> let body = Sugar.func_body ($1 c) @@ at in + {ftype = -1 @@ at; locals = []; body} } | LPAR PARAM value_type_list RPAR func_fields - { fun c -> anon_locals c $3; let f = $5 c in - {f with params = $3 @ f.params} } - | LPAR PARAM bind_var value_type RPAR func_fields /* Sugar */ - { fun c -> bind_local c $3; let f = $6 c in - {f with params = $4 :: f.params} } - | LPAR RESULT value_type RPAR func_fields - { let at = at () in - fun c -> let f = $5 c in - match f.result with - | Some _ -> Error.error at "more than one return type" - | None -> {f with result = Some $3} } + { {(fst $5) with ins = $3 @ (fst $5).ins}, + fun c -> anon_locals c $3; (snd $5) c } + | LPAR PARAM bind_var VALUE_TYPE RPAR func_fields /* Sugar */ + { {(fst $6) with ins = $4 :: (fst $6).ins}, + fun c -> bind_local c $3; (snd $6) c } + | LPAR RESULT VALUE_TYPE RPAR func_fields + { if (fst $5).out <> None then + Error.error (at ()) "more than one return type"; + {(fst $5) with out = Some $3}, + fun c -> (snd $5) c } | LPAR LOCAL value_type_list RPAR func_fields - { fun c -> anon_locals c $3; let f = $5 c in - {f with locals = $3 @ f.locals} } - | LPAR LOCAL bind_var value_type RPAR func_fields /* Sugar */ - { fun c -> bind_local c $3; let f = $6 c in - {f with locals = $4 :: f.locals} } + { fst $5, + fun c -> anon_locals c $3; let f = (snd $5) c in + {f with locals = $3 @ f.locals} } + | LPAR LOCAL bind_var VALUE_TYPE RPAR func_fields /* Sugar */ + { fst $6, + fun c -> bind_local c $3; let f = (snd $6) c in + {f with locals = $4 :: f.locals} } +; +type_decl : + | LPAR TYPE var RPAR { $3 } ; func : - | LPAR FUNC func_fields RPAR + | LPAR FUNC type_decl func_fields RPAR { let at = at () in - fun c -> anon_func c; fun () -> $3 (enter_func c) @@ at } + fun c -> anon_func c; let t = explicit_decl c $3 (fst $4) at in + fun () -> do_func c t (snd $4) at } + | LPAR FUNC bind_var type_decl func_fields RPAR /* Sugar */ + { let at = at () in + fun c -> bind_func c $3; let t = explicit_decl c $4 (fst $5) at in + fun () -> do_func c t (snd $5) at } + | LPAR FUNC func_fields RPAR /* Sugar */ + { let at = at () in + fun c -> anon_func c; let t = implicit_decl c (fst $3) at in + fun () -> do_func c t (snd $3) at } | LPAR FUNC bind_var func_fields RPAR /* Sugar */ { let at = at () in - fun c -> bind_func c $3; fun () -> $4 (enter_func c) @@ at } + fun c -> bind_func c $3; let t = implicit_decl c (fst $4) at in + fun () -> do_func c t (snd $4) at } ; @@ -290,22 +350,32 @@ memory : @@ at () } ; -func_params : - | LPAR PARAM value_type_list RPAR { $3 } -; -func_result : - | /* empty */ { None } - | LPAR RESULT value_type RPAR { Some $3 } +type_list : + | /* empty */ + { fun c -> () } + | LPAR FUNC func_type RPAR type_list + { fun c -> anon_type c $3; $5 c } + | LPAR FUNC bind_var func_type RPAR type_list /* Sugar */ + { fun c -> bind_type c $3 $4; $6 c } ; + import : - | LPAR IMPORT bind_var TEXT TEXT func_params func_result RPAR - { let at = at () in fun c -> bind_import c $3; - {module_name = $4; func_name = $5; func_params = $6; func_result = $7 } - @@ at } - | LPAR IMPORT TEXT TEXT func_params func_result RPAR /* Sugar */ - { let at = at () in fun c -> anon_import c; - {module_name = $3; func_name = $4; func_params = $5; func_result = $6 } - @@ at } + | LPAR IMPORT TEXT TEXT type_decl RPAR + { let at = at () in + fun c -> anon_import c; let itype = explicit_decl c $5 empty_type at in + {itype; module_name = $3; func_name = $4} @@ at } + | LPAR IMPORT bind_var TEXT TEXT type_decl RPAR /* Sugar */ + { let at = at () in + fun c -> bind_import c $3; let itype = explicit_decl c $6 empty_type at in + {itype; module_name = $4; func_name = $5} @@ at } + | LPAR IMPORT TEXT TEXT func_type RPAR /* Sugar */ + { let at = at () in + fun c -> anon_import c; let itype = implicit_decl c $5 at in + {itype; module_name = $3; func_name = $4} @@ at } + | LPAR IMPORT bind_var TEXT TEXT func_type RPAR /* Sugar */ + { let at = at () in + fun c -> bind_import c $3; let itype = implicit_decl c $6 at in + {itype; module_name = $4; func_name = $5} @@ at } ; export : @@ -316,8 +386,8 @@ export : module_fields : | /* empty */ { fun c -> - {imports = []; exports = []; tables = []; funcs = []; - memory = None} } + {memory = None; types = c.types.tlist; funcs = []; imports = []; + exports = []; tables = []} } | func module_fields { fun c -> let f = $1 c in let m = $2 c in {m with funcs = f () :: m.funcs} } @@ -330,6 +400,8 @@ module_fields : | LPAR TABLE var_list RPAR module_fields { fun c -> let m = $5 c in {m with tables = ($3 c func @@ ati 3) :: m.tables} } + | LPAR TYPES type_list RPAR module_fields + { fun c -> $3 c; $5 c } | memory module_fields { fun c -> let m = $2 c in match m.memory with diff --git a/ml-proto/host/print.ml b/ml-proto/host/print.ml index 15b29a33d9..e718723074 100644 --- a/ml-proto/host/print.ml +++ b/ml-proto/host/print.ml @@ -11,9 +11,8 @@ open Printf open Types -let func_type f = - let {Ast.params; result; _} = f.it in - {ins = List.map it params; out = Lib.Option.map it result} +let func_type m f = + List.nth m.it.types f.it.ftype.it let string_of_table_type = function | None -> "()" @@ -21,13 +20,13 @@ let string_of_table_type = function let print_var_sig prefix i t = - printf "%s %d : %s\n" prefix i (Types.string_of_value_type t.it) + printf "%s %d : %s\n" prefix i (string_of_value_type t.it) -let print_func_sig prefix i f = - printf "%s %d : %s\n" prefix i (Types.string_of_func_type (func_type f)) +let print_func_sig m prefix i f = + printf "%s %d : %s\n" prefix i (string_of_func_type (func_type m f)) -let print_export_sig prefix n f = - printf "%s \"%s\" : %s\n" prefix n (Types.string_of_func_type (func_type f)) +let print_export_sig m prefix n f = + printf "%s \"%s\" : %s\n" prefix n (string_of_func_type (func_type m f)) let print_table_sig prefix i t_opt = printf "%s %d : %s\n" prefix i (string_of_table_type t_opt) @@ -35,23 +34,23 @@ let print_table_sig prefix i t_opt = (* Ast *) -let print_func i f = - print_func_sig "func" i f +let print_func m i f = + print_func_sig m "func" i f let print_export m i ex = - print_export_sig "export" ex.it.name (List.nth m.it.funcs ex.it.func.it) + print_export_sig m "export" ex.it.name (List.nth m.it.funcs ex.it.func.it) let print_table m i tab = let t_opt = match tab.it with | [] -> None - | x::_ -> Some (func_type (List.nth m.it.funcs x.it)) + | x::_ -> Some (func_type m (List.nth m.it.funcs x.it)) in print_table_sig "table" i t_opt let print_module m = let {funcs; exports; tables} = m.it in - List.iteri print_func funcs; + List.iteri (print_func m) funcs; List.iteri (print_export m) exports; List.iteri (print_table m) tables; flush_all () diff --git a/ml-proto/host/script.ml b/ml-proto/host/script.ml index 63d15af837..8c65bea713 100644 --- a/ml-proto/host/script.ml +++ b/ml-proto/host/script.ml @@ -61,7 +61,7 @@ let run_command cmd = Print.print_module_sig m end; trace "Initializing..."; - let imports = Builtins.match_imports m.it.Ast.imports in + let imports = Builtins.match_imports m in let host_params = {Eval.page_size = Params.page_size} in current_module := Some (Eval.init m imports host_params) diff --git a/ml-proto/spec/ast.ml b/ml-proto/spec/ast.ml index 8c7a4d3782..a52fd5056f 100644 --- a/ml-proto/spec/ast.ml +++ b/ml-proto/spec/ast.ml @@ -26,8 +26,7 @@ open Values (* Types *) -type value_type = Types.value_type Source.phrase -type expr_type = value_type option +type value_type = Types.value_type (* Operators *) @@ -63,7 +62,7 @@ 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 memop = {ty : Types.value_type; align : int option} +type memop = {ty : value_type; align : int option} type extop = {memop : memop; sz : Memory.mem_size; ext : Memory.extension} type wrapop = {memop : memop; sz : Memory.mem_size} type hostop = @@ -125,10 +124,9 @@ and segment = Memory.segment Source.phrase type func = func' Source.phrase and func' = { - params : value_type list; - result : expr_type; + ftype : var; locals : value_type list; - body : expr + body : expr; } type export = export' Source.phrase @@ -137,10 +135,9 @@ and export' = {name : string; func : var} type import = import' Source.phrase and import' = { + itype : var; module_name : string; func_name : string; - func_params : value_type list; - func_result : expr_type; } type table = var list Source.phrase @@ -149,6 +146,7 @@ type module_ = module_' Source.phrase and module_' = { memory : memory option; + types : Types.func_type list; funcs : func list; imports : import list; exports : export list; diff --git a/ml-proto/spec/check.ml b/ml-proto/spec/check.ml index f0f83f4bb3..0ce2e17fd0 100644 --- a/ml-proto/spec/check.ml +++ b/ml-proto/spec/check.ml @@ -17,6 +17,7 @@ let require b at s = if not b then error at s type context = { + types : func_type list; funcs : func_type list; imports : func_type list; tables : func_type list; @@ -95,15 +96,6 @@ let type_hostop = function | GrowMemory -> {ins = [Int32Type]; out = None} -let type_func f = - let {params; result; _} = f.it in - {ins = List.map it params; out = Lib.Option.map it result} - -let type_import f = - let {func_params; func_result; _} = f.it in - {ins = List.map it func_params; out = Lib.Option.map it func_result} - - (* Type Analysis *) (* @@ -145,10 +137,10 @@ let rec check_expr c et e = check_expr_opt c (label c x) eo e.at | Switch (t, e1, cs, e2) -> - require (t.it = Int32Type || t.it = Int64Type) t.at "invalid switch type"; + require (t = Int32Type || t = Int64Type) e.at "invalid switch type"; (* TODO: Check that cases are unique. *) - check_expr c (Some t.it) e1; - List.iter (check_case c t.it et) cs; + check_expr c (Some t) e1; + List.iter (check_case c t et) cs; check_expr c et e2 | Call (x, es) -> @@ -276,11 +268,15 @@ and check_mem_type ty sz at = * s : func_type *) +let get_type types t = + require (t.it < List.length types) t.at "type index out of bounds"; + List.nth types t.it + let check_func c f = - let {params; result; locals; body = e} = f.it in - let c' = {c with locals = List.map it params @ List.map it locals; - return = Lib.Option.map it result} in - check_expr c' (Lib.Option.map it result) e + let {ftype; locals; body} = f.it in + let s = get_type c.types ftype in + let c' = {c with locals = s.ins @ locals; return = s.out} in + check_expr c' s.out body let check_table funcs tables tab = match tab.it with @@ -319,11 +315,12 @@ let check_memory memory = ignore (List.fold_left (check_segment mem.initial) Int64.zero mem.segments) let check_module m = - let {imports; exports; tables; funcs; memory} = m.it in + let {memory; types; funcs; imports; exports; tables} = m.it in Lib.Option.app check_memory memory; - let func_types = List.map type_func funcs in - let c = {funcs = func_types; - imports = List.map type_import imports; + let func_types = List.map (fun f -> get_type types f.it.ftype) funcs in + let c = {types; + funcs = func_types; + imports = List.map (fun i -> get_type types i.it.itype) imports; tables = List.fold_left (check_table func_types) [] tables; locals = []; return = None; diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index ff9693d821..ab3758c6a8 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -3,6 +3,7 @@ *) open Values +open Types open Ast open Source @@ -12,7 +13,6 @@ let error = Error.error (* Module Instances *) type value = Values.value -type func = Ast.func type import = value list -> value option type host_params = {page_size : Memory.size} @@ -21,7 +21,7 @@ type export_map = func ExportMap.t type instance = { - funcs : func list; + m : module_; imports : import list; exports : export_map; tables : func list list; @@ -45,7 +45,7 @@ let lookup category list x = try List.nth list x.it with Failure _ -> error x.at ("runtime: undefined " ^ category ^ " " ^ string_of_int x.it) -let func c x = lookup "function" c.instance.funcs x +let func c x = lookup "function" c.instance.m.it.funcs x let import c x = lookup "import" c.instance.imports x let table c x y = lookup "entry" (lookup "table" c.instance.tables x) y let local c x = lookup "local" c.locals x @@ -72,8 +72,8 @@ let memory_error at = function let type_error at v t = error at - ("runtime: type error, expected " ^ Types.string_of_value_type t ^ - ", got " ^ Types.string_of_value_type (type_of v)) + ("runtime: type error, expected " ^ string_of_value_type t ^ + ", got " ^ string_of_value_type (type_of v)) let numerics_error at = function | Numerics.IntegerOverflow -> @@ -97,7 +97,7 @@ let some v at = let int32 v at = match some v at with | Int32 i -> i - | v -> type_error at v Types.Int32Type + | v -> type_error at v Int32Type let mem_size v at = let i32 = int32 v at in @@ -114,6 +114,10 @@ let mem_overflow x = let callstack_exhaustion at = error at ("runtime: callstack exhausted") +let func_type instance f = + assert (f.it.ftype.it < List.length instance.m.it.types); + List.nth instance.m.it.types f.it.ftype.it + (* Evaluation *) @@ -260,12 +264,12 @@ and eval_case c vo stage case = | `Seek, false | `Done _, _ -> stage -and eval_func (m : instance) f vs = +and eval_func instance f vs = let args = List.map ref vs in - let vars = List.map (fun t -> ref (default_value t.it)) f.it.locals in + let vars = List.map (fun t -> ref (default_value t)) f.it.locals in let locals = args @ vars in - let c = {instance = m; locals; labels = []} in - coerce f.it.result (eval_expr c f.it.body) + let c = {instance; locals; labels = []} in + coerce (func_type instance f).out (eval_expr c f.it.body) and coerce et vo = if et = None then None else vo @@ -309,18 +313,18 @@ let init m imports host = assert (List.length imports = List.length m.it.Ast.imports); assert (host.page_size > 0L); assert (Lib.Int64.is_power_of_two host.page_size); - let {Ast.exports; tables; funcs; memory; _} = m.it in + let {memory; funcs; exports; tables; _} = m.it in let memory' = Lib.Option.map init_memory memory in let func x = List.nth funcs x.it in let export ex = ExportMap.add ex.it.name (func ex.it.func) in let exports = List.fold_right export exports ExportMap.empty in let tables = List.map (fun tab -> List.map func tab.it) tables in - {funcs; imports; exports; tables; memory = memory'; host} + {m; imports; exports; tables; memory = memory'; host} -let invoke m name vs = +let invoke instance name vs = try - let f = export m (name @@ no_region) in - assert (List.length vs = List.length f.it.params); - eval_func m f vs + let f = export instance (name @@ no_region) in + assert (List.length vs = List.length (func_type instance f).ins); + eval_func instance f vs with Stack_overflow -> callstack_exhaustion no_region diff --git a/ml-proto/test/expected-output/func_ptrs.wast.log b/ml-proto/test/expected-output/func_ptrs.wast.log new file mode 100644 index 0000000000..8f757d3c04 --- /dev/null +++ b/ml-proto/test/expected-output/func_ptrs.wast.log @@ -0,0 +1 @@ +83 : i32 diff --git a/ml-proto/test/func_ptrs.wast b/ml-proto/test/func_ptrs.wast new file mode 100644 index 0000000000..ac14609590 --- /dev/null +++ b/ml-proto/test/func_ptrs.wast @@ -0,0 +1,27 @@ +(module + (types + (func (param) (result i32)) + (func $T (param i32) (result i32)) + (func $U (param i32)) + ) + + (func $one (type 0) (i32.const 13)) + (export "one" $one) + + (func $two (type $T) (i32.add (get_local 0) (i32.const 1))) + (export "two" $two) + + (func $three (type $T) (param $a i32) (result i32) (i32.sub (get_local 0) (i32.const 2))) + (export "three" $three) + + (import $print "stdio" "print" (type 2)) + (func $four (type $U) (call_import $print (get_local 0))) + (export "four" $four) +) +(assert_return (invoke "one") (i32.const 13)) +(assert_return (invoke "two" (i32.const 13)) (i32.const 14)) +(assert_return (invoke "three" (i32.const 13)) (i32.const 11)) +(invoke "four" (i32.const 83)) + +(assert_invalid (module (func (type 42))) "type index out of bounds") +(assert_invalid (module (import "stdio" "print" (type 43))) "type index out of bounds") From ab9d99499d03fb50a8b3f6e9c084ddcdb3bdf574 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Tue, 13 Oct 2015 18:39:27 -0500 Subject: [PATCH 2/5] Add note in test --- ml-proto/test/func_ptrs.wast | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ml-proto/test/func_ptrs.wast b/ml-proto/test/func_ptrs.wast index ac14609590..a001bd62e6 100644 --- a/ml-proto/test/func_ptrs.wast +++ b/ml-proto/test/func_ptrs.wast @@ -11,6 +11,8 @@ (func $two (type $T) (i32.add (get_local 0) (i32.const 1))) (export "two" $two) + ;; Both signature and parameters are allowed (and required to match) + ;; since this allows the naming of parameters. (func $three (type $T) (param $a i32) (result i32) (i32.sub (get_local 0) (i32.const 2))) (export "three" $three) From 253d8fdd84fd5779f55583cb9b1e54cb47e72534 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 14 Oct 2015 10:30:23 -0500 Subject: [PATCH 3/5] Go back to enter_func --- ml-proto/host/parser.mly | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 9d3a07405f..d5182d4491 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -63,12 +63,9 @@ let c0 () = {types = empty_types (); funcs = empty (); imports = empty (); locals = empty (); labels = VarMap.empty} -let do_func c ftype f at = +let enter_func c = assert (VarMap.is_empty c.labels); - let c' = {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()} in - let func = f c' in - assert (VarMap.is_empty c.labels); - {func with ftype} @@ at + {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()} let lookup_type c x = try VarMap.find x.it c.types.tmap @@ -314,19 +311,19 @@ func : | LPAR FUNC type_decl func_fields RPAR { let at = at () in fun c -> anon_func c; let t = explicit_decl c $3 (fst $4) at in - fun () -> do_func c t (snd $4) at } + fun () -> {((snd $4) (enter_func c)) with ftype = t} @@ at } | LPAR FUNC bind_var type_decl func_fields RPAR /* Sugar */ { let at = at () in fun c -> bind_func c $3; let t = explicit_decl c $4 (fst $5) at in - fun () -> do_func c t (snd $5) at } + fun () -> {((snd $5) (enter_func c)) with ftype = t} @@ at } | LPAR FUNC func_fields RPAR /* Sugar */ { let at = at () in fun c -> anon_func c; let t = implicit_decl c (fst $3) at in - fun () -> do_func c t (snd $3) at } + fun () -> {((snd $3) (enter_func c)) with ftype = t} @@ at } | LPAR FUNC bind_var func_fields RPAR /* Sugar */ { let at = at () in fun c -> bind_func c $3; let t = implicit_decl c (fst $4) at in - fun () -> do_func c t (snd $4) at } + fun () -> {((snd $4) (enter_func c)) with ftype = t} @@ at } ; From 4baf913378f68af5a838b51eae6244faad482021 Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 14 Oct 2015 10:51:50 -0500 Subject: [PATCH 4/5] Address comments --- ml-proto/host/parser.mly | 24 ++++++++++++------------ ml-proto/spec/eval.ml | 10 +++++----- ml-proto/test/func_ptrs.wast | 17 ++++++++++++----- 3 files changed, 29 insertions(+), 22 deletions(-) diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index d5182d4491..7ec36d0886 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -114,12 +114,12 @@ let anon_label c = {c with labels = VarMap.map ((+) 1) c.labels} let empty_type = {ins = []; out = None} let explicit_decl c name t at = - let i = name c lookup_type in - if i.it < List.length c.types.tlist && + let x = name c lookup_type in + if x.it < List.length c.types.tlist && t <> empty_type && - t <> List.nth c.types.tlist i.it then + t <> List.nth c.types.tlist x.it then Error.error at "signature mismatch"; - i + x let implicit_decl c t at = match Lib.List.index_of t c.types.tlist with @@ -170,15 +170,15 @@ value_type_list : | /* empty */ { [] } | VALUE_TYPE value_type_list { $1 :: $2 } ; -func_params : - | LPAR PARAM value_type_list RPAR { $3 } -; -func_result : - | /* empty */ { None } - | LPAR RESULT VALUE_TYPE RPAR { Some $3 } -; func_type : - | func_params func_result { {ins = $1; out = $2} } + | /* empty */ + { {ins = []; out = None} } + | LPAR PARAM value_type_list RPAR + { {ins = $3; out = None} } + | LPAR PARAM value_type_list RPAR LPAR RESULT VALUE_TYPE RPAR + { {ins = $3; out = Some $7} } + | LPAR RESULT VALUE_TYPE RPAR + { {ins = []; out = Some $3} } ; diff --git a/ml-proto/spec/eval.ml b/ml-proto/spec/eval.ml index ab3758c6a8..32d16ba0a9 100644 --- a/ml-proto/spec/eval.ml +++ b/ml-proto/spec/eval.ml @@ -21,7 +21,7 @@ type export_map = func ExportMap.t type instance = { - m : module_; + module_ : module_; imports : import list; exports : export_map; tables : func list list; @@ -45,7 +45,7 @@ let lookup category list x = try List.nth list x.it with Failure _ -> error x.at ("runtime: undefined " ^ category ^ " " ^ string_of_int x.it) -let func c x = lookup "function" c.instance.m.it.funcs x +let func c x = lookup "function" c.instance.module_.it.funcs x let import c x = lookup "import" c.instance.imports x let table c x y = lookup "entry" (lookup "table" c.instance.tables x) y let local c x = lookup "local" c.locals x @@ -115,8 +115,8 @@ let callstack_exhaustion at = error at ("runtime: callstack exhausted") let func_type instance f = - assert (f.it.ftype.it < List.length instance.m.it.types); - List.nth instance.m.it.types f.it.ftype.it + assert (f.it.ftype.it < List.length instance.module_.it.types); + List.nth instance.module_.it.types f.it.ftype.it (* Evaluation *) @@ -319,7 +319,7 @@ let init m imports host = let export ex = ExportMap.add ex.it.name (func ex.it.func) in let exports = List.fold_right export exports ExportMap.empty in let tables = List.map (fun tab -> List.map func tab.it) tables in - {m; imports; exports; tables; memory = memory'; host} + {module_ = m; imports; exports; tables; memory = memory'; host} let invoke instance name vs = try diff --git a/ml-proto/test/func_ptrs.wast b/ml-proto/test/func_ptrs.wast index a001bd62e6..91f6b3f2f7 100644 --- a/ml-proto/test/func_ptrs.wast +++ b/ml-proto/test/func_ptrs.wast @@ -1,11 +1,15 @@ (module (types - (func (param) (result i32)) - (func $T (param i32) (result i32)) - (func $U (param i32)) + (func) ;; 0: void -> void + (func $A) ;; 1: void -> void + (func (param)) ;; 2: void -> void + (func (result i32)) ;; 3: void -> i32 + (func (param) (result i32)) ;; 4: void -> i32 + (func $T (param i32) (result i32)) ;; 5: i32 -> i32 + (func $U (param i32)) ;; 6: i32 -> void ) - (func $one (type 0) (i32.const 13)) + (func $one (type 4) (i32.const 13)) (export "one" $one) (func $two (type $T) (i32.add (get_local 0) (i32.const 1))) @@ -16,9 +20,12 @@ (func $three (type $T) (param $a i32) (result i32) (i32.sub (get_local 0) (i32.const 2))) (export "three" $three) - (import $print "stdio" "print" (type 2)) + (import $print "stdio" "print" (type 6)) (func $four (type $U) (call_import $print (get_local 0))) (export "four" $four) + + (func (type 0)) + (func (type $A)) ) (assert_return (invoke "one") (i32.const 13)) (assert_return (invoke "two" (i32.const 13)) (i32.const 14)) From 5666ceebce2f6d9b82921f62319e4d36cbe2d91c Mon Sep 17 00:00:00 2001 From: Luke Wagner Date: Wed, 14 Oct 2015 11:13:59 -0500 Subject: [PATCH 5/5] Remove 'types', use individual 'type' defs instead --- ml-proto/host/lexer.mll | 1 - ml-proto/host/parser.mly | 28 +++++++++++++--------------- ml-proto/test/func_ptrs.wast | 22 ++++++++++------------ 3 files changed, 23 insertions(+), 28 deletions(-) diff --git a/ml-proto/host/lexer.mll b/ml-proto/host/lexer.mll index d193d82448..7b98399493 100644 --- a/ml-proto/host/lexer.mll +++ b/ml-proto/host/lexer.mll @@ -242,7 +242,6 @@ rule token = parse | "grow_memory" { GROW_MEMORY } | "type" { TYPE } - | "types" { TYPES } | "func" { FUNC } | "param" { PARAM } | "result" { RESULT } diff --git a/ml-proto/host/parser.mly b/ml-proto/host/parser.mly index 7ec36d0886..38b48ba0b3 100644 --- a/ml-proto/host/parser.mly +++ b/ml-proto/host/parser.mly @@ -135,7 +135,7 @@ let implicit_decl c t at = %token GET_LOCAL SET_LOCAL LOAD STORE %token CONST UNARY BINARY COMPARE CONVERT %token FUNC TYPE PARAM RESULT LOCAL -%token MODULE MEMORY TYPES SEGMENT IMPORT EXPORT TABLE +%token MODULE MEMORY SEGMENT IMPORT EXPORT TABLE %token PAGE_SIZE MEMORY_SIZE GROW_MEMORY %token ASSERT_INVALID ASSERT_RETURN ASSERT_RETURN_NAN ASSERT_TRAP INVOKE %token EOF @@ -304,15 +304,15 @@ func_fields : fun c -> bind_local c $3; let f = (snd $6) c in {f with locals = $4 :: f.locals} } ; -type_decl : +type_use : | LPAR TYPE var RPAR { $3 } ; func : - | LPAR FUNC type_decl func_fields RPAR + | LPAR FUNC type_use func_fields RPAR { let at = at () in fun c -> anon_func c; let t = explicit_decl c $3 (fst $4) at in fun () -> {((snd $4) (enter_func c)) with ftype = t} @@ at } - | LPAR FUNC bind_var type_decl func_fields RPAR /* Sugar */ + | LPAR FUNC bind_var type_use func_fields RPAR /* Sugar */ { let at = at () in fun c -> bind_func c $3; let t = explicit_decl c $4 (fst $5) at in fun () -> {((snd $5) (enter_func c)) with ftype = t} @@ at } @@ -347,21 +347,19 @@ memory : @@ at () } ; -type_list : - | /* empty */ - { fun c -> () } - | LPAR FUNC func_type RPAR type_list - { fun c -> anon_type c $3; $5 c } - | LPAR FUNC bind_var func_type RPAR type_list /* Sugar */ - { fun c -> bind_type c $3 $4; $6 c } +type_def : + | LPAR TYPE LPAR FUNC func_type RPAR RPAR + { fun c -> anon_type c $5 } + | LPAR TYPE bind_var LPAR FUNC func_type RPAR RPAR + { fun c -> bind_type c $3 $6 } ; import : - | LPAR IMPORT TEXT TEXT type_decl RPAR + | LPAR IMPORT TEXT TEXT type_use RPAR { let at = at () in fun c -> anon_import c; let itype = explicit_decl c $5 empty_type at in {itype; module_name = $3; func_name = $4} @@ at } - | LPAR IMPORT bind_var TEXT TEXT type_decl RPAR /* Sugar */ + | LPAR IMPORT bind_var TEXT TEXT type_use RPAR /* Sugar */ { let at = at () in fun c -> bind_import c $3; let itype = explicit_decl c $6 empty_type at in {itype; module_name = $4; func_name = $5} @@ at } @@ -397,8 +395,8 @@ module_fields : | LPAR TABLE var_list RPAR module_fields { fun c -> let m = $5 c in {m with tables = ($3 c func @@ ati 3) :: m.tables} } - | LPAR TYPES type_list RPAR module_fields - { fun c -> $3 c; $5 c } + | type_def module_fields + { fun c -> $1 c; $2 c } | memory module_fields { fun c -> let m = $2 c in match m.memory with diff --git a/ml-proto/test/func_ptrs.wast b/ml-proto/test/func_ptrs.wast index 91f6b3f2f7..c79144f7bb 100644 --- a/ml-proto/test/func_ptrs.wast +++ b/ml-proto/test/func_ptrs.wast @@ -1,13 +1,14 @@ (module - (types - (func) ;; 0: void -> void - (func $A) ;; 1: void -> void - (func (param)) ;; 2: void -> void - (func (result i32)) ;; 3: void -> i32 - (func (param) (result i32)) ;; 4: void -> i32 - (func $T (param i32) (result i32)) ;; 5: i32 -> i32 - (func $U (param i32)) ;; 6: i32 -> void - ) + (type (func)) ;; 0: void -> void + (type $S (func)) ;; 1: void -> void + (type (func (param))) ;; 2: void -> void + (type (func (result i32))) ;; 3: void -> i32 + (type (func (param) (result i32))) ;; 4: void -> i32 + (type $T (func (param i32) (result i32))) ;; 5: i32 -> i32 + (type $U (func (param i32))) ;; 6: i32 -> void + + (func (type 0)) + (func (type $S)) (func $one (type 4) (i32.const 13)) (export "one" $one) @@ -23,9 +24,6 @@ (import $print "stdio" "print" (type 6)) (func $four (type $U) (call_import $print (get_local 0))) (export "four" $four) - - (func (type 0)) - (func (type $A)) ) (assert_return (invoke "one") (i32.const 13)) (assert_return (invoke "two" (i32.const 13)) (i32.const 14))