@ -9,11 +9,20 @@
module L = Logging
module L = Logging
let performance_critical_implies_no_allocation = true
(* Warning name when a performance critical method directly or indirectly
(* Warning name when a performance critical method directly or indirectly
calls a method annotatd as expensive * )
calls a method annotatd as expensive * )
let calls_expensive_method =
let calls_expensive_method =
" CHECKERS_CALLS_EXPENSIVE_METHOD "
" CHECKERS_CALLS_EXPENSIVE_METHOD "
(* Warning name when a performance critical method directly or indirectly
calls a method allocating memory * )
let allocates_memory =
" CHECKERS_ALLOCATES_MEMORY "
(* Warning name for the subtyping rule: method not annotated as expensive cannot be overridden
(* Warning name for the subtyping rule: method not annotated as expensive cannot be overridden
by a method annotated as expensive * )
by a method annotated as expensive * )
let expensive_overrides_unexpensive =
let expensive_overrides_unexpensive =
@ -45,17 +54,31 @@ let method_is_performance_critical pname =
check_method Annotations . ia_is_performance_critical pname
check_method Annotations . ia_is_performance_critical pname
let method_overrides_performance_critical tenv pname =
let method_is_no_allcation pname =
( performance_critical_implies_no_allocation
&& method_is_performance_critical pname )
| | check_method Annotations . ia_is_no_allocation pname
let method_overrides is_annotated tenv pname =
let overrides () =
let overrides () =
let found = ref false in
let found = ref false in
PatternMatch . proc_iter_overridden_methods
PatternMatch . proc_iter_overridden_methods
( fun pn -> found := method_is_performance_critical pn )
( fun pn -> found := is_annotated pn )
tenv pname ;
tenv pname ;
! found in
! found in
method_is_performance_critical pname
is_annotated pname
| | overrides ()
| | overrides ()
let method_overrides_performance_critical tenv pname =
method_overrides method_is_performance_critical tenv pname
let method_overrides_no_allocation tenv pname =
method_overrides method_is_no_allcation tenv pname
let is_modeled_expensive tenv pname =
let is_modeled_expensive tenv pname =
if SymExec . function_is_builtin pname then false
if SymExec . function_is_builtin pname then false
else if Procname . java_get_method pname < > " findViewById " then false
else if Procname . java_get_method pname < > " findViewById " then false
@ -78,20 +101,42 @@ let method_is_expensive tenv pname =
| | check_method Annotations . ia_is_expensive pname
| | check_method Annotations . ia_is_expensive pname
let lookup_ expensive_ calls pname =
let lookup_ call_ summary pname =
match Specs . get_summary pname with
match Specs . get_summary pname with
| None -> None
| Some summary -> summary . Specs . payload . Specs . calls
let lookup_expensive_calls pname =
match lookup_call_summary pname with
| None -> []
| None -> []
| Some summary ->
| Some { Specs . expensive_calls } -> expensive_calls
begin
match summary . Specs . payload . Specs . calls with
| Some calls -> calls
let lookup_allocations pname =
| None -> []
match lookup_call_summary pname with
end
| None -> []
| Some { Specs . allocations } -> allocations
let method_calls_expensive tenv pname =
let method_calls_expensive tenv pname =
let calls_expensive () =
match lookup_call_summary pname with
| Some { Specs . expensive_calls } ->
expensive_calls < > []
| None -> false in
method_is_expensive tenv pname
method_is_expensive tenv pname
| | lookup_expensive_calls pname < > []
| | calls_expensive ()
let method_allocates pname =
let allocates () =
match lookup_call_summary pname with
| Some { Specs . allocations } ->
allocations < > []
| None -> false in
Procname . is_constructor pname
| | allocates ()
let lookup_location pname =
let lookup_location pname =
@ -100,20 +145,29 @@ let lookup_location pname =
| Some summary -> summary . Specs . attributes . ProcAttributes . loc
| Some summary -> summary . Specs . attributes . ProcAttributes . loc
let collect_ expensive_ call tenv caller_pdesc checked_pnames call_ list ( pname , _ ) =
let collect_ calls tenv caller_pdesc checked_pnames call_ summary ( pname , _ ) =
if Procname . Set . mem pname ! checked_pnames then call_ list
if Procname . Set . mem pname ! checked_pnames then call_ summary
else
else
begin
begin
Ondemand . do_analysis caller_pdesc pname ;
Ondemand . do_analysis caller_pdesc pname ;
checked_pnames := Procname . Set . add pname ! checked_pnames ;
checked_pnames := Procname . Set . add pname ! checked_pnames ;
let call_loc = lookup_location pname in
let call_loc = lookup_location pname in
if method_calls_expensive tenv pname then
let updated_expensive_calls =
( pname , call_loc ) :: call_list
if method_calls_expensive tenv pname then
else
( pname , call_loc ) :: call_summary . Specs . expensive_calls
call_list
else
call_summary . Specs . expensive_calls in
let updated_allocations =
if method_allocates pname then
( pname , call_loc ) :: call_summary . Specs . allocations
else
call_summary . Specs . allocations in
{ Specs . expensive_calls = updated_expensive_calls ;
Specs . allocations = updated_allocations }
end
end
let update_summary calls pname =
let update_summary call_summary pname =
match Specs . get_summary pname with
match Specs . get_summary pname with
| None -> ()
| None -> ()
| Some summary ->
| Some summary ->
@ -121,41 +175,65 @@ let update_summary calls pname =
{ summary with
{ summary with
Specs . payload =
Specs . payload =
{ summary . Specs . payload with
{ summary . Specs . payload with
Specs . calls = Some call s; }
Specs . calls = Some call _summary }
} in
} in
Specs . add_summary pname updated_summary
Specs . add_summary pname updated_summary
let report_expensive_calls tenv pname pdesc loc calls =
let string_of_pname =
let string_of_pname = Procname . to_simplified_string ~ withclass : true in
Procname . to_simplified_string ~ withclass : true
let update_trace trace loc =
if Location . equal loc Location . dummy then trace
let update_trace trace loc =
else
if Location . equal loc Location . dummy then trace
let trace_elem = {
else
Errlog . lt_level = 0 ;
let trace_elem = {
lt_loc = loc ;
Errlog . lt_level = 0 ;
lt_description = " " ;
lt_loc = loc ;
lt_node_tags = [] ;
lt_description = " " ;
} in
lt_node_tags = [] ;
trace_elem :: trace in
} in
let rec report_expensive_call visited_pnames ( trace , stack_str ) ( callee_pname , callee_loc ) =
trace_elem :: trace
if method_is_expensive tenv callee_pname then
let final_trace = IList . rev ( update_trace trace callee_loc ) in
let exp_pname_str = string_of_pname callee_pname in
let report_expensive_call_stack pname loc trace stack_str expensive_pname call_loc =
let description =
let final_trace = IList . rev ( update_trace trace call_loc ) in
Printf . sprintf
let exp_pname_str = string_of_pname expensive_pname in
" Method `%s` annotated with `@%s` calls `%s%s` where `%s` is annotated with `@%s` "
let description =
( Procname . to_simplified_string pname )
Printf . sprintf
Annotations . performance_critical
" Method `%s` annotated with `@%s` calls `%s%s` where `%s` is annotated with `@%s` "
stack_str
( Procname . to_simplified_string pname )
exp_pname_str
Annotations . performance_critical
exp_pname_str
stack_str
Annotations . expensive in
exp_pname_str
let exn =
exp_pname_str
Exceptions . Checkers ( calls_expensive_method , Localise . verbatim_desc description ) in
Annotations . expensive in
Reporting . log_error pname ~ loc : ( Some loc ) ~ ltr : ( Some final_trace ) exn
let exn =
Exceptions . Checkers ( calls_expensive_method , Localise . verbatim_desc description ) in
Reporting . log_error pname ~ loc : ( Some loc ) ~ ltr : ( Some final_trace ) exn
let report_allocation_stack pname loc trace stack_str constructor_pname call_loc =
let final_trace = IList . rev ( update_trace trace call_loc ) in
let constr_str = string_of_pname constructor_pname in
let description =
Printf . sprintf
" Method `%s` annotated with `@%s` allocates `%s` via `%s%s` "
( Procname . to_simplified_string pname )
Annotations . no_allocation
constr_str
stack_str
( " new " ^ constr_str ) in
let exn =
Exceptions . Checkers ( allocates_memory , Localise . verbatim_desc description ) in
Reporting . log_error pname ~ loc : ( Some loc ) ~ ltr : ( Some final_trace ) exn
let report_call_stack end_of_stack lookup_next_calls report tenv pname pdesc loc calls =
let rec loop visited_pnames ( trace , stack_str ) ( callee_pname , callee_loc ) =
if end_of_stack tenv callee_pname then
report pname loc trace stack_str callee_pname callee_loc
else
else
let next_calls = lookup_expensive_calls callee_pname in
let next_calls = lookup_ next _calls callee_pname in
let callee_pname_str = string_of_pname callee_pname in
let callee_pname_str = string_of_pname callee_pname in
let new_stack_str = stack_str ^ callee_pname_str ^ " -> " in
let new_stack_str = stack_str ^ callee_pname_str ^ " -> " in
let new_trace = update_trace trace callee_loc in
let new_trace = update_trace trace callee_loc in
@ -165,9 +243,21 @@ let report_expensive_calls tenv pname pdesc loc calls =
if Procname . Set . mem p set then ( accu , set )
if Procname . Set . mem p set then ( accu , set )
else ( ( p , loc ) :: accu , Procname . Set . add p set ) )
else ( ( p , loc ) :: accu , Procname . Set . add p set ) )
( [] , visited_pnames ) next_calls in
( [] , visited_pnames ) next_calls in
IList . iter ( report_expensive_call updated_visited ( new_trace , new_stack_str ) ) unseen_pnames in
IList . iter ( loop updated_visited ( new_trace , new_stack_str ) ) unseen_pnames in
let start_trace = update_trace [] ( Cfg . Procdesc . get_loc pdesc ) in
let start_trace = update_trace [] ( Cfg . Procdesc . get_loc pdesc ) in
IList . iter ( report_expensive_call Procname . Set . empty ( start_trace , " " ) ) calls
IList . iter ( loop Procname . Set . empty ( start_trace , " " ) ) calls
let report_expensive_calls tenv pname pdesc loc calls =
report_call_stack
method_is_expensive lookup_expensive_calls report_expensive_call_stack
tenv pname pdesc loc calls
let report_allocations tenv pname pdesc loc calls =
report_call_stack
( fun _ p -> Procname . is_constructor p ) lookup_allocations report_allocation_stack
tenv pname pdesc loc calls
let check_one_procedure tenv pname pdesc =
let check_one_procedure tenv pname pdesc =
@ -176,7 +266,9 @@ let check_one_procedure tenv pname pdesc =
let attributes = Cfg . Procdesc . get_attributes pdesc in
let attributes = Cfg . Procdesc . get_attributes pdesc in
let expensive = is_expensive attributes
let expensive = is_expensive attributes
and performance_critical =
and performance_critical =
method_overrides_performance_critical tenv pname in
method_overrides_performance_critical tenv pname
and no_allocation =
method_overrides_no_allocation tenv pname in
let check_expensive_subtyping_rules overridden_pname =
let check_expensive_subtyping_rules overridden_pname =
if not ( method_is_expensive tenv overridden_pname ) then
if not ( method_is_expensive tenv overridden_pname ) then
@ -195,15 +287,20 @@ let check_one_procedure tenv pname pdesc =
PatternMatch . proc_iter_overridden_methods
PatternMatch . proc_iter_overridden_methods
check_expensive_subtyping_rules tenv pname ;
check_expensive_subtyping_rules tenv pname ;
let expensive_ calls =
let call_ summary =
let checked_pnames = ref Procname . Set . empty in
let checked_pnames = ref Procname . Set . empty in
let empty_summary =
{ Specs . expensive_calls = [] ;
allocations = [] } in
Cfg . Procdesc . fold_calls
Cfg . Procdesc . fold_calls
( collect_expensive_call tenv pdesc checked_pnames ) [] pdesc in
( collect_ calls tenv pdesc checked_pnames ) empty_summary pdesc in
update_summary expensive_ calls pname ;
update_summary call_ summary pname ;
if performance_critical then
if performance_critical then
report_expensive_calls tenv pname pdesc loc expensive_calls
report_expensive_calls tenv pname pdesc loc call_summary . Specs . expensive_calls ;
if no_allocation then
report_allocations tenv pname pdesc loc call_summary . Specs . allocations
let callback_performance_checker { Callbacks . proc_desc ; proc_name ; get_proc_desc ; tenv } =
let callback_performance_checker { Callbacks . proc_desc ; proc_name ; get_proc_desc ; tenv } =