diff --git a/example/c/README.md b/example/c/README.md index 71175b8cb..dd099ab9c 100644 --- a/example/c/README.md +++ b/example/c/README.md @@ -367,7 +367,7 @@ int main(void) { ``` ```sh -$ owi c --e-acsl primes.c +$ owi c --e-acsl primes.c -w1 Assert failure: false Model: (model diff --git a/src/ast/binary.ml b/src/ast/binary.ml index aea8437c1..15bc972d2 100644 --- a/src/ast/binary.ml +++ b/src/ast/binary.ml @@ -50,27 +50,27 @@ type elem = type modul = { id : string option - ; types : binary rec_type Named.t - ; global : (global, binary global_type) Runtime.t Named.t - ; table : (binary table, binary table_type) Runtime.t Named.t - ; mem : (mem, limits) Runtime.t Named.t - ; func : (binary func, binary block_type) Runtime.t Named.t + ; types : binary rec_type array + ; global : (global, binary global_type) Runtime.t array + ; table : (binary table, binary table_type) Runtime.t array + ; mem : (mem, limits) Runtime.t array + ; func : (binary func, binary block_type) Runtime.t array (* TODO: switch to func_type *) - ; elem : elem Named.t - ; data : data Named.t + ; elem : elem array + ; data : data array ; exports : exports ; start : int option } let empty_modul = { id = None - ; types = Named.empty - ; global = Named.empty - ; table = Named.empty - ; mem = Named.empty - ; func = Named.empty - ; elem = Named.empty - ; data = Named.empty + ; types = [||] + ; global = [||] + ; table = [||] + ; mem = [||] + ; func = [||] + ; elem = [||] + ; data = [||] ; exports = { global = []; mem = []; table = []; func = [] } ; start = None } diff --git a/src/ast/binary_encoder.ml b/src/ast/binary_encoder.ml index 394d6e577..c445c3520 100644 --- a/src/ast/binary_encoder.ml +++ b/src/ast/binary_encoder.ml @@ -89,15 +89,21 @@ let write_valtype buf vt = let c = get_char_valtype vt in Buffer.add_char buf c -let encode_vector buf datas encode_func = +let encode_vector length iter buf datas encode_func = let vector_buf = Buffer.create 16 in - let len = List.length datas in - List.iter (encode_func vector_buf) datas; + let len = length datas in + iter (encode_func vector_buf) datas; write_u32_of_int buf len; Buffer.add_buffer buf vector_buf +let encode_vector_list buf datas encode_func = + encode_vector List.length List.iter buf datas encode_func + +let encode_vector_array buf datas encode_func = + encode_vector Array.length Array.iter buf datas encode_func + let write_resulttype buf (rt : _ result_type) = - encode_vector buf rt write_valtype + encode_vector_list buf rt write_valtype let write_paramtype buf (pt : _ param_type) = let vt = List.map snd pt in @@ -111,11 +117,10 @@ let write_block_type buf (typ : binary block_type option) = match typ with | None | Some (Bt_raw (None, ([], []))) -> Buffer.add_char buf '\x40' | Some (Bt_raw (None, ([], [ vt ]))) -> write_valtype buf vt - | Some (Bt_raw (None, (pt, _))) -> - write_paramtype buf pt - (* TODO: memo - will this pattern matching be enough with the use of the new modul.types field? - *) + | Some (Bt_raw (None, (pt, _))) -> write_paramtype buf pt + (* TODO: memo + will this pattern matching be enough with the use of the new modul.types field? + *) | _ -> assert false (* TODO: same, new pattern matching cases ? *) let write_block_type_idx buf (typ : binary block_type) = @@ -200,9 +205,8 @@ let rec write_instr buf instr = | Br idx -> write_char_indice buf '\x0C' idx | Br_if idx -> write_char_indice buf '\x0D' idx | Br_table (idxs, idx) -> - let idxs = Array.to_list idxs in add_char '\x0E'; - encode_vector buf idxs write_indice; + encode_vector_array buf idxs write_indice; write_indice buf idx | Return -> add_char '\x0F' | Call idx -> write_char_indice buf '\x10' idx @@ -540,12 +544,11 @@ let write_locals buf locals = let write_element buf ({ typ = _, ht; init; mode; _ } : elem) = let write_init buf init = let is_ref_func = ref true in - encode_vector buf init (fun buf expr -> - match expr with - | [ Ref_func idx ] -> write_indice buf idx - | expr -> - write_expr buf expr ~end_op_code:None; - is_ref_func := false ); + encode_vector_list buf init (fun buf -> function + | [ Ref_func idx ] -> write_indice buf idx + | expr -> + write_expr buf expr ~end_op_code:None; + is_ref_func := false ); !is_ref_func in match mode with @@ -626,24 +629,21 @@ let encode_section buf id encode_func data = end (* type: section 1 *) -let encode_types buf (rec_types : binary rec_type Named.t) = - encode_vector buf rec_types.values - (fun buf (typ : binary rec_type Indexed.t) -> - let typ = Indexed.get typ in +let encode_types buf rec_types = + encode_vector_array buf rec_types (fun buf -> function + | [] -> assert false + | _ :: _ :: _ -> + (* TODO rec types *) + assert false + | [ typ ] -> ( match typ with - | [] -> assert false - | _ :: _ :: _ -> - (* TODO rec types *) - assert false - | [ typ ] -> ( - match typ with - | _name, (Final, _idx, Def_func_t (pt, rt)) -> - Buffer.add_char buf '\x60'; - write_paramtype buf pt; - write_resulttype buf rt - | _ -> - (* TODO non final types and other type declarations *) - assert false ) ) + | _name, (Final, _idx, Def_func_t (pt, rt)) -> + Buffer.add_char buf '\x60'; + write_paramtype buf pt; + write_resulttype buf rt + | _ -> + (* TODO non final types and other type declarations *) + assert false ) ) (* import: section 2 *) let encode_imports buf (funcs, tables, memories, globals) = @@ -662,20 +662,18 @@ let encode_imports buf (funcs, tables, memories, globals) = (* function: section 3 *) let encode_functions buf (funcs : binary func list) = let idx = ref 0 in - encode_vector buf funcs (fun buf func -> + encode_vector_list buf funcs (fun buf func -> write_block_type_idx buf func.type_f; incr idx ) (* table: section 4 *) -let encode_tables buf tables = encode_vector buf tables write_table +let encode_tables buf tables = encode_vector_list buf tables write_table (* memory: section 5 *) -let encode_memories buf memories = encode_vector buf memories write_memory +let encode_memories buf memories = encode_vector_list buf memories write_memory (* global: section 6 *) -let encode_globals buf globals = - let globals = List.rev globals in - encode_vector buf globals write_global +let encode_globals buf globals = encode_vector_list buf globals write_global (* export: section 7 *) let encode_exports buf ({ global; mem; table; func } : exports) = @@ -699,19 +697,16 @@ let encode_start buf int_opt = match int_opt with None -> () | Some funcidx -> write_u32_of_int buf funcidx (* element: section 9 *) -let encode_elements buf { Named.values = elems; _ } = - encode_vector buf elems (fun buf elem -> - let elem = Indexed.get elem in - write_element buf elem ) +let encode_elements buf elems = encode_vector_array buf elems write_element (* datacount: section 12 *) -let encode_datacount buf { Named.values = datas; _ } = - let len = List.length datas in +let encode_datacount buf datas = + let len = Array.length datas in write_u32_of_int buf len (* code: section 10 *) let encode_codes buf funcs = - encode_vector buf funcs (fun buf { locals; body; _ } -> + encode_vector_list buf funcs (fun buf { locals; body; _ } -> let code_buf = Buffer.create 16 in write_locals code_buf locals; write_expr code_buf body ~end_op_code:None; @@ -719,54 +714,49 @@ let encode_codes buf funcs = Buffer.add_buffer buf code_buf ) (* data: section 11 *) -let encode_datas buf { Named.values = datas; _ } = - encode_vector buf datas (fun buf data -> - let data = Indexed.get data in - write_data buf data ) +let encode_datas buf datas = encode_vector_array buf datas write_data -let keep_local { Named.values; _ } = +let keep_local values = List.filter_map - (fun data -> - match Indexed.get data with - | Runtime.Local data -> Some data - | Runtime.Imported _data -> None ) - (List.rev values) + (function Runtime.Local data -> Some data | Runtime.Imported _data -> None) + (Array.to_list values) -let keep_imported { Named.values; _ } = +let keep_imported values = List.filter_map - (fun data -> - match Indexed.get data with - | Runtime.Local _data -> None - | Runtime.Imported data -> Some data ) - (List.rev values) + (function Runtime.Local _data -> None | Runtime.Imported data -> Some data) + (Array.to_list values) -let encode (modul : Binary.modul) = +let encode + ({ func; table; global; exports; start; data; mem; types; elem; _ } : + Binary.modul ) = let buf = Buffer.create 256 in - let local_funcs = keep_local modul.func in - let local_tables = keep_local modul.table in - let local_memories = keep_local modul.mem in - let local_globales = keep_local modul.global in - let imported_funcs = keep_imported modul.func in - let imported_tables = keep_imported modul.table in - let imported_memories = keep_imported modul.mem in - let imported_globals = keep_imported modul.global in + + let local_funcs = keep_local func in + let local_tables = keep_local table in + let local_memories = keep_local mem in + let local_globales = keep_local global in + let imported_funcs = keep_imported func in + let imported_tables = keep_imported table in + let imported_memories = keep_imported mem in + let imported_globals = keep_imported global in + Buffer.add_string buf "\x00\x61\x73\x6d"; (* magic *) Buffer.add_string buf "\x01\x00\x00\x00"; (* version *) - encode_section buf '\x01' encode_types modul.types; + encode_section buf '\x01' encode_types types; encode_section buf '\x02' encode_imports (imported_funcs, imported_tables, imported_memories, imported_globals); encode_section buf '\x03' encode_functions local_funcs; encode_section buf '\x04' encode_tables local_tables; encode_section buf '\x05' encode_memories local_memories; encode_section buf '\x06' encode_globals local_globales; - encode_section buf '\x07' encode_exports modul.exports; - encode_section buf '\x08' encode_start modul.start; - encode_section buf '\x09' encode_elements modul.elem; - encode_section buf '\x0C' encode_datacount modul.data; + encode_section buf '\x07' encode_exports exports; + encode_section buf '\x08' encode_start start; + encode_section buf '\x09' encode_elements elem; + encode_section buf '\x0C' encode_datacount data; encode_section buf '\x0A' encode_codes local_funcs; - encode_section buf '\x0B' encode_datas modul.data; + encode_section buf '\x0B' encode_datas data; Buffer.contents buf let write_file filename content = diff --git a/src/ast/binary_to_text.ml b/src/ast/binary_to_text.ml index f30a9fb45..7380c9ee5 100644 --- a/src/ast/binary_to_text.ml +++ b/src/ast/binary_to_text.ml @@ -122,95 +122,80 @@ let convert_data (e : Binary.data) : Text.data = let mode = convert_data_mode mode in { id; init; mode } -let from_types (types : Types.binary Types.rec_type Named.t) : - Text.module_field list = - Named.fold - (fun i (t : Types.binary Types.rec_type) acc -> +let from_types types : Text.module_field list = + Array.map + (fun (t : Types.binary Types.rec_type) -> let t = convert_rec_type t in - (i, MType t) :: acc ) - types [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_global (global : (Binary.global, binary global_type) Runtime.t Named.t) - : Text.module_field list = - Named.fold - (fun i (g : (Binary.global, binary global_type) Runtime.t) acc -> - match g with - | Runtime.Local g -> + MType t ) + types + |> Array.to_list + +let from_global global : Text.module_field list = + Array.map + (function + | Runtime.Local (g : Binary.global) -> let typ = convert_global_type g.typ in let init = convert_expr g.init in let id = g.id in - (i, MGlobal { typ; init; id }) :: acc + MGlobal { typ; init; id } | Imported { modul; name; assigned_name; desc } -> let desc = Import_global (assigned_name, convert_global_type desc) in - (i, MImport { modul; name; desc }) :: acc ) - global [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_table (table : (binary table, binary table_type) Runtime.t Named.t) : - Text.module_field list = - Named.fold - (fun i (t : (binary table, binary table_type) Runtime.t) acc -> - match t with + MImport { modul; name; desc } ) + global + |> Array.to_list + +let from_table table : Text.module_field list = + Array.map + (function | Runtime.Local t -> let t = convert_table t in - (i, MTable t) :: acc + MTable t | Imported { modul; name; assigned_name; desc } -> let desc = Import_table (assigned_name, convert_table_type desc) in - (i, MImport { modul; name; desc }) :: acc ) - table [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_mem (mem : (mem, limits) Runtime.t Named.t) : Text.module_field list = - Named.fold - (fun i mem acc -> - match mem with - | Runtime.Local mem -> (i, MMem mem) :: acc + MImport { modul; name; desc } ) + table + |> Array.to_list + +let from_mem mem : Text.module_field list = + Array.map + (function + | Runtime.Local mem -> MMem mem | Imported { modul; name; assigned_name; desc } -> let desc = Import_mem (assigned_name, desc) in - (i, MImport { modul; name; desc }) :: acc ) - mem [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_func (func : (binary func, binary block_type) Runtime.t Named.t) : - Text.module_field list = - Named.fold - (fun i (func : (binary func, binary block_type) Runtime.t) acc -> - match func with + MImport { modul; name; desc } ) + mem + |> Array.to_list + +let from_func func : Text.module_field list = + Array.map + (function | Runtime.Local func -> let type_f = convert_block_type func.type_f in let locals = convert_param_type func.locals in let body = convert_expr func.body in let id = func.id in - (i, MFunc { type_f; locals; body; id }) :: acc + MFunc { type_f; locals; body; id } | Imported { modul; name; assigned_name; desc } -> let desc = Import_func (assigned_name, convert_block_type desc) in - (i, MImport { modul; name; desc }) :: acc ) - func [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_elem (elem : Binary.elem Named.t) : Text.module_field list = - Named.fold - (fun i (elem : Binary.elem) acc -> + MImport { modul; name; desc } ) + func + |> Array.to_list + +let from_elem elem : Text.module_field list = + Array.map + (fun (elem : Binary.elem) -> let elem = convert_elem elem in - (i, MElem elem) :: acc ) - elem [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd - -let from_data (data : Binary.data Named.t) : Text.module_field list = - Named.fold - (fun i (data : Binary.data) acc -> + MElem elem ) + elem + |> Array.to_list + +let from_data data : Text.module_field list = + Array.map + (fun (data : Binary.data) -> let data = convert_data data in - (i, MData data) :: acc ) - data [] - |> List.sort (fun (i1, _t1) (i2, _t2) -> Int.compare i1 i2) - |> List.map snd + MData data ) + data + |> Array.to_list let from_exports (exports : Binary.exports) : Text.module_field list = let global = diff --git a/src/cmd/cmd_utils.ml b/src/cmd/cmd_utils.ml index c2250a02b..9f03d6f6b 100644 --- a/src/cmd/cmd_utils.ml +++ b/src/cmd/cmd_utils.ml @@ -43,12 +43,13 @@ let add_main_as_start (m : Binary.modul) = | None -> (* TODO: fail/display a warning saying nothing will be done ? *) Ok m - | Some export -> ( + | Some export -> (* We found a main function, so we check its type and build a start function that put the right values on the stack, call the main function and drop the results *) let main_id = export.id in - match Indexed.get_at main_id m.func.values with - | None -> Error (`Msg "can't find a main function") - | Some main_function -> + if main_id >= Array.length m.func then + Error (`Msg "can't find a main function") + else + let main_function = m.func.(main_id) in let (Bt_raw main_type) = match main_function with Local f -> f.type_f | Imported i -> i.desc in @@ -79,18 +80,13 @@ let add_main_as_start (m : Binary.modul) = { Types.type_f; locals = []; body; id = None } in let start_func = Runtime.Local start_code in - let named = m.func.named in + (* We need to add the new start function to the funcs of the module at the next free index *) - let next_free_index = - List.fold_left - (fun next_free_index v -> - let index = Indexed.get_index v in - if next_free_index > index then next_free_index else index + 1 ) - 0 m.func.values - in - let values = - Indexed.return next_free_index start_func :: m.func.values + let func = + Array.init + (Array.length m.func + 1) + (fun i -> if i = Array.length m.func then start_func else m.func.(i)) in - let func = { Named.named; values } in - let start = Some next_free_index in - { m with func; start } ) + + let start = Some (Array.length m.func) in + { m with func; start } diff --git a/src/data_structures/named.ml b/src/data_structures/named.ml index 09367645e..0a1b9b988 100644 --- a/src/data_structures/named.ml +++ b/src/data_structures/named.ml @@ -18,3 +18,14 @@ let fold f v acc = let map f v = let values = List.map f v.values in { v with values } + +let to_array v = + let tbl = Hashtbl.create 512 in + List.iter + (fun v -> + let i = Indexed.get_index v in + let v = Indexed.get v in + if Hashtbl.mem tbl i then assert false else Hashtbl.add tbl i v ) + v.values; + Array.init (List.length v.values) (fun i -> + match Hashtbl.find_opt tbl i with None -> assert false | Some v -> v ) diff --git a/src/data_structures/named.mli b/src/data_structures/named.mli index e2da1fe73..b519e0af1 100644 --- a/src/data_structures/named.mli +++ b/src/data_structures/named.mli @@ -12,3 +12,5 @@ val empty : 'a t val fold : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val map : ('a Indexed.t -> 'b Indexed.t) -> 'a t -> 'b t + +val to_array : 'a t -> 'a array diff --git a/src/link/link.ml b/src/link/link.ml index bcb17e5df..c8e78f204 100644 --- a/src/link/link.ml +++ b/src/link/link.ml @@ -152,13 +152,15 @@ let eval_global ls env (global : (Binary.global, binary global_type) Runtime.t) | Imported import -> load_global ls import let eval_globals ls env globals : Link_env.Build.t Result.t = - Named.fold - (fun id global env -> - let* env in - let* global = eval_global ls env global in - let env = Link_env.Build.add_global id global env in - Ok env ) - globals (Ok env) + let+ env, _i = + array_fold_left + (fun (env, i) global -> + let+ global = eval_global ls env global in + let env = Link_env.Build.add_global i global env in + (env, succ i) ) + (env, 0) globals + in + env (* let eval_in_data (env : Link_env.t) (data : _ data') : (int, value) data' = @@ -194,13 +196,15 @@ let eval_memory ls (memory : (mem, limits) Runtime.t) : | Imported import -> load_memory ls import let eval_memories ls env memories = - Named.fold - (fun id mem env -> - let* env in - let* memory = eval_memory ls mem in - let env = Link_env.Build.add_memory id memory env in - Ok env ) - memories (Ok env) + let+ env, _i = + array_fold_left + (fun (env, id) mem -> + let+ memory = eval_memory ls mem in + let env = Link_env.Build.add_memory id memory env in + (env, succ id) ) + (env, 0) memories + in + env let table_types_are_compatible (import, (t1 : binary ref_type)) (imported, t2) = limit_is_included ~import ~imported && Types.ref_type_eq t1 t2 @@ -218,13 +222,15 @@ let eval_table ls (table : (_, binary table_type) Runtime.t) : table Result.t = | Imported import -> load_table ls import let eval_tables ls env tables = - Named.fold - (fun id table env -> - let* env in - let* table = eval_table ls table in - let env = Link_env.Build.add_table id table env in - Ok env ) - tables (Ok env) + let+ env, _i = + array_fold_left + (fun (env, i) table -> + let+ table = eval_table ls table in + let env = Link_env.Build.add_table i table env in + (env, succ i) ) + (env, 0) tables + in + env let load_func (ls : 'f state) (import : binary block_type Imported.t) : func Result.t = @@ -246,13 +252,15 @@ let eval_func ls (finished_env : Link_env.t') func : func Result.t = | Imported import -> load_func ls import let eval_functions ls (finished_env : Link_env.t') env functions = - Named.fold - (fun id func env -> - let* env in - let* func = eval_func ls finished_env func in - let env = Link_env.Build.add_func id func env in - Ok env ) - functions (Ok env) + let+ env, _i = + array_fold_left + (fun (env, i) func -> + let+ func = eval_func ls finished_env func in + let env = Link_env.Build.add_func i func env in + (env, succ i) ) + (env, 0) functions + in + env let active_elem_expr ~offset ~length ~table ~elem = [ I32_const offset @@ -278,60 +286,61 @@ let get_i32 = function | _ -> Error (`Type_mismatch "get_i32") let define_data env data = - Named.fold - (fun id (data : Binary.data) env_and_init -> - let* env, init = env_and_init in - let data' : Link_env.data = { value = data.init } in - let env = Link_env.Build.add_data id data' env in - let* init = - match data.mode with - | Data_active (mem, offset) -> - let* offset = Eval_const.expr env offset in - let length = Int32.of_int @@ String.length data.init in - let* offset = get_i32 offset in - let id = Raw id in - let* v = active_data_expr ~offset ~length ~mem ~data:id in - ok @@ (v :: init) - | Data_passive -> Ok init - in - Ok (env, init) ) - data - (Ok (env, [])) + let+ env, init, _i = + array_fold_left + (fun (env, init, i) (data : Binary.data) -> + let data' : Link_env.data = { value = data.init } in + let env = Link_env.Build.add_data i data' env in + let+ init = + match data.mode with + | Data_active (mem, offset) -> + let* offset = Eval_const.expr env offset in + let length = Int32.of_int @@ String.length data.init in + let* offset = get_i32 offset in + let id = Raw i in + let* v = active_data_expr ~offset ~length ~mem ~data:id in + ok @@ (v :: init) + | Data_passive -> Ok init + in + (env, init, succ i) ) + (env, [], 0) data + in + (env, List.rev init) let define_elem env elem = - Named.fold - (fun id (elem : Binary.elem) env_and_inits -> - let* env, inits = env_and_inits in - let* init = list_map (Eval_const.expr env) elem.init in - let* init_as_ref = - list_map - (fun v -> - match v with - | Concrete_value.Ref v -> Ok v - | _ -> Error `Constant_expression_required ) - init - in - let env = - match elem.mode with - | Elem_active _ | Elem_passive -> - Link_env.Build.add_elem id { value = Array.of_list init_as_ref } env - | Elem_declarative -> - (* Declarative element have no runtime value *) - Link_env.Build.add_elem id { value = [||] } env - in - let* inits = - match elem.mode with - | Elem_active (None, _) -> assert false - | Elem_active (Some table, offset) -> - let length = Int32.of_int @@ List.length init in - let* offset = Eval_const.expr env offset in - let* offset = get_i32 offset in - ok @@ (active_elem_expr ~offset ~length ~table ~elem:id :: inits) - | Elem_passive | Elem_declarative -> Ok inits - in - Ok (env, inits) ) - elem - (Ok (env, [])) + let+ env, inits, _i = + array_fold_left + (fun (env, inits, i) (elem : Binary.elem) -> + let* init = list_map (Eval_const.expr env) elem.init in + let* init_as_ref = + list_map + (function + | Concrete_value.Ref v -> Ok v + | _ -> Error `Constant_expression_required ) + init + in + let value = + match elem.mode with + | Elem_active _ | Elem_passive -> Array.of_list init_as_ref + | Elem_declarative -> + (* Declarative element have no runtime value *) + [||] + in + let env = Link_env.Build.add_elem i { value } env in + let+ inits = + match elem.mode with + | Elem_active (None, _) -> assert false + | Elem_active (Some table, offset) -> + let length = Int32.of_int @@ List.length init in + let* offset = Eval_const.expr env offset in + let* offset = get_i32 offset in + ok @@ (active_elem_expr ~offset ~length ~table ~elem:i :: inits) + | Elem_passive | Elem_declarative -> Ok inits + in + (env, inits, succ i) ) + (env, [], 0) elem + in + (env, List.rev inits) let populate_exports env (exports : Binary.exports) : exports Result.t = let fill_exports get_env exports names = diff --git a/src/optimize/optimize.ml b/src/optimize/optimize.ml index 03a169438..f8bccc3db 100644 --- a/src/optimize/optimize.ml +++ b/src/optimize/optimize.ml @@ -513,16 +513,11 @@ let optimize_func (func : binary func) = let locals, body = remove_unused_locals locals nb_args body in { type_f; locals; body; id } -let optimize_runtime_func f = - Indexed.map - (function - | Runtime.Imported _ as f -> f - | Local f -> Runtime.Local (optimize_func f) ) - f - -let optimize_funcs funs = Named.map optimize_runtime_func funs +let optimize_runtime_func = function + | Runtime.Imported _ as f -> f + | Local f -> Runtime.Local (optimize_func f) let modul m = Log.debug0 "optimizing ...@\n"; - let func = optimize_funcs m.func in + let func = Array.map optimize_runtime_func m.func in { m with func } diff --git a/src/parser/binary_parser.ml b/src/parser/binary_parser.ml index 677c9494c..4945a8527 100644 --- a/src/parser/binary_parser.ml +++ b/src/parser/binary_parser.ml @@ -930,10 +930,10 @@ let sections_iterate (input : Input.t) = let* _custom_sections, input = parse_many_custom_section input in (* Type *) - let* type_section, input = + let* types, input = section_parse input ~expected_id:'\x01' [] (vector read_type) in - let type_section = Array.of_list type_section in + let types = Array.of_list types in (* Custom *) let* _custom_sections', input = parse_many_custom_section input in @@ -978,7 +978,7 @@ let sections_iterate (input : Input.t) = (* Globals *) let* global_section, input = section_parse input ~expected_id:'\x06' [] - (vector_no_id (read_global type_section)) + (vector_no_id (read_global types)) in (* Custom *) @@ -1008,7 +1008,7 @@ let sections_iterate (input : Input.t) = (* Elements *) let* element_section, input = section_parse input ~expected_id:'\x09' [] - @@ vector_no_id (read_element type_section) + @@ vector_no_id (read_element types) in (* Custom *) @@ -1028,8 +1028,7 @@ let sections_iterate (input : Input.t) = (* Code *) let* code_section, input = - section_parse input ~expected_id:'\x0A' [] - (vector_no_id (read_code type_section)) + section_parse input ~expected_id:'\x0A' [] (vector_no_id (read_code types)) in let* () = @@ -1043,13 +1042,14 @@ let sections_iterate (input : Input.t) = let _custom_sections = _custom_sections @ _custom_sections' in (* Data *) - let+ data_section, input = - section_parse input ~expected_id:'\x0B' [] - (vector_no_id (read_data type_section)) + let+ data, input = + section_parse input ~expected_id:'\x0B' [] (vector_no_id (read_data types)) in + let data = Array.of_list data in + let* () = - match (List.length data_section, data_count_section) with + match (Array.length data, data_count_section) with | 0, None -> Ok () | _data_len, None -> let code_use_dataidx = ref false in @@ -1075,15 +1075,6 @@ let sections_iterate (input : Input.t) = else Ok () in - let indexed_of_list l = List.mapi Indexed.return l in - let indexed_of_array l = Array.mapi Indexed.return l |> Array.to_list in - - (* Types *) - let types = - let values = indexed_of_array type_section in - { Named.values; named = String_map.empty } - in - (* Memories *) let mem = let local = List.map (fun mem -> Runtime.Local mem) memory_section in @@ -1096,8 +1087,7 @@ let sections_iterate (input : Input.t) = | _not_a_memory_import -> None ) import_section in - let values = indexed_of_list (imported @ local) in - { Named.values; named = String_map.empty } + Array.of_list (imported @ local) in (* Globals *) @@ -1113,8 +1103,7 @@ let sections_iterate (input : Input.t) = | _not_a_global_import -> None ) import_section in - let values = indexed_of_list (imported @ local) in - { Named.values; named = String_map.empty } + Array.of_list (imported @ local) in (* Functions *) @@ -1123,7 +1112,7 @@ let sections_iterate (input : Input.t) = List.map2 (fun typeidx (locals, body) -> Runtime.Local - { type_f = block_type_of_rec_type type_section.(typeidx) + { type_f = block_type_of_rec_type types.(typeidx) ; locals ; body ; id = None @@ -1139,13 +1128,12 @@ let sections_iterate (input : Input.t) = { modul ; name ; assigned_name = None - ; desc = block_type_of_rec_type type_section.(typeidx) + ; desc = block_type_of_rec_type types.(typeidx) } | _not_a_function_import -> None ) import_section in - let values = indexed_of_list (imported @ local) in - { Named.values; named = String_map.empty } + Array.of_list (imported @ local) in (* Tables *) @@ -1165,21 +1153,11 @@ let sections_iterate (input : Input.t) = | _not_a_table_import -> None ) import_section in - let values = indexed_of_list (imported @ local) in - { Named.values; named = String_map.empty } + Array.of_list (imported @ local) in (* Elems *) - let elem = - let values = indexed_of_list element_section in - { Named.values; named = String_map.empty } - in - - (* Data *) - let data = - let values = indexed_of_list data_section in - { Named.values; named = String_map.empty } - in + let elem = Array.of_list element_section in (* Exports *) let empty_exports = { global = []; mem = []; table = []; func = [] } in diff --git a/src/text_to_binary/rewrite.ml b/src/text_to_binary/rewrite.ml index a04904d16..b7a7d2d64 100644 --- a/src/text_to_binary/rewrite.ml +++ b/src/text_to_binary/rewrite.ml @@ -417,17 +417,16 @@ let modul (modul : Assigned.t) : Binary.modul Result.t = Some id in + let id = modul.id in + let mem = Named.to_array modul.mem in + let table = Named.to_array modul.table in + let types = Named.to_array types in + let global = Named.to_array global in + let elem = Named.to_array elem in + let data = Named.to_array data in + let func = Named.to_array func in + let modul : Binary.modul = - { id = modul.id - ; mem = modul.mem - ; table = modul.table - ; types - ; global - ; elem - ; data - ; exports - ; func - ; start - } + { id; mem; table; types; global; elem; data; exports; func; start } in modul diff --git a/src/utils/syntax.ml b/src/utils/syntax.ml index dcab8db4b..d02c5c9b9 100644 --- a/src/utils/syntax.ml +++ b/src/utils/syntax.ml @@ -70,3 +70,10 @@ let array_map f a = raise Exit | Ok v -> v ) with Exit -> Option.get !err + +let array_fold_left f acc l = + Array.fold_left + (fun acc v -> + let* acc in + f acc v ) + (Ok acc) l diff --git a/src/utils/syntax.mli b/src/utils/syntax.mli index bec07d026..995712820 100644 --- a/src/utils/syntax.mli +++ b/src/utils/syntax.mli @@ -37,3 +37,9 @@ val array_map : ('a -> ('b, 'err) Prelude.Result.t) -> 'a array -> ('b array, 'err) Prelude.Result.t + +val array_fold_left : + ('a -> 'b -> ('a, 'err) Prelude.Result.t) + -> 'a + -> 'b array + -> ('a, 'err) Prelude.Result.t diff --git a/src/validate/typecheck.ml b/src/validate/typecheck.ml index 36a2a35bb..0c0505f1b 100644 --- a/src/validate/typecheck.ml +++ b/src/validate/typecheck.ml @@ -42,12 +42,10 @@ module Index = struct end let check_mem modul n = - if n >= List.length modul.mem.values then Error (`Unknown_memory (Raw n)) - else Ok () + if n >= Array.length modul.mem then Error (`Unknown_memory (Raw n)) else Ok () let check_data modul n = - if n >= List.length modul.data.values then Error (`Unknown_data (Raw n)) - else Ok () + if n >= Array.length modul.data then Error (`Unknown_data (Raw n)) else Ok () let check_align memarg_align align = if Int32.ge memarg_align align then Error `Alignment_too_large else Ok () @@ -67,19 +65,18 @@ module Env = struct | Some v -> Ok v let global_get i modul = - let value = Indexed.get_at i modul.global.values in - match value with - | None -> Error (`Unknown_global (Raw i)) - | Some (Runtime.Local { typ = desc; _ } | Imported { desc; _ }) -> Ok desc + if i >= Array.length modul.global then Error (`Unknown_global (Raw i)) + else + match modul.global.(i) with + | Runtime.Local { typ = desc; _ } | Imported { desc; _ } -> Ok desc let func_get i modul = - let value = Indexed.get_at i modul.func.values in - match value with - | None -> Error (`Unknown_func (Raw i)) - | Some - ( Runtime.Local { type_f = Bt_raw (_, t); _ } - | Imported { desc = Bt_raw (_, t); _ } ) -> - Ok t + if i >= Array.length modul.func then Error (`Unknown_func (Raw i)) + else + match modul.func.(i) with + | Runtime.Local { type_f = Bt_raw (_, t); _ } + | Imported { desc = Bt_raw (_, t); _ } -> + Ok t let block_type_get i env = match List.nth_opt env.blocks i with @@ -87,16 +84,14 @@ module Env = struct | Some bt -> Ok bt let table_type_get i (modul : Binary.modul) = - let value = Indexed.get_at i modul.table.values in - match value with - | None -> Error (`Unknown_table (Raw i)) - | Some (Runtime.Local (_, (_, t)) | Imported { desc = _, t; _ }) -> Ok t + if i >= Array.length modul.table then Error (`Unknown_table (Raw i)) + else + match modul.table.(i) with + | Runtime.Local (_, (_, t)) | Imported { desc = _, t; _ } -> Ok t - let elem_type_get i env = - let value = Indexed.get_at i env.modul.elem.values in - match value with - | None -> Error (`Unknown_elem (Raw i)) - | Some value -> Ok value.typ + let elem_type_get i modul = + if i >= Array.length modul.elem then Error (`Unknown_elem (Raw i)) + else match modul.elem.(i) with value -> Ok value.typ let make ~params ~locals ~modul ~result_type ~refs = let l = List.mapi (fun i v -> (i, v)) (params @ locals) in @@ -450,7 +445,7 @@ let rec typecheck_instr (env : Env.t) (stack : stack) (instr : binary instr) : Ok stack | Table_init (Raw ti, Raw ei) -> let* table_typ = Env.table_type_get ti env.modul in - let* elem_typ = Env.elem_type_get ei env in + let* elem_typ = Env.elem_type_get ei env.modul in if not @@ Stack.match_ref_type (snd table_typ) (snd elem_typ) then Error (`Type_mismatch "table_init") else Stack.pop [ i32; i32; i32 ] stack @@ -474,7 +469,7 @@ let rec typecheck_instr (env : Env.t) (stack : stack) (instr : binary instr) : Stack.push [ i32 ] stack | Ref_null rt -> Stack.push [ Ref_type rt ] stack | Elem_drop (Raw id) -> - let* _elem_typ = Env.elem_type_get id env in + let* _elem_typ = Env.elem_type_get id env.modul in Ok stack | Select t -> let* stack = Stack.pop [ i32 ] stack in @@ -597,19 +592,20 @@ let typecheck_const_instr (modul : modul) refs stack = function let* _t = Env.func_get i modul in Hashtbl.add refs i (); Stack.push [ Ref_type Func_ht ] stack - | Global_get (Raw i as idx) -> - let value = Indexed.get_at i modul.global.values in - let* mut, typ = - match value with - | None | Some (Local _) -> Error (`Unknown_global idx) - | Some (Imported t) -> Ok t.desc - in - let* () = - match mut with - | Const -> Ok () - | Var -> Error `Constant_expression_required - in - Stack.push [ typ_of_val_type typ ] stack + | Global_get (Raw i) -> + if i >= Array.length modul.global then Error (`Unknown_global (Raw i)) + else + let* mut, typ = + match modul.global.(i) with + | Runtime.Local _ -> Error (`Unknown_global (Raw i)) + | Imported { desc; _ } -> Ok desc + in + let* () = + match mut with + | Const -> Ok () + | Var -> Error `Constant_expression_required + in + Stack.push [ typ_of_val_type typ ] stack | I_binop (t, _op) -> let t = itype t in let* stack = Stack.pop [ t; t ] stack in @@ -628,8 +624,8 @@ let typecheck_const_expr (modul : modul) refs = list_fold_left (typecheck_const_instr modul refs) [] let typecheck_global (modul : modul) refs - (global : (global, binary global_type) Runtime.t Indexed.t) = - match Indexed.get global with + (global : (global, binary global_type) Runtime.t) = + match global with | Imported _ -> Ok () | Local { typ; init; _ } -> ( let* real_type = typecheck_const_expr modul refs init in @@ -641,8 +637,7 @@ let typecheck_global (modul : modul) refs else Ok () | _whatever -> Error (`Type_mismatch "typecheck_global 2") ) -let typecheck_elem modul refs (elem : elem Indexed.t) = - let elem = Indexed.get elem in +let typecheck_elem modul refs (elem : elem) = let _null, expected_type = elem.typ in let* () = list_iter @@ -673,8 +668,7 @@ let typecheck_elem modul refs (elem : elem Indexed.t) = | [ _t ] -> Ok () | _whatever -> Error (`Type_mismatch "typecheck_elem 5") ) -let typecheck_data modul refs (data : data Indexed.t) = - let data = Indexed.get data in +let typecheck_data modul refs (data : data) = match data.mode with | Data_passive -> Ok () | Data_active (n, e) -> ( @@ -689,17 +683,14 @@ let typecheck_start { start; func; _ } = | None -> Ok () | Some idx -> ( let* f = - match List.find_opt (Indexed.has_index idx) func.values with - | None -> Error (`Unknown_func (Raw idx)) - | Some f -> Ok f - in - let pt, rt = - match Indexed.get f with - | Local { type_f = Bt_raw (_, t); _ } - | Imported { desc = Bt_raw (_, t); _ } -> - t + if idx >= Array.length func then Error (`Unknown_func (Raw idx)) + else Ok func.(idx) in - match (pt, rt) with [], [] -> Ok () | _, _ -> Error `Start_function ) + match f with + | Local { type_f = Bt_raw (_, ([], [])); _ } + | Imported { desc = Bt_raw (_, ([], [])); _ } -> + Ok () + | _ -> Error `Start_function ) let validate_exports modul = let* () = @@ -736,17 +727,15 @@ let check_limit { min; max } = if min > max then Error `Size_minimum_greater_than_maximum else Ok () let validate_tables modul = - list_iter - (fun t -> - match Indexed.get t with + array_iter + (function | Runtime.Local (_, (limits, _)) | Imported { desc = limits, _; _ } -> check_limit limits ) - modul.table.values + modul.table let validate_mem modul = - list_iter - (fun t -> - match Indexed.get t with + array_iter + (function | Runtime.Local (_, desc) | Imported { desc; _ } -> let* () = if desc.min > 65536 then Error `Memory_size_too_large @@ -756,14 +745,14 @@ let validate_mem modul = | Some _ | None -> Ok () in check_limit desc ) - modul.mem.values + modul.mem let modul (modul : modul) = Log.debug0 "typechecking ...@\n"; let refs = Hashtbl.create 512 in - let* () = list_iter (typecheck_global modul refs) modul.global.values in - let* () = list_iter (typecheck_elem modul refs) modul.elem.values in - let* () = list_iter (typecheck_data modul refs) modul.data.values in + let* () = array_iter (typecheck_global modul refs) modul.global in + let* () = array_iter (typecheck_elem modul refs) modul.elem in + let* () = array_iter (typecheck_data modul refs) modul.data in let* () = typecheck_start modul in let* () = validate_exports modul in let* () = validate_tables modul in @@ -771,8 +760,4 @@ let modul (modul : modul) = List.iter (fun (export : export) -> Hashtbl.add refs export.id ()) modul.exports.func; - Named.fold - (fun _index func acc -> - let* () = acc in - typecheck_function modul func refs ) - modul.func (Ok ()) + array_iter (fun func -> typecheck_function modul func refs) modul.func