From 6da548c048e7308ed94e61a3fe065026f1854a49 Mon Sep 17 00:00:00 2001 From: Nikos Gorogiannis Date: Fri, 22 Nov 2024 09:41:55 -0800 Subject: [PATCH] [core] migrate more uses of Set and Map Summary: Migrating to OCaml 5.2 requires upgrading Core and that breaks many uses of `Set` and `Map`. This diff fixes uses in Erlang, Topl and Lineage by converting to `Stdlib` sets and maps where necessary. Reviewed By: geralt-encore Differential Revision: D66357472 Privacy Context Container: L1208441 fbshipit-source-id: ce499f0ffe9b4501ac376f7ebf9d697ce9eba256 --- infer/src/base/ToplAst.ml | 2 +- infer/src/checkers/Lineage.ml | 19 +-- infer/src/checkers/LineageShape.ml | 16 +-- infer/src/checkers/annotationReachability.ml | 12 +- infer/src/erlang/ErlangAst.ml | 2 +- infer/src/erlang/ErlangAstValidator.ml | 8 +- infer/src/erlang/ErlangEnvironment.ml | 122 ++++++++++-------- infer/src/erlang/ErlangEnvironment.mli | 14 +- infer/src/erlang/ErlangJsonParser.ml | 20 +-- infer/src/erlang/ErlangScopes.ml | 14 +- infer/src/erlang/ErlangTranslator.ml | 50 +++---- infer/src/erlang/ErlangTypes.ml | 4 +- infer/src/erlang/ErlangTypes.mli | 2 +- infer/src/erlang/dune | 2 +- infer/src/integration/Erlang.ml | 2 +- infer/src/istd/IString.ml | 10 +- infer/src/istd/IString.mli | 4 +- infer/src/istd/dune | 2 +- .../src/pulse/PulseTransitiveAccessChecker.ml | 6 +- infer/src/topl/ToplAutomaton.ml | 24 ++-- 20 files changed, 179 insertions(+), 156 deletions(-) diff --git a/infer/src/base/ToplAst.ml b/infer/src/base/ToplAst.ml index dd799782721..393bfcbfbca 100644 --- a/infer/src/base/ToplAst.ml +++ b/infer/src/base/ToplAst.ml @@ -57,7 +57,7 @@ type label = ; pattern: label_pattern } [@@deriving show] -type vertex = string [@@deriving compare, hash, sexp, show] +type vertex = string [@@deriving compare, hash, sexp, show, equal] type transition = {source: vertex; target: vertex; label: label option} [@@deriving show] diff --git a/infer/src/checkers/Lineage.ml b/infer/src/checkers/Lineage.ml index 3081f0c9a86..677e1b32f36 100644 --- a/infer/src/checkers/Lineage.ml +++ b/infer/src/checkers/Lineage.ml @@ -70,10 +70,11 @@ module Local = struct | ConstantString of string | Cell of (Cell.t[@sexp.opaque]) [@@deriving compare, equal, sexp, hash] + + let pp _ _ = assert false end include T - include Comparable.Make (T) let pp fmt local = match local with @@ -88,10 +89,10 @@ module Local = struct module Set = struct - include Set + include PrettyPrintable.MakeHashSexpPPSet (T) (** Shortcut for adding a Cell-variant local *) - let add_cell set cell = add set (Cell cell) + let add_cell set cell = add (Cell cell) set end end @@ -433,13 +434,13 @@ end = struct module FieldPathSet = struct (* Sets of field paths, that shall be associated to an argument index *) - module M = Set.Make_tree (FieldPath) + module M = PrettyPrintable.MakeHashSexpPPSet (FieldPath) include M let pp ~arg_index = (* Prints: $argN#foo#bar $argN#other#field *) let pp_field_path = Fmt.using (fun path -> arg_index & path) F.arg_path in - IFmt.Labelled.iter ~sep:Fmt.sp M.iter pp_field_path + IFmt.Labelled.iter ~sep:Fmt.sp (fun a ~f -> M.iter f a) pp_field_path end (* Marshallable maps from integer indices. Note: using an array instead of Map could improve the @@ -469,15 +470,15 @@ end = struct | None -> FieldPathSet.singleton arg_field_path | Some field_path_set -> - FieldPathSet.add field_path_set arg_field_path ) + FieldPathSet.add arg_field_path field_path_set ) let fold t ~f ~init = IntMap.fold ~f:(fun ~key:arg_index ~data:field_path_set acc -> FieldPathSet.fold - ~f:(fun acc arg_field_path -> f ~arg_index ~arg_field_path acc) - ~init:acc field_path_set ) + (fun arg_field_path acc -> f ~arg_index ~arg_field_path acc) + field_path_set acc ) ~init t end @@ -1514,7 +1515,7 @@ end = struct let local_set local_set : unit t = fun shapes node f astate -> - Set.fold ~f:(fun acc one_local -> local one_local shapes node f acc) ~init:astate local_set + Local.Set.fold (fun one_local acc -> local one_local shapes node f acc) local_set astate let atom atom_name : unit t = local (ConstantAtom atom_name) diff --git a/infer/src/checkers/LineageShape.ml b/infer/src/checkers/LineageShape.ml index 072d5b419a2..f99a5bf2788 100644 --- a/infer/src/checkers/LineageShape.ml +++ b/infer/src/checkers/LineageShape.ml @@ -235,7 +235,7 @@ end returns some field [foo] of [X]: we want to know that we should create the Lineage node [$argN#foo] at the same time as the node [$argN]. *) -module StringSet = Set.Make_tree (String) +module StringSet = IString.Set module FieldLabelMap = Map.Make_tree (FieldLabel) module Structure : sig @@ -352,7 +352,7 @@ end = struct Fmt.pf fmt "?" | Variant constructors -> Fmt.pf fmt "[@[%a@]]" - (IFmt.Labelled.iter ~sep:(Fmt.any "@ |@ ") StringSet.iter Fmt.string) + (IFmt.Labelled.iter ~sep:(Fmt.any "@ |@ ") (fun a ~f -> StringSet.iter f a) Fmt.string) constructors | Vector {is_fully_abstract; fields; all_map_value} -> (* Example: ('foo' : <1>, 'bar' : <1>, baz : <2>) {* : <1>} *) @@ -389,7 +389,7 @@ end = struct let local_abstract = LocalAbstract let variant constructors = - if StringSet.length constructors <= ShapeConfig.variant_width then Variant constructors + if StringSet.cardinal constructors <= ShapeConfig.variant_width then Variant constructors else scalar @@ -653,7 +653,7 @@ end = struct let id = Union_find.get shape in match Hashtbl.find shape_structures id with | Some (Variant constructors) -> - Some (StringSet.to_list constructors) + Some (StringSet.elements constructors) | _ -> None @@ -1457,9 +1457,7 @@ end = struct let fold_field_labels_actual summary (var, field_path) ~init ~f ~fallback = match find_var_path_structure summary (var, field_path) with | Variant set -> - StringSet.fold ~init - ~f:(fun acc constructor -> f acc (FieldLabel.map_key constructor)) - set + StringSet.fold (fun constructor acc -> f acc (FieldLabel.map_key constructor)) set init | _ -> fallback init @@ -1477,8 +1475,8 @@ end = struct let* summary = summary_option in match find_var_path_structure summary var_path with | Variant set -> - if Int.O.(StringSet.length set = 1) then - let+ constructor = StringSet.choose set in + if Int.O.(StringSet.cardinal set = 1) then + let+ constructor = StringSet.choose_opt set in FieldLabel.map_key constructor else None | _ -> diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index 6d98978dd7e..f8c6ea3ddf8 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/infer/src/checkers/annotationReachability.ml @@ -81,7 +81,7 @@ let parse_custom_models () = match Config.annotation_reachability_custom_models with (* The default value for JSON options is an empty list and not an empty object *) | `List [] -> - String.Map.empty + IString.Map.empty | json -> json |> Yojson.Safe.Util.to_assoc |> List.map ~f:(fun (key, val_arr) -> @@ -89,7 +89,7 @@ let parse_custom_models () = , val_arr |> Yojson.Safe.Util.to_list |> List.map ~f:Yojson.Safe.Util.to_string |> List.map ~f:Str.regexp ) ) - |> String.Map.of_alist_exn + |> Stdlib.List.to_seq |> IString.Map.of_seq let check_attributes check tenv pname = @@ -111,7 +111,7 @@ let check_modeled_annotation models annot pname = let method_name = Procname.to_string ~verbosity:(if Procname.is_erlang pname then Verbose else FullNameOnly) pname in - Option.exists (String.Map.find models annot.Annot.class_name) ~f:(fun methods -> + Option.exists (IString.Map.find_opt annot.Annot.class_name models) ~f:(fun methods -> List.exists methods ~f:(fun r -> Str.string_match r method_name 0) ) @@ -166,7 +166,7 @@ module AnnotationSpec = struct ; name: string (** Short name to be added at the beginning of the report *) ; description: string (** Extra description to be added to the issue report *) ; issue_type: IssueType.t - ; models: Str.regexp list IStd.String.Map.t (** model functions as if they were annotated *) + ; models: Str.regexp list IString.Map.t (** model functions as if they were annotated *) ; pre_check: Domain.t InterproceduralAnalysis.t -> unit (** additional check before reporting *) } end @@ -386,7 +386,7 @@ module NoAllocationAnnotationSpec = struct ; name= "" ; description= "" ; issue_type= IssueType.checkers_allocates_memory - ; models= String.Map.empty + ; models= IString.Map.empty ; pre_check= (fun _ -> ()) } end @@ -427,7 +427,7 @@ module ExpensiveAnnotationSpec = struct ; name= "" ; description= "" ; issue_type= IssueType.checkers_calls_expensive_method - ; models= String.Map.empty + ; models= IString.Map.empty ; pre_check= (fun ({InterproceduralAnalysis.proc_desc; tenv} as analysis_data) -> let proc_name = Procdesc.get_proc_name proc_desc in diff --git a/infer/src/erlang/ErlangAst.ml b/infer/src/erlang/ErlangAst.ml index 518cf788da3..2f1cb3fb4a0 100644 --- a/infer/src/erlang/ErlangAst.ml +++ b/infer/src/erlang/ErlangAst.ml @@ -173,7 +173,7 @@ and tuple_type = AnySize | FixedSize of type_ list [@@deriving sexp_of] (* Function specs can be overloaded, forming disjunctions. Currently the only kind of constraints are "subtype of" which we track in a map. *) -type spec_disjunct = {arguments: type_ list; return: type_; constraints: type_ String.Map.t} +type spec_disjunct = {arguments: type_ list; return: type_; constraints: type_ IString.Map.t} [@@deriving sexp_of] type spec = spec_disjunct list [@@deriving sexp_of] diff --git a/infer/src/erlang/ErlangAstValidator.ml b/infer/src/erlang/ErlangAstValidator.ml index 74c114c83d1..232bc03f6f5 100644 --- a/infer/src/erlang/ErlangAstValidator.ml +++ b/infer/src/erlang/ErlangAstValidator.ml @@ -22,7 +22,7 @@ let pp_location (loc : Ast.location) = let validate_record_name (env : (_, _) Env.t) name = - match String.Map.find env.records name with + match IString.Map.find_opt name env.records with | None -> L.debug Capture Verbose "Record definition not found for '%s'@." name ; false @@ -31,12 +31,12 @@ let validate_record_name (env : (_, _) Env.t) name = let validate_record_field (env : (_, _) Env.t) name field = - match String.Map.find env.records name with + match IString.Map.find_opt name env.records with | None -> L.debug Capture Verbose "Record definition not found for '%s'@." name ; false | Some record_info -> ( - match String.Map.find record_info.field_info field with + match IString.Map.find_opt field record_info.field_info with | None -> L.debug Capture Verbose "Record field '%s' not found in definition of '%s'@." field name ; false @@ -357,7 +357,7 @@ let rec validate_type (type_ : Ast.type_) = let validate_spec_disjunct ({arguments; return; constraints} : Ast.spec_disjunct) = List.for_all ~f:validate_type arguments && validate_type return - && String.Map.for_all ~f:validate_type constraints + && IString.Map.for_all (fun _k v -> validate_type v) constraints let validate_spec_arities (func_arity : int) (spec : Ast.spec) = diff --git a/infer/src/erlang/ErlangEnvironment.ml b/infer/src/erlang/ErlangEnvironment.ml index 3a9fc4391a5..7650eed572d 100644 --- a/infer/src/erlang/ErlangEnvironment.ml +++ b/infer/src/erlang/ErlangEnvironment.ml @@ -17,11 +17,14 @@ type 'a present = Present of 'a module UnqualifiedFunction = struct module T = struct - type t = {name: string; arity: int} [@@deriving sexp, compare] + type t = {name: string; arity: int} [@@deriving sexp, compare, equal, hash] + + let pp _ _ = assert false end include T - include Comparable.Make (T) + module Set = PrettyPrintable.MakeHashSexpPPSet (T) + module Map = PrettyPrintable.MakeHashSexpPPMap (T) let of_ast (f : Ast.function_) : t = match f with @@ -33,21 +36,21 @@ end type record_field_info = {index: int; initializer_: Ast.expression option} [@@deriving sexp_of] -type record_info = {field_names: string list; field_info: record_field_info String.Map.t} +type record_info = {field_names: string list; field_info: record_field_info IString.Map.t} [@@deriving sexp_of] type ('procdesc, 'result) t = { cfg: (Cfg.t[@sexp.opaque]) - ; module_info: (Annot.t String.Map.t[@sexp.opaque]) + ; module_info: (Annot.t IString.Map.t[@sexp.opaque]) (** used to store data for Module:module_info *) ; current_module: module_name (** used to qualify function names *) ; is_otp: bool (** does this module come from the OTP library *) ; functions: UnqualifiedFunction.Set.t (** used to resolve function names *) ; specs: Ast.spec UnqualifiedFunction.Map.t (** map functions to their specs *) - ; types: Ast.type_ String.Map.t (** user defined types *) + ; types: Ast.type_ IString.Map.t (** user defined types *) ; exports: UnqualifiedFunction.Set.t (** used to determine public/private access *) ; imports: module_name UnqualifiedFunction.Map.t (** used to resolve function names *) - ; records: record_info String.Map.t (** used to get fields, indexes and initializers *) + ; records: record_info IString.Map.t (** used to get fields, indexes and initializers *) ; location: Location.t (** used to tag nodes and instructions being created *) ; procdesc: ('procdesc[@sexp.opaque]) ; result: ('result[@sexp.opaque]) } @@ -58,15 +61,15 @@ let unknown_module_name = "__INFER_UNKNOWN_MODULE" let initialize_environment module_ otp_modules = let init = { cfg= Cfg.create () - ; module_info= String.Map.empty + ; module_info= IString.Map.empty ; current_module= unknown_module_name ; is_otp= false ; functions= UnqualifiedFunction.Set.empty ; specs= UnqualifiedFunction.Map.empty - ; types= String.Map.empty + ; types= IString.Map.empty ; exports= UnqualifiedFunction.Set.empty ; imports= UnqualifiedFunction.Map.empty - ; records= String.Map.empty + ; records= IString.Map.empty ; location= Location.dummy ; procdesc= Absent ; result= Absent } @@ -74,75 +77,90 @@ let initialize_environment module_ otp_modules = let f env (form : Ast.form) = match form.simple_form with | Export functions -> - let f exports function_ = Set.add exports (UnqualifiedFunction.of_ast function_) in + let f exports function_ = + UnqualifiedFunction.Set.add (UnqualifiedFunction.of_ast function_) exports + in let exports = List.fold ~init:env.exports ~f functions in {env with exports} | Import {module_name; functions} -> let f imports function_ = let key = UnqualifiedFunction.of_ast function_ in - match Map.add ~key ~data:module_name imports with - | `Ok imports -> - imports - | `Duplicate -> - L.debug Capture Verbose "repeated import: %s/%d" key.name key.arity ; - imports + UnqualifiedFunction.Map.update key + (function + | None -> + Some module_name + | some_import -> + L.debug Capture Verbose "repeated import: %s/%d" key.name key.arity ; + some_import ) + imports in let imports = List.fold ~init:env.imports ~f functions in {env with imports} - | Record {name; fields} -> ( + | Record {name; fields} -> let process_one_field one_index map (one_field : Ast.record_field) = (* Tuples are indexed from 1 and the first one is the name, hence start from 2 *) - match - Map.add ~key:one_field.field_name - ~data:{index= one_index + 2; initializer_= one_field.initializer_} - map - with - | `Ok map -> - map - | `Duplicate -> - L.die InternalError "repeated field in record: %s" one_field.field_name + IString.Map.update one_field.field_name + (function + | None -> + Some {index= one_index + 2; initializer_= one_field.initializer_} + | Some _ -> + L.die InternalError "repeated field in record: %s" one_field.field_name ) + map in - let field_info = List.foldi ~init:String.Map.empty ~f:process_one_field fields in + let field_info = List.foldi ~init:IString.Map.empty ~f:process_one_field fields in let field_names = List.map ~f:(fun (rf : Ast.record_field) -> rf.field_name) fields in - match Map.add ~key:name ~data:{field_names; field_info} env.records with - | `Ok records -> - {env with records} - | `Duplicate -> - L.die InternalError "repeated record: %s" name ) + let records = + IString.Map.update name + (function + | None -> + Some {field_names; field_info} + | Some _ -> + L.die InternalError "repeated record: %s" name ) + env.records + in + {env with records} | Module current_module -> if String.(unknown_module_name <> env.current_module) then L.die InternalError "trying to set current module twice: old: %s, new: %s" env.current_module current_module ; - let is_otp = String.Set.mem otp_modules current_module in + let is_otp = IString.Set.mem current_module otp_modules in {env with current_module; is_otp} | File _ -> env (* Handled during translation. *) | Function {function_; _} -> let key = UnqualifiedFunction.of_ast function_ in - {env with functions= Set.add env.functions key} - | Spec {function_; spec} -> ( + {env with functions= UnqualifiedFunction.Set.add key env.functions} + | Spec {function_; spec} -> let key = UnqualifiedFunction.of_ast function_ in - match Map.add ~key ~data:spec env.specs with - | `Ok specs -> - {env with specs} - | `Duplicate -> - L.die InternalError "repeated spec for %s/%d" key.name key.arity ) - | Type {name; type_} -> ( - match Map.add ~key:name ~data:type_ env.types with - | `Ok types -> - {env with types} - | `Duplicate -> - L.die InternalError "repeated type '%s'" name ) + let specs = + UnqualifiedFunction.Map.update key + (function + | None -> + Some spec + | Some _ -> + L.die InternalError "repeated spec for %s/%d" key.name key.arity ) + env.specs + in + {env with specs} + | Type {name; type_} -> + let types = + IString.Map.update name + (function None -> Some type_ | Some _ -> L.die InternalError "repeated type '%s'" name) + env.types + in + {env with types} | Attribute (StringAttribute {tag; value}) -> let module_info = let parameter = {Annot.name= Some tag; value= Str value} in let class_name = ErlangTypeName.module_info_attributes_class_name in - Map.update env.module_info class_name ~f:(function - | None -> - {Annot.class_name; parameters= [parameter]} - | Some annot -> - let {Annot.parameters} = annot in - {annot with Annot.parameters= parameter :: parameters} ) + IString.Map.update class_name + (function + | None -> + Some {Annot.class_name; parameters= [parameter]} + | Some annot -> + let {Annot.parameters} = annot in + Some {annot with Annot.parameters= parameter :: parameters} ) + env.module_info in {env with module_info} in diff --git a/infer/src/erlang/ErlangEnvironment.mli b/infer/src/erlang/ErlangEnvironment.mli index d7be0d7002f..c2bfbe0e3e2 100644 --- a/infer/src/erlang/ErlangEnvironment.mli +++ b/infer/src/erlang/ErlangEnvironment.mli @@ -23,34 +23,36 @@ module UnqualifiedFunction : sig include T end - include module type of Comparable.Make (T) + module Set : PrettyPrintable.HashSexpPPSet with type elt = t + + module Map : PrettyPrintable.HashSexpPPMap with type key = t end type record_field_info = {index: int; initializer_: Ast.expression option} [@@deriving sexp_of] -type record_info = {field_names: string list; field_info: record_field_info String.Map.t} +type record_info = {field_names: string list; field_info: record_field_info IString.Map.t} [@@deriving sexp_of] (** This data structure holds module-level information and other global data that we pass around when translating individual functions of the module. *) type ('procdesc, 'result) t = { cfg: (Cfg.t[@sexp.opaque]) - ; module_info: (Annot.t String.Map.t[@sexp.opaque]) + ; module_info: (Annot.t IString.Map.t[@sexp.opaque]) (** used to store data for Module:module_info *) ; current_module: module_name (** used to qualify function names *) ; is_otp: bool (** does this module come from the OTP library *) ; functions: UnqualifiedFunction.Set.t (** used to resolve function names *) ; specs: Ast.spec UnqualifiedFunction.Map.t (** map functions to their specs *) - ; types: Ast.type_ String.Map.t (** user defined types *) + ; types: Ast.type_ IString.Map.t (** user defined types *) ; exports: UnqualifiedFunction.Set.t (** used to determine public/private access *) ; imports: module_name UnqualifiedFunction.Map.t (** used to resolve function names *) - ; records: record_info String.Map.t (** used to get fields, indexes and initializers *) + ; records: record_info IString.Map.t (** used to get fields, indexes and initializers *) ; location: Location.t (** used to tag nodes and instructions being created *) ; procdesc: ('procdesc[@sexp.opaque]) ; result: ('result[@sexp.opaque]) } [@@deriving sexp_of] -val initialize_environment : Ast.form list -> String.Set.t -> (absent, absent) t +val initialize_environment : Ast.form list -> IString.Set.t -> (absent, absent) t (** Entry point: go through the top-level forms in the module and initialize the environment. *) val typ_of_name : ErlangTypeName.t -> Typ.t diff --git a/infer/src/erlang/ErlangJsonParser.ml b/infer/src/erlang/ErlangJsonParser.ml index c483e3c9f88..ea60279680f 100644 --- a/infer/src/erlang/ErlangJsonParser.ml +++ b/infer/src/erlang/ErlangJsonParser.ml @@ -710,7 +710,7 @@ let to_spec_disjunct json : Ast.spec_disjunct option = | `List [`String "type"; _anno; `String "fun"; `List [args_json; ret_json]] -> let* return = to_spec_ret ret_json in let* arguments = to_spec_args args_json in - Some {Ast.arguments; return; constraints= String.Map.empty} + Some {Ast.arguments; return; constraints= IString.Map.empty} | `List [ `String "type" ; _anno @@ -722,15 +722,17 @@ let to_spec_disjunct json : Ast.spec_disjunct option = let* arguments = to_spec_args args_json in let* constr_list = to_list ~f:to_constraint constraints_json in let f map (key, data) = - match Map.add ~key ~data map with - | `Ok map -> - map - | `Duplicate -> - L.debug Capture Verbose "Ignoring duplicate constraint for type variable %s in %s@." key - (Yojson.Safe.show json) ; - map + IString.Map.update key + (function + | None -> + Some data + | some_d -> + L.debug Capture Verbose "Ignoring duplicate constraint for type variable %s in %s@." + key (Yojson.Safe.show json) ; + some_d ) + map in - let constraints = List.fold ~f ~init:String.Map.empty constr_list in + let constraints = List.fold ~f ~init:IString.Map.empty constr_list in Some {Ast.arguments; return; constraints} | _ -> unknown "spec" json diff --git a/infer/src/erlang/ErlangScopes.ml b/infer/src/erlang/ErlangScopes.ml index 126abe7fe6e..a25e1030bf6 100644 --- a/infer/src/erlang/ErlangScopes.ml +++ b/infer/src/erlang/ErlangScopes.ml @@ -11,7 +11,7 @@ module Env = ErlangEnvironment module L = Logging (* One frame in the stack of scopes *) -type scope = {procname: Procname.t; locals: String.Set.t; captured: Pvar.Set.t} +type scope = {procname: Procname.t; locals: IString.Set.t; captured: Pvar.Set.t} (* Data structure we pass around for giving unique names to lambdas (per function). Initial plan was to use line+column, but if a macro expands to multiple lambdas, @@ -20,7 +20,7 @@ type lambda_name_counter = {funcname: string; mutable counter: int} let lookup_var (scopes : scope list) (vname : string) : Procname.t option = List.find_map scopes ~f:(fun {procname; locals} -> - if String.Set.mem locals vname then Some procname else None ) + if IString.Set.mem vname locals then Some procname else None ) let push_scope = @@ -29,7 +29,7 @@ let push_scope = if (not !warned) && List.length scopes > 100 then ( L.debug Capture Verbose "@[Many nested scopes: translation might be slow@." ; warned := true ) ; - {procname; locals= String.Set.empty; captured= Pvar.Set.empty} :: scopes + {procname; locals= IString.Set.empty; captured= Pvar.Set.empty} :: scopes let pop_scope scopes = @@ -176,7 +176,7 @@ let rec annotate_expression (env : (_, _) Env.t) lambda_cntr (scopes : scope lis (* The anonymus variable is always fresh in the local scope *) v.scope <- Some {procname= hd.procname; is_first_use= true} ; scopes ) - else if String.Set.mem hd.locals v.vname then ( + else if IString.Set.mem v.vname hd.locals then ( (* Known local var *) v.scope <- Some {procname= hd.procname; is_first_use= false} ; scopes ) @@ -190,7 +190,7 @@ let rec annotate_expression (env : (_, _) Env.t) lambda_cntr (scopes : scope lis | None -> (* It's a local we see here first *) v.scope <- Some {procname= hd.procname; is_first_use= true} ; - {hd with locals= String.Set.add hd.locals v.vname} :: tl ) + {hd with locals= IString.Set.add v.vname hd.locals} :: tl ) | [] -> L.die InternalError "No scope found during variable annotation." ) @@ -253,14 +253,14 @@ and merge_scopes ~into (scopes : scope list list) = (* Merge results: intersect locals, union captured *) let merge (acc : scope) (s : scope) = { acc with - locals= String.Set.inter acc.locals s.locals + locals= IString.Set.inter acc.locals s.locals ; captured= Pvar.Set.union acc.captured s.captured } in let merged = List.reduce_exn ~f:merge top_scopes in (* Add to top scope *) let top_scope, tl_scopes = pop_scope into in { top_scope with - locals= String.Set.union top_scope.locals merged.locals + locals= IString.Set.union top_scope.locals merged.locals ; captured= Pvar.Set.union top_scope.captured merged.captured } :: tl_scopes diff --git a/infer/src/erlang/ErlangTranslator.ml b/infer/src/erlang/ErlangTranslator.ml index c78bc9e7d86..76cdcdfbfea 100644 --- a/infer/src/erlang/ErlangTranslator.ml +++ b/infer/src/erlang/ErlangTranslator.ml @@ -434,8 +434,8 @@ and translate_pattern_map (env : (_, _) Env.t) value updates : Block.t = and translate_pattern_record_index (env : (_, _) Env.t) value name field : Block.t = - let record_info = String.Map.find_exn env.records name in - let field_info = String.Map.find_exn record_info.field_info field in + let record_info = IString.Map.find name env.records in + let field_info = IString.Map.find field record_info.field_info in let index_expr = Exp.Const (Cint (IntLit.of_int field_info.index)) in translate_pattern_integer env value index_expr @@ -455,7 +455,7 @@ and match_record_name env value name (record_info : Env.record_info) : Block.t = and translate_pattern_record_update (env : (_, _) Env.t) value name updates : Block.t = - let record_info = String.Map.find_exn env.records name in + let record_info = IString.Map.find name env.records in (* Match the type and the record name *) let record_name_matcher = match_record_name env value name record_info in (* Match each specified field *) @@ -464,7 +464,7 @@ and translate_pattern_record_update (env : (_, _) Env.t) value name updates : Bl let make_one_field_matcher (one_update : Ast.record_update) = match one_update.field with | Some name -> - let field_info = String.Map.find_exn record_info.field_info name in + let field_info = IString.Map.find name record_info.field_info in let value_id = mk_fresh_id () in let tuple_elem = ErlangTypeName.tuple_elem field_info.index in let load_instr = load_field_from_id env value_id value tuple_elem tuple_typ in @@ -808,11 +808,11 @@ and lookup_module_for_unqualified (env : (_, _) Env.t) function_name arity = as compiler should enforce that both cannot hold at the same time). Then assume it's built-in. *) let uf_name = {Env.UnqualifiedFunction.name= function_name; arity} in - match Env.UnqualifiedFunction.Map.find env.imports uf_name with + match Env.UnqualifiedFunction.Map.find_opt uf_name env.imports with | Some name -> name | None -> - if Env.UnqualifiedFunction.Set.mem env.functions uf_name then env.current_module + if Env.UnqualifiedFunction.Set.mem uf_name env.functions then env.current_module else ErlangTypeName.erlang_namespace @@ -1310,7 +1310,7 @@ and translate_expression_receive (env : (_, _) Env.t) cases timeout : Block.t = and translate_expression_record_access (env : (_, _) Env.t) ret_var record name field : Block.t = (* Under the hood, a record is a tagged tuple, the first element is the name, and then the fields follow in the order as in the record definition. *) - let record_info = String.Map.find_exn env.records name in + let record_info = IString.Map.find name env.records in let record_id = mk_fresh_id () in let record_block = let value_block = translate_expression_to_id env record_id record in @@ -1320,7 +1320,7 @@ and translate_expression_record_access (env : (_, _) Env.t) ret_var record name let matcher_block = {matcher_block with exit_failure= Some crash_node} in Block.all env [value_block; matcher_block] in - let field_info = String.Map.find_exn record_info.field_info field in + let field_info = IString.Map.find field record_info.field_info in let field_no = field_info.index in let tuple_typ : ErlangTypeName.t = Tuple (1 + List.length record_info.field_names) in let field_load = @@ -1331,8 +1331,8 @@ and translate_expression_record_access (env : (_, _) Env.t) ret_var record name and translate_expression_record_index (env : (_, _) Env.t) ret_var name field : Block.t = - let record_info = String.Map.find_exn env.records name in - let field_info = String.Map.find_exn record_info.field_info field in + let record_info = IString.Map.find name env.records in + let field_info = IString.Map.find field record_info.field_info in let expr = Exp.Const (Cint (IntLit.of_int field_info.index)) in box_integer env ret_var expr @@ -1340,18 +1340,22 @@ and translate_expression_record_index (env : (_, _) Env.t) ret_var name field : and translate_expression_record_update (env : (_, _) Env.t) ret_var record name updates : Block.t = (* Under the hood, a record is a tagged tuple, the first element is the name, and then the fields follow in the order as in the record definition. *) - let record_info = String.Map.find_exn env.records name in + let record_info = IString.Map.find name env.records in let tuple_typ : ErlangTypeName.t = Tuple (1 + List.length record_info.field_names) in (* First collect all the fields that are updated *) let collect_updates map (one_update : Ast.record_update) = match one_update.field with | Some name -> - Map.add_exn ~key:name ~data:one_update.expression map + IString.Map.update name + (function None -> Some one_update.expression | Some _ -> assert false) + map | None -> (* '_' stands for 'everything else' *) - Map.add_exn ~key:"_" ~data:one_update.expression map + IString.Map.update "_" + (function None -> Some one_update.expression | Some _ -> assert false) + map in - let updates_map = List.fold ~init:String.Map.empty ~f:collect_updates updates in + let updates_map = List.fold ~init:IString.Map.empty ~f:collect_updates updates in (* Translate record expression if it is an update *) let record_id = mk_fresh_id () in let record_block = @@ -1369,16 +1373,16 @@ and translate_expression_record_update (env : (_, _) Env.t) ret_var record name (* Translate each field: the value can come from 5 different sources *) let translate_one_field ((one_field_name, one_id) : string * Ident.t) = (* (1) Check if field is explicitly set *) - match String.Map.find updates_map one_field_name with + match IString.Map.find_opt one_field_name updates_map with | Some expr -> translate_expression_to_id env one_id expr | None -> ( (* (2) Check if field is set using 'everything else' *) - match String.Map.find updates_map "_" with + match IString.Map.find_opt "_" updates_map with | Some expr -> translate_expression_to_id env one_id expr | None -> ( - let field_info = String.Map.find_exn record_info.field_info one_field_name in + let field_info = IString.Map.find one_field_name record_info.field_info in (* (3) Check if we have to copy over from record that is being updated *) match record with | Some _ -> @@ -1588,7 +1592,9 @@ let mk_procdesc (env : (_, _) Env.t) attributes = let mk_attributes (env : (_, _) Env.t) (uf_name : Env.UnqualifiedFunction.t) procname = let default = ProcAttributes.default env.location.file procname in - let access : ProcAttributes.access = if Set.mem env.exports uf_name then Public else Private in + let access : ProcAttributes.access = + if Env.UnqualifiedFunction.Set.mem uf_name env.exports then Public else Private + in let formals = List.init ~f:(fun i -> (mangled_arg i, any_typ, Annot.Item.empty)) uf_name.arity in {default with access; formals; is_defined= true; loc= env.location; ret_type= any_typ} @@ -1600,7 +1606,7 @@ let translate_one_function (env : (_, _) Env.t) function_ clauses = let procdesc = mk_procdesc env attributes in let ret_var = Exp.Lvar (Pvar.get_ret_pvar procname) in let env = {env with procdesc= Env.Present procdesc; result= Env.Present ret_var} in - let spec = Env.UnqualifiedFunction.Map.find env.specs uf_name in + let spec = Env.UnqualifiedFunction.Map.find_opt uf_name env.specs in translate_function_clauses env procdesc attributes procname clauses spec @@ -1631,7 +1637,7 @@ let translate_one_type (env : (_, _) Env.t) name type_ = let load_instr = Sil.Load {id= arg_id; e= Exp.Lvar pvar; typ= any_typ; loc= attributes.loc} in let load_block = Block.make_instruction env [load_instr] in let type_check_block, condition = - ErlangTypes.type_condition env String.Map.empty (arg_id, type_) + ErlangTypes.type_condition env IString.Map.empty (arg_id, type_) in let store_instr = Sil.Store {e1= ret_var; typ= any_typ; e2= condition; loc= env.location} in let store_block = Block.make_instruction env [store_instr] in @@ -1649,7 +1655,7 @@ let translate_one_spec (env : (_, _) Env.t) function_ spec = let uf_name, procname = Env.func_procname env function_ in (* Skip specs where we have a function, because those are translated by [translate_one_function] and the spec is used there. *) - if Env.UnqualifiedFunction.Set.mem env.functions uf_name then () + if Env.UnqualifiedFunction.Set.mem uf_name env.functions then () else let attributes = mk_attributes env uf_name procname in let attributes = {attributes with is_synthetic_method= true} in @@ -1675,7 +1681,7 @@ let add_module_info_field (env : (_, _) Env.t) tenv = Tenv.mk_struct tenv typ |> ignore ; let name = Fieldname.make typ ErlangTypeName.module_info_field_name in let field_typ = Typ.mk_struct typ in - let annot = Map.data env.module_info in + let annot = IString.Map.bindings env.module_info |> List.map ~f:snd in let field = Struct.mk_field name field_typ ~annot in Tenv.add_field tenv typ field diff --git a/infer/src/erlang/ErlangTypes.ml b/infer/src/erlang/ErlangTypes.ml index 40d62124be5..522f88f7fc1 100644 --- a/infer/src/erlang/ErlangTypes.ml +++ b/infer/src/erlang/ErlangTypes.ml @@ -77,7 +77,7 @@ let rec type_condition_real (env : (_, _) Env.t) constraints ((ident, type_) : I simple_condition Nil ident | Record name -> ( (* We can replace this check with [find_exn] once we have AST validation for specs (T115271156). *) - match String.Map.find env.records name with + match IString.Map.find_opt name env.records with | Some record_info -> let tuple_size = 1 + List.length record_info.field_names in let tuple_typ = ErlangTypeName.Tuple tuple_size in @@ -123,7 +123,7 @@ let rec type_condition_real (env : (_, _) Env.t) constraints ((ident, type_) : I | Var v -> ( (* Simple substitution. Can go into infinite loop. For now we assume that the type checker rejects such cases before. TODO: check for cycles in a validation step (T115271156) *) - match Map.find constraints v with + match IString.Map.find_opt v constraints with | Some subtyp -> type_condition_real env constraints (ident, subtyp) | None -> diff --git a/infer/src/erlang/ErlangTypes.mli b/infer/src/erlang/ErlangTypes.mli index 285408214f6..3bc9f211861 100644 --- a/infer/src/erlang/ErlangTypes.mli +++ b/infer/src/erlang/ErlangTypes.mli @@ -9,7 +9,7 @@ open! IStd val type_condition : (Procdesc.t ErlangEnvironment.present, 'a) ErlangEnvironment.t - -> (string, ErlangAst.type_, 'b) Map_intf.Map.t + -> ErlangAst.type_ IString.Map.t -> Ident.t * ErlangAst.type_ -> ErlangBlock.t * Exp.t (** Given an argument, its type (and a list of constraints), returns a condition that is true if the diff --git a/infer/src/erlang/dune b/infer/src/erlang/dune index 071c8e85c37..9d6a3931c50 100644 --- a/infer/src/erlang/dune +++ b/infer/src/erlang/dune @@ -22,4 +22,4 @@ IR)) (libraries core IStdlib IBase IR) (preprocess - (pps ppx_compare ppx_sexp_conv))) + (pps ppx_compare ppx_sexp_conv ppx_hash))) diff --git a/infer/src/integration/Erlang.ml b/infer/src/integration/Erlang.ml index 4a606348be8..c08c581d64d 100644 --- a/infer/src/integration/Erlang.ml +++ b/infer/src/integration/Erlang.ml @@ -34,7 +34,7 @@ let parse_translate_store ?(base_dir = None) result_dir = let otp_modules = match Utils.read_file otp_modules_file with | Ok modules -> - String.Set.of_list modules + IString.Set.of_list modules | Error err -> L.die InternalError "Error while loading list of OTP modules from file %s: %s@." otp_modules_file err diff --git a/infer/src/istd/IString.ml b/infer/src/istd/IString.ml index 17b0fde6f4c..1bc73933a67 100644 --- a/infer/src/istd/IString.ml +++ b/infer/src/istd/IString.ml @@ -6,11 +6,7 @@ *) open! IStd - -module T = struct - type t = string [@@deriving compare, hash, equal] -end - -module Map = Stdlib.Map.Make (T) -module Set = Stdlib.Set.Make (T) +module T = String +module Map = PrettyPrintable.MakeHashSexpPPMap (T) +module Set = PrettyPrintable.MakeHashSexpPPSet (T) module Hash = Stdlib.Hashtbl.Make (T) diff --git a/infer/src/istd/IString.mli b/infer/src/istd/IString.mli index 0aeacb41204..e491ab3440e 100644 --- a/infer/src/istd/IString.mli +++ b/infer/src/istd/IString.mli @@ -5,8 +5,8 @@ * LICENSE file in the root directory of this source tree. *) -module Map : Stdlib.Map.S with type key = string +module Map : PrettyPrintable.HashSexpPPMap with type key = string -module Set : Stdlib.Set.S with type elt = string +module Set : PrettyPrintable.HashSexpPPSet with type elt = string module Hash : Stdlib.Hashtbl.S with type key = string diff --git a/infer/src/istd/dune b/infer/src/istd/dune index 8d631bdc958..8da178d93fa 100644 --- a/infer/src/istd/dune +++ b/infer/src/istd/dune @@ -20,7 +20,7 @@ re yojson) (preprocess - (pps ppx_compare ppx_hash))) + (pps ppx_compare ppx_hash ppx_sexp_conv))) (documentation (package infer) diff --git a/infer/src/pulse/PulseTransitiveAccessChecker.ml b/infer/src/pulse/PulseTransitiveAccessChecker.ml index 6f126fc4386..e99e92e01de 100644 --- a/infer/src/pulse/PulseTransitiveAccessChecker.ml +++ b/infer/src/pulse/PulseTransitiveAccessChecker.ml @@ -145,10 +145,10 @@ end = struct in let has_parents tenv type_name = let parents = - Tenv.fold_supers tenv type_name ~init:String.Set.empty ~f:(fun parent _ acc -> - String.Set.add acc (Typ.Name.name parent) ) + Tenv.fold_supers tenv type_name ~init:IString.Set.empty ~f:(fun parent _ acc -> + IString.Set.add (Typ.Name.name parent) acc ) in - fun classes -> List.exists classes ~f:(String.Set.mem parents) + fun classes -> List.exists classes ~f:(fun c -> IString.Set.mem c parents) in let check_extends tenv procname final_class_only initial_caller_class_extends = match Procname.get_class_type_name procname with diff --git a/infer/src/topl/ToplAutomaton.ml b/infer/src/topl/ToplAutomaton.ml index cf19ec116a3..0f46524f7eb 100644 --- a/infer/src/topl/ToplAutomaton.ml +++ b/infer/src/topl/ToplAutomaton.ml @@ -14,17 +14,17 @@ let tt fmt = Logging.debug Analysis mode fmt -type pindex = int [@@deriving compare, hash, sexp] +type pindex = int [@@deriving compare, hash, sexp, equal] type pname = ToplAst.property_name module Vname = struct module T = struct - type t = pindex * ToplAst.vertex [@@deriving compare, hash, sexp] + type t = pindex * ToplAst.vertex [@@deriving compare, hash, sexp, equal] end include T - include Hashable.Make (T) + module Hash = Stdlib.Hashtbl.Make (T) end type vname = Vname.t @@ -53,12 +53,12 @@ type t = (** [index_in H a] returns a pair of functions [(opt, err)] that lookup the (last) index of an element in [a]. The difference is that [opt x] returns an option, while [err msg x] makes Infer die, mentioning [msg].*) -let index_in (type k) (module H : Hashtbl_intf.S with type key = k) (a : k array) : +let index_in (type k) (module H : Stdlib.Hashtbl.S with type key = k) (a : k array) : (k -> int option) * (string -> k -> int) = - let h = H.create ~size:(2 * Array.length a) () in - let f i x = H.set h ~key:x ~data:i in + let h = H.create (2 * Array.length a) in + let f i x = H.add h x i in Array.iteri ~f a ; - let opt = H.find h in + let opt = H.find_opt h in let err msg x = match opt x with | Some x -> @@ -74,7 +74,7 @@ let make properties = let f {ToplAst.name} = name in Array.of_list (List.map ~f properties) in - let _pindex_opt, pindex = index_in (module String.Table) names in + let _pindex_opt, pindex = index_in (module IString.Hash) names in let pindex = pindex "property name" in let messages : string array = let f {ToplAst.name; message} = @@ -90,7 +90,7 @@ let make properties = Array.of_list (List.dedup_and_sort ~compare:Vname.compare (List.concat_mapi ~f properties)) in Array.iteri ~f:(fun i (p, v) -> tt "state[%d]=(%d,%s)@\n" i p v) states ; - let _vindex_opt, vindex = index_in (module Vname.Table) states in + let _vindex_opt, vindex = index_in (module Vname.Hash) states in let vindex = vindex "vertex" in let transitions : transition array = let f pindex p = @@ -145,9 +145,9 @@ let tcount a = Array.length a.transitions let registers a = (* TODO(rgrigore): cache *) - let do_assignment acc (r, _v) = String.Set.add acc r in + let do_assignment acc (r, _v) = IString.Set.add r acc in let do_action acc = List.fold ~init:acc ~f:do_assignment in - let do_value acc = ToplAst.(function Register r -> String.Set.add acc r | _ -> acc) in + let do_value acc = ToplAst.(function Register r -> IString.Set.add r acc | _ -> acc) in let do_predicate acc = ToplAst.(function Binop (_op, l, r) -> do_value (do_value acc l) r | _ -> acc) in @@ -155,7 +155,7 @@ let registers a = let do_label acc {ToplAst.action; condition} = do_action (do_condition acc condition) action in let do_label_opt acc = Option.fold ~init:acc ~f:do_label in let do_transition acc {label} = do_label_opt acc label in - String.Set.to_list (Array.fold ~init:String.Set.empty ~f:do_transition a.transitions) + IString.Set.elements (Array.fold ~init:IString.Set.empty ~f:do_transition a.transitions) let tfilter_mapi a ~f = Array.to_list (Array.filter_mapi ~f a.transitions)