[tenv][merge][java] intelligently merge type definitions for the same typename

Summary:
Merging global type environments for Java needs some form of non-trivial type definition merging because:
- The frontend is likely non-deterministic, so it can capture the same type differently.
- There are classes that appear with two distinct definitions (usually ordered by inclusion) when one is produced by an ABI-like compilation process (so only public fields/methods would appear for example), and one full version.
- The frontend produces dummy versions (empty definitions), and full ones.
- The location information is variously missing/present.

This diff tries to strike a balance between a full semantic merge (which depends on the frontend/buck integration) and the current code which "merges" by clobbering old definitions with new ones.

One side-effect of this diff is that code cannot expect a special order for supers.

Reviewed By: jvillard

Differential Revision: D22630286

fbshipit-source-id: fc66c7000

infer/src/IR/Annot.ml

@@ -14,7 +14,7 @@ module F = Format
 (** Type to represent an [@Annotation] with potentially complex parameter values such as arrays or
     other annotations. *)
 type t = {class_name: string  (** name of the annotation *); parameters: parameter list}
-[@@deriving compare]
+[@@deriving compare, equal]
 
 and parameter = {name: string option; value: value} [@@deriving compare]
 
@@ -86,7 +86,7 @@ and pp fmt annotation =
 
 module Item = struct
   (** Annotation for one item: a list of annotations with visibility. *)
-  type nonrec t = (t * bool) list [@@deriving compare]
+  type nonrec t = (t * bool) list [@@deriving compare, equal]
 
   (** Pretty print an item annotation. *)
   let pp fmt ann =

infer/src/IR/Annot.mli

@@ -14,7 +14,7 @@ module F = Format
 (** Type to represent an [@Annotation] with potentially complex parameter values such as arrays or
     other annotations. *)
 type t = {class_name: string  (** name of the annotation *); parameters: parameter list}
-[@@deriving compare]
+[@@deriving compare, equal]
 
 and parameter = {name: string option; value: value} [@@deriving compare]
 
@@ -45,7 +45,7 @@ val pp : F.formatter -> t -> unit
 
 module Item : sig
   (** Annotation for one item: a list of annotations with visibility. *)
-  type nonrec t = (t * bool) list [@@deriving compare]
+  type nonrec t = (t * bool) list [@@deriving compare, equal]
 
   val pp : F.formatter -> t -> unit
   (** Pretty print an item annotation. *)

infer/src/IR/Struct.ml

@@ -8,17 +8,35 @@
 open! IStd
 module F = Format
 
-type field = Fieldname.t * Typ.t * Annot.Item.t [@@deriving compare]
+type field = Fieldname.t * Typ.t * Annot.Item.t [@@deriving compare, equal]
 
-type fields = field list
+type fields = field list [@@deriving equal]
+
+type java_class_kind = Interface | AbstractClass | NormalClass [@@deriving equal, compare]
+
+let pp_java_class_kind fmt kind =
+  F.pp_print_string fmt
+    ( match kind with
+    | Interface ->
+        "Interface"
+    | AbstractClass ->
+        "AbstractClass"
+    | NormalClass ->
+        "NormalClass" )
 
-type java_class_kind = Interface | AbstractClass | NormalClass [@@deriving equal]
 
 type java_class_info =
   { kind: java_class_kind  (** class kind in Java *)
   ; loc: Location.t option
         (** None should correspond to rare cases when it was impossible to fetch the location in
             source file *) }
+[@@deriving equal]
+
+let pp_java_class_info fmt {kind; loc} =
+  F.fprintf fmt "{kind= %a; loc= %a}" pp_java_class_kind kind (Pp.option Location.pp) loc
+
+
+let pp_java_class_info_opt fmt jopt = Pp.option pp_java_class_info fmt jopt
 
 (** Type for a structured value. *)
 type t =
@@ -31,6 +49,7 @@ type t =
   ; annots: Annot.Item.t  (** annotations *)
   ; java_class_info: java_class_info option  (** present if and only if the class is Java *)
   ; dummy: bool  (** dummy struct for class including static method *) }
+[@@deriving equal]
 
 type lookup = Typ.Name.t -> t option
 
@@ -38,7 +57,10 @@ let pp_field pe f (field_name, typ, ann) =
   F.fprintf f "@\n\t\t%a %a %a" (Typ.pp_full pe) typ Fieldname.pp field_name Annot.Item.pp ann
 
 
-let pp pe name f {fields; supers; methods; exported_objc_methods; annots} =
+let pp pe name f
+    ({fields; statics; subs; supers; methods; exported_objc_methods; annots; java_class_info; dummy}[@warning
+                                                                                                    "+9"])
+    =
   let pp_field pe f (field_name, typ, ann) =
     F.fprintf f "@;<0 2>%a %a %a" (Typ.pp_full pe) typ Fieldname.pp field_name Annot.Item.pp ann
   in
@@ -52,19 +74,27 @@ let pp pe name f {fields; supers; methods; exported_objc_methods; annots} =
   F.fprintf f
     "%a@,\
      @[<v>fields: {@[<v>%a@]}@,\
+     statics: {@[<v>%a@]}@,\
      supers: {@[<v>%a@]}@,\
+     subs: {@[<v>%a@]}@,\
      methods: {@[<v>%a@]}@,\
      exported_obj_methods: {@[<v>%a@]}@,\
-     annots: {%a}@]@,"
+     annots: {@[<v>%a@]}@,\
+     java_class_info: {@[<v>%a@]}@,\
+     dummy: %b@]@,"
     Typ.Name.pp name
     (seq (pp_field pe))
     fields
+    (seq (pp_field pe))
+    statics
     (seq (fun f n -> F.fprintf f "@;<0 2>%a" Typ.Name.pp n))
     supers
+    (seq (fun f n -> F.fprintf f "@;<0 2>%a" Typ.Name.pp n))
+    (Typ.Name.Set.elements subs)
     (seq (fun f m -> F.fprintf f "@;<0 2>%a" Procname.pp m))
     methods
     (seq (fun f m -> F.fprintf f "@;<0 2>%a" Procname.pp m))
-    exported_objc_methods Annot.Item.pp annots
+    exported_objc_methods Annot.Item.pp annots pp_java_class_info_opt java_class_info dummy
 
 
 let internal_mk_struct ?default ?fields ?statics ?methods ?exported_objc_methods ?supers ?annots
@@ -159,3 +189,86 @@ let get_field_type_and_annotation ~lookup field_name_to_lookup typ =
 let is_dummy {dummy} = dummy
 
 let add_sub sub x = {x with subs= Typ.Name.Set.add sub x.subs}
+
+let merge_lists ~compare ~newer ~current =
+  let equal x y = Int.equal 0 (compare x y) in
+  match (newer, current) with
+  | [], _ ->
+      current
+  | _, [] ->
+      newer
+  | _, _ when List.equal equal newer current ->
+      newer
+  | _, _ ->
+      List.dedup_and_sort ~compare (newer @ current)
+
+
+let merge_fields ~newer ~current = merge_lists ~compare:compare_field ~newer ~current
+
+let merge_supers ~newer ~current = merge_lists ~compare:Typ.Name.compare ~newer ~current
+
+let merge_methods ~newer ~current = merge_lists ~compare:Procname.compare ~newer ~current
+
+let merge_annots ~newer ~current = merge_lists ~compare:[%compare: Annot.t * bool] ~newer ~current
+
+let merge_kind ~newer ~current =
+  (* choose the maximal, ie most concrete *)
+  if compare_java_class_kind newer current < 0 then current else newer
+
+
+(* choose [Some] option if possible, [newer] if both [None] else [merge] *)
+let merge_opt ~merge ~newer ~current =
+  match (newer, current) with
+  | _, None ->
+      newer
+  | None, _ ->
+      current
+  | Some newer, Some current ->
+      Some (merge ~newer ~current)
+
+
+let merge_loc ~newer ~current =
+  if Location.equal Location.dummy newer then current
+  else if Location.equal Location.dummy current then newer
+  else if (* arbitrarily but deterministically choose one *) Location.compare newer current <= 0
+  then newer
+  else current
+
+
+let merge_loc_opt ~newer ~current = merge_opt ~merge:merge_loc ~newer ~current
+
+let merge_java_class_info ~newer ~current =
+  { kind= merge_kind ~newer:newer.kind ~current:current.kind
+  ; loc= merge_loc_opt ~newer:newer.loc ~current:current.loc }
+
+
+let merge_java_class_info_opt ~newer ~current =
+  merge_opt ~merge:merge_java_class_info ~newer ~current
+
+
+let full_merge ~newer ~current =
+  let fields = merge_fields ~newer:newer.fields ~current:current.fields in
+  let statics = merge_fields ~newer:newer.statics ~current:current.statics in
+  let supers = merge_supers ~newer:newer.supers ~current:current.supers in
+  (* the semantics of [subs] is such that no merging is attempted *)
+  let methods = merge_methods ~newer:newer.methods ~current:current.methods in
+  (* we are merging only Java classes, so [exported_obj_methods] should be empty, so no merge *)
+  let annots = merge_annots ~newer:newer.annots ~current:current.annots in
+  let java_class_info =
+    merge_java_class_info_opt ~newer:newer.java_class_info ~current:current.java_class_info
+  in
+  {newer with fields; statics; supers; methods; annots; java_class_info}
+
+
+let merge typename ~newer ~current =
+  match (typename : Typ.Name.t) with
+  | CStruct _ | CUnion _ | ObjcClass _ | ObjcProtocol _ | CppClass _ ->
+      if not (is_dummy newer) then newer else current
+  | JavaClass _ when is_dummy newer ->
+      current
+  | JavaClass _ when is_dummy current ->
+      newer
+  | JavaClass _ when equal newer current ->
+      newer
+  | JavaClass _ ->
+      full_merge ~newer ~current

infer/src/IR/Struct.mli

@@ -70,7 +70,8 @@ val get_field_type_and_annotation :
   lookup:lookup -> Fieldname.t -> Typ.t -> (Typ.t * Annot.Item.t) option
 (** Return the type of the field [fn] and its annotation, None if [typ] has no field named [fn] *)
 
-val is_dummy : t -> bool
-
 val add_sub : Typ.Name.t -> t -> t
 (** Add a subclass to the struct type *)
+
+val merge : Typ.Name.t -> newer:t -> current:t -> t
+(** best effort directed merge of two structs for the same typename *)

infer/src/IR/Tenv.ml

@@ -97,11 +97,15 @@ module SQLite : SqliteUtils.Data with type t = per_file = struct
 end
 
 let merge ~src ~dst =
-  TypenameHash.iter
-    (fun pname cfg ->
-      if (not (Struct.is_dummy cfg)) || not (TypenameHash.mem dst pname) then
-        TypenameHash.replace dst pname cfg )
-    src
+  let merge_internal typename newer =
+    match TypenameHash.find_opt dst typename with
+    | None ->
+        TypenameHash.add dst typename newer
+    | Some current ->
+        let merged_struct = Struct.merge typename ~newer ~current in
+        TypenameHash.replace dst typename merged_struct
+  in
+  TypenameHash.iter merge_internal src
 
 
 let merge_per_file ~src ~dst =