From 3fe50d7423b8ef3ef51e9b0024715796481d2be9 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Sun, 17 Sep 2023 22:52:19 +0200 Subject: [PATCH] better interface fox Indexed --- src/assigned.ml | 16 ++++++++-------- src/grouped.ml | 15 ++++++++------- src/indexed.ml | 17 ++++++++++++++++- src/indexed.mli | 14 ++++++++++++++ src/named.ml | 9 +++++---- src/optimize.ml | 11 +++++------ src/rewrite.ml | 38 ++++++++++++++++++++------------------ src/typecheck.ml | 24 +++++++++++++----------- 8 files changed, 89 insertions(+), 55 deletions(-) create mode 100644 src/indexed.mli diff --git a/src/assigned.ml b/src/assigned.ml index e2ed3a966..3a7fa56ad 100644 --- a/src/assigned.ml +++ b/src/assigned.ml @@ -52,9 +52,7 @@ let assign_type (acc : type_acc) (name, sub_type) : type_acc Result.t = let+ str_type = Simplified_types.convert_str None str_type in let id = last_assigned_int in let last_assigned_int = succ last_assigned_int in - let declared_types = - { Indexed.index = id; value = str_type } :: declared_types - in + let declared_types = Indexed.return id str_type :: declared_types in let named_types = match name with | None -> named_types @@ -79,7 +77,7 @@ let assign_heap_type (acc : type_acc) typ : type_acc Result.t = let all_types = TypeMap.add typ id all_types in let func_types = match typ with - | Def_func_t _ftype -> { Indexed.index = id; value = typ } :: func_types + | Def_func_t _ftype -> Indexed.return id typ :: func_types | Def_array_t (_mut, _storage_type) -> func_types | Def_struct_t _ -> func_types in @@ -109,11 +107,13 @@ let get_runtime_name (get_name : 'a -> string option) (elt : ('a, 'b) Runtime.t) let name kind ~get_name values = let assign_one (named : int String_map.t) (elt : _ Indexed.t) = - match get_name elt.value with + let elt_v = Indexed.get elt in + match get_name elt_v with | None -> Ok named | Some name -> + let index = Indexed.get_index elt in if String_map.mem name named then error_s "duplicate %s %s" kind name - else ok @@ String_map.add name elt.index named + else ok @@ String_map.add name index named in let+ named = list_fold_left assign_one String_map.empty values in { Named.values; named } @@ -129,9 +129,9 @@ let check_type_id (types : str_type Named.t) (check : Grouped.type_check) = | Some t -> Ok t ) in (* TODO more efficient version of that *) - match List.find_opt (fun v -> v.Indexed.index = id) types.values with + match Indexed.get_at id types.values with | None -> Error "unknown type" - | Some { value = Def_func_t func_type'; _ } -> + | Some (Def_func_t func_type') -> let* func_type = Simplified_types.convert_func_type None func_type in if not (equal_func_types func_type func_type') then Error "inline function type" diff --git a/src/grouped.ml b/src/grouped.ml index 63cfc1453..d21512bb3 100644 --- a/src/grouped.ml +++ b/src/grouped.ml @@ -77,32 +77,32 @@ let init_curr = { global = 0; table = 0; mem = 0; func = 0; elem = 0; data = 0 } let add_global value (fields : t) (curr : curr) = let index = curr.global in - ( { fields with global = { index; value } :: fields.global } + ( { fields with global = Indexed.return index value :: fields.global } , { curr with global = succ curr.global } ) let add_table value (fields : t) (curr : curr) = let index = curr.table in - ( { fields with table = { index; value } :: fields.table } + ( { fields with table = Indexed.return index value :: fields.table } , { curr with table = succ curr.table } ) let add_mem value (fields : t) (curr : curr) = let index = curr.mem in - ( { fields with mem = { index; value } :: fields.mem } + ( { fields with mem = Indexed.return index value :: fields.mem } , { curr with mem = succ curr.mem } ) let add_func value (fields : t) (curr : curr) = let index = curr.func in - ( { fields with func = { index; value } :: fields.func } + ( { fields with func = Indexed.return index value :: fields.func } , { curr with func = succ curr.func } ) let add_elem value (fields : t) (curr : curr) = let index = curr.elem in - ( { fields with elem = { index; value } :: fields.elem } + ( { fields with elem = Indexed.return index value :: fields.elem } , { curr with elem = succ curr.elem } ) let add_data value (fields : t) (curr : curr) = let index = curr.data in - ( { fields with data = { index; value } :: fields.data } + ( { fields with data = Indexed.return index value :: fields.data } , { curr with data = succ curr.data } ) let check_limit { min; max } = @@ -184,7 +184,8 @@ let of_symbolic (modul : Symbolic.modul) : t Result.t = (typ :: fields.function_type, type_checks) in let index = curr.func in - let func = { Indexed.value = Runtime.Local func; index } :: fields.func in + let value = Runtime.Local func in + let func = Indexed.return index value :: fields.func in Ok ( { fields with func; function_type; type_checks } , { curr with func = succ curr.func } ) diff --git a/src/indexed.ml b/src/indexed.ml index 7758a7ade..1dc3af078 100644 --- a/src/indexed.ml +++ b/src/indexed.ml @@ -7,10 +7,25 @@ type 'a t = ; value : 'a } +let get v = v.value + +let get_index v = v.index + +let bind v f = f v.value + +let map f v = { index = v.index; value = f v.value } + +let return index value = { index; value } + let has_index idx { index; _ } = idx = index -let get_at i values = +let get_at_exn i values = let { value; _ } = List.find (has_index i) values in value +let get_at i values = + match List.find_opt (has_index i) values with + | None -> None + | Some { value; _ } -> Some value + let pp f fmt v = Format.fprintf fmt "%a" f v.value diff --git a/src/indexed.mli b/src/indexed.mli new file mode 100644 index 000000000..5d143836a --- /dev/null +++ b/src/indexed.mli @@ -0,0 +1,14 @@ +type 'a t + +val get : 'a t -> 'a +val get_index : 'a t -> int +val bind : 'a t -> ('a -> 'b t) -> 'b t +val map : ('a -> 'b) -> 'a t -> 'b t +val return : int -> 'a -> 'a t + + +val get_at : int -> 'a t list -> 'a option +val get_at_exn : int -> 'a t list -> 'a +val has_index : int -> 'a t -> bool + +val pp : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a t -> unit diff --git a/src/named.ml b/src/named.ml index 5915727c8..b016d4682 100644 --- a/src/named.ml +++ b/src/named.ml @@ -2,8 +2,6 @@ (* Copyright © 2021 Léo Andrès *) (* Copyright © 2021 Pierre Chambart *) -open Indexed - (** named values (fields) *) type 'a t = { values : 'a Indexed.t list @@ -11,9 +9,12 @@ type 'a t = } let fold f v acc = - List.fold_left (fun acc v -> f v.index v.value acc) acc v.values + List.fold_left + (fun acc v -> f (Indexed.get_index v) (Indexed.get v) acc) + acc v.values -let iter f v = List.iter (fun v -> f v.index v.value) v.values +let iter f v = + List.iter (fun v -> f (Indexed.get_index v) (Indexed.get v)) v.values let map f v = let values = List.map f v.values in diff --git a/src/optimize.ml b/src/optimize.ml index 549cbf0cb..c8650acfb 100644 --- a/src/optimize.ml +++ b/src/optimize.ml @@ -370,12 +370,11 @@ let optimize_func func = { type_f; locals; body; id } let optimize_runtime_func f = - let { Indexed.value; Indexed.index } = f in - match value with - | Runtime.Imported _ -> f - | Local f -> - let value = Runtime.Local (optimize_func f) in - { value; index } + 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 diff --git a/src/rewrite.ml b/src/rewrite.ml index c7f688b9c..64eacc627 100644 --- a/src/rewrite.ml +++ b/src/rewrite.ml @@ -33,7 +33,7 @@ let find_global (modul : Assigned.t) ~imported_only id : (int * mut) Result.t = let* idx = find "unknown global" modul.global id in let va = List.find (Indexed.has_index idx) modul.global.values in let+ mut, _typ = - match va.value with + match Indexed.get va with | Imported imported -> Ok imported.desc | Local global -> if imported_only then Error "unknown global" @@ -73,10 +73,10 @@ let rewrite_expr (modul : Assigned.t) (locals : param list) let bt_some_to_raw : Symbolic.block_type -> block_type Result.t = function | Symbolic.Arg.Bt_ind ind -> begin - match get "unknown type" modul.typ (Some ind) with - | Ok { value = Def_func_t t'; _ } -> Ok t' - | Error _ as e -> e - | Ok _ -> Error "TODO: Simplify.bt_some_to_raw" + let* v = get "unknown type" modul.typ (Some ind) in + match Indexed.get v with + | Def_func_t t' -> Ok t' + | _ -> Error "TODO: Simplify.bt_some_to_raw" end | Bt_raw (type_use, t) -> ( let* t = Simplified_types.convert_func_type None t in @@ -85,10 +85,10 @@ let rewrite_expr (modul : Assigned.t) (locals : param list) | Some ind -> (* we check that the explicit type match the type_use, we have to remove parameters names to do so *) let* t' = - match get "unknown type" modul.typ (Some ind) with - | Ok { value = Def_func_t t'; _ } -> Ok t' - | Error _ as e -> e - | Ok _ -> Error "TODO: Simplify.bt_some_to_raw" + let* v = get "unknown type" modul.typ (Some ind) in + match Indexed.get v with + | Def_func_t t' -> Ok t' + | _ -> Error "TODO: Simplify.bt_some_to_raw" in let ok = Simplified_types.equal_func_types t t' in if not ok then Error "inline function type" else Ok t ) @@ -98,8 +98,8 @@ let rewrite_expr (modul : Assigned.t) (locals : param list) function | None -> Ok None | Some bt -> - let* raw = bt_some_to_raw bt in - Ok (Some raw) + let+ raw = bt_some_to_raw bt in + Some raw in let* locals, after_last_assigned_local = @@ -428,10 +428,10 @@ let rewrite_block_type (modul : Assigned.t) (block_type : Symbolic.block_type) : block_type Result.t = match block_type with | Symbolic.Arg.Bt_ind id -> begin - match get "unknown type" modul.typ (Some id) with - | Ok { value = Def_func_t t'; _ } -> Ok t' - | Error _ as e -> e - | Ok _ -> Error "TODO: Simplify.bt_some_to_raw" + let* v = get "unknown type" modul.typ (Some id) in + match Indexed.get v with + | Def_func_t t' -> Ok t' + | _ -> Error "TODO: Simplify.bt_some_to_raw" end | Bt_raw (_, func_type) -> Simplified_types.convert_func_type None func_type @@ -511,8 +511,10 @@ let rewrite_named f named = let+ values = list_map (fun ind -> - let+ value = f ind.Indexed.value in - { ind with value } ) + let index = Indexed.get_index ind in + let value = Indexed.get ind in + let+ value = f value in + Indexed.return index value ) named.Named.values in { named with Named.values } @@ -544,7 +546,7 @@ let modul (modul : Assigned.t) : modul Result.t = let* idx = find "unknown function" func (Some start) in let va = List.find (Indexed.has_index idx) func.Named.values in let param_typ, result_typ = - match va.value with + match Indexed.get va with | Local func -> func.type_f | Imported imported -> imported.desc in diff --git a/src/typecheck.ml b/src/typecheck.ml index 30570dcf3..551b8f353 100644 --- a/src/typecheck.ml +++ b/src/typecheck.ml @@ -50,14 +50,14 @@ module Env = struct let local_get i env = match Index.Map.find i env.locals with v -> v let global_get i env = - let value = Indexed.get_at i env.globals.values in + let value = Indexed.get_at_exn i env.globals.values in let _mut, typ = match value with Local { typ; _ } -> typ | Runtime.Imported t -> t.desc in typ let func_get i env = - let value = Indexed.get_at i env.funcs.values in + let value = Indexed.get_at_exn i env.funcs.values in match value with | Local { type_f; _ } -> type_f | Runtime.Imported t -> t.desc @@ -65,19 +65,19 @@ module Env = struct let block_type_get i env = List.nth env.blocks i let table_type_get_from_module i (modul : Simplified.modul) = - let value = Indexed.get_at i modul.table.values in + let value = Indexed.get_at_exn i modul.table.values in match value with | Local table -> snd (snd table) | Runtime.Imported t -> snd t.desc let table_type_get i env = - let value = Indexed.get_at i env.tables.values in + let value = Indexed.get_at_exn i env.tables.values in match value with | Local table -> snd (snd table) | Runtime.Imported t -> snd t.desc let elem_type_get i env = - let value = Indexed.get_at i env.elems.values in + let value = Indexed.get_at_exn i env.elems.values in value.typ let make ~params ~locals ~globals ~funcs ~result_type ~tables ~elems ~refs = @@ -538,7 +538,7 @@ let typecheck_const_instr (modul : modul) refs stack = function Hashtbl.add refs i (); Stack.push [ Ref_type Func_ht ] stack | Global_get i -> - let value = Indexed.get_at i modul.global.values in + let value = Indexed.get_at_exn i modul.global.values in let* _mut, typ = match value with | Local _ -> Error "unknown global" @@ -563,7 +563,7 @@ let typecheck_const_expr (modul : modul) refs = let typecheck_global (modul : modul) refs (global : (global, global_type) Runtime.t Indexed.t) = - match global.value with + match Indexed.get global with | Imported _ -> Ok () | Local { typ; init; _ } -> ( let* real_type = typecheck_const_expr modul refs init in @@ -578,7 +578,8 @@ let typecheck_global (modul : modul) refs | _whatever -> Error "type mismatch (typecheck_global wrong num)" ) let typecheck_elem modul refs (elem : elem Indexed.t) = - let _null, expected_type = elem.value.typ in + let elem = Indexed.get elem in + let _null, expected_type = elem.typ in let* () = list_iter (fun init -> @@ -589,9 +590,9 @@ let typecheck_elem modul refs (elem : elem Indexed.t) = Error "type mismatch (typecheck_elem)" else Ok () | _whatever -> Error "type mismatch (typecheck_elem wrong num)" ) - elem.value.init + elem.init in - match elem.value.mode with + match elem.mode with | Elem_passive | Elem_declarative -> Ok () | Elem_active (None, _e) -> assert false | Elem_active (Some tbl_i, e) -> ( @@ -606,7 +607,8 @@ let typecheck_elem modul refs (elem : elem Indexed.t) = | _whatever -> Error "type mismatch (typecheck_elem)" ) let typecheck_data modul refs (data : data Indexed.t) = - match data.value.mode with + let data = Indexed.get data in + match data.mode with | Data_passive -> Ok () | Data_active (_i, e) -> ( let* t = typecheck_const_expr modul refs e in