diff --git a/interpreter/binary/decode.ml b/interpreter/binary/decode.ml index a266634..841e685 100644 --- a/interpreter/binary/decode.ml +++ b/interpreter/binary/decode.ml @@ -95,7 +95,11 @@ let rec vsN n s = else Int64.(logor x (shift_left (vsN (n - 7) s) 7)) let vu1 s = Int64.to_int (vuN 1 s) -let vu32 s = Int64.to_int32 (vuN 32 s) +let vu32 s = + let res = Int64.to_int32 (vuN 32 s) in + (* prerr_endline ("Got int " ^ Int32.to_string res); *) + res + let vs7 s = Int64.to_int (vsN 7 s) let vs32 s = Int64.to_int32 (vsN 32 s) let vs64 s = vsN 64 s @@ -116,8 +120,10 @@ let vec f s = let n = len32 s in list f n s let name s = let pos = pos s in - try Utf8.decode (string s) with Utf8.Utf8 -> - error s pos "invalid UTF-8 encoding" + let str = string s in + (* prerr_endline ("??? " ^ str) ; *) + try Utf8.decode str with Utf8.Utf8 -> + ( prerr_endline ("??? " ^ str) ; error s pos "invalid UTF-8 encoding" ) let sized f s = let size = len32 s in diff --git a/interpreter/main/flags.ml b/interpreter/main/flags.ml index c2d9fe6..0b4526f 100644 --- a/interpreter/main/flags.ml +++ b/interpreter/main/flags.ml @@ -16,6 +16,8 @@ let debug_error = ref false let disable_float = ref false +let br_mode = ref false + let trace_from = ref (-1) let insert_error = ref (-1) @@ -70,6 +72,7 @@ let input_all_file_proofs = ref false let input_proof = ref false let input_out = ref false let output_proof = ref false +let output_io_proof = ref false let sbrk_offset = ref 0l diff --git a/interpreter/main/main.ml b/interpreter/main/main.ml index 69c45a6..98eafd4 100644 --- a/interpreter/main/main.ml +++ b/interpreter/main/main.ml @@ -39,6 +39,8 @@ let add_arg source = args := !args @ [source] let quote s = "\"" ^ String.escaped s ^ "\"" +let inter_mode = ref false + let merge_mode = ref false let float_mode = ref false let float_error_mode = ref false @@ -52,6 +54,7 @@ let underscore_mode = ref false let counter_mode = ref false let test_counter_mode = ref false let handle_nan_mode = ref false +let dyncall_mode = ref false let critical_mode = ref false let buildstack_mode = ref false @@ -81,6 +84,7 @@ let argspec = Arg.align "-t", Arg.Set Flags.trace, " trace execution"; "-v", Arg.Unit banner, " show version"; + "-inter", Arg.Set inter_mode, " start execution at an intermediate state"; "-critical", Arg.Set critical_mode, " find the critical path to step"; "-limit-stack", Arg.Set check_stack_mode, " check sizes of stack frames"; "-build-stack", Arg.Set buildstack_mode, " build the stack for critical path"; @@ -106,6 +110,7 @@ let argspec = Arg.align "-counter", Arg.Set counter_mode, " add a counter variable to the file"; "-test-counter", Arg.Set test_counter_mode, " add a counter variable to the file (new test version)"; "-handle-nan", Arg.Set handle_nan_mode, " canonize floating point values to remove non-determinism"; + "-dyncall", Arg.Set dyncall_mode, " simplify dynamic calls"; "-add-globals", Arg.String (fun s -> globals_file := Some s), " add globals to the module"; "-init-code", Arg.String (fun s -> add_arg ("(input " ^ quote s ^ ")") ; init_code := Some s), " output initial code for a wasm file"; "-imports", Arg.Set print_imports, " print imports from the wasm file"; @@ -152,6 +157,7 @@ let argspec = Arg.align "-input", Arg.Set Flags.input_proof, " output information about input"; "-input2", Arg.Set Flags.input_out, " output information about input"; "-output", Arg.Set Flags.output_proof, " output information about output"; + "-output-io", Arg.Set Flags.output_io_proof, " output information about output"; "-sbrk-offset", Arg.Int (fun n -> Flags.sbrk_offset := Int32.of_int n), " memory offset used by sbrk"; "-output-step", Arg.Int (fun x -> Flags.output_file_at := x), " for which step the file will be output"; "-output-file", Arg.Int (fun x -> Flags.output_file_number := x), " which file will be output at the given step"; @@ -200,6 +206,9 @@ let () = Run.create_sexpr_file "critical.wast" () (fun () -> m); Run.create_binary_file "critical.wasm" () (fun () -> m) | _ -> () ); + ( match !inter_mode, !lst with + | true, m :: _ -> Loadstate.run m + | _ -> () ); ( match !secret_stack_mode, !lst with | true, m :: _ -> let m = Secretstack.process m in @@ -224,6 +233,12 @@ let () = Run.create_sexpr_file "intfloat.wast" () (fun () -> m); Run.create_binary_file "intfloat.wasm" () (fun () -> m) | _ -> () ); + ( match !dyncall_mode, !lst with + | true, a :: _ -> + let m = Dyncall.process a in + Run.create_sexpr_file "dyncall.wast" () (fun () -> m); + Run.create_binary_file "dyncall.wasm" () (fun () -> m) + | _ -> () ); ( match !float_error_mode, !lst with | true, a :: _ -> let m = Floaterror.process a in @@ -294,7 +309,7 @@ let () = | true, m :: _ -> let open Source in let open Ast in - let lst = Merkle.func_imports m in + let lst = Sourceutil.func_imports m in let import_name n = "[\"" ^ Utf8.encode n.it.module_name ^ "\",\"" ^ Utf8.encode n.it.item_name ^ "\"]" in Printf.printf "[%s]\n" (String.concat ", " (List.map import_name lst)) | _ -> () ); diff --git a/interpreter/merkle/addglobals.ml b/interpreter/merkle/addglobals.ml index 341783f..1385225 100644 --- a/interpreter/merkle/addglobals.ml +++ b/interpreter/merkle/addglobals.ml @@ -4,7 +4,7 @@ open Merge open Ast open Types open Source -open Merkle +open Sourceutil (* remap function calls *) let rec remap_func' map gmap gmap2 ftmap = function @@ -57,11 +57,11 @@ let add_import taken special imports map map2 num imp = let loc = Int32.of_int (List.length !imports) in Hashtbl.add map (Int32.of_int num) loc; imports := imp :: !imports; - Run.trace ("Got import " ^ name); + trace ("Got import " ^ name); Hashtbl.add taken name loc end else begin let loc = Hashtbl.find taken name in - Run.trace ("Dropping import " ^ name); + trace ("Dropping import " ^ name); Hashtbl.add map (Int32.of_int num) loc end; if Hashtbl.mem special name then begin @@ -70,54 +70,41 @@ let add_import taken special imports map map2 num imp = let int_global i = GetGlobal {it=Int32.of_int i; at=no_region} -let int_const y = Const (elem (Values.I32 (Int32.of_int y))) -let int64_const y = Const (elem (Values.I64 y)) -let f64_const y = Const (elem (Values.F64 y)) - -let int_binary i = - let res = Bytes.create 4 in - Bytes.set res 0 (Char.chr (i land 0xff)); - Bytes.set res 1 (Char.chr ((i lsr 8) land 0xff)); - Bytes.set res 2 (Char.chr ((i lsr 16) land 0xff)); - Bytes.set res 3 (Char.chr ((i lsr 24) land 0xff)); - Bytes.to_string res - -let generate_data (addr, i) : string segment = - elem { - offset=elem [elem (int_const (addr*4))]; - index=elem 0l; - init=int_binary i; - } - (* need to add a TOTAL_MEMORY global *) -let add_i32_global m name tmem = - let open Types in - let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in - do_it m (fun m -> {m with - globals=m.globals@[elem {value=elem [elem (int_const tmem)]; gtype=GlobalType (I32Type, Immutable)}]; - exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) - -let add_i64_global m name tmem = - let open Types in - let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in - do_it m (fun m -> {m with - globals=m.globals@[elem {value=elem [elem (int64_const tmem)]; gtype=GlobalType (I64Type, Immutable)}]; - exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) - -let add_f64_global m name tmem = - let open Types in - let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in - do_it m (fun m -> {m with - globals=m.globals@[elem {value=elem [elem (f64_const tmem)]; gtype=GlobalType (F64Type, Immutable)}]; - exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) - -let has_import m name = - List.exists (fun im -> Utf8.encode im.it.item_name = name) m.it.imports +let add_setters m = + let asmjs = find_global_index m (Utf8.decode "ASMJS") in + do_it m (fun m -> + (* add function types *) + let ftypes = m.types @ [ + it (FuncType ([I32Type], [])); + ] in + let ftypes_len = List.length m.types in + let set_type = it (Int32.of_int (ftypes_len)) in + let make_func num = + elem { + ftype = set_type; + locals = []; + body = List.map it [GetLocal (it 0l); SetGlobal (it num)]; + } in + (* add exports *) + let fnum = List.length (func_imports (it m)) + List.length m.funcs in + let added = [ + it {name=Utf8.decode "setHelperStack"; edesc=it (FuncExport (it (Int32.of_int fnum)))}; + it {name=Utf8.decode "setHelperStackLimit"; edesc=it (FuncExport (it (Int32.of_int (fnum+1))))}; + ] in + let stack_ptr = asmjs - 16 in (* this is the difficult place *) + let stack_max = stack_ptr + 1 in + let set1 = make_func (Int32.of_int stack_ptr) in + let set2 = make_func (Int32.of_int stack_max) in + {m with funcs=m.funcs @ [set1; set2]; + types=ftypes; + exports=m.exports @ added; }) let add_globals m fn = let globals, mem, tmem = load_file fn in - let m = if !Flags.asmjs then add_i32_global m "ASMJS" 0 else m in + let m = + if !Flags.asmjs then add_setters (add_i32_global m "ASMJS" 1) else m in let m = add_i32_global m "TOTAL_MEMORY" tmem in (* let m = add_i32_global m "GAS" 0 in *) let m = add_i32_global m "GAS_LIMIT" (!Flags.gas_limit) in @@ -141,7 +128,7 @@ let add_globals m fn = let name = "_env_" ^ x in let inst = Const (elem (Values.I32 (Int32.of_int y))) in Hashtbl.add special_globals name inst; - Run.trace ("Blah " ^ name ^ " fddd " ^ string_of_int (555+i)); + trace ("Blah " ^ name ^ " fddd " ^ string_of_int (555+i)); Hashtbl.add taken_globals name (Int32.add 555l (Int32.of_int i)) in List.iteri reserve_export globals; List.iteri (fun n x -> add_import taken_globals special_globals g_imports gmap1 gmap2 n x) (global_imports m); @@ -153,10 +140,10 @@ let add_globals m fn = let offset_ga = num_g - num_ga in List.iteri (fun i _ -> - Run.trace ("global " ^ string_of_int (i+num_ga) ^ " -> " ^ string_of_int (i + num_ga + offset_ga)); + trace ("global " ^ string_of_int (i+num_ga) ^ " -> " ^ string_of_int (i + num_ga + offset_ga)); Hashtbl.add gmap1 (Int32.of_int (i + num_ga)) (Int32.of_int (i + num_ga + offset_ga))) m.it.globals; - List.iter (fun (x,y) -> Run.trace ("Global " ^ x ^ " = " ^ string_of_int y)) globals; + List.iter (fun (x,y) -> trace ("Global " ^ x ^ " = " ^ string_of_int y)) globals; (* initialize these globals differently *) (* when initializing globals, cannot access previous globals *) (* remap exports *) @@ -164,7 +151,7 @@ let add_globals m fn = (* funcs will have to be remapped *) let funcs_a = List.map (remap (fun x -> x) (Hashtbl.find gmap1) (Hashtbl.find gmap2) ftmap1) m.it.funcs in (* table elements have to be remapped *) - Run.trace ("Remapping globals"); + trace ("Remapping globals"); let new_data = List.map generate_data mem in let mem_size = Int32.of_int (Byteutil.pow2 (!Flags.memory_size - 13)) in let mem = { @@ -172,9 +159,15 @@ let add_globals m fn = module_name=Utf8.decode "env"; item_name=Utf8.decode "memory"; } in + let table = if other_imports_nomem m = [] then [] else [ + elem {idesc=elem (TableImport (TableType ({min=100000l; max=None}, AnyFuncType))); + module_name=Utf8.decode "env"; + item_name=Utf8.decode "table"; + } + ] in {m with it={(m.it) with funcs = funcs_a; data=m.it.data@new_data; globals = List.map (remap_global (fun x -> x) (Hashtbl.find gmap1) (Hashtbl.find gmap2) ftmap1) m.it.globals; - imports = List.rev !g_imports @ func_imports m @ other_imports_nomem m @ [elem mem]; + imports = List.rev !g_imports @ func_imports m @ table @ [elem mem]; exports = exports_a; elems = List.map (remap_elem_segments (fun x -> x) (Hashtbl.find gmap1) (Hashtbl.find gmap2) ftmap1) m.it.elems; }} diff --git a/interpreter/merkle/buildstack.ml b/interpreter/merkle/buildstack.ml index da66223..48f5787 100644 --- a/interpreter/merkle/buildstack.ml +++ b/interpreter/merkle/buildstack.ml @@ -13,10 +13,7 @@ open Ast open Source open Types open Values - -let do_it x f = {x with it=f x.it} - -let it e = {it=e; at=no_region} +open Sourceutil type ctx = { tctx : Valid.context; @@ -36,11 +33,23 @@ type ctx = { store_local_i64 : var; store_local_f32 : var; store_local_f64 : var; - + + store_indirect : var; + store_call : var; + store_pc : var; + adjust_stack_i32 : var; adjust_stack_i64 : var; adjust_stack_f32 : var; adjust_stack_f64 : var; + + orig_locals : int; + params : int; + + func_idx : int; + + find_return_pc : int32 -> int; + } (* perhaps should get everything as args, just be a C function: add them to env *) @@ -122,20 +131,35 @@ let determine_type tctx block = | Some x :: _ -> x | _ -> raise (Failure "typing error") -let store_locals ctx = - let num_locals = List.length ctx.tctx.Valid.locals in +let store_params ctx = +(* let num_locals = List.length ctx.tctx.Valid.locals in *) let res = ref [] in - for i = 0 to num_locals - 1 do + for i = 0 to ctx.params - 1 do let var = it (Int32.of_int i) in let lst = match Valid.local ctx.tctx var with | I32Type -> [GetLocal var; Call ctx.store_local_i32] | F32Type -> [GetLocal var; Call ctx.store_local_f32] | F64Type -> [GetLocal var; Call ctx.store_local_f64] | I64Type -> [Const (it (I32 64l)); GetLocal var; Store {ty=I64Type; align=0; offset=0l; sz=None}; Call ctx.store_local_i64] in - res := !res @ (Const (it (I32 (Int32.of_int i))) :: lst) +(* res := !res @ (Const (it (I32 (Int32.of_int i))) :: lst) *) + res := !res @ lst done; !res +let store_locals ctx = +(* let num_locals = List.length ctx.tctx.Valid.locals in *) + let res = ref [] in + for i = ctx.params to ctx.orig_locals - 1 do + let var = it (Int32.of_int i) in + let lst = match Valid.local ctx.tctx var with + | I32Type -> [GetLocal var; Call ctx.store_local_i32] + | F32Type -> [GetLocal var; Call ctx.store_local_f32] + | F64Type -> [GetLocal var; Call ctx.store_local_f64] + | I64Type -> [Const (it (I32 64l)); GetLocal var; Store {ty=I64Type; align=0; offset=0l; sz=None}; Call ctx.store_local_i64] in +(* res := !res @ (Const (it (I32 (Int32.of_int i))) :: lst) *) + res := !res @ lst + done; + !res let rec remap_blocks label inst = let handle {it=v; _} = if Int32.of_int label > v then it v else it (Int32.add v 1l) in @@ -160,8 +184,33 @@ let store_top ctx = function | I64Type -> [SetGlobal ctx.g64; Const (it (I32 64l)); GetGlobal ctx.g64; Store {ty=I64Type; align=0; offset=0l; sz=None}; Call ctx.adjust_stack_i64; GetGlobal ctx.g64] | F64Type -> [Call ctx.adjust_stack_f64] +let store_hidden ctx id = + try + let exprs, _ = Hashtbl.find Secretstack.info id in + let dta = List.nth !Secretstack.func_info ctx.func_idx in + let handle e_id = + let (ty, var) = List.assoc e_id dta in + match ty with + | I32Type -> [GetLocal var; Call ctx.store_local_i32] + | F32Type -> [GetLocal var; Call ctx.store_local_f32] + | F64Type -> [GetLocal var; Call ctx.store_local_f64] + | I64Type -> [Const (it (I32 64l)); GetLocal var; Store {ty=I64Type; align=0; offset=0l; sz=None}; Call ctx.store_local_i64] in + List.flatten (List.map handle exprs) + with Not_found -> [] + let rec process_inst ctx inst = - let s_block = [Call ctx.count; If ([], List.map it (store_locals ctx), [])] in + let id = Int32.of_int inst.at.right.line in + let i_loc = + try ctx.find_return_pc id + with Not_found -> 0 in + let s_block_loop () = + [Call ctx.count; If ([], List.map it (store_locals ctx @ [Const (it (I32 (Int32.of_int i_loc))); Call ctx.store_pc]), [])] in + let s_block_call () = + [Call ctx.count; If ([], List.map it (store_locals ctx @ store_hidden ctx id @ [Const (it (I32 (Int32.of_int i_loc))); Call ctx.store_call; Const (it (I32 (Int32.of_int (i_loc-2)))); Call ctx.store_pc]), [])] in + let s_block_calli () = + [Call ctx.count; If ([], List.map it (store_locals ctx @ store_hidden ctx id @ [Const (it (I32 (Int32.of_int i_loc))); Call ctx.store_call; Const (it (I32 (Int32.of_int (i_loc-2)))); Call ctx.store_pc]), [])] in + let s_block_return () = + [Call ctx.count; If ([], List.map it (store_locals ctx @ store_hidden ctx id @ [Const (it (I32 (Int32.of_int i_loc))); Call ctx.store_pc]), [])] in let e_block call = function | FuncType (_, []) -> [call] | FuncType (_, [ty]) -> call :: store_top ctx ty (* adjust stack will have to check if it is critical *) @@ -171,14 +220,10 @@ let rec process_inst ctx inst = let res = match inst.it with | Block (ty, lst) -> [Block (ty, List.flatten (List.map (process_inst ctx) lst))] | If (ty, l1, l2) -> [If (ty, List.flatten (List.map (process_inst ctx) l1), List.flatten (List.map (process_inst ctx) l2))] - | Loop (ty, lst) -> [Loop (ty, List.map it s_block @ List.flatten (List.map (process_inst ctx) lst))] + | Loop (ty, lst) -> [Loop (ty, List.map it (s_block_loop ()) @ List.flatten (List.map (process_inst ctx) lst))] (* Just before call, store all locals (arguments will be stored later, but what if builtin) *) - (* - | Call x -> s_block @ [Call x] @ e_block (ctx.var_type x.it) - | CallIndirect x -> s_block @ [CallIndirect x] @ e_block (ctx.lookup_type x.it) - *) - | Call x -> s_block @ e_block (Call x) (ctx.var_type x.it) @ s_block - | CallIndirect x -> s_block @ e_block (CallIndirect x) (ctx.lookup_type x.it) @ s_block + | Call x -> s_block_call () @ e_block (Call x) (ctx.var_type x.it) @ s_block_return () + | CallIndirect x -> (* prerr_endline ("at call " ^ Int32.to_string id); *) s_block_calli () @ [Call ctx.store_indirect] @ e_block (CallIndirect x) (ctx.lookup_type x.it) @ s_block_return () | a -> [a] in List.map it res @@ -191,7 +236,7 @@ let process_function ctx f = let ctx = {ctx with tctx=Valid.func_context ctx.tctx f} in (* let FuncType (_, rets) = ctx.lookup_type f.it.ftype.it in *) let s_block = List.map it [ - Call ctx.store_arg; If ([], List.map it (store_locals ctx), []) + Call ctx.store_arg; If ([], List.map it (store_params ctx), []) ] in do_it f (fun f -> {f with body=s_block @ List.flatten (List.map (process_inst ctx) f.body)}) @@ -208,16 +253,35 @@ let list_to_map lst = List.iter (fun el -> Hashtbl.add res el true) lst; res -let process m = +let process m_orig = + let m = Secretstack.relabel m_orig in + Flags.br_mode := true; + let code = Run.get_code m in + let return_pc = Hashtbl.create 100 in + let handle i = function + | Merkle.BREAKPOINT id -> Hashtbl.add return_pc id i + | Merkle.CALL (_, id) -> Hashtbl.add return_pc id i + | Merkle.CALLI id -> Hashtbl.add return_pc id i (* ; prerr_endline ("adding " ^ Int32.to_string id) *) + | _ -> () in + List.iteri handle code; + let m = Secretstack.process m in + let _, ttab = make_tables m.it in + let orig_locals = List.map (fun f -> + let FuncType (par,_) = Hashtbl.find ttab f.it.ftype.it in + List.length f.it.locals + List.length par) m_orig.it.funcs in + let f_params = List.map (fun f -> + let FuncType (par,_) = Hashtbl.find ttab f.it.ftype.it in + List.length par) m_orig.it.funcs in + (* Information about hidden variables is at [Secretstack.info] *) do_it m (fun m -> (* add function types *) - let i_num = List.length (Merkle.func_imports (it m)) in + let i_num = List.length (func_imports (it m)) in let ftypes = m.types @ [ it (FuncType ([], [I32Type])); - it (FuncType ([I32Type; I32Type], [])); it (FuncType ([I32Type], [])); - it (FuncType ([I32Type; F32Type], [])); - it (FuncType ([I32Type; F64Type], [])); + it (FuncType ([], [])); + it (FuncType ([F32Type], [])); + it (FuncType ([F64Type], [])); it (FuncType ([I32Type], [I32Type])); it (FuncType ([], [])); @@ -249,6 +313,9 @@ let process m = it {module_name=Utf8.decode "env"; item_name=Utf8.decode "adjustStackF32"; idesc=it (FuncImport adjust_stack_f32)}; (* for each type, need a different function *) it {module_name=Utf8.decode "env"; item_name=Utf8.decode "adjustStackF64"; idesc=it (FuncImport adjust_stack_f64)}; (* for each type, need a different function *) it {module_name=Utf8.decode "env"; item_name=Utf8.decode "testStep"; idesc=it (FuncImport count_type)}; + it {module_name=Utf8.decode "env"; item_name=Utf8.decode "storeIndirect"; idesc=it (FuncImport adjust_stack_i32)}; + it {module_name=Utf8.decode "env"; item_name=Utf8.decode "storeReturnPC"; idesc=it (FuncImport store_type_i32)}; + it {module_name=Utf8.decode "env"; item_name=Utf8.decode "storePC"; idesc=it (FuncImport store_type_i32)}; ] in let imps = m.imports @ added in (* @@ -264,7 +331,7 @@ let process m = globals=m.globals @ [it {gtype=GlobalType (I64Type, Mutable); value=it [it (Const (it (I64 0L)))]}]; exports=List.map (Merge.remap_export remap (fun x -> x) (fun x -> x) "") m.exports; elems=List.map (Merge.remap_elements remap) m.elems; } in - let ftab, ttab = Merkle.make_tables pre_m in + let ftab, ttab = make_tables pre_m in let ctx = { g64 = it (Int32.of_int (List.length m.globals)); tctx = Valid.module_context (it pre_m); @@ -279,15 +346,19 @@ let process m = adjust_stack_f32 = it (Int32.of_int (i_num+8)); adjust_stack_f64 = it (Int32.of_int (i_num+9)); is_critical = it (Int32.of_int (i_num+10)); + store_indirect = it (Int32.of_int (i_num+11)); + store_call = it (Int32.of_int (i_num+12)); + store_pc = it (Int32.of_int (i_num+13)); var_type = Hashtbl.find ftab; lookup_type = Hashtbl.find ttab; (* possible = (fun loc -> Hashtbl.mem pos_tab loc); bottom = List.hd (List.rev pos_lst); *) label = 0; + orig_locals = 0; + params = 0; + func_idx = 0; + find_return_pc = (fun x -> Hashtbl.find return_pc x); } in - let res = {pre_m with funcs=List.map (process_function ctx) pre_m.funcs} in - res - ) - - + let res = {pre_m with funcs=List.mapi (fun i f -> process_function {ctx with orig_locals=List.nth orig_locals i; params=List.nth f_params i; func_idx=i} f) pre_m.funcs} in + res) diff --git a/interpreter/merkle/compiler.ml b/interpreter/merkle/compiler.ml index ea7d9be..ad208b2 100644 --- a/interpreter/merkle/compiler.ml +++ b/interpreter/merkle/compiler.ml @@ -106,14 +106,14 @@ let compile labels = function "vm.stack_ptr--; r1 = vm.stack[vm.stack_ptr];" ^ "if (r1 < 0 || r1 >= " ^ string_of_int x ^ ") r1 = " ^ string_of_int x ^ ";" ^ "vm.pc = vm.pc + 1 + r1; goto *jumptable[vm.pc];" - | CALL x -> + | CALL (x,_) -> Hashtbl.add labels x true; "vm.callstack[vm.call_ptr] = vm.pc+1;" ^ "vm.call_ptr++;" ^ "vm.pc = " ^ string_of_int x ^ "-1;" ^ "goto label_" ^ string_of_int x ^ ";" | CHECKCALLI _ -> "vm.pc++;" - | CALLI -> + | CALLI _ -> "vm.stack_ptr--;" ^ "r1 = vm.stack[vm.stack_ptr];" ^ "vm.callstack[vm.call_ptr] = vm.pc+1;" ^ diff --git a/interpreter/merkle/critical.ml b/interpreter/merkle/critical.ml index bff8e89..b6c14be 100644 --- a/interpreter/merkle/critical.ml +++ b/interpreter/merkle/critical.ml @@ -3,10 +3,7 @@ open Ast open Source open Types open Values - -let do_it x f = {x with it=f x.it} - -let it e = {it=e; at=no_region} +open Sourceutil (* type ctx = { @@ -18,7 +15,7 @@ type ctx = { type ctx = { enter_loop : var; push_func : var; - enter_func : var; +(* enter_func : var; *) pop : var; loc : Int32.t; f_loops : Int32.t list; @@ -46,9 +43,13 @@ let process_function ctx f = {f with body= (* List.map it [Const (it (I32 loc)); Call ctx.push_func] @ *) List.flatten (List.map (process_inst ctx) f.body)}) let process m = +(* + let m = Secretstack.relabel m in + let m = Secretstack.process m in +*) do_it m (fun m -> (* add function types *) - let i_num = List.length (Merkle.func_imports (it m)) in + let i_num = List.length (func_imports (it m)) in let ftypes = m.types @ [ it (FuncType ([], [I32Type])); it (FuncType ([I32Type], [])); @@ -64,14 +65,14 @@ let process m = it {module_name=Utf8.decode "env"; item_name=Utf8.decode "popFuncCritical"; idesc=it (FuncImport set_type)}; it {module_name=Utf8.decode "env"; item_name=Utf8.decode "enterLoopCritical"; idesc=it (FuncImport pop_type)}; it {module_name=Utf8.decode "env"; item_name=Utf8.decode "pushFuncCritical"; idesc=it (FuncImport set_type)}; - it {module_name=Utf8.decode "env"; item_name=Utf8.decode "enterFuncCritical"; idesc=it (FuncImport pop_type)}; +(* it {module_name=Utf8.decode "env"; item_name=Utf8.decode "enterFuncCritical"; idesc=it (FuncImport pop_type)}; *) ] in let imps = m.imports @ added in let ctx = { pop = it (Int32.of_int (i_num+0)); enter_loop = it (Int32.of_int (i_num+1)); push_func = it (Int32.of_int (i_num+2)); - enter_func = it (Int32.of_int (i_num+3)); +(* enter_func = it (Int32.of_int (i_num+3)); *) f_loops = []; loc = 0l; } in diff --git a/interpreter/merkle/dyncall.ml b/interpreter/merkle/dyncall.ml new file mode 100644 index 0000000..f46df6c --- /dev/null +++ b/interpreter/merkle/dyncall.ml @@ -0,0 +1,27 @@ + +open Ast +open Source +open Sourceutil + +(* Handling dynamic calls *) +let process m = + let imports = Import.link m in + let inst = Eval.init m imports in + let tab = Hashtbl.create 10 in + let handle_import num im = + let mname = Utf8.encode im.it.module_name in + let fname = Utf8.encode im.it.item_name in + if mname = "env" && String.length fname > 8 && String.sub fname 0 8 = "_invoke_" then begin + let number = String.sub fname 8 (String.length fname - 8) in + try + let idx = find_function_index m.it inst (Utf8.decode ("_dynCall_" ^ number)) in + Hashtbl.add tab (Int32.of_int num) (Int32.of_int idx) + with Not_found -> prerr_endline ("Warning: cannot find dynamic call with signature " ^ number) + end in + List.iteri handle_import (Sourceutil.func_imports m); + let fmap x = try Hashtbl.find tab x with Not_found -> x in + do_it m (fun m -> + {m with funcs = List.map (Merge.remap fmap (fun x -> x) (fun x -> x)) m.funcs; + elems = List.map (Merge.remap_elements fmap) m.elems;} + ) + diff --git a/interpreter/merkle/floaterror.ml b/interpreter/merkle/floaterror.ml index 91085aa..a9f1aaa 100644 --- a/interpreter/merkle/floaterror.ml +++ b/interpreter/merkle/floaterror.ml @@ -2,11 +2,8 @@ open Source open Ast -open Types open Values -open Merkle - -let do_it x f = {x with it=f x.it} +open Sourceutil let process m = let rec convert_op' = function diff --git a/interpreter/merkle/intfloat.ml b/interpreter/merkle/intfloat.ml index 7920bc5..d84693d 100644 --- a/interpreter/merkle/intfloat.ml +++ b/interpreter/merkle/intfloat.ml @@ -3,17 +3,15 @@ open Source open Ast open Types open Values -open Merkle +open Sourceutil (* just simply merge two files *) -let do_it x f = {x with it=f x.it} - let simple_add n i = Int32.add i (Int32.of_int n) let merge a b = let funcs_a = a.it.funcs in - let num = List.length (Merkle.func_imports a) + List.length funcs_a in + let num = List.length (func_imports a) + List.length funcs_a in let num_ft = List.length a.it.types in let funcs_b = List.map (Merge.remap (simple_add num) (fun x -> x) (simple_add num_ft)) b.it.funcs in {a with it={(a.it) with funcs = funcs_a@funcs_b; @@ -22,7 +20,7 @@ let merge a b = exports = a.it.exports@List.filter Merge.drop_table (List.map (Merge.remap_export (simple_add num) (fun x -> x) (simple_add num_ft) "") b.it.exports); elems = a.it.elems; types=a.it.types@b.it.types; - data=a.it.data@b.it.data@[Addglobals.generate_data (256, !Flags.memory_offset)]}} + data=a.it.data@b.it.data@[generate_data (256, !Flags.memory_offset)]}} let convert_type' = function | I32Type -> I32Type @@ -155,13 +153,11 @@ let convert_float m = and convert_body lst = List.flatten (List.map convert_op lst) in let convert_func f = do_it f (fun f -> {f with body=convert_body f.body}) in let convert_global g = do_it g (fun g -> {value=do_it g.value convert_body; gtype=convert_gtype g.gtype}) in - Run.trace "Converting floats"; + trace "Converting floats"; do_it m (fun m -> {m with funcs=List.map convert_func m.funcs; globals=List.map convert_global m.globals}) let process a b = - convert_float (convert_types (merge a b)) - - - - + let res = convert_float (convert_types (merge a b)) in + (* Need to add memory offset here *) + add_i32_global res "MEMORY_OFFSET" (!Flags.memory_offset) diff --git a/interpreter/merkle/loadstate.ml b/interpreter/merkle/loadstate.ml new file mode 100644 index 0000000..3045c7b --- /dev/null +++ b/interpreter/merkle/loadstate.ml @@ -0,0 +1,32 @@ + +(* Loading an intermediate state and running from there *) + +open Source +open Sourceutil + +let load_file vm = + let open Yojson.Basic in + let open Mrun in + let data = from_channel (open_in "state.json") in + vm.pc <- Util.to_int (Util.member "pc" data) + 1; + let call_lst = List.map Util.to_int (Util.to_list (Util.member "call_stack" data)) in + let stack_lst = List.map Util.to_int (Util.to_list (Util.member "stack" data)) in + vm.stack <- Array.make (Byteutil.pow2 !Flags.stack_size) (i 0); + vm.call_stack <- Array.make (Byteutil.pow2 !Flags.call_size) 0; + vm.stack_ptr <- List.length stack_lst; + vm.call_ptr <- List.length call_lst; + List.iteri (fun j elem -> vm.call_stack.(j) <- elem) call_lst; + List.iteri (fun j elem -> vm.stack.(j) <- Values.I64 (Int64.of_int elem)) stack_lst + +let run mdle = + Flags.br_mode := true; + let imports = Import.link mdle in + let inst = Eval.init mdle imports in + let func = match Instance.export inst (Utf8.decode "_main") with + | Some (Instance.ExternalFunc (Instance.AstFunc (_, func))) -> func + | _ -> raise (Failure "no main function") in + let vm = Run.setup_vm inst mdle.it func [] in + load_file vm; + (* here we should load *) + ignore (Run.run_test_aux vm) + diff --git a/interpreter/merkle/mbinary.ml b/interpreter/merkle/mbinary.ml index ae5622b..520d2b4 100644 --- a/interpreter/merkle/mbinary.ml +++ b/interpreter/merkle/mbinary.ml @@ -171,6 +171,7 @@ let alu_byte = function | Convert (F64 F64Op.PromoteF32) -> op 0xbb | Convert (F64 F64Op.DemoteF64) -> assert false | Convert (F64 F64Op.ReinterpretInt) -> op 0xbf + | _ -> assert false let in_code_byte = function | NoIn -> 0x00 @@ -431,6 +432,7 @@ let rec makeMerkle16 arr idx level = if level = 0 then ( if idx < Array.length arr then arr.(idx) else ( (* prerr_endline "here" ; *) zeroword16 ) ) else keccak (makeMerkle16 arr idx (level-1)) (makeMerkle16 arr (idx+pow2 (level-1)) (level-1)) in Hashtbl.add cache16 key res; +(* prerr_endline ("here " ^ w256_to_string res); *) res let rec makeMerkle arr idx level = diff --git a/interpreter/merkle/merge.ml b/interpreter/merkle/merge.ml index 0e8ec67..3564f3b 100644 --- a/interpreter/merkle/merge.ml +++ b/interpreter/merkle/merge.ml @@ -1,7 +1,7 @@ open Ast open Source -open Merkle +open Sourceutil (* remap function calls *) let rec remap_func' map gmap ftmap = function @@ -97,13 +97,13 @@ let merge a b = let loc = Int32.of_int (List.length !imports) in Hashtbl.add map (Int32.of_int num) loc; imports := imp :: !imports; - Run.trace ("Got import " ^ name ^ ", linked to " ^ Int32.to_string loc); + trace ("Got import " ^ name ^ ", linked to " ^ Int32.to_string loc); (* if name = "_env__llvm_bswap_i64" || (String.length name > 11 && String.sub name 0 11 = "_env_invoke") then () else *) Hashtbl.add taken_cur name loc; Hashtbl.add taken name loc end else begin let loc = Hashtbl.find taken name in - Run.trace ("Dropping import " ^ name ^ ", linked to " ^ Int32.to_string loc); + trace ("Dropping import " ^ name ^ ", linked to " ^ Int32.to_string loc); Hashtbl.add map (Int32.of_int num) loc end in (* first just have to calculate total number of imports *) @@ -115,7 +115,7 @@ let merge a b = List.iteri (fun n x -> add_import taken_globals taken_imports_b g_imports gmap2 n x) (global_imports b); let num_f = List.length !f_imports in let num_g = List.length !g_imports in - Run.trace ("Function imports: " ^ string_of_int num_f ^ "; Global imports: " ^ string_of_int num_g); + trace ("Function imports: " ^ string_of_int num_f ^ "; Global imports: " ^ string_of_int num_g); (* now can calculate the export positions *) let taken_imports = Hashtbl.create 10 in let taken_imports_a = Hashtbl.create 10 in @@ -140,8 +140,8 @@ let merge a b = f_imports := []; List.iteri (fun n x -> add_import taken_imports taken_imports_a f_imports map1 n x) imports_a; List.iteri (fun n x -> add_import taken_imports taken_imports_b f_imports map2 n x) imports_b; - Run.trace ("Function imports: " ^ string_of_int num_f ^ "; Global imports: " ^ string_of_int num_g); - Run.trace ("Functions A: " ^ string_of_int (List.length a.it.funcs) ^ "; Functions B: " ^ string_of_int (List.length b.it.funcs)); + trace ("Function imports: " ^ string_of_int num_f ^ "; Global imports: " ^ string_of_int num_g); + trace ("Functions A: " ^ string_of_int (List.length a.it.funcs) ^ "; Functions B: " ^ string_of_int (List.length b.it.funcs)); (* add remapping for functions *) List.iteri (fun i _ -> Hashtbl.add map1 (Int32.of_int (i + num_fa)) (Int32.of_int (i + num_fa + offset_a))) a.it.funcs; @@ -149,10 +149,10 @@ let merge a b = Hashtbl.add map2 (Int32.of_int (i + num_fb)) (Int32.of_int (i + num_fb + offset_b))) b.it.funcs; (* add remapping for globals *) List.iteri (fun i _ -> - Run.trace ("global " ^ string_of_int i ^ " -> " ^ string_of_int (i + num_ga + offset_ga)); + trace ("global " ^ string_of_int i ^ " -> " ^ string_of_int (i + num_ga + offset_ga)); Hashtbl.add gmap1 (Int32.of_int (i + num_ga)) (Int32.of_int (i + num_ga + offset_ga))) a.it.globals; List.iteri (fun i _ -> - Run.trace ("global " ^ string_of_int i ^ " -> " ^ string_of_int (i + num_gb + offset_gb)); + trace ("global " ^ string_of_int i ^ " -> " ^ string_of_int (i + num_gb + offset_gb)); Hashtbl.add gmap2 (Int32.of_int (i + num_gb)) (Int32.of_int (i + num_gb + offset_gb))) b.it.globals; (* remap exports *) let exports_a = List.map (remap_export (Hashtbl.find map1) (Hashtbl.find gmap1) ftmap1 "") a.it.exports in @@ -162,7 +162,7 @@ let merge a b = let funcs_b = List.map (remap (Hashtbl.find map2) (Hashtbl.find gmap2) ftmap2) b.it.funcs in let more_imports = other_imports a @ List.filter drop_table_import (other_imports b) in (* table elements have to be remapped *) - Run.trace ("Remapping globals"); + trace ("Remapping globals"); {a with it={(a.it) with funcs = funcs_a@funcs_b; globals = List.map (remap_global (Hashtbl.find map1) (Hashtbl.find gmap1) ftmap1) a.it.globals @ List.map (remap_global (Hashtbl.find map2) (Hashtbl.find gmap2) ftmap2) b.it.globals; diff --git a/interpreter/merkle/merkle.ml b/interpreter/merkle/merkle.ml index f8291e5..8e17cef 100644 --- a/interpreter/merkle/merkle.ml +++ b/interpreter/merkle/merkle.ml @@ -5,6 +5,7 @@ open Ast open Source open Types open Values +open Sourceutil let (@) a b = List.rev_append (List.rev a) b @@ -15,65 +16,12 @@ let _ = Hashtbl.add custom_calls "_readBlock" 1; Hashtbl.add custom_calls "_internalStep" 2 -let trace = Byteutil.trace - (* perhaps we need to link the modules first *) (* have a separate call stack? *) (* perhaps the memory will include the stack? nope *) -let value_bool v = not (v = I32 0l || v = I64 0L) - -let value_to_int = function - | I32 i -> Int32.to_int i - | I64 i -> Int64.to_int i - | _ -> 0 - -let value_to_int64 = function - | I32 i -> Int64.of_int32 i - | I64 i -> i - | _ -> 0L - -let i x = I32 (Int32.of_int x) - -let is_float_op = function - | I32 _ | I64 _ -> false - | _ -> true - -let req_type = function - | I32 I32Op.ExtendSI32 -> I32Type - | I32 I32Op.ExtendUI32 -> I32Type - | I32 I32Op.WrapI64 -> I64Type - | I32 I32Op.TruncSF32 -> F32Type - | I32 I32Op.TruncUF32 -> F32Type - | I32 I32Op.TruncSF64 -> F64Type - | I32 I32Op.TruncUF64 -> F64Type - | I32 I32Op.ReinterpretFloat -> F32Type - | I64 I64Op.ExtendSI32 -> I32Type - | I64 I64Op.ExtendUI32 -> I32Type - | I64 I64Op.WrapI64 -> I64Type - | I64 I64Op.TruncSF32 -> F32Type - | I64 I64Op.TruncUF32 -> F32Type - | I64 I64Op.TruncSF64 -> F64Type - | I64 I64Op.TruncUF64 -> F64Type - | I64 I64Op.ReinterpretFloat -> F64Type - | F32 F32Op.ConvertSI32 -> I32Type - | F32 F32Op.ConvertUI32 -> I32Type - | F32 F32Op.ConvertSI64 -> I64Type - | F32 F32Op.ConvertUI64 -> I64Type - | F32 F32Op.PromoteF32 -> F32Type - | F32 F32Op.DemoteF64 -> F64Type - | F32 F32Op.ReinterpretInt -> I32Type - - | F64 F64Op.ConvertSI32 -> I32Type - | F64 F64Op.ConvertUI32 -> I32Type - | F64 F64Op.ConvertSI64 -> I64Type - | F64 F64Op.ConvertUI64 -> I64Type - | F64 F64Op.PromoteF32 -> F32Type - | F64 F64Op.DemoteF64 -> F64Type - | F64 F64Op.ReinterpretInt -> I64Type - type inst = | EXIT | UNREACHABLE @@ -82,7 +30,7 @@ type inst = | JUMPI of int | JUMPZ of int | JUMPFORWARD of int (* size of jump table *) - | CALL of int + | CALL of int * Int32.t | LABEL of int | RETURN | LOAD of loadop @@ -95,7 +43,7 @@ type inst = | STOREGLOBAL of int | CURMEM | GROW (* Grow memory *) - | CALLI (* indirect call *) + | CALLI of Int32.t (* indirect call (extra ID) *) | CHECKCALLI of Int64.t (* check type of indirect call *) | PUSH of value (* constant *) | TEST of testop (* numeric test *) @@ -118,6 +66,7 @@ type inst = | SETGLOBALS of int | SETMEMORY of int | CUSTOM of int + | BREAKPOINT of Int32.t type control = { target : int; @@ -133,12 +82,11 @@ type context = { f_types2 : (Int32.t, func_type) Hashtbl.t; block_return : control list; mdle : Ast.module_'; + add_points : bool; } (* Push the break points to stack? they can have own stack, also returns will have the same *) -let rec make a n = if n = 0 then [] else a :: make a (n-1) - let rec adjust_stack_aux diff num = if num = 0 then [] else begin @@ -151,8 +99,8 @@ let adjust_stack diff num = ( (* trace ("Adjusting stack: " ^ string_of_int num ^ " return values, " ^ string_of_int diff ^ " extra values"); *) adjust_stack_aux diff num @ [DROP diff] ) -let rec compile ctx expr = compile' ctx expr.it -and compile' ctx = function +let rec compile ctx expr = compile' ctx (Int32.of_int expr.at.right.line) expr.it +and compile' ctx id = function | Unreachable -> ctx, [UNREACHABLE] | Nop -> @@ -194,15 +142,15 @@ and compile' ctx = function let ctx = {ctx with label=ctx.label+1; bptr=ctx.bptr+1; block_return={level=ctx.ptr+rets; rets=rets; target=start_label}::old_return} in let ctx, body = compile_block ctx lst in (* trace ("loop end " ^ string_of_int ctx.ptr); *) - {ctx with bptr=ctx.bptr-1; block_return=old_return}, [LABEL start_label] @ body + {ctx with bptr=ctx.bptr-1; block_return=old_return}, [LABEL start_label] @ ( if ctx.add_points then [BREAKPOINT id] else [] ) @ body | If (ty, texp, fexp) -> (* trace ("if " ^ string_of_int ctx.ptr); *) let else_label = ctx.label in let end_label = ctx.label+1 in let a_ptr = ctx.ptr-1 in let ctx = {ctx with ptr=a_ptr; label=ctx.label+3} in - let ctx, tbody = compile' ctx (Block (ty, texp)) in - let ctx, fbody = compile' {ctx with ptr=a_ptr} (Block (ty, fexp)) in + let ctx, tbody = compile' ctx id (Block (ty, texp)) in + let ctx, fbody = compile' {ctx with ptr=a_ptr} id (Block (ty, fexp)) in ctx, [JUMPZ else_label] @ tbody @ [JUMP end_label; LABEL else_label] @ fbody @ [LABEL end_label] | Br x -> let num = Int32.to_int x.it in @@ -251,11 +199,13 @@ and compile' ctx = function (* Will just push the pc *) (* trace ("Function call " ^ Int32.to_string v.it); *) let FuncType (par,ret) = Hashtbl.find ctx.f_types v.it in - {ctx with ptr=ctx.ptr+List.length ret-List.length par}, [CALL (Int32.to_int v.it)] + let br = if ctx.add_points then [BREAKPOINT id] else [] in + {ctx with ptr=ctx.ptr+List.length ret-List.length par}, br @ [CALL (Int32.to_int v.it, id)] @ br | CallIndirect v -> let FuncType (par,ret) = Hashtbl.find ctx.f_types2 v.it in (* trace ("call indirect type: " ^ Int64.to_string (Byteutil.ftype_hash (FuncType (par,ret)))); *) - {ctx with ptr=ctx.ptr+List.length ret-List.length par-1}, [CHECKCALLI (Byteutil.ftype_hash (FuncType (par,ret))); CALLI] + let br = if ctx.add_points then [BREAKPOINT id] else [] in + {ctx with ptr=ctx.ptr+List.length ret-List.length par-1}, br @ [CHECKCALLI (Byteutil.ftype_hash (FuncType (par,ret))); CALLI id] @ br | Select -> (* trace "select"; *) let else_label = ctx.label in @@ -285,12 +235,6 @@ and compile_block ctx = function (* Initialize local variables with correct types *) -let type_to_str = function - | I32Type -> "i32" - | I64Type -> "i64" - | F32Type -> "f32" - | F64Type -> "f64" - let find_export_name m num = let rec get_exports = function | [] -> "internal function" @@ -314,7 +258,7 @@ let compile_func ctx idx func = trace ("---- function start params:" ^ string_of_int (List.length par) ^ " locals: " ^ string_of_int (List.length func.it.locals) ^ " type: " ^ Int32.to_string func.it.ftype.it); trace ("Type hash: " ^ Int64.to_string (Byteutil.ftype_hash (FuncType (par,ret)))); (* Just params are now in the stack *) - let ctx, body = compile' {ctx with ptr=ctx.ptr+List.length par+List.length func.it.locals} (Block (ret, func.it.body)) in + let ctx, body = compile' {ctx with ptr=ctx.ptr+List.length par+List.length func.it.locals} 0l (Block (ret, func.it.body)) in trace ("---- function end " ^ string_of_int ctx.ptr); ctx, ( if false (* !Flags.trace *) then [STUB (find_export_name ctx.mdle idx ^ " Idx " ^ string_of_int idx ^ " Params " ^ String.concat "," (List.map type_to_str par) ^ " Return " ^ String.concat "," (List.map type_to_str ret))] else [] ) @ @@ -343,97 +287,10 @@ let resolve_to n lst = List.map (resolve_inst tab) lst let resolve_inst2 tab = function - | CALL l -> CALL (Hashtbl.find tab l) + | CALL (l, id) -> CALL (Hashtbl.find tab l, id) | a -> a -let empty_ctx mdle = {ptr=0; label=0; bptr=0; block_return=[]; f_types2=Hashtbl.create 1; f_types=Hashtbl.create 1; mdle} - -let make_tables m = - let ftab = Hashtbl.create 10 in - let ttab = Hashtbl.create 10 in - List.iteri (fun i f -> Hashtbl.add ttab (Int32.of_int i) f.it) m.types; - let rec get_imports i = function - | [] -> [] - | {it=im; _} :: tl -> - match im.idesc.it with - | FuncImport tvar -> - let ty = Hashtbl.find ttab tvar.it in - Hashtbl.add ftab (Int32.of_int i) ty; - im :: get_imports (i+1) tl - | _ -> get_imports i tl in - let f_imports = get_imports 0 m.imports in - let num_imports = List.length f_imports in - List.iteri (fun i f -> - let ty = Hashtbl.find ttab f.it.ftype.it in - Hashtbl.add ftab (Int32.of_int (i + num_imports)) ty) m.funcs; - ftab, ttab - -let elem x = {it=x; at=no_region} - -let func_imports m = - let rec do_get = function - | [] -> [] - | ({it={idesc={it=FuncImport _;_};_};_} as el)::tl -> el :: do_get tl - | _::tl -> do_get tl in - do_get m.it.imports - -let global_imports m = - let rec do_get = function - | [] -> [] - | ({it={idesc={it=GlobalImport _;_};_};_} as el)::tl -> el :: do_get tl - | _::tl -> do_get tl in - do_get m.it.imports - -let other_imports m = - let rec do_get = function - | [] -> [] - | {it={idesc={it=FuncImport _;_};_};_}::tl -> do_get tl - | {it={idesc={it=GlobalImport _;_};_};_}::tl -> do_get tl - | el::tl -> el :: do_get tl in - do_get m.it.imports - -let other_imports_nomem m = - let rec do_get = function - | [] -> [] - | {it={idesc={it=FuncImport _;_};_};_}::tl -> do_get tl - | {it={idesc={it=GlobalImport _;_};_};_}::tl -> do_get tl - | {it={idesc={it=MemoryImport _;_};_};_}::tl -> do_get tl - | el::tl -> el :: do_get tl in - do_get m.it.imports - -let find_function m func = - let ftab = Hashtbl.create 10 in - let ttab = Hashtbl.create 10 in - List.iteri (fun i f -> Hashtbl.add ttab (Int32.of_int i) f.it) m.types; - let rec get_imports i = function - | [] -> [] - | {it=im; _} :: tl -> - match im.idesc.it with - | FuncImport tvar -> - let ty = Hashtbl.find ttab tvar.it in - Hashtbl.add ftab (Int32.of_int i) ty; - im :: get_imports (i+1) tl - | _ -> get_imports i tl in - let num_imports = List.length (get_imports 0 m.imports) in - let entry = ref (-1) in - List.iteri (fun i f -> - if f = func then ( entry := i + num_imports )) m.funcs; - !entry - -let find_function_index m inst name = - ( match Instance.export inst name with - | Some (Instance.ExternalFunc (Instance.AstFunc (_, func))) -> find_function m func - | _ -> raise Not_found ) - -let find_global_index m inst name = - let num_imports = 0l (* Int32.of_int (List.length (global_imports m)) *) in - let rec get_exports = function - | [] -> trace ("Cannot Find global: " ^ Utf8.encode name); raise Not_found - | {it=im; _} :: tl -> - match im.edesc.it with - | GlobalExport tvar -> if im.name = name then Int32.add tvar.it num_imports else get_exports tl - | _ -> get_exports tl in - Int32.to_int (get_exports m.it.exports) +let empty_ctx mdle = {ptr=0; label=0; bptr=0; block_return=[]; f_types2=Hashtbl.create 1; f_types=Hashtbl.create 1; mdle; add_points=false} let malloc_string mdle malloc str = let open Memory in @@ -445,16 +302,16 @@ let malloc_string mdle malloc str = done; res := [DUP 1; PUSH (i 0); STORE {ty=I32Type; align=0; offset=Int32.of_int (len-1); sz=Some Mem8}] :: !res; (* array address is left *) - [PUSH (i len); CALL malloc] @ List.flatten (List.rev (!res)) + [PUSH (i len); CALL (malloc, 0l)] @ List.flatten (List.rev (!res)) let make_args mdle inst lst = let malloc = find_function_index mdle inst (Utf8.decode "_malloc") in [PUSH (i (List.length lst)); (* argc *) - PUSH (i (List.length lst * 4)); CALL malloc] @ (* argv *) + PUSH (i (List.length lst * 4)); CALL (malloc, 0l)] @ (* argv *) List.flatten (List.mapi (fun i str -> [DUP 1] @ malloc_string mdle malloc str @ [STORE {ty=I32Type; align=0; offset=Int32.of_int (i*4 + !Flags.memory_offset); sz=None}]) lst) let simple_call mdle inst name = - try [STUB name; CALL (find_function_index mdle inst (Utf8.decode name))] + try [STUB name; CALL (find_function_index mdle inst (Utf8.decode name), 0l)] with Not_found -> [] let init_fs_stack mdle inst = @@ -463,11 +320,13 @@ let init_fs_stack mdle inst = prerr_endline ("All globals " ^ string_of_int (List.length mdle.globals)); let stack_max = List.length (global_imports (elem mdle)) + 3 in *) prerr_endline ("Warning: asm.js initialization is very dependant on the filesystem.wasm"); - let len = List.length (global_imports (elem mdle)) + List.length mdle.globals in - let stack_ptr = len - 20 in (* this is the difficult place *) + let asmjs = find_global_index (elem mdle) (Utf8.decode "ASMJS") in + (* let len = List.length (global_imports (elem mdle)) + List.length mdle.globals in + let stack_ptr = len - 20 in *) + let stack_ptr = asmjs - 16 in (* this is the difficult place *) let stack_max = stack_ptr + 1 in let malloc = find_function_index mdle inst (Utf8.decode "_malloc") in - [PUSH (i 1024); CALL malloc; DUP 1; DUP 1; + [PUSH (i 1024); CALL (malloc, 0l); DUP 1; DUP 1; STOREGLOBAL stack_ptr; BIN (I32 I32Op.Add); STOREGLOBAL stack_max] @@ -476,13 +335,13 @@ let init_system mdle inst = (* This is the last point that we can use to initialize metering *) let num_globals = List.length (global_imports (elem mdle)) + List.length mdle.globals in ( try - let initial_gas_limit = find_global_index (elem mdle) inst (Utf8.decode "GAS_LIMIT") in + let initial_gas_limit = find_global_index (elem mdle) (Utf8.decode "GAS_LIMIT") in let gas_limit = num_globals in let gas = num_globals + 1 in [LOADGLOBAL initial_gas_limit; CONV (I64 I64Op.ExtendUI32); PUSH (I64 1000000L); BIN (I64 I64Op.Mul); STOREGLOBAL gas_limit; PUSH (I64 0L); STOREGLOBAL gas] with Not_found -> [] ) @ simple_call mdle inst "__post_instantiate" @ - (if (try ignore (find_global_index (elem mdle) inst (Utf8.decode "ASMJS")); true with Not_found -> false) then init_fs_stack mdle inst else [] ) @ + (if (try ignore (find_global_index (elem mdle) (Utf8.decode "ASMJS")); true with Not_found -> false) then init_fs_stack mdle inst else [] ) @ simple_call mdle inst "_initSystem" let find_initializers mdle = @@ -510,21 +369,27 @@ let make_cxx_init mdle inst = (* @ [STUB "Initialization finished"] *) +let generic_stub m inst mname fname = + try [STUB (mname ^ " . " ^ fname); CALL (find_function_index m inst (Utf8.decode "_finalizeSystem"), 0l); EXIT] + with Not_found -> [STUB (mname ^ " . " ^ fname); EXIT] + +(* let generic_stub m inst mname fname = try [STUB (mname ^ " . " ^ fname); - CALL (find_function_index m inst (Utf8.decode "_callArguments")); + CALL (find_function_index m inst (Utf8.decode "_callArguments"), 0l); DROP_N; - CALL (find_function_index m inst (Utf8.decode "_callMemory")); + CALL (find_function_index m inst (Utf8.decode "_callMemory"), 0l); (* Just handle zero or one return values *) - CALL (find_function_index m inst (Utf8.decode "_callReturns")); + CALL (find_function_index m inst (Utf8.decode "_callReturns"), 0l); JUMPI (-2); JUMP (-3); LABEL (-2); - CALL (find_function_index m inst (Utf8.decode "_getReturn")); (* here we should do a type adjustment???? *) + CALL (find_function_index m inst (Utf8.decode "_getReturn"), 0l); (* here we should do a type adjustment???? *) LABEL (-3); RETURN] with Not_found -> [STUB (mname ^ " . " ^ fname); RETURN] +*) let mem_init_size m = if !Flags.run_wasm || !Flags.disable_float then Byteutil.pow2 (!Flags.memory_size - 13) else @@ -551,10 +416,28 @@ let flatten_tl lst = | a::tl -> do_flatten (a @ acc) tl in do_flatten [] (List.rev lst) -let kludge = ref (fun m -> 1) +let generate_entry id_to_local (lst, others) = + let stack_size = List.length lst + others in + (* others will have to be moved to make space *) + let n = List.length lst in + gen n (fun i -> DUP 1) @ (* fillers *) + gen others (fun i -> DUP (others-i+n+1)) @ (* this should copy the others *) + List.flatten (List.mapi (fun i id -> [DUP (stack_size + List.assoc id_to_local id); SWAP (stack_size-i); DROP 1]) lst) (* access local variable, then write to filled location *) + +let generate_exit id_to_local (lst, others) = + (* let stack_size = List.length lst + others in *) + (* others will have to be moved over the hidden variables *) + let n = List.length lst in + List.flatten (gen others (fun i -> [DUP (others-i+1); SWAP (others-i+1+n); DROP 1])) @ (* this should copy the others *) + [DROP others] let compile_test m func vs init inst = (* debug_exports m; *) + (try + let g_ind = find_global_index (elem m) (Utf8.decode "MEMORY_OFFSET") in + let g = List.nth m.globals g_ind in + Flags.memory_offset := value_to_int (Eval.eval_const inst g.it.value) + with Not_found -> () ); trace ("Function types: " ^ string_of_int (List.length m.types)); trace ("Functions: " ^ string_of_int (List.length m.funcs)); trace ("Tables: " ^ string_of_int (List.length m.tables)); @@ -586,7 +469,7 @@ let compile_test m func vs init inst = (* perhaps could do something with the function type *) (* one idea would be to use a debugging message *) let exit_code = - try [CALL (find_function_index m inst (Utf8.decode "_finalizeSystem")); EXIT] + try [CALL (find_function_index m inst (Utf8.decode "_finalizeSystem"), 0l); EXIT] with Not_found -> [EXIT] in let import_codes = List.map (fun im -> let mname = Utf8.encode im.module_name in @@ -600,12 +483,12 @@ let compile_test m func vs init inst = if mname = "env" && fname = "_outputData" then [OUTPUTDATA;RETURN] else if mname = "env" && fname = "_sbrk" then [STUB "sbrk"; - LOADGLOBAL (find_global_index (elem m) inst (Utf8.decode "DYNAMICTOP_PTR")); + LOADGLOBAL (find_global_index (elem m) (Utf8.decode "DYNAMICTOP_PTR")); LOAD {ty=I32Type; align=0; offset=Int32.of_int !Flags.memory_offset; sz=None}; DUP 1; DUP 3; BIN (I32 I32Op.Add); - LOADGLOBAL (find_global_index (elem m) inst (Utf8.decode "DYNAMICTOP_PTR")); + LOADGLOBAL (find_global_index (elem m) (Utf8.decode "DYNAMICTOP_PTR")); DUP 2; STORE {ty=I32Type; align=0; offset=Int32.of_int !Flags.memory_offset; sz=None}; DUP 2; @@ -616,22 +499,22 @@ let compile_test m func vs init inst = (* invoke index, a1, a2*) if mname = "env" && String.length fname > 7 && String.sub fname 0 7 = "invoke_" then let number = String.sub fname 7 (String.length fname - 7) in - [CALL (find_function_index m inst (Utf8.decode ("dynCall_" ^ number))); RETURN] else + [CALL (find_function_index m inst (Utf8.decode ("dynCall_" ^ number)), 0l); RETURN] else if mname = "env" && String.length fname > 8 && String.sub fname 0 8 = "_invoke_" then let number = String.sub fname 8 (String.length fname - 8) in - try [ (* STUB fname; *) CALL (find_function_index m inst (Utf8.decode ("_dynCall_" ^ number))); RETURN] + try [ (* STUB fname; *) CALL (find_function_index m inst (Utf8.decode ("_dynCall_" ^ number)), 0l); RETURN] with Not_found -> prerr_endline ("Warning: cannot find dynamic call number " ^ number); [RETURN] else if mname = "env" && fname = "abort" then [UNREACHABLE] else if mname = "env" && fname = "_exit" then exit_code else if mname = "env" && fname = "getTotalMemory" then - try [LOADGLOBAL (find_global_index (elem m) inst (Utf8.decode "TOTAL_MEMORY")); RETURN] + try [LOADGLOBAL (find_global_index (elem m) (Utf8.decode "TOTAL_MEMORY")); RETURN] with Not_found -> ( prerr_endline "Warning, cannot find global variable TOTAL_MEMORY. Use emscripten-module-wrapper to run files that were generated by emscripten"; [PUSH (i (1024*1024*1500)); RETURN] ) else if mname = "env" && fname = "setTempRet0" then - try [STUB "setTempRet0 (found)"; CALL (find_function_index m inst (Utf8.decode ("setTempRet0"))); RETURN] + try [STUB "setTempRet0 (found)"; CALL (find_function_index m inst (Utf8.decode ("setTempRet0")), 0l); RETURN] with Not_found -> [STUB "setTempRet0"; DROP 1; RETURN] else (* if mname = "env" && fname = "_rintf" then [UNA (F32 F32Op.Nearest); RETURN] else *) if mname = "env" && fname = "_rintf" then [STUB "rintf"; RETURN] else @@ -640,7 +523,7 @@ let compile_test m func vs init inst = if mname = "env" && fname = "_cosf" then [STUB "cosf"; RETURN] else if mname = "env" && fname = "_sinf" then [STUB "sinf"; RETURN] else if mname = "env" && fname = "pushFrame" then - let stack_limit = Int32.of_int (Byteutil.pow2 !Flags.stack_size - !kludge (elem m)) in + let stack_limit = Int32.of_int (Byteutil.pow2 !Flags.stack_size - Stacksize.check (elem m)) in let call_limit = Int32.of_int (Byteutil.pow2 !Flags.call_size - 1) in let num_globals = List.length (global_imports (elem m)) + List.length m.globals in let call_stack = num_globals + 2 in @@ -658,9 +541,9 @@ let compile_test m func vs init inst = PUSH (I32 0l); LOADGLOBAL frame_stack; BIN (I32 I32Op.Sub); STOREGLOBAL frame_stack; LOADGLOBAL call_stack; PUSH (I32 1l); BIN (I32 I32Op.Sub); STOREGLOBAL call_stack; RETURN; LABEL (-11); UNREACHABLE] else - if mname = "env" && fname = "usegas" then + if mname = "env" && fname = "usegas" || mname = "env" && fname = "gas" then try - let _ (* initial gas limit *) = find_global_index (elem m) inst (Utf8.decode "GAS_LIMIT") in + let _ (* initial gas limit *) = find_global_index (elem m) (Utf8.decode "GAS_LIMIT") in let num_globals = List.length (global_imports (elem m)) + List.length m.globals in let gas_limit = num_globals in let gas = num_globals + 1 in @@ -669,13 +552,13 @@ let compile_test m func vs init inst = if mname = "env" && fname = "_debugString" then [STUB (mname ^ " . " ^ fname); RETURN] else if mname = "env" && fname = "_debugBuffer" then [STUB (mname ^ " . " ^ fname); DROP 1; RETURN] else if mname = "env" && fname = "_debugInt" then [STUB (mname ^ " . " ^ fname); RETURN] else - if mname = "env" && fname = "_getSystem" then [LOADGLOBAL (find_global_index (elem m) inst (Utf8.decode "_system_ptr")); RETURN] else - if mname = "env" && fname = "_setSystem" then [STOREGLOBAL (find_global_index (elem m) inst (Utf8.decode "_system_ptr")); RETURN] else + if mname = "env" && fname = "_getSystem" then [LOADGLOBAL (find_global_index (elem m) (Utf8.decode "_system_ptr")); RETURN] else + if mname = "env" && fname = "_setSystem" then [STOREGLOBAL (find_global_index (elem m) (Utf8.decode "_system_ptr")); RETURN] else if mname = "env" && Hashtbl.mem custom_calls fname then [CUSTOM (Hashtbl.find custom_calls fname); RETURN] else generic_stub m inst mname fname ) f_imports in let module_codes = List.mapi (fun i f -> if f = func then trace "*************** CURRENT "; - compile_func {(empty_ctx m) with f_types2=ttab; f_types=ftab} (i + List.length f_imports) f) m.funcs in + compile_func {(empty_ctx m) with f_types2=ttab; f_types=ftab; add_points = !Flags.br_mode} (i + List.length f_imports) f) m.funcs in let f_resolve = Hashtbl.create 10 in let rec build n acc l_acc = function | [] -> acc @@ -684,7 +567,7 @@ let compile_test m func vs init inst = trace ("Function " ^ string_of_int n ^ " at " ^ string_of_int l_acc); let x = resolve_to l_acc fcode in build (n+1) (x::acc) (List.length x + l_acc) tl in - let test_code = init @ List.map (fun v -> PUSH v) vs @ [CALL !entry] @ exit_code in + let test_code = init @ List.map (fun v -> PUSH v) vs @ [CALL (!entry, 0l)] @ exit_code in let codes = build 0 [test_code] (List.length test_code) (import_codes @ List.map snd module_codes) in trace ("Here, working"); let flat_code = flatten_tl (List.rev codes) in diff --git a/interpreter/merkle/mproof.ml b/interpreter/merkle/mproof.ml index af82305..2ff4264 100644 --- a/interpreter/merkle/mproof.ml +++ b/interpreter/merkle/mproof.ml @@ -1,11 +1,9 @@ -open Merkle open Values open Mrun open Mbinary open Byteutil - -let trace = Merkle.trace +open Sourceutil let to_hex a = "\"0x" ^ w256_to_string a ^ "\"" @@ -734,6 +732,18 @@ let vm_to_string vm = " \"memsize\": " ^ string_of_int vm.bin_memsize ^ " " ^ "}" +let vm_io_to_string vm = + let code_bin = map_hash (fun v -> microp_word (get_code v)) vm.code in + let input_size_bin = map_hash u256 vm.input.file_size in + let input_name_bin = map_hash string_to_root vm.input.file_name in + let input_data_bin = map_hash bytes_to_root vm.input.file_data in + "{" ^ + " \"code\": " ^ to_hex code_bin ^ "," ^ + " \"input_size\": " ^ to_hex input_size_bin ^ "," ^ + " \"input_name\": " ^ to_hex input_name_bin ^ "," ^ + " \"input_data\": " ^ to_hex input_data_bin ^ + "}" + let proof3_to_string (m, vm, loc) = "{ \"vm\": " ^ vm_to_string vm ^ ", \"machine\": " ^ machine_to_string m ^ ", \"merkle\": " ^ loc_to_string loc ^ " }" diff --git a/interpreter/merkle/mrun.ml b/interpreter/merkle/mrun.ml index 0861731..bd072b7 100644 --- a/interpreter/merkle/mrun.ml +++ b/interpreter/merkle/mrun.ml @@ -2,6 +2,7 @@ open Merkle open Values open Types +open Sourceutil let rec pow2 n = if n = 0 then 1 else 2 * pow2 (n-1) @@ -46,6 +47,7 @@ type alu_code = | DebugInt | DebugString | DebugBuffer + | Breakpoint type reg = | Reg1 @@ -262,7 +264,7 @@ let get_vm_string vm loc = let get_vm_buffer vm loc len = let res = ref "" in (* let loc = ref (get_memory_int vm loc) in *) - for i = 0 to len - 1 do + for i = 0 to min (len - 1) 256 do res := !res ^ String.make 1 (get_memory_char vm (loc+i)); done; !res @@ -477,7 +479,7 @@ let write_register vm regs v = function set_input_name vm s2 s1 v | InputDataOut -> let s2 = value_to_int regs.reg1 in - let s1 = value_to_int regs.reg2 in +(* let s1 = value_to_int regs.reg2 in *) let v = value_to_int v in let s1 = if v < 0 then v + 256 else v in trace ("output data to file number " ^ string_of_int s2 ^ ": " ^ string_of_int s1); @@ -630,7 +632,7 @@ let print_conv64 = function | I64Op.ReinterpretFloat -> "reinterpret" exception FloatsDisabled - +exception BreakpointExn let handle_alu vm r1 r2 r3 ireg = function | FixMemory (ty, sz) -> mem_load r2 r3 ty sz (value_to_int r1+value_to_int ireg) @@ -687,11 +689,13 @@ let handle_alu vm r1 r2 r3 ireg = function let ptr = value_to_int (vm.stack.(vm.stack_ptr - 1)) in prerr_endline ("DEBUG: " ^ string_of_int ptr); i 0 + | Breakpoint -> raise BreakpointExn open Ast let get_code = function | NOP -> noop + | BREAKPOINT _ -> {noop with alu_code=Breakpoint} | STUB _ -> noop | UNREACHABLE -> {noop with alu_code=Trap} | EXIT -> {noop with immed=I64 (Int64.of_int magic_pc); read_reg1 = Immed; pc_ch=StackReg} @@ -699,9 +703,9 @@ let get_code = function | JUMPI x -> {noop with immed=i x; read_reg1 = Immed; read_reg2 = StackIn0; read_reg3 = ReadPc; alu_code = CheckJump; pc_ch=StackReg; stack_ch=StackDec} | JUMPZ x -> {noop with immed=i x; read_reg1 = Immed; read_reg2 = StackIn0; read_reg3 = ReadPc; alu_code = CheckJumpZ; pc_ch=StackReg; stack_ch=StackDec} | JUMPFORWARD x -> {noop with immed=i x; read_reg1 = StackIn0; read_reg2 = ReadPc; alu_code = CheckJumpForward; pc_ch=StackReg; stack_ch=StackDec} - | CALL x -> {noop with immed=i x; read_reg1=Immed; read_reg2 = ReadPc; write1 = (Reg2, CallOut); call_ch = StackInc; pc_ch=StackReg} + | CALL (x, _) -> {noop with immed=i x; read_reg1=Immed; read_reg2 = ReadPc; write1 = (Reg2, CallOut); call_ch = StackInc; pc_ch=StackReg} | CHECKCALLI x -> {noop with immed=I64 x; read_reg1=StackIn0; read_reg2=TableTypeIn; alu_code=CheckDynamicCall; pc_ch=StackInc} - | CALLI -> {noop with read_reg2=ReadPc; read_reg1=StackIn0; read_reg3=TableIn; pc_ch=StackReg3; write1 = (Reg2, CallOut); call_ch = StackInc; stack_ch=StackDec} + | CALLI _ -> {noop with read_reg2=ReadPc; read_reg1=StackIn0; read_reg3=TableIn; pc_ch=StackReg3; write1 = (Reg2, CallOut); call_ch = StackInc; stack_ch=StackDec} | INPUTSIZE -> {noop with read_reg1=StackIn0; read_reg2=InputSizeIn; write1 = (Reg2, StackOut1)} | INPUTNAME -> {noop with read_reg1=StackIn0; read_reg2=StackIn1; read_reg3=InputNameIn; write1 = (Reg3, StackOut2); stack_ch=StackDec} | INPUTDATA -> {noop with read_reg1=StackIn0; read_reg2=StackIn1; read_reg3=InputDataIn; write1 = (Reg3, StackOut2); stack_ch=StackDec} @@ -864,17 +868,18 @@ let vm_step vm = match vm.code.(vm.pc) with vm.calltable_types.(x) <- value_to_int64 vm.stack.(vm.stack_ptr-1); vm.stack_ptr <- vm.stack_ptr - 1 | EXIT -> vm.pc <- magic_pc + | BREAKPOINT _ -> raise BreakpointExn | UNREACHABLE -> raise (Eval.Trap (Source.no_region, "unreachable executed")) | JUMPFORWARD x -> let idx = value_to_int vm.stack.(vm.stack_ptr-1) in let idx = if idx < 0 || idx >= x then x else idx in vm.pc <- vm.pc + 1 + idx; vm.stack_ptr <- vm.stack_ptr - 1 - | CALL x -> + | CALL (x,_) -> vm.call_stack.(vm.call_ptr) <- vm.pc+1; vm.call_ptr <- vm.call_ptr + 1; vm.pc <- x - | CALLI -> + | CALLI _ -> let addr = value_to_int vm.stack.(vm.stack_ptr-1) in vm.stack_ptr <- vm.stack_ptr - 1; vm.call_stack.(vm.call_ptr) <- vm.pc+1; @@ -1151,6 +1156,7 @@ let trace_step vm = if Array.length vm.code <= vm.pc then "Microp" else match vm.code.(vm.pc) with | NOP -> "NOP" + | BREAKPOINT _ -> "BREAKPOINT" | STUB str -> "STUB " ^ str | UNREACHABLE -> "UNREACHABLE" | EXIT -> "EXIT" @@ -1172,7 +1178,7 @@ let trace_step vm = let x = vm.stack.(vm.stack_ptr-1) in "JUMPZ " ^ (if not (value_bool x) then " jump" else " no jump") ^ " " ^ string_of_value x | JUMPFORWARD x -> "JUMPFORWARD " ^ string_of_value vm.stack.(vm.stack_ptr-1) - | CALL x -> "CALL " ^ string_of_int x + | CALL (x,_) -> "CALL " ^ string_of_int x | LABEL _ -> "LABEL ???" | RETURN -> "RETURN" | LOAD x -> @@ -1201,7 +1207,7 @@ let trace_step vm = | TEST op -> "TEST" | BIN op -> "BIN " ^ string_of_value vm.stack.(vm.stack_ptr-2) ^ " " ^ string_of_value vm.stack.(vm.stack_ptr-1) | CMP op -> "CMP " ^ string_of_value vm.stack.(vm.stack_ptr-2) ^ " " ^ string_of_value vm.stack.(vm.stack_ptr-1) - | CALLI -> "CALLI" + | CALLI _ -> "CALLI" | CHECKCALLI x -> "CHECKCALLI" | SETSTACK v -> "SETSTACK" | SETCALLSTACK v -> "SETCALLSTACK" @@ -1212,6 +1218,7 @@ let trace_step vm = let trace_clean vm = match vm.code.(vm.pc) with | NOP -> "NOP" + | BREAKPOINT _ -> "BREAKPOINT" | STUB str -> "STUB " ^ str | UNREACHABLE -> "UNREACHABLE" | EXIT -> "EXIT" @@ -1226,7 +1233,7 @@ let trace_clean vm = match vm.code.(vm.pc) with | JUMPI x -> "JUMPI" | JUMPZ x -> "JUMPZ" | JUMPFORWARD x -> "JUMPFORWARD" - | CALL x -> "CALL " ^ string_of_int x + | CALL (x,_) -> "CALL " ^ string_of_int x | LABEL _ -> "LABEL ???" | RETURN -> "RETURN" | LOAD x -> @@ -1248,7 +1255,7 @@ let trace_clean vm = match vm.code.(vm.pc) with | TEST op -> "TEST" | BIN op -> "BIN" | CMP op -> "CMP" - | CALLI -> "CALLI" + | CALLI _ -> "CALLI" | CHECKCALLI x -> "CHECKCALLI" | SETSTACK v -> "SETSTACK" | SETCALLSTACK v -> "SETCALLSTACK" diff --git a/interpreter/merkle/secretstack.ml b/interpreter/merkle/secretstack.ml index 5987698..0c82da4 100644 --- a/interpreter/merkle/secretstack.ml +++ b/interpreter/merkle/secretstack.ml @@ -1,15 +1,11 @@ -open Merkle open Ast open Source open Types +open Sourceutil (* Analyze stack *) -let do_it x f = {x with it=f x.it} - -let it e = {it=e; at=no_region} - type control = { rets : int; level : int; @@ -27,18 +23,6 @@ type context = { tctx : Valid.context; } -let relabel lst = - let uniq = ref 1 in - let rec compile expr = - incr uniq; - {it=compile' expr.it; at={left=no_pos; right={file="label"; line= !uniq; column=0}}} - and compile' = function - | Block (ty, lst) -> Block (ty, List.map compile lst) - | Loop (ty, lst) -> Loop (ty, List.map compile lst) - | If (ty, texp, fexp) -> If (ty, List.map compile texp, List.map compile fexp) - | a -> a in - List.map compile lst - (* Associating instructions with types *) let assoc_types ctx func = let res = Hashtbl.create 10 in @@ -61,18 +45,12 @@ let assoc_types ctx func = (* the idea would be to add local variables so that there are never hidden elements in the stack when making a call *) -let rec popn n = function - | a::tl when n > 0 -> popn (n-1) tl - | lst -> lst - -let rec take n = function - | a::tl when n > 0 -> a :: take (n-1) tl - | lst -> [] - let una_stack id x = {x with stack=id::popn 1 x.stack} let bin_stack id x = {x with stack=id::popn 2 x.stack} let n_stack n id x = {x with stack=id::popn n x.stack} +let info = Hashtbl.create 100 + let rec compile marked (ctx : context) expr = compile' marked ctx (Int32.of_int expr.at.right.line) expr.it and compile' marked ctx id = function | Block (ty, lst) -> @@ -90,7 +68,13 @@ and compile' marked ctx id = function | Loop (_, lst) -> let old_return = ctx.block_return in let extra = ctx.ptr - ctx.locals in - if extra > 0 then trace ("loop start " ^ string_of_int extra); + (* we should mark the extra here, too *) + if extra > 0 then begin + trace ("loop start " ^ string_of_int extra); + let hidden = take extra ctx.stack in + marked := hidden @ !marked; + Hashtbl.add info id (hidden, 0); + end; let ctx = {ctx with bptr=ctx.bptr+1; block_return={level=ctx.ptr; rets=0}::old_return} in let ctx = compile_block marked ctx lst in if extra > 0 then trace ("loop end " ^ string_of_int extra); @@ -99,14 +83,22 @@ and compile' marked ctx id = function (* Will just push the pc *) let FuncType (par,ret) = Hashtbl.find ctx.f_types v.it in let extra = ctx.ptr - ctx.locals - List.length par in - if extra > 0 then trace ("call " ^ string_of_int extra); - marked := (take extra (popn (List.length par) ctx.stack)) @ !marked; + if extra > 0 then begin + trace ("call " ^ string_of_int extra); + let hidden = take extra (popn (List.length par) ctx.stack) in + marked := hidden @ !marked; + Hashtbl.add info id (hidden, List.length par); + end; {ctx with ptr=ctx.ptr+List.length ret-List.length par; stack=make id (List.length ret) @ popn (List.length par) ctx.stack} | CallIndirect v -> let FuncType (par,ret) = Hashtbl.find ctx.f_types2 v.it in let extra = ctx.ptr - ctx.locals - List.length par - 1 in - if extra > 0 then trace ("calli " ^ string_of_int extra); - marked := (take extra (popn (List.length par+1) ctx.stack)) @ !marked; + if extra > 0 then begin + trace ("calli " ^ string_of_int extra ^ " adding info for " ^ Int32.to_string id); + let hidden = take extra (popn (List.length par+1) ctx.stack) in + marked := hidden @ !marked; + Hashtbl.add info id (hidden, List.length par+1); + end; {ctx with ptr=ctx.ptr+List.length ret-List.length par-1; stack=make id (List.length ret) @ popn (List.length par + 1) ctx.stack} | If (ty, texp, fexp) -> let a_ptr = ctx.ptr-1 in @@ -128,7 +120,6 @@ and compile' marked ctx id = function let c = List.nth ctx.block_return num in {ctx with ptr=ctx.ptr - c.rets; stack=popn c.rets ctx.stack} | BrIf x -> - let num = Int32.to_int x.it in {ctx with ptr = ctx.ptr-1; stack=popn 1 ctx.stack} | BrTable (tab, def) -> let num = Int32.to_int def.it in @@ -171,12 +162,13 @@ let tee_locals assoc func = and compile_list lst = List.flatten (List.map compile lst) in compile_list func.it.body +let func_info = ref [] + let compile_func ctx func = let FuncType (par,ret) = Hashtbl.find ctx.f_types2 func.it.ftype.it in trace ("---- function start params:" ^ string_of_int (List.length par) ^ " locals: " ^ string_of_int (List.length func.it.locals)); (* Just params are now in the stack *) let locals = List.length par + List.length func.it.locals in - let func = do_it func (fun f -> {f with body=relabel f.body}) in let res = assoc_types (Valid.func_context ctx.tctx func) func in let marked = ref [] in let ctx = compile' marked {ctx with ptr=locals; locals=locals} 0l (Block (ret, func.it.body)) in @@ -187,8 +179,10 @@ let compile_func ctx func = | _ -> trace ("Warning: empty type") ; raise Not_found with Not_found -> ( trace ("Warning: cannot find type") ; I32Type) in + (* Association list from expression ids to local variables *) let marked = List.mapi (fun i x -> x, (find_type x, {it=Int32.of_int (i+locals); at=no_region})) !marked in trace ("---- function end " ^ string_of_int ctx.ptr); + func_info := !func_info @ [marked]; do_it func (fun f -> {f with locals=f.locals@List.map (fun (_,(t,_)) -> t) marked; body=tee_locals marked func}) let make_tables m = @@ -211,7 +205,13 @@ let make_tables m = Hashtbl.add ftab (Int32.of_int (i + num_imports)) ty) m.funcs; ftab, ttab +let relabel m = + do_it m (fun m -> + {m with funcs=List.map (fun func -> do_it func (fun f -> {f with body=relabel f.body})) m.funcs}) + let process m_ = + Hashtbl.clear info; + func_info := []; do_it m_ (fun m -> let ftab, ttab = make_tables m in let ctx = { diff --git a/interpreter/merkle/shiftmem.ml b/interpreter/merkle/shiftmem.ml index 2b8bd25..ecc9be6 100644 --- a/interpreter/merkle/shiftmem.ml +++ b/interpreter/merkle/shiftmem.ml @@ -1,11 +1,9 @@ open Source open Ast -open Merkle +open Sourceutil open Values -let do_it x f = {x with it=f x.it} - (* offset in load, store and memory segments *) let rec convert_inst' num = function diff --git a/interpreter/merkle/sourceutil.ml b/interpreter/merkle/sourceutil.ml new file mode 100644 index 0000000..75563a2 --- /dev/null +++ b/interpreter/merkle/sourceutil.ml @@ -0,0 +1,227 @@ +open Ast +open Source +open Types +open Values + +(* Analyze stack *) + +let do_it x f = {x with it=f x.it} + +let it e = {it=e; at=no_region} + +let uniq = ref 1 + +let relabel lst = + let rec compile expr = + incr uniq; + {it=compile' expr.it; at={left=no_pos; right={file="label"; line= !uniq; column=0}}} + and compile' = function + | Block (ty, lst) -> Block (ty, List.map compile lst) + | Loop (ty, lst) -> Loop (ty, List.map compile lst) + | If (ty, texp, fexp) -> If (ty, List.map compile texp, List.map compile fexp) + | a -> a in + List.map compile lst + +let rec popn n = function + | a::tl when n > 0 -> popn (n-1) tl + | lst -> lst + +let rec take n = function + | a::tl when n > 0 -> a :: take (n-1) tl + | lst -> [] + +let rec gen n a = if n = 0 then [] else a (n-1) :: gen (n-1) a + +let value_bool v = not (v = I32 0l || v = I64 0L) + +let value_to_int = function + | I32 i -> Int32.to_int i + | I64 i -> Int64.to_int i + | _ -> 0 + +let value_to_int64 = function + | I32 i -> Int64.of_int32 i + | I64 i -> i + | _ -> 0L + +let i x = I32 (Int32.of_int x) + +let is_float_op = function + | I32 _ | I64 _ -> false + | _ -> true + +let req_type = function + | I32 I32Op.ExtendSI32 -> I32Type + | I32 I32Op.ExtendUI32 -> I32Type + | I32 I32Op.WrapI64 -> I64Type + | I32 I32Op.TruncSF32 -> F32Type + | I32 I32Op.TruncUF32 -> F32Type + | I32 I32Op.TruncSF64 -> F64Type + | I32 I32Op.TruncUF64 -> F64Type + | I32 I32Op.ReinterpretFloat -> F32Type + | I64 I64Op.ExtendSI32 -> I32Type + | I64 I64Op.ExtendUI32 -> I32Type + | I64 I64Op.WrapI64 -> I64Type + | I64 I64Op.TruncSF32 -> F32Type + | I64 I64Op.TruncUF32 -> F32Type + | I64 I64Op.TruncSF64 -> F64Type + | I64 I64Op.TruncUF64 -> F64Type + | I64 I64Op.ReinterpretFloat -> F64Type + | F32 F32Op.ConvertSI32 -> I32Type + | F32 F32Op.ConvertUI32 -> I32Type + | F32 F32Op.ConvertSI64 -> I64Type + | F32 F32Op.ConvertUI64 -> I64Type + | F32 F32Op.PromoteF32 -> F32Type + | F32 F32Op.DemoteF64 -> F64Type + | F32 F32Op.ReinterpretInt -> I32Type + + | F64 F64Op.ConvertSI32 -> I32Type + | F64 F64Op.ConvertUI32 -> I32Type + | F64 F64Op.ConvertSI64 -> I64Type + | F64 F64Op.ConvertUI64 -> I64Type + | F64 F64Op.PromoteF32 -> F32Type + | F64 F64Op.DemoteF64 -> F64Type + | F64 F64Op.ReinterpretInt -> I64Type + +let rec make a n = if n = 0 then [] else a :: make a (n-1) + +let trace = Byteutil.trace + +let make_tables m = + let ftab = Hashtbl.create 10 in + let ttab = Hashtbl.create 10 in + List.iteri (fun i f -> Hashtbl.add ttab (Int32.of_int i) f.it) m.types; + let rec get_imports i = function + | [] -> [] + | {it=im; _} :: tl -> + match im.idesc.it with + | FuncImport tvar -> + let ty = Hashtbl.find ttab tvar.it in + Hashtbl.add ftab (Int32.of_int i) ty; + im :: get_imports (i+1) tl + | _ -> get_imports i tl in + let f_imports = get_imports 0 m.imports in + let num_imports = List.length f_imports in + List.iteri (fun i f -> + let ty = Hashtbl.find ttab f.it.ftype.it in + Hashtbl.add ftab (Int32.of_int (i + num_imports)) ty) m.funcs; + ftab, ttab + +let elem x = {it=x; at=no_region} + +let func_imports m = + let rec do_get = function + | [] -> [] + | ({it={idesc={it=FuncImport _;_};_};_} as el)::tl -> el :: do_get tl + | _::tl -> do_get tl in + do_get m.it.imports + +let global_imports m = + let rec do_get = function + | [] -> [] + | ({it={idesc={it=GlobalImport _;_};_};_} as el)::tl -> el :: do_get tl + | _::tl -> do_get tl in + do_get m.it.imports + +let other_imports m = + let rec do_get = function + | [] -> [] + | {it={idesc={it=FuncImport _;_};_};_}::tl -> do_get tl + | {it={idesc={it=GlobalImport _;_};_};_}::tl -> do_get tl + | el::tl -> el :: do_get tl in + do_get m.it.imports + +let other_imports_nomem m = + let rec do_get = function + | [] -> [] + | {it={idesc={it=FuncImport _;_};_};_}::tl -> do_get tl + | {it={idesc={it=GlobalImport _;_};_};_}::tl -> do_get tl + | {it={idesc={it=MemoryImport _;_};_};_}::tl -> do_get tl + | el::tl -> el :: do_get tl in + do_get m.it.imports + +let find_function m func = + let ftab = Hashtbl.create 10 in + let ttab = Hashtbl.create 10 in + List.iteri (fun i f -> Hashtbl.add ttab (Int32.of_int i) f.it) m.types; + let rec get_imports i = function + | [] -> [] + | {it=im; _} :: tl -> + match im.idesc.it with + | FuncImport tvar -> + let ty = Hashtbl.find ttab tvar.it in + Hashtbl.add ftab (Int32.of_int i) ty; + im :: get_imports (i+1) tl + | _ -> get_imports i tl in + let num_imports = List.length (get_imports 0 m.imports) in + let entry = ref (-1) in + List.iteri (fun i f -> + if f = func then ( entry := i + num_imports )) m.funcs; + !entry + +let find_function_index m inst name = + ( match Instance.export inst name with + | Some (Instance.ExternalFunc (Instance.AstFunc (_, func))) -> find_function m func + | _ -> raise Not_found ) + +let find_global_index m name = + let num_imports = 0l (* Int32.of_int (List.length (global_imports m)) *) in + let rec get_exports = function + | [] -> trace ("Cannot Find global: " ^ Utf8.encode name); raise Not_found + | {it=im; _} :: tl -> + match im.edesc.it with + | GlobalExport tvar -> if im.name = name then Int32.add tvar.it num_imports else get_exports tl + | _ -> get_exports tl in + Int32.to_int (get_exports m.it.exports) + +let type_to_str = function + | I32Type -> "i32" + | I64Type -> "i64" + | F32Type -> "f32" + | F64Type -> "f64" + + +let int_const y = Const (elem (Values.I32 (Int32.of_int y))) +let int64_const y = Const (elem (Values.I64 y)) +let f64_const y = Const (elem (Values.F64 y)) + +let int_binary i = + let res = Bytes.create 4 in + Bytes.set res 0 (Char.chr (i land 0xff)); + Bytes.set res 1 (Char.chr ((i lsr 8) land 0xff)); + Bytes.set res 2 (Char.chr ((i lsr 16) land 0xff)); + Bytes.set res 3 (Char.chr ((i lsr 24) land 0xff)); + Bytes.to_string res + +let generate_data (addr, i) : string segment = + elem { + offset=elem [elem (int_const (addr*4))]; + index=elem 0l; + init=int_binary i; + } + +let add_i32_global m name tmem = + let open Types in + let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in + do_it m (fun m -> {m with + globals=m.globals@[elem {value=elem [elem (int_const tmem)]; gtype=GlobalType (I32Type, Immutable)}]; + exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) + +let add_i64_global m name tmem = + let open Types in + let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in + do_it m (fun m -> {m with + globals=m.globals@[elem {value=elem [elem (int64_const tmem)]; gtype=GlobalType (I64Type, Immutable)}]; + exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) + +let add_f64_global m name tmem = + let open Types in + let idx = Int32.of_int (List.length (global_imports m) + List.length m.it.globals) in + do_it m (fun m -> {m with + globals=m.globals@[elem {value=elem [elem (f64_const tmem)]; gtype=GlobalType (F64Type, Immutable)}]; + exports=m.exports@[elem {name=Utf8.decode name; edesc=elem (GlobalExport (elem idx))}]}) + +let has_import m name = + List.exists (fun im -> Utf8.encode im.it.item_name = name) m.it.imports + + diff --git a/interpreter/merkle/stacksize.ml b/interpreter/merkle/stacksize.ml index 63b4d83..a1372ca 100644 --- a/interpreter/merkle/stacksize.ml +++ b/interpreter/merkle/stacksize.ml @@ -1,8 +1,8 @@ -open Merkle open Ast open Source open Types +open Sourceutil type control = { rets : int; @@ -135,7 +135,7 @@ let check_func ctx func = let add_functions m = do_it m (fun m -> (* add function types *) - let i_num = List.length (Merkle.func_imports (it m)) in + let i_num = List.length (func_imports (it m)) in let ftypes = m.types @ [ it (FuncType ([I32Type], [])); ] in @@ -170,7 +170,11 @@ let check m = f_types2=ttab; f_types=ftab; locals=0; stack=[] } in let lst = List.sort compare (List.map (fun x -> check_func ctx x) m.it.funcs) in - if lst <> [] then prerr_endline ("Highest " ^ string_of_int (List.hd (List.rev lst))) + if lst <> [] then + let highest = List.hd (List.rev lst) in + prerr_endline ("Highest " ^ string_of_int highest); + max 10 highest + else 10 let process_func ctx push_f pop_f func = let limit = Int32.of_int (check_func ctx func) in @@ -183,8 +187,9 @@ let process_func ctx push_f pop_f func = let process m = let m = add_functions m in - let push_f = Int32.of_int (List.length (Merkle.func_imports m) - 2) in - let pop_f = Int32.of_int (List.length (Merkle.func_imports m) - 1) in + let m = add_i32_global m "FRAME_MAX" (check m) in + let push_f = Int32.of_int (List.length (func_imports m) - 2) in + let pop_f = Int32.of_int (List.length (func_imports m) - 1) in let ftab, ttab = Secretstack.make_tables m.it in let ctx = { ptr=0; bptr=0; block_return=[]; diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml index 5065b57..ad6b5d2 100644 --- a/interpreter/script/run.ml +++ b/interpreter/script/run.ml @@ -321,14 +321,16 @@ let add_input vm i fname = let open Mrun in vm.input.file_name.(i) <- terminate fname; let fname = if !Flags.input_out then fname ^ ".out" else fname in - let ch = open_in_bin fname in - let sz = in_channel_length ch in - vm.input.file_size.(i) <- sz; - let dta = Bytes.create sz in - really_input ch dta 0 sz; - close_in ch; - vm.input.file_data.(i) <- dta; - trace ("Added file " ^ fname ^ ", " ^ string_of_int sz ^ " bytes") + try + let ch = open_in_bin fname in + let sz = in_channel_length ch in + vm.input.file_size.(i) <- sz; + let dta = Bytes.create sz in + really_input ch dta 0 sz; + close_in ch; + vm.input.file_data.(i) <- dta; + trace ("Added file " ^ fname ^ ", " ^ string_of_int sz ^ " bytes") + with _ -> prerr_endline ("Warning: cannot find file " ^ fname ) let output_files vm = let open Mrun in @@ -391,6 +393,15 @@ let setup_vm inst mdle func vs = (* prerr_endline "Initialized"; *) vm +let get_code mdle = + let imports = Import.link mdle in + let inst = Eval.init mdle imports in + let func = match Instance.export inst (Utf8.decode "_main") with + | Some (Instance.ExternalFunc (Instance.AstFunc (_, func))) -> func + | _ -> raise (Failure "no main function") in + let vm = setup_vm inst mdle.it func [] in + Array.to_list vm.Mrun.code + let take_array n arr = let res = ref [] in for i = 0 to n-1 do @@ -418,6 +429,9 @@ let handle_exit vm selected = if selected && !Flags.output_proof then begin let vm_bin = Mbinary.vm_to_bin vm in Printf.printf "{\"vm\": %s, \"hash\": %s, \"steps\": %i, \"files\": %s}\n" (Mproof.vm_to_string vm_bin) (Mproof.to_hex (Mbinary.hash_io_bin vm_bin)) vm.step (print_file_names vm) + end; + if selected && !Flags.output_io_proof then begin + Printf.printf "{\"vm\": %s, \"hash\": %s, \"steps\": %i, \"files\": %s}\n" (Mproof.vm_io_to_string vm) (Mproof.to_hex (Mbinary.hash_io vm)) vm.step (print_file_names vm) end let run_test_aux vm =