[concurrency] improve function for searching annotations

Summary: The type hierarchy was traversed multiple times when searching for annotations: once for methods/overrides annotated and once for superclasses.  This can be done in one pass.

Reviewed By: dulmarod

Differential Revision: D17787172

fbshipit-source-id: 248dd4c27

infer/src/absint/PatternMatch.ml

@@ -329,15 +329,18 @@ let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttribute
   List.iter ~f:do_node nodes ; List.rev !res
 
 
-let override_find ?(check_current_type = true) f tenv proc_name =
+let is_override_of proc_name =
   let method_name = Typ.Procname.get_method proc_name in
   let parameter_length = List.length (Typ.Procname.get_parameters proc_name) in
-  let is_override pname =
-    (not (Typ.Procname.is_constructor pname))
-    && String.equal (Typ.Procname.get_method pname) method_name
-    (* TODO (T32979782): match parameter types, taking subtyping and type erasure into account *)
-    && Int.equal (List.length (Typ.Procname.get_parameters pname)) parameter_length
-  in
+  Staged.stage (fun pname ->
+      (not (Typ.Procname.is_constructor pname))
+      && String.equal (Typ.Procname.get_method pname) method_name
+      (* TODO (T32979782): match parameter types, taking subtyping and type erasure into account *)
+      && Int.equal (List.length (Typ.Procname.get_parameters pname)) parameter_length )
+
+
+let override_find ?(check_current_type = true) f tenv proc_name =
+  let is_override = Staged.unstage (is_override_of proc_name) in
   let rec find_super_type super_class_name =
     Tenv.lookup tenv super_class_name
     |> Option.bind ~f:(fun {Typ.Struct.methods; supers} ->

infer/src/absint/PatternMatch.mli

@@ -105,14 +105,6 @@ val proc_calls :
   -> (Typ.Procname.t * ProcAttributes.t) list
 (** Return the callees that satisfy [filter]. *)
 
-val override_find :
-     ?check_current_type:bool
-  -> (Typ.Procname.t -> bool)
-  -> Tenv.t
-  -> Typ.Procname.t
-  -> Typ.Procname.t option
-(** Return a method which overrides [procname] and satisfies [f] (including [procname] itself when [check_current_type] is true, which it is by default). *)
-
 val override_exists :
   ?check_current_type:bool -> (Typ.Procname.t -> bool) -> Tenv.t -> Typ.Procname.t -> bool
 (** Return true if applying the given predicate to an override of [procname] (including [procname] itself when [check_current_type] is true, which it is by default) returns true. *)
@@ -155,3 +147,5 @@ val check_current_class_attributes : (Annot.Item.t -> bool) -> Tenv.t -> Typ.Pro
 val find_superclasses_with_attributes :
   (Annot.Item.t -> bool) -> Tenv.t -> Typ.Name.t -> Typ.Name.t list
 (** find superclasss with attributes (e.g., @ThreadSafe), including current class*)
+
+val is_override_of : Typ.Procname.t -> (Typ.Procname.t -> bool) Staged.t

infer/src/concurrency/ConcurrencyModels.ml

@@ -312,21 +312,6 @@ let get_current_class_and_annotated_superclasses is_annot tenv pname =
       None
 
 
-let is_class_or_superclasses_annotated is_annot tenv pname =
-  get_current_class_and_annotated_superclasses is_annot tenv pname
-  |> Option.exists ~f:(fun (_, annotated) -> not (List.is_empty annotated))
-
-
-let find_method_or_override_annotated ~attrs_of_pname is_annot pname tenv =
-  PatternMatch.override_find
-    (fun pn -> Annotations.pname_has_return_annot pn ~attrs_of_pname is_annot)
-    tenv pname
-
-
-let is_method_or_override_annotated ~attrs_of_pname is_annot pname tenv =
-  find_method_or_override_annotated ~attrs_of_pname is_annot pname tenv |> Option.is_some
-
-
 let ui_matcher_records =
   let open MethodMatcher in
   let fragment_methods =
@@ -372,52 +357,65 @@ let is_ui_method =
   fun tenv pname -> MethodMatcher.of_list matchers tenv pname []
 
 
-let if_pred_evalopt ~pred ~f x =
-  IOption.if_none_evalopt x ~f:(fun () -> if pred () then Some (f ()) else None)
+type annotation_trail = DirectlyAnnotated | Override of Typ.Procname.t | SuperClass of Typ.name
+
+let find_override_or_superclass_annotated ~attrs_of_pname is_annot tenv proc_name =
+  let is_annotated pn = Annotations.pname_has_return_annot pn ~attrs_of_pname is_annot in
+  let is_override = Staged.unstage (PatternMatch.is_override_of proc_name) in
+  let rec find_override_or_superclass_aux class_name =
+    match Tenv.lookup tenv class_name with
+    | None ->
+        None
+    | Some tstruct when Annotations.struct_typ_has_annot tstruct is_annot ->
+        Some (SuperClass class_name)
+    | Some (tstruct : Typ.Struct.t) -> (
+      match
+        List.find_map tstruct.methods ~f:(fun pn ->
+            if is_override pn && is_annotated pn then Some (Override pn) else None )
+      with
+      | Some _ as result ->
+          result
+      | None ->
+          List.find_map tstruct.supers ~f:find_override_or_superclass_aux )
+  in
+  if is_annotated proc_name then Some DirectlyAnnotated
+  else Typ.Procname.get_class_type_name proc_name |> Option.bind ~f:find_override_or_superclass_aux
 
 
 let mono_pname = MF.wrap_monospaced Typ.Procname.pp
 
-let runs_on_ui_thread ~attrs_of_pname tenv proc_desc =
+let runs_on_ui_thread ~attrs_of_pname tenv pname =
   let is_uithread = Annotations.ia_is_uithread_equivalent in
-  let pname = Procdesc.get_proc_name proc_desc in
+  let describe ~procname fmt = function
+    | DirectlyAnnotated ->
+        F.fprintf fmt "%a is annotated %a" mono_pname procname MF.pp_monospaced
+          Annotations.ui_thread
+    | Override override_pname ->
+        F.fprintf fmt "class %a overrides %a, which is annotated %a" mono_pname procname mono_pname
+          override_pname MF.pp_monospaced Annotations.ui_thread
+    | SuperClass class_name -> (
+      match Typ.Procname.get_class_type_name procname with
+      | None ->
+          L.die InternalError "Cannot get class of method %a@." Typ.Procname.pp procname
+      | Some current_class ->
+          let pp_extends fmt current_class =
+            if Typ.Name.equal current_class class_name then ()
+            else F.fprintf fmt " extends %a, which" (MF.wrap_monospaced Typ.Name.pp) class_name
+          in
+          F.fprintf fmt "class %s%a is annotated %a"
+            (MF.monospaced_to_string (Typ.Name.name current_class))
+            pp_extends current_class MF.pp_monospaced Annotations.ui_thread )
+  in
   if
-    is_method_or_override_annotated ~attrs_of_pname Annotations.ia_is_worker_thread pname tenv
-    || is_class_or_superclasses_annotated Annotations.ia_is_worker_thread tenv pname
+    find_override_or_superclass_annotated ~attrs_of_pname Annotations.ia_is_worker_thread tenv
+      pname
+    |> Option.is_some
   then None
+  else if is_ui_method tenv pname then
+    Some (F.asprintf "%a is a standard UI-thread method" mono_pname pname)
   else
-    None
-    |> if_pred_evalopt
-         ~pred:(fun () -> is_ui_method tenv pname)
-         ~f:(fun () -> F.asprintf "%a is a standard UI-thread method" mono_pname pname)
-    |> if_pred_evalopt
-         ~pred:(fun () -> Annotations.pdesc_has_return_annot proc_desc is_uithread)
-         ~f:(fun () ->
-           F.asprintf "%a is annotated %s" mono_pname pname
-             (MF.monospaced_to_string Annotations.ui_thread) )
-    |> IOption.if_none_evalopt ~f:(fun () ->
-           find_method_or_override_annotated ~attrs_of_pname is_uithread pname tenv
-           |> Option.map ~f:(fun override_pname ->
-                  F.asprintf "class %a overrides %a, which is annotated %s" mono_pname pname
-                    mono_pname override_pname
-                    (MF.monospaced_to_string Annotations.ui_thread) ) )
-    |> IOption.if_none_evalopt ~f:(fun () ->
-           get_current_class_and_annotated_superclasses is_uithread tenv pname
-           |> Option.bind ~f:(function
-                | current_class, (super_class :: _ as super_classes) ->
-                    let middle =
-                      if List.exists super_classes ~f:(Typ.Name.equal current_class) then ""
-                      else
-                        F.asprintf " extends %a, which" (MF.wrap_monospaced Typ.Name.pp)
-                          super_class
-                    in
-                    Some
-                      (F.asprintf "class %s%s is annotated %s"
-                         (MF.monospaced_to_string (Typ.Name.name current_class))
-                         middle
-                         (MF.monospaced_to_string Annotations.ui_thread))
-                | _ ->
-                    None ) )
+    find_override_or_superclass_annotated ~attrs_of_pname is_uithread tenv pname
+    |> Option.map ~f:(fun trail -> F.asprintf "%a" (describe ~procname:pname) trail)
 
 
 let cpp_lock_types_matcher = Clang.lock_types_matcher

infer/src/concurrency/ConcurrencyModels.mli

@@ -34,9 +34,9 @@ val get_thread : Typ.Procname.t -> thread
 (** describe how this procedure behaves with respect to thread access *)
 
 val runs_on_ui_thread :
-     attrs_of_pname:(Typ.Procname.t -> ProcAttributes.t option)
+     attrs_of_pname:(BuiltinDecl.t -> ProcAttributes.t option)
   -> Tenv.t
-  -> Procdesc.t
+  -> Typ.Procname.t
   -> string option
 (** We don't want to warn on methods that run on the UI thread because they should always be
     single-threaded. Assume that methods annotated with @UiThread, @OnEvent, @OnBind, @OnMount,
@@ -47,13 +47,20 @@ val runs_on_ui_thread :
 val get_current_class_and_annotated_superclasses :
   (Annot.Item.t -> bool) -> Tenv.t -> Typ.Procname.t -> (Typ.name * Typ.name list) option
 
-val find_method_or_override_annotated :
-     attrs_of_pname:(Typ.Procname.t -> ProcAttributes.t option)
-  -> (Annot.Item.t -> bool)
-  -> Typ.Procname.t
-  -> Tenv.t
-  -> Typ.Procname.t sexp_option
-
 val cpp_lock_types_matcher : QualifiedCppName.Match.quals_matcher
 
 val is_recursive_lock_type : Typ.name -> bool
+
+(** Type documenting why a method is considered as annotated with a certain annotation *)
+type annotation_trail =
+  | DirectlyAnnotated  (** the method is directly annotated as such *)
+  | Override of Typ.Procname.t  (** it overrides a method annotated in a super class *)
+  | SuperClass of Typ.name  (** the method's class or a super class of that is annotated as such *)
+
+val find_override_or_superclass_annotated :
+     attrs_of_pname:(BuiltinDecl.t -> ProcAttributes.t option)
+  -> (Annot.Item.t -> bool)
+  -> Tenv.t
+  -> Typ.Procname.t
+  -> annotation_trail sexp_option
+(** check if a method's annotations satisfy the given predicate *)

infer/src/concurrency/RacerD.ml

@@ -512,11 +512,11 @@ let analyze_procedure {Callbacks.exe_env; summary} =
     let initial =
       let threads =
         if
-          runs_on_ui_thread ~attrs_of_pname:Summary.OnDisk.proc_resolve_attributes tenv proc_desc
+          runs_on_ui_thread ~attrs_of_pname:Summary.OnDisk.proc_resolve_attributes tenv proc_name
           |> Option.is_some
           || is_thread_confined_method tenv proc_desc
         then ThreadsDomain.AnyThreadButSelf
-        else if Procdesc.is_java_synchronized proc_desc || is_marked_thread_safe proc_desc tenv
+        else if Procdesc.is_java_synchronized proc_desc || is_marked_thread_safe proc_name tenv
         then ThreadsDomain.AnyThread
         else ThreadsDomain.NoThread
       in
@@ -1054,8 +1054,7 @@ let report_unsafe_accesses ~issue_log classname (aggregated_access_map : ReportM
     match snapshot.access.elem with
     | Access.InterfaceCall reported_pname
       when AccessSnapshot.is_unprotected snapshot
-           && ThreadsDomain.is_any threads
-           && is_marked_thread_safe procdesc tenv ->
+           && ThreadsDomain.is_any threads && is_marked_thread_safe pname tenv ->
         (* un-annotated interface call + no lock in method marked thread-safe. warn *)
         report_unannotated_interface_violation ~acc reported_pname reported_access
     | Access.InterfaceCall _ ->

infer/src/concurrency/RacerDModels.ml

@@ -9,6 +9,8 @@ open! IStd
 module L = Logging
 open ConcurrencyModels
 
+let attrs_of_pname = Summary.OnDisk.proc_resolve_attributes
+
 module AnnotationAliases = struct
   let of_json = function
     | `List aliases ->
@@ -154,10 +156,7 @@ let should_skip =
       false
 
 
-let has_return_annot predicate pn =
-  Annotations.pname_has_return_annot pn ~attrs_of_pname:Summary.OnDisk.proc_resolve_attributes
-    predicate
-
+let has_return_annot predicate pn = Annotations.pname_has_return_annot pn ~attrs_of_pname predicate
 
 let is_functional pname =
   let is_annotated_functional = has_return_annot Annotations.ia_is_functional in
@@ -263,10 +262,11 @@ let is_box = function
 
 
 (* Methods in @ThreadConfined classes and methods annotated with @ThreadConfined are assumed to all
-                 run on the same thread. For the moment we won't warn on accesses resulting from use of such
-                 methods at all. In future we should account for races between these methods and methods from
-                 completely different classes that don't necessarily run on the same thread as the confined
-                 object. *)
+  run on the same thread. For the moment we won't warn on accesses resulting from use of such
+  methods at all. In future we should account for races between these methods and methods from
+  completely different classes that don't necessarily run on the same thread as the confined
+  object. *)
+(* FIXME use ConcurrencyModels.find_override_or_superclass_annotated *)
 let is_thread_confined_method tenv pdesc =
   Annotations.pdesc_return_annot_ends_with pdesc Annotations.thread_confined
   || PatternMatch.check_current_class_attributes Annotations.ia_is_thread_confined tenv
@@ -310,6 +310,7 @@ let is_assumed_thread_safe item_annot =
   List.exists ~f item_annot
 
 
+(* FIXME use ConcurrencyModels.find_override_or_superclass_annotated *)
 let pdesc_is_assumed_thread_safe pdesc tenv =
   is_assumed_thread_safe (Annotations.pdesc_get_return_annot pdesc)
   || PatternMatch.check_current_class_attributes is_assumed_thread_safe tenv
@@ -339,28 +340,22 @@ let get_current_class_and_threadsafe_superclasses tenv pname =
   get_current_class_and_annotated_superclasses is_thread_safe tenv pname
 
 
-let is_thread_safe_class pname tenv =
-  (not
-     ((* current class not marked thread-safe *)
-      PatternMatch.check_current_class_attributes Annotations.ia_is_not_thread_safe tenv pname))
-  &&
-  (* current class or superclass is marked thread-safe *)
-  match get_current_class_and_threadsafe_superclasses tenv pname with
-  | Some (_, thread_safe_annotated_classes) ->
-      not (List.is_empty thread_safe_annotated_classes)
+let is_thread_safe_method pname tenv =
+  match find_override_or_superclass_annotated ~attrs_of_pname is_thread_safe tenv pname with
+  | Some (DirectlyAnnotated | Override _) ->
+      true
   | _ ->
       false
 
 
-let is_thread_safe_method pname tenv =
-  find_method_or_override_annotated ~attrs_of_pname:Summary.OnDisk.proc_resolve_attributes
-    is_thread_safe pname tenv
-  |> Option.is_some
-
-
-let is_marked_thread_safe pdesc tenv =
-  let pname = Procdesc.get_proc_name pdesc in
-  is_thread_safe_class pname tenv || is_thread_safe_method pname tenv
+let is_marked_thread_safe pname tenv =
+  ((* current class not marked [@NotThreadSafe] *)
+   (* FIXME use ConcurrencyModels.find_override_or_superclass_annotated *)
+   not
+     (PatternMatch.check_current_class_attributes Annotations.ia_is_not_thread_safe tenv pname))
+  && ConcurrencyModels.find_override_or_superclass_annotated ~attrs_of_pname is_thread_safe tenv
+       pname
+     |> Option.is_some
 
 
 let is_safe_access (access : 'a HilExp.Access.t) prefix_exp tenv =
@@ -415,6 +410,7 @@ let should_flag_interface_call tenv exps call_flags pname =
       && (not (is_builder_function java_pname))
       (* can't ask anyone to annotate interfaces in library code, and Builders should always be
       thread-safe (would be unreasonable to ask everyone to annotate them) *)
+      (* FIXME use ConcurrencyModels.find_override_or_superclass_annotated for the two cases below *)
       && (not (PatternMatch.check_class_attributes thread_safe_or_thread_confined tenv pname))
       && (not (has_return_annot thread_safe_or_thread_confined pname))
       && receiver_is_not_safe exps tenv
@@ -427,6 +423,7 @@ let is_synchronized_container callee_pname (access_exp : HilExp.AccessExpression
   let is_threadsafe_collection pn tenv =
     match pn with
     | Typ.Procname.Java java_pname ->
+        (* FIXME use get_class_type_name *)
         let typename = Typ.Name.Java.from_string (Typ.Procname.Java.get_class_name java_pname) in
         let aux tn _ =
           match Typ.Name.name tn with

infer/src/concurrency/RacerDModels.mli

@@ -42,7 +42,7 @@ val is_thread_safe_method : Typ.Procname.t -> Tenv.t -> bool
     is @ThreadSafe, @ThreadSafe(enableChecks = true), or is defined
     as an alias of @ThreadSafe in a .inferconfig file. *)
 
-val is_marked_thread_safe : Procdesc.t -> Tenv.t -> bool
+val is_marked_thread_safe : Typ.Procname.t -> Tenv.t -> bool
 
 val is_safe_access : 'a HilExp.Access.t -> HilExp.AccessExpression.t -> Tenv.t -> bool
 (** check if an access to a field is thread-confined, or whether the field is volatile *)

infer/src/concurrency/starvation.ml

@@ -162,7 +162,7 @@ let analyze_procedure {Callbacks.exe_env; summary} =
     in
     let initial =
       ConcurrencyModels.runs_on_ui_thread ~attrs_of_pname:Summary.OnDisk.proc_resolve_attributes
-        tenv proc_desc
+        tenv procname
       |> Option.value_map ~default:initial ~f:(StarvationDomain.set_on_ui_thread initial ~loc)
     in
     let filter_blocks =