[IR] Remove redundant struct_typ.name field

Summary:
It is no longer necessary to keep the name of a struct within the
struct, as the name will just have been used to look it up.

Reviewed By: cristianoc

Differential Revision: D3919355

fbshipit-source-id: ab65168

infer/src/IR/Procname.re

@@ -240,6 +240,12 @@ let objc_cpp_get_class_name objc_cpp => objc_cpp.class_name;
 let java_get_class_name (j: java) => java_type_to_string j.class_name;
 
 
+/** Return the package.classname as a typename of a java procname. */
+let java_get_class_type_name (j: java) => Typename.Java.from_string (
+  java_type_to_string j.class_name
+);
+
+
 /** Return the class name of a java procedure name. */
 let java_get_simple_class_name (j: java) => snd j.class_name;
 

infer/src/IR/Procname.rei

@@ -155,6 +155,10 @@ let objc_method_kind_of_bool: bool => objc_cpp_method_kind;
 let java_get_class_name: java => string;
 
 
+/** Return the class name as a typename of a java procedure name. */
+let java_get_class_type_name: java => Typename.t;
+
+
 /** Return the simple class name of a java procedure name. */
 let java_get_simple_class_name: java => string;
 

infer/src/IR/Tenv.re

@@ -48,7 +48,7 @@ let mk_struct
       methods::?methods
       supers::?supers
       annots::?annots
-      name;
+      ();
   TypenameHash.replace tenv name struct_typ;
   struct_typ
 };
@@ -81,17 +81,6 @@ let lookup tenv name =>
 let add tenv name struct_typ => TypenameHash.replace tenv name struct_typ;
 
 
-/** resolve a type string to a Java *class* type. For strings that may represent primitive or array
-    typs, use [lookup_java_typ_from_string] */
-let lookup_java_class_from_string tenv typ_str :option Typ.struct_typ =>
-  lookup tenv (Typename.Java.from_string typ_str);
-
-
-/** Return the declaring class type of [pname_java] */
-let lookup_declaring_class tenv pname_java =>
-  lookup_java_class_from_string tenv (Procname.java_get_class_name pname_java);
-
-
 /** Get method that is being overriden by java_pname (if any) **/
 let get_overriden_method tenv pname_java => {
   let struct_typ_get_method_by_name struct_typ method_name =>
@@ -109,7 +98,7 @@ let get_overriden_method tenv pname_java => {
       }
     | [] => None
     };
-  switch (lookup_declaring_class tenv pname_java) {
+  switch (lookup tenv (Procname.java_get_class_type_name pname_java)) {
   | Some {Typ.supers: supers} => get_overriden_method_in_supers pname_java supers
   | _ => None
   }
@@ -145,7 +134,7 @@ let pp fmt (tenv: t) =>
     (
       fun name typ => {
         Format.fprintf fmt "@[<6>NAME: %s@." (Typename.to_string name);
-        Format.fprintf fmt "@[<6>TYPE: %a@." (Typ.pp_struct_typ pe_text (fun _ () => ())) typ
+        Format.fprintf fmt "@[<6>TYPE: %a@." (Typ.pp_struct_typ pe_text (fun _ () => ()) name) typ
       }
     )
     tenv;

infer/src/IR/Tenv.rei

@@ -41,10 +41,6 @@ let load_from_file: DB.filename => option t;
 let lookup: t => Typename.t => option Typ.struct_typ;
 
 
-/** Return the declaring class type of [pname_java] */
-let lookup_declaring_class: t => Procname.java => option Typ.struct_typ;
-
-
 /** Construct a struct_typ, normalizing field types */
 let mk_struct:
   t =>

infer/src/IR/Typ.re

@@ -296,7 +296,6 @@ type struct_fields = list (Ident.fieldname, t, item_annotation);
 
 /** Type for a structured value. */
 type struct_typ = {
-  name: Typename.t, /** name */
   fields: struct_fields, /** non-static fields */
   statics: struct_fields, /** static fields */
   supers: list Typename.t, /** superclasses */
@@ -346,28 +345,6 @@ let equal t1 t2 => compare t1 t2 == 0;
 let fld_typ_ann_compare fta1 fta2 =>
   triple_compare Ident.fieldname_compare compare item_annotation_compare fta1 fta2;
 
-let fld_typ_ann_list_compare ftal1 ftal2 => IList.compare fld_typ_ann_compare ftal1 ftal2;
-
-let struct_typ_compare struct_typ1 struct_typ2 =>
-  switch (struct_typ1.name, struct_typ2.name) {
-  | (TN_csu (Class Java) _, TN_csu (Class Java) _) =>
-    Typename.compare struct_typ1.name struct_typ2.name
-  | _ =>
-    let n = fld_typ_ann_list_compare struct_typ1.fields struct_typ2.fields;
-    if (n != 0) {
-      n
-    } else {
-      let n = fld_typ_ann_list_compare struct_typ1.statics struct_typ2.statics;
-      if (n != 0) {
-        n
-      } else {
-        Typename.compare struct_typ1.name struct_typ2.name
-      }
-    }
-  };
-
-let struct_typ_equal struct_typ1 struct_typ2 => struct_typ_compare struct_typ1 struct_typ2 == 0;
-
 
 /** Pretty print a type declaration.
     pp_base prints the variable for a declaration, or can be skip to print only the type */
@@ -410,7 +387,7 @@ let pp pe f te =>
     ()
   };
 
-let pp_struct_typ pe pp_base f {fields, name} =>
+let pp_struct_typ pe pp_base name f {fields} =>
   if false {
     /* change false to true to print the details of struct */
     F.fprintf
@@ -441,11 +418,6 @@ let d_list (tl: list t) => L.add_print_action (L.PTtyp_list, Obj.repr tl);
 
 
 /** {2 Sets and maps of types} */
-let module StructSet = Set.Make {
-  type t = struct_typ;
-  let compare = struct_typ_compare;
-};
-
 let module Set = Set.Make {
   type nonrec t = t;
   let compare = compare;
@@ -469,25 +441,16 @@ let internal_mk_struct
     methods::methods=?
     supers::supers=?
     annots::annots=?
-    name => {
+    () => {
   let mk_struct_
-      name::name
       default::
-        default={
-          name,
-          fields: [],
-          statics: [],
-          methods: [],
-          supers: [],
-          annots: item_annotation_empty
-        }
+        default={fields: [], statics: [], methods: [], supers: [], annots: item_annotation_empty}
       fields::fields=default.fields
       statics::statics=default.statics
       methods::methods=default.methods
       supers::supers=default.supers
       annots::annots=default.annots
       () => {
-    name,
     fields,
     statics,
     methods,
@@ -495,7 +458,6 @@ let internal_mk_struct
     annots
   };
   mk_struct_
-    name::name
     default::?default
     fields::?fields
     statics::?statics
@@ -582,14 +544,6 @@ let get_field_type_and_annotation lookup::lookup fn typ =>
   | _ => None
   };
 
-
-/** if [struct_typ] is a class, return its class kind (Java, CPP, or Obj-C) */
-let struct_typ_get_class_kind struct_typ =>
-  switch struct_typ.name {
-  | TN_csu (Class class_kind) _ => Some class_kind
-  | _ => None
-  };
-
 let is_class_of_kind typ ck =>
   switch typ {
   | Tstruct (TN_csu (Class ck') _) => ck == ck'

infer/src/IR/Typ.rei

@@ -151,7 +151,6 @@ type struct_fields = list (Ident.fieldname, t, item_annotation);
 
 /** Type for a structured value. */
 type struct_typ = private {
-  name: Typename.t, /** name */
   fields: struct_fields, /** non-static fields */
   statics: struct_fields, /** static fields */
   supers: list Typename.t, /** supers */
@@ -166,8 +165,6 @@ type lookup = Typename.t => option struct_typ;
 let fld_typ_ann_compare:
   (Ident.fieldname, t, item_annotation) => (Ident.fieldname, t, item_annotation) => int;
 
-let struct_typ_equal: struct_typ => struct_typ => bool;
-
 
 /** Comparision for types. */
 let compare: t => t => int;
@@ -176,7 +173,8 @@ let compare: t => t => int;
 /** Equality for types. */
 let equal: t => t => bool;
 
-let pp_struct_typ: printenv => (F.formatter => unit => unit) => F.formatter => struct_typ => unit;
+let pp_struct_typ:
+  printenv => (F.formatter => unit => unit) => Typename.t => F.formatter => struct_typ => unit;
 
 
 /** [pp_decl pe pp_base f typ] pretty prints a type declaration.
@@ -203,8 +201,6 @@ let d_list: list t => unit;
 
 
 /** Sets of types. */
-let module StructSet: Set.S with type elt = struct_typ;
-
 let module Set: Set.S with type elt = t;
 
 
@@ -222,7 +218,7 @@ let internal_mk_struct:
   methods::list Procname.t? =>
   supers::list Typename.t? =>
   annots::item_annotation? =>
-  Typename.t =>
+  unit =>
   struct_typ;
 
 
@@ -252,10 +248,6 @@ let struct_typ_fld: lookup::lookup => default::t => Ident.fieldname => t => t;
 let get_field_type_and_annotation:
   lookup::lookup => Ident.fieldname => t => option (t, item_annotation);
 
-
-/** if [struct_typ] is a class, return its class kind (Java, CPP, or Obj-C) */
-let struct_typ_get_class_kind: struct_typ => option Csu.class_kind;
-
 let is_objc_class: t => bool;
 
 let is_cpp_class: t => bool;

infer/src/backend/interproc.ml

@@ -660,7 +660,7 @@ let report_context_leaks pname sigma tenv =
       Prop.compute_reachable_hpreds sigma fld_exps in
     (* raise an error if any Context expression is in [reachable_exps] *)
     IList.iter
-      (fun (context_exp, {Typ.name}) ->
+      (fun (context_exp, name) ->
          if Exp.Set.mem context_exp reachable_exps then
            let leak_path =
              match get_fld_typ_path_opt fld_exps context_exp reachable_hpreds with
@@ -675,15 +675,10 @@ let report_context_leaks pname sigma tenv =
   let context_exps =
     IList.fold_left
       (fun exps hpred -> match hpred with
-         | Sil.Hpointsto (_, Eexp (exp, _), Sizeof (Tptr (Tstruct name, _), _, _)) -> (
-             match Tenv.lookup tenv name with
-             | Some struct_typ
-               when AndroidFramework.is_context tenv struct_typ &&
-                    not (AndroidFramework.is_application tenv struct_typ) ->
-                 (exp, struct_typ) :: exps
-             | _ ->
-                 exps
-           )
+         | Sil.Hpointsto (_, Eexp (exp, _), Sizeof (Tptr (Tstruct name, _), _, _))
+           when AndroidFramework.is_context tenv name
+             && not (AndroidFramework.is_application tenv name) ->
+             (exp, name) :: exps
          | _ -> exps)
       []
       sigma in

infer/src/backend/prover.ml

@@ -1530,11 +1530,9 @@ struct
 
   let cloneable_type = Typename.Java.from_string "java.lang.Cloneable"
 
-  let is_interface tenv class_name =
-    match Tenv.lookup tenv class_name with
-    | Some ({ name = TN_csu (Class Java, _) } as struct_typ) ->
-        (IList.length struct_typ.fields = 0) &&
-        (IList.length struct_typ.methods = 0)
+  let is_interface tenv (class_name: Typename.t) =
+    match class_name, Tenv.lookup tenv class_name with
+    | TN_csu (Class Java, _), Some { fields = []; methods = []; } -> true
     | _ -> false
 
   let is_root_class class_name =
@@ -1547,10 +1545,10 @@ struct
 
   (** check if c1 is a subclass of c2 *)
   let check_subclass_tenv tenv c1 c2 =
-    let rec check cn =
+    let rec check (cn: Typename.t) =
       Typename.equal cn c2 || is_root_class c2 ||
-      match Tenv.lookup tenv cn with
-      | Some ({ name = TN_csu (Class _, _); supers }) ->
+      match cn, Tenv.lookup tenv cn with
+      | TN_csu (Class _, _), Some { supers } ->
           IList.exists check supers
       | _ -> false in
     check c1
@@ -1671,8 +1669,8 @@ let get_overrides_of tenv supertype pname =
             false
       )
     | _ -> false in
-  let gather_overrides tname {Typ.name} overrides_acc =
-    let typ = Typ.Tstruct name in
+  let gather_overrides tname _ overrides_acc =
+    let typ = Typ.Tstruct tname in
     (* get all types in the type environment that are non-reflexive subtypes of [supertype] *)
     if not (Typ.equal typ supertype) && Subtyping_check.check_subtype tenv typ supertype then
       (* only select the ones that implement [pname] as overrides *)

infer/src/backend/rearrange.ml

@@ -106,7 +106,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
         ([], Sil.Estruct ([], inst), t)
     | Tstruct name, (Off_fld (f, _)) :: off' -> (
         match Tenv.lookup tenv name with
-        | Some ({ name; fields; statics; } as struct_typ) -> (
+        | Some ({ fields; statics; } as struct_typ) -> (
             match IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') (fields @ statics) with
             | _, t', _ ->
                 let atoms', se', res_t' =
@@ -207,7 +207,7 @@ let rec _strexp_extend_values
         pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
   | (Off_fld (f, _)) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> (
       match Tenv.lookup tenv name with
-      | Some ({ name; fields; statics; } as struct_typ) -> (
+      | Some ({ fields; statics; } as struct_typ) -> (
           let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in
           match IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') (fields @ statics) with
           | _, typ', _ -> (

infer/src/backend/symExec.ml

@@ -496,12 +496,12 @@ let method_exists right_proc_name methods =
 let resolve_method tenv class_name proc_name =
   let found_class =
     let visited = ref Typename.Set.empty in
-    let rec resolve class_name =
+    let rec resolve (class_name: Typename.t) =
       visited := Typename.Set.add class_name !visited;
       let right_proc_name =
         Procname.replace_class proc_name (Typename.name class_name) in
-      match Tenv.lookup tenv class_name with
-      | Some { name = TN_csu (Class _, _); methods; supers } ->
+      match class_name, Tenv.lookup tenv class_name with
+      | TN_csu (Class _, _), Some { methods; supers } ->
           if method_exists right_proc_name methods then
             Some right_proc_name
           else
@@ -542,8 +542,9 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Procname.t
     match pname with
     | Procname.Java pname_java ->
         begin
-          match Tenv.lookup_declaring_class tenv pname_java with
-          | Some {name} -> Typ.Tptr (Tstruct name, Pk_pointer)
+          let name = Procname.java_get_class_type_name pname_java in
+          match Tenv.lookup tenv name with
+          | Some _ -> Typ.Tptr (Tstruct name, Pk_pointer)
           | None -> fallback_typ
         end
     | _ ->

infer/src/backend/utils.ml

@@ -65,12 +65,16 @@ let pair_compare compare compare' (x1, y1) (x2, y2) =
   let n = compare x1 x2 in
   if n <> 0 then n else compare' y1 y2
 
-(** Generic comparison of pairs given a compare function for each element of the triple *)
+(** Generic comparison of triples given a compare function for each element of the triple *)
 let triple_compare compare compare' compare'' (x1, y1, z1) (x2, y2, z2) =
   let n = compare x1 x2 in
   if n <> 0 then n else let n = compare' y1 y2 in
     if n <> 0 then n else compare'' z1 z2
 
+(** Generic equality of triples given an equal function for each element of the triple *)
+let triple_equal x_equal y_equal z_equal (x1, y1, z1) (x2, y2, z2) =
+  x_equal x1 x2 && y_equal y1 y2 && z_equal z1 z2
+
 let fst3 (x,_,_) = x
 let snd3 (_,x,_) = x
 let trd3 (_,_,x) = x

infer/src/backend/utils.mli

@@ -50,8 +50,15 @@ val opt_compare : ('a -> 'a -> int) -> 'a option -> 'a option -> int
 (** Generic comparison of pairs given a compare function for each element of the pair. *)
 val pair_compare : ('a -> 'b -> int) -> ('c -> 'd -> int) -> ('a * 'c) -> ('b * 'd) -> int
 
-(** Generic comparison of pairs given a compare function for each element of the triple. *)
-val triple_compare : ('a -> 'b -> int) -> ('c -> 'd -> int) -> ('e -> 'f -> int) -> ('a * 'c * 'e) -> ('b * 'd * 'f) -> int
+(** Generic comparison of triples given a compare function for each element of the triple. *)
+val triple_compare :
+  ('a -> 'b -> int) -> ('c -> 'd -> int) -> ('e -> 'f -> int) ->
+  ('a * 'c * 'e) -> ('b * 'd * 'f) -> int
+
+(** Generic equality of triples given an equal function for each element of the triple. *)
+val triple_equal :
+  ('a -> 'b -> bool) -> ('c -> 'd -> bool) -> ('e -> 'f -> bool) ->
+  ('a * 'c * 'e) -> ('b * 'd * 'f) -> bool
 
 (** Comparison for strings *)
 val string_compare : string -> string -> int

infer/src/checkers/annotationReachability.ml

@@ -136,15 +136,10 @@ let is_allocator tenv pname =
 let check_attributes check tenv pname =
   let check_class_attributes check tenv = function
     | Procname.Java java_pname ->
-        let check_class_annots { Typ.annots; } =
-          check annots in
-        begin
-          match Tenv.lookup_declaring_class tenv java_pname with
-          | Some current_class ->
-              check_class_annots current_class ||
-              PatternMatch.strict_supertype_exists tenv check_class_annots current_class
-          | None -> false
-        end
+        let check_class_annots _ { Typ.annots; } = check annots in
+        PatternMatch.supertype_exists tenv
+          check_class_annots
+          (Procname.java_get_class_type_name java_pname)
     | _ -> false in
   let check_method_attributes check pname =
     match Specs.proc_resolve_attributes pname with

infer/src/checkers/annotations.ml

@@ -35,13 +35,6 @@ let equal as1 as2 =
 let visibleForTesting = "com.google.common.annotations.VisibleForTesting"
 let suppressLint = "android.annotation.SuppressLint"
 
-
-(** Return the annotations on the declaring class of [pname]. Only works for Java *)
-let get_declaring_class_annotations pname tenv =
-  match Tenv.lookup_declaring_class tenv pname with
-  | Some { annots } -> Some annots
-  | None -> None
-
 let ia_iter f =
   let ann_iter (a, _) = f a in
   IList.iter ann_iter

infer/src/checkers/annotations.mli

@@ -54,9 +54,6 @@ val equal : annotated_signature -> annotated_signature -> bool
 (** Get a method signature with annotations from a proc_attributes. *)
 val get_annotated_signature : ProcAttributes.t -> annotated_signature
 
-(** Return the annotations on the declaring class of [java_pname]. *)
-val get_declaring_class_annotations : Procname.java -> Tenv.t -> Typ.item_annotation option
-
 val nullable : string
 
 (** Return true if [annot] ends with [ann_name] *)

infer/src/checkers/checkers.ml

@@ -210,11 +210,8 @@ let callback_check_write_to_parcel_java
       let class_name =
         Typename.TN_csu (Csu.Class Csu.Java, Mangled.from_string "android.os.Parcelable") in
       match this_type with
-      | Typ.Tptr (Tstruct name, _) | Tstruct name -> (
-          match Tenv.lookup tenv name with
-          | Some struct_typ -> PatternMatch.is_immediate_subtype struct_typ class_name
-          | None -> false
-        )
+      | Typ.Tptr (Tstruct name, _) | Tstruct name ->
+          PatternMatch.is_immediate_subtype tenv name class_name
       | _ -> false in
     method_match () && expr_match () && type_match () in
 

infer/src/checkers/fragmentRetainsViewChecker.ml

@@ -26,12 +26,7 @@ let callback_fragment_retains_view_java
   (* TODO: handle fields nullified in callees in the same file *)
   let is_on_destroy_view = Procname.java_get_method pname_java = "onDestroyView" in
   let fld_typ_is_view = function
-    | Typ.Tptr (Typ.Tstruct tname, _) ->
-        begin
-          match Tenv.lookup tenv tname with
-          | Some struct_typ -> AndroidFramework.is_view tenv struct_typ
-          | None -> false
-        end
+    | Typ.Tptr (Tstruct tname, _) -> AndroidFramework.is_view tenv tname
     | _ -> false in
   (* is [fldname] a View type declared by [class_typename]? *)
   let is_declared_view_typ class_typename (fldname, fld_typ, _) =
@@ -42,8 +37,7 @@ let callback_fragment_retains_view_java
       let class_typename =
         Typename.Java.from_string (Procname.java_get_class_name pname_java) in
       match Tenv.lookup tenv class_typename with
-      | Some ({ fields } as struct_typ)
-        when AndroidFramework.is_fragment tenv struct_typ ->
+      | Some { fields } when AndroidFramework.is_fragment tenv class_typename ->
           let declared_view_fields =
             IList.filter (is_declared_view_typ class_typename) fields in
           let fields_nullified = PatternMatch.get_fields_nullified proc_desc in

infer/src/checkers/patternMatch.ml

@@ -35,43 +35,27 @@ let java_proc_name_with_class_method pn_java class_with_path method_name =
      Procname.java_get_method pn_java = method_name
    with _ -> false)
 
-let get_direct_supers tenv = function
-  | { Typ.name = TN_csu (Class _, _); supers } ->
-      IList.map (Tenv.lookup tenv) supers
-      |> IList.flatten_options
-  | _ ->
-      []
+(** Holds iff the predicate holds on a supertype of the named type, including the type itself *)
+let rec supertype_exists tenv pred name =
+  match Tenv.lookup tenv name with
+  | Some ({supers} as struct_typ) ->
+      pred name struct_typ || IList.exists (fun name -> supertype_exists tenv pred name) supers
+  | None ->
+      false
 
-(** get the supers of [typ]. does not include [typ] itself *)
-let strict_supertype_iter tenv f_typ orig_struct_typ =
-  let rec get_supers_rec struct_typ =
-    let direct_supers = get_direct_supers tenv struct_typ in
-    IList.iter f_typ direct_supers;
-    IList.iter get_supers_rec direct_supers in
-  get_supers_rec orig_struct_typ
-
-(** Return [true] if [f_typ] evaluates to true on a strict supertype of [orig_struct_typ] *)
-let strict_supertype_exists tenv f_typ orig_struct_typ =
-  let rec get_supers_rec struct_typ =
-    let direct_supers = get_direct_supers tenv struct_typ in
-    IList.exists f_typ direct_supers ||
-    IList.exists get_supers_rec direct_supers in
-  get_supers_rec orig_struct_typ
-
-let is_immediate_subtype this_type super_type_name =
-  IList.exists (Typename.equal super_type_name) this_type.Typ.supers
+let is_immediate_subtype tenv this_type_name super_type_name =
+  match Tenv.lookup tenv this_type_name with
+  | Some {supers} -> IList.exists (Typename.equal super_type_name) supers
+  | None -> false
 
 (** return true if [typ0] <: [typ1] *)
-let is_subtype tenv struct_typ0 struct_typ1 =
-  Typ.struct_typ_equal struct_typ0 struct_typ1 ||
-  strict_supertype_exists tenv (Typ.struct_typ_equal struct_typ1) struct_typ0
+let is_subtype tenv name0 name1 =
+  supertype_exists tenv (fun name _ -> Typename.equal name name1) name0
 
 let is_subtype_of_str tenv cn1 classname_str =
   let typename = Typename.Java.from_string classname_str in
-  let lookup = Tenv.lookup tenv in
-  match lookup cn1, lookup typename with
-  | Some struct_typ1, Some struct_typ2 -> is_subtype tenv struct_typ1 struct_typ2
-  | _ -> false
+  Typename.equal cn1 typename ||
+  is_subtype tenv cn1 typename
 
 (** The type the method is invoked on *)
 let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with
@@ -354,13 +338,9 @@ let proc_iter_overridden_methods f tenv proc_name =
   match proc_name with
   | Procname.Java proc_name_java ->
       let type_name = Typename.Java.from_string (Procname.java_get_class_name proc_name_java) in
-      (match Tenv.lookup tenv type_name with
-       | Some {name} ->
       IList.iter
         (do_super_type tenv)
-             (type_get_direct_supertypes tenv (Typ.Tstruct name))
-       | None ->
-           ())
+        (type_get_direct_supertypes tenv (Typ.Tstruct type_name))
   | _ ->
       () (* Only java supported at the moment *)
 

infer/src/checkers/patternMatch.mli

@@ -51,19 +51,16 @@ val is_getter : Procname.java -> bool
 val is_setter : Procname.java -> bool
 
 (** Is the type a direct subtype of the typename? *)
-val is_immediate_subtype : Typ.struct_typ -> Typename.t -> bool
+val is_immediate_subtype : Tenv.t -> Typename.t -> Typename.t -> bool
 
 (** Is the type a transitive subtype of the typename? *)
-val is_subtype : Tenv.t -> Typ.struct_typ -> Typ.struct_typ -> bool
+val is_subtype : Tenv.t -> Typename.t -> Typename.t -> bool
 
 (** Resolve [typ_str] in [tenv], then check [typ] <: [typ_str] *)
 val is_subtype_of_str : Tenv.t -> Typename.t -> string -> bool
 
-(** get the superclasses of [typ]. does not include [typ] itself *)
-val strict_supertype_iter : Tenv.t -> (Typ.struct_typ -> unit) -> Typ.struct_typ -> unit
-
-(** Return [true] if [f_typ] evaluates to true on a strict supertype of [orig_struct_typ] *)
-val strict_supertype_exists : Tenv.t -> (Typ.struct_typ -> bool) -> Typ.struct_typ -> bool
+(** Holds iff the predicate holds on a supertype of the named type, including the type itself *)
+val supertype_exists : Tenv.t -> (Typename.t -> Typ.struct_typ -> bool) -> Typename.t -> bool
 
 (** Get the name of the type of a constant *)
 val java_get_const_type_name : Const.t -> string

infer/src/clang/cFrontend_utils.ml

@@ -525,7 +525,7 @@ struct
 
 
   let sort_fields_tenv tenv =
-    let sort_fields_struct _ ({Typ.name; fields} as st) =
+    let sort_fields_struct name ({Typ.fields} as st) =
       ignore (Tenv.mk_struct tenv ~default:st ~fields:(sort_fields fields) name) in
     Tenv.iter sort_fields_struct tenv
 

infer/src/clang/cTrans.ml

@@ -126,7 +126,8 @@ struct
         Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
     let mblock = Mangled.from_string block_name in
     let block_name = Typename.TN_csu (Csu.Class Csu.Objc, mblock) in
-    let block_type = Typ.Tstruct (Tenv.mk_struct tenv ~fields block_name).name in
+    ignore (Tenv.mk_struct tenv ~fields block_name);
+    let block_type = Typ.Tstruct block_name in
     let trans_res =
       CTrans_utils.alloc_trans
         trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true None in

infer/src/clang/cTypes_decl.ml

@@ -191,14 +191,13 @@ and get_record_declaration_struct_type tenv decl =
         let statics = [] in (* Note: We treat static field same as global variables *)
         let methods = get_class_methods name decl_list in (* C++ methods only *)
         let supers = get_superclass_list_cpp decl in
-        let sil_type =
-          Typ.Tstruct
-            (Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots sil_typename).name in
+        ignore (Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots sil_typename);
+        let sil_type = Typ.Tstruct sil_typename in
         Ast_utils.update_sil_types_map type_ptr sil_type;
         sil_type
       ) else (
         match Tenv.lookup tenv sil_typename with
-        | Some {name} -> Typ.Tstruct name (* just reuse what is already in tenv *)
+        | Some _ -> Typ.Tstruct sil_typename (* just reuse what is already in tenv *)
         | None ->
             (* This is first forward declaration seen. Add Tstruct to sil_types_map and struct with
                only ref counter field to tenv. Later, when we see the definition, the tenv will be

infer/src/clang/objcInterface_decl.ml

@@ -131,7 +131,8 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info name_info d
     "  >>>Verifying that Typename '%s' is in tenv\n" (Typename.to_string interface_name);
   (match Tenv.lookup tenv interface_name with
    | Some st ->
-       Printing.log_out "  >>>OK. Found typ='%a'\n" (Typ.pp_struct_typ pe_text (fun _ () -> ())) st
+       Printing.log_out "  >>>OK. Found typ='%a'\n"
+         (Typ.pp_struct_typ pe_text (fun _ () -> ()) interface_name) st
    | None -> Printing.log_out "  >>>NOT Found!!\n");
   Typ.Tstruct interface_name
 
@@ -141,8 +142,8 @@ let add_missing_methods tenv class_name ck decl_info decl_list curr_class =
   let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
   Ast_utils.update_sil_types_map decl_key (Typ.Tstruct class_tn_name);
   begin
-    match Tenv.lookup tenv class_tn_name with
-    | Some ({ statics = []; name = TN_csu (Class _, _); methods; } as struct_typ) ->
+    match class_tn_name, Tenv.lookup tenv class_tn_name with
+    | TN_csu (Class _, _), Some ({ statics = []; methods; } as struct_typ) ->
         let methods = General_utils.append_no_duplicates_methods methods decl_methods in
         ignore( Tenv.mk_struct tenv ~default:struct_typ ~methods class_tn_name )
     | _ -> ()

infer/src/harness/androidFramework.ml

@@ -11,7 +11,6 @@ open! Utils
 
 module L = Logging
 module F = Format
-module TypSet = Typ.StructSet
 
 (** Android lifecycle types and their lifecycle methods that are called by the framework *)
 
@@ -56,27 +55,25 @@ let android_lifecycles =
      fragment_lifecycle);
   ]
 
-let is_subtype_package_class tenv struct_typ package classname =
-  let classname = Mangled.from_package_class package classname in
-  match Tenv.lookup tenv (Typename.TN_csu (Csu.Class Csu.Java, classname)) with
-  | Some found_struct_typ -> PatternMatch.is_subtype tenv struct_typ found_struct_typ
-  | _ -> false
+let is_subtype_package_class tenv tname package classname =
+  PatternMatch.is_subtype tenv
+    tname (Typename.TN_csu (Class Java, Mangled.from_package_class package classname))
 
-let is_context tenv typ =
-  is_subtype_package_class tenv typ "android.content" "Context"
+let is_context tenv tname =
+  is_subtype_package_class tenv tname "android.content" "Context"
 
-let is_application tenv typ =
-  is_subtype_package_class tenv typ "android.app" "Application"
+let is_application tenv tname =
+  is_subtype_package_class tenv tname "android.app" "Application"
 
-let is_activity tenv typ =
-  is_subtype_package_class tenv typ "android.app" "Activity"
+let is_activity tenv tname =
+  is_subtype_package_class tenv tname "android.app" "Activity"
 
-let is_view tenv typ =
-  is_subtype_package_class tenv typ "android.view" "View"
+let is_view tenv tname =
+  is_subtype_package_class tenv tname "android.view" "View"
 
-let is_fragment tenv typ =
-  is_subtype_package_class tenv typ "android.app" "Fragment" ||
-  is_subtype_package_class tenv typ "android.support.v4.app" "Fragment"
+let is_fragment tenv tname =
+  is_subtype_package_class tenv tname "android.app" "Fragment" ||
+  is_subtype_package_class tenv tname "android.support.v4.app" "Fragment"
 
 (** return true if [class_name] is the name of a class that belong to the Android framework *)
 let is_android_lib_class class_name =
@@ -86,8 +83,8 @@ let is_android_lib_class class_name =
 (** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and
     a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
 let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs =
-  match Tenv.lookup tenv (Typename.TN_csu (Csu.Class Csu.Java, lifecycle_typ)) with
-  | Some ({ name = TN_csu (Class _, _); methods } as lifecycle_typ) ->
+  match Tenv.lookup tenv lifecycle_typ with
+  | Some { methods } ->
       (* TODO (t4645631): collect the procedures for which is_java is returning false *)
       let lookup_proc lifecycle_proc =
         IList.find (fun decl_proc ->
@@ -103,8 +100,8 @@ let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs =
             try (lookup_proc lifecycle_proc_str) :: lifecycle_procs
             with Not_found -> lifecycle_procs)
           [] lifecycle_proc_strs in
-      Some (lifecycle_typ, lifecycle_procs)
-  | _ -> None
+      lifecycle_procs
+  | _ -> []
 
 (** return the complete list of (package, lifecycle_classname, lifecycle_methods) trios *)
 let get_lifecycles = android_lifecycles

infer/src/harness/androidFramework.mli

@@ -15,26 +15,25 @@ open! Utils
 val get_lifecycles : (string * string * string list) list
 
 (** return true if [typ] <: android.content.Context *)
-val is_context : Tenv.t -> Typ.struct_typ -> bool
+val is_context : Tenv.t -> Typename.t -> bool
 
 (** return true if [struct_typ] <: android.app.Application *)
-val is_application : Tenv.t -> Typ.struct_typ -> bool
+val is_application : Tenv.t -> Typename.t -> bool
 
 (** return true if [struct_typ] <: android.app.Activity *)
-val is_activity : Tenv.t -> Typ.struct_typ -> bool
+val is_activity : Tenv.t -> Typename.t -> bool
 
 (** return true if [struct_typ] <: android.view.View *)
-val is_view : Tenv.t -> Typ.struct_typ -> bool
+val is_view : Tenv.t -> Typename.t -> bool
 
-val is_fragment : Tenv.t -> Typ.struct_typ -> bool
+val is_fragment : Tenv.t -> Typename.t -> bool
 
 (** return true if [procname] is a special lifecycle cleanup method *)
 val is_destroy_method : Procname.t -> bool
 
 (** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity)
     and a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
-val get_lifecycle_for_framework_typ_opt :
-  Tenv.t -> Mangled.t -> string list -> (Typ.struct_typ * Procname.t list) option
+val get_lifecycle_for_framework_typ_opt : Tenv.t -> Typename.t -> string list -> Procname.t list
 
 (** return true if [class_name] is the name of a class that belong to the Android framework *)
 val is_android_lib_class : Typename.t -> bool

infer/src/harness/harness.ml

@@ -16,10 +16,10 @@ module F = Format
 
 (** if [struct_typ] is a lifecycle type, generate a list of (method call, receiver) pairs
     constituting a lifecycle trace *)
-let try_create_lifecycle_trace struct_typ lifecycle_struct_typ lifecycle_procs tenv =
-  match struct_typ with
-  | { Typ.name = TN_csu (Class Java, _) as name } ->
-      if PatternMatch.is_subtype tenv struct_typ lifecycle_struct_typ &&
+let try_create_lifecycle_trace name lifecycle_name lifecycle_procs tenv =
+  match name with
+  | Typename.TN_csu (Class Java, _) ->
+      if PatternMatch.is_subtype tenv name lifecycle_name &&
          not (AndroidFramework.is_android_lib_class name) then
         let ptr_to_struct_typ = Some (Typ.Tptr (Tstruct name, Pk_pointer)) in
         IList.fold_left
@@ -37,19 +37,19 @@ let try_create_lifecycle_trace struct_typ lifecycle_struct_typ lifecycle_procs t
 (** generate a harness for a lifecycle type in an Android application *)
 let create_harness cfg cg tenv =
   IList.iter (fun (pkg, clazz, lifecycle_methods) ->
-      let typname = Mangled.from_package_class pkg clazz in
-      match AndroidFramework.get_lifecycle_for_framework_typ_opt tenv typname lifecycle_methods with
-      | Some (framework_typ, framework_procs) ->
+      let typname = Typename.TN_csu (Class Java, Mangled.from_package_class pkg clazz) in
+      let framework_procs =
+        AndroidFramework.get_lifecycle_for_framework_typ_opt tenv typname lifecycle_methods in
       (* iterate through the type environment and generate a lifecycle harness for each
          subclass of [lifecycle_typ] *)
       (* TODO: instead of iterating through the type environment, interate through the types
          declared in [cfg] *)
-          Tenv.iter (fun _ struct_typ ->
-              match try_create_lifecycle_trace struct_typ framework_typ framework_procs tenv with
+      Tenv.iter (fun name _ ->
+          match try_create_lifecycle_trace name typname framework_procs tenv with
           | [] -> ()
           | lifecycle_trace ->
               let harness_procname =
-                    let harness_cls_name = Typename.name struct_typ.name in
+                let harness_cls_name = Typename.name name in
                 let pname =
                   Procname.Java
                     (Procname.java
@@ -60,5 +60,4 @@ let create_harness cfg cg tenv =
                 | _ -> assert false in
               Inhabit.inhabit_trace tenv lifecycle_trace harness_procname cg cfg
         ) tenv
-      | None -> ()
     ) AndroidFramework.get_lifecycles

infer/src/harness/inhabit.ml

@@ -97,8 +97,8 @@ let rec inhabit_typ tenv typ cfg env =
           let get_all_suitable_constructors (typ: Typ.t) =
             match typ with
             | Tstruct name -> (
-                match Tenv.lookup tenv name with
-                | Some { name = TN_csu (Class _, _); methods } ->
+                match name, Tenv.lookup tenv name with
+                | TN_csu (Class _, _), Some { methods } ->
                     let is_suitable_constructor p =
                       let try_get_non_receiver_formals p =
                         get_non_receiver_formals (formals_from_name cfg p) in

infer/src/java/jTransType.ml

@@ -322,14 +322,16 @@ and get_class_struct_typ program tenv cn =
                   match jclass.Javalib.c_super_class with
                   | None -> interface_list (* base case of the recursion *)
                   | Some super_cn ->
-                      let super_classname = (get_class_struct_typ program tenv super_cn).Typ.name in
+                      ignore (get_class_struct_typ program tenv super_cn);
+                      let super_classname = typename_of_classname super_cn in
                       super_classname :: interface_list in
                 (super_classname_list, nonstatics, statics, item_annotation) in
           let methods = IList.map (fun j -> Procname.Java j) (get_class_procnames cn node) in
           Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots name
 
 let get_class_type_no_pointer program tenv cn =
-  Typ.Tstruct ((get_class_struct_typ program tenv cn).name)
+  ignore (get_class_struct_typ program tenv cn);
+  Typ.Tstruct (typename_of_classname cn)
 
 let get_class_type program tenv cn =
   Typ.Tptr (get_class_type_no_pointer program tenv cn, Pk_pointer)