@ -15,25 +15,24 @@ module F = Format
(* * data type for the control flow graph *)
type t = Procdesc . t Typ . Procname . Hash . t
(* * create a new empty cfg *)
let create_cfg () = Typ . Procname . Hash . create 16
let create () = Typ . Procname . Hash . create 16
let add_proc_desc cfg pname pdesc = Typ . Procname . Hash . add cfg pname pdesc
let remove_proc_desc cfg pname = Typ . Procname . Hash . remove cfg pname
let iter_proc_desc cfg f = Typ . Procname . Hash . iter f cfg
let get_all_proc_descs cfg =
let procs = ref [] in
let f _ pdesc = procs := pdesc :: ! procs in
Typ . Procname . Hash . iter f cfg ; ! procs
let fold_proc_desc cfg f init = Typ . Procname . Hash . fold f cfg init
let find_proc_desc_from_name cfg pname =
try Some ( Typ . Procname . Hash . find cfg pname ) with Not_found -> None
let get_all_proc_names cfg =
let procs = ref [] in
let f pname _ = procs := pname :: ! procs in
Typ . Procname . Hash . iter f cfg ; ! procs
(* * Create a new procdesc *)
let create_proc_desc cfg ( proc_attributes : ProcAttributes . t ) =
let pdesc = Procdesc . from_proc_attributes ~ called_from_cfg : true proc_attributes in
add_proc_desc cfg proc_attributes . proc_name pdesc ;
let pdesc = Procdesc . from_proc_attributes proc_attributes in
Typ . Procname . Hash . add cfg proc_attributes . proc_name pdesc ;
pdesc
@ -42,7 +41,7 @@ let iter_all_nodes ?(sorted= false) f cfg =
let do_proc_desc _ ( pdesc : Procdesc . t ) =
List . iter ~ f : ( fun node -> f pdesc node ) ( Procdesc . get_nodes pdesc )
in
if not sorted then iter_proc_desc cfg do_proc_desc
if not sorted then Typ . Procname . Hash . iter do_proc_desc cfg
else
Typ . Procname . Hash . fold
( fun _ pdesc desc_nodes ->
@ -54,13 +53,6 @@ let iter_all_nodes ?(sorted= false) f cfg =
| > List . iter ~ f : ( fun ( d , n ) -> f d n )
(* * Get all the procdescs ( defined and declared ) *)
let get_all_procs cfg =
let procs = ref [] in
let f _ pdesc = procs := pdesc :: ! procs in
iter_proc_desc cfg f ; ! procs
(* * checks whether a cfg is connected or not *)
let check_cfg_connectedness cfg =
let is_exit_node n =
@ -88,7 +80,7 @@ let check_cfg_connectedness cfg =
if not Config . keep_going && Typ . Procname . is_java pname && List . exists ~ f : broken_node nodes then
L . ( die InternalError ) " Broken CFG on %a " Typ . Procname . pp pname
in
iter_proc_desc cfg do_pdesc
Typ . Procname . Hash . iter do_pdesc cfg
let load_statement =
@ -118,7 +110,7 @@ let save_attributes source_file cfg =
in
Attributes . store attributes'
in
iter_proc_desc cfg save_proc
Typ . Procname . Hash . iter save_proc cfg
(* * Inline a synthetic ( access or bridge ) method. *)
@ -180,15 +172,15 @@ let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option =
let proc_inline_synthetic_methods cfg pdesc : unit =
let instr_inline_synthetic_method = function
| Sil . Call ( ret_id , Exp . Const Const . Cfun pn , etl , loc , _ ) -> (
match find_proc_desc_from_name cfg pn with
| Some pd ->
match Typ . Procname . Hash . find cfg pn with
| pd ->
let is_access = Typ . Procname . java_is_access_method pn in
let attributes = Procdesc . get_attributes pd in
let is_synthetic = attributes . is_synthetic_method in
let is_bridge = attributes . is_bridge_method in
if is_access | | is_bridge | | is_synthetic then inline_synthetic_method ret_id etl pd loc
else None
| None ->
| exception Not_found ->
None )
| _ ->
None
@ -213,7 +205,7 @@ let proc_inline_synthetic_methods cfg pdesc : unit =
(* * Inline the java synthetic methods in the cfg *)
let inline_java_synthetic_methods cfg =
let f pname pdesc = if Typ . Procname . is_java pname then proc_inline_synthetic_methods cfg pdesc in
iter_proc_desc cfg f
Typ . Procname . Hash . iter f cfg
(* * compute the list of procedures added or changed in [cfg_new] over [cfg_old] *)
@ -298,340 +290,7 @@ let store source_file cfg =
SqliteUtils . sqlite_unit_step ~ finalize : false ~ log : " Cfg.store " db store_stmt )
(* * Applies convert_instr_list to all the instructions in all the nodes of the cfg *)
let convert_cfg ~ callee_pdesc ~ resolved_pdesc convert_instr_list =
let resolved_pname = Procdesc . get_proc_name resolved_pdesc
and callee_start_node = Procdesc . get_start_node callee_pdesc
and callee_exit_node = Procdesc . get_exit_node callee_pdesc in
let convert_node_kind = function
| Procdesc . Node . Start_node _ ->
Procdesc . Node . Start_node resolved_pname
| Procdesc . Node . Exit_node _ ->
Procdesc . Node . Exit_node resolved_pname
| node_kind ->
node_kind
in
let node_map = ref Procdesc . NodeMap . empty in
let rec convert_node node =
let loc = Procdesc . Node . get_loc node
and kind = convert_node_kind ( Procdesc . Node . get_kind node )
and instrs = convert_instr_list ( Procdesc . Node . get_instrs node ) in
Procdesc . create_node resolved_pdesc loc kind instrs
and loop callee_nodes =
match callee_nodes with
| [] ->
[]
| node :: other_node ->
let converted_node =
try Procdesc . NodeMap . find node ! node_map with Not_found ->
let new_node = convert_node node
and successors = Procdesc . Node . get_succs node
and exn_nodes = Procdesc . Node . get_exn node in
node_map := Procdesc . NodeMap . add node new_node ! node_map ;
if Procdesc . Node . equal node callee_start_node then
Procdesc . set_start_node resolved_pdesc new_node ;
if Procdesc . Node . equal node callee_exit_node then
Procdesc . set_exit_node resolved_pdesc new_node ;
Procdesc . node_set_succs_exn callee_pdesc new_node ( loop successors ) ( loop exn_nodes ) ;
new_node
in
converted_node :: loop other_node
in
ignore ( loop [ callee_start_node ] ) ;
resolved_pdesc
(* * clone a procedure description and apply the type substitutions where
the parameters are used * )
let specialize_types_proc callee_pdesc resolved_pdesc substitutions =
let resolved_pname = Procdesc . get_proc_name resolved_pdesc in
let convert_pvar pvar = Pvar . mk ( Pvar . get_name pvar ) resolved_pname in
let mk_ptr_typ typename =
(* Only consider pointers from Java objects for now *)
Typ . mk ( Tptr ( Typ . mk ( Tstruct typename ) , Typ . Pk_pointer ) )
in
let convert_exp = function
| Exp . Lvar origin_pvar ->
Exp . Lvar ( convert_pvar origin_pvar )
| exp ->
exp
in
let subst_map = ref Ident . IdentMap . empty in
let redirect_typename origin_id =
try Some ( Ident . IdentMap . find origin_id ! subst_map ) with Not_found -> None
in
let convert_instr instrs = function
| Sil . Load
( id
, ( Exp . Lvar origin_pvar as origin_exp )
, { Typ . desc = Tptr ( { desc = Tstruct origin_typename } , Pk_pointer ) }
, loc ) ->
let specialized_typname =
try Mangled . Map . find ( Pvar . get_name origin_pvar ) substitutions with Not_found ->
origin_typename
in
subst_map := Ident . IdentMap . add id specialized_typname ! subst_map ;
Sil . Load ( id , convert_exp origin_exp , mk_ptr_typ specialized_typname , loc ) :: instrs
| Sil . Load ( id , ( Exp . Var origin_id as origin_exp ) , ( { Typ . desc = Tstruct _ } as origin_typ ) , loc ) ->
let updated_typ : Typ . t =
try Typ . mk ~ default : origin_typ ( Tstruct ( Ident . IdentMap . find origin_id ! subst_map ) )
with Not_found -> origin_typ
in
Sil . Load ( id , convert_exp origin_exp , updated_typ , loc ) :: instrs
| Sil . Load ( id , origin_exp , origin_typ , loc ) ->
Sil . Load ( id , convert_exp origin_exp , origin_typ , loc ) :: instrs
| Sil . Store ( assignee_exp , origin_typ , origin_exp , loc ) ->
let set_instr =
Sil . Store ( convert_exp assignee_exp , origin_typ , convert_exp origin_exp , loc )
in
set_instr :: instrs
| Sil . Call
( return_ids
, Exp . Const Const . Cfun Typ . Procname . Java callee_pname_java
, ( Exp . Var id , _ ) :: origin_args
, loc
, call_flags )
when call_flags . CallFlags . cf_virtual && redirect_typename id < > None ->
let redirected_typename = Option . value_exn ( redirect_typename id ) in
let redirected_typ = mk_ptr_typ redirected_typename in
let redirected_pname =
Typ . Procname . replace_class ( Typ . Procname . Java callee_pname_java ) redirected_typename
in
let args =
let other_args = List . map ~ f : ( fun ( exp , typ ) -> ( convert_exp exp , typ ) ) origin_args in
( Exp . Var id , redirected_typ ) :: other_args
in
let call_instr =
Sil . Call ( return_ids , Exp . Const ( Const . Cfun redirected_pname ) , args , loc , call_flags )
in
call_instr :: instrs
| Sil . Call ( return_ids , origin_call_exp , origin_args , loc , call_flags ) ->
let converted_args = List . map ~ f : ( fun ( exp , typ ) -> ( convert_exp exp , typ ) ) origin_args in
let call_instr =
Sil . Call ( return_ids , convert_exp origin_call_exp , converted_args , loc , call_flags )
in
call_instr :: instrs
| Sil . Prune ( origin_exp , loc , is_true_branch , if_kind ) ->
Sil . Prune ( convert_exp origin_exp , loc , is_true_branch , if_kind ) :: instrs
| Sil . Declare_locals ( typed_vars , loc ) ->
let new_typed_vars =
List . map ~ f : ( fun ( pvar , typ ) -> ( convert_pvar pvar , typ ) ) typed_vars
in
Sil . Declare_locals ( new_typed_vars , loc ) :: instrs
| Sil . Nullify _ | Abstract _ | Sil . Remove_temps _ ->
(* these are generated instructions that will be replaced by the preanalysis *)
instrs
in
let convert_instr_list instrs = List . fold ~ f : convert_instr ~ init : [] instrs | > List . rev in
convert_cfg ~ callee_pdesc ~ resolved_pdesc convert_instr_list
(* * Creates a copy of a procedure description and a list of type substitutions of the form
( name , typ ) where name is a parameter . The resulting proc desc is isomorphic but
all the type of the parameters are replaced in the instructions according to the list .
The virtual calls are also replaced to match the parameter types * )
let specialize_types callee_pdesc resolved_pname args =
let callee_attributes = Procdesc . get_attributes callee_pdesc in
let resolved_params , substitutions =
List . fold2_exn
~ f : ( fun ( params , subts ) ( param_name , param_typ ) ( _ , arg_typ ) ->
match arg_typ . Typ . desc with
| Tptr ( { desc = Tstruct typename } , Pk_pointer ) ->
(* Replace the type of the parameter by the type of the argument *)
( ( param_name , arg_typ ) :: params , Mangled . Map . add param_name typename subts )
| _ ->
( ( param_name , param_typ ) :: params , subts ) )
~ init : ( [] , Mangled . Map . empty ) callee_attributes . formals args
in
let resolved_attributes =
{ callee_attributes with
formals = List . rev resolved_params
; proc_name = resolved_pname
; is_specialized = true
; err_log = Errlog . empty () }
in
Attributes . store resolved_attributes ;
let resolved_pdesc =
let tmp_cfg = create_cfg () in
create_proc_desc tmp_cfg resolved_attributes
in
specialize_types_proc callee_pdesc resolved_pdesc substitutions
let specialize_with_block_args_instrs resolved_pdesc substitutions =
let resolved_pname = Procdesc . get_proc_name resolved_pdesc in
let convert_pvar pvar = Pvar . mk ( Pvar . get_name pvar ) resolved_pname in
let convert_exp exp =
match exp with
| Exp . Lvar origin_pvar ->
let new_pvar = convert_pvar origin_pvar in
Exp . Lvar new_pvar
| _ ->
exp
in
let convert_instr ( instrs , id_map ) instr =
let convert_generic_call return_ids exp origin_args loc call_flags =
let converted_args = List . map ~ f : ( fun ( exp , typ ) -> ( convert_exp exp , typ ) ) origin_args in
let call_instr = Sil . Call ( return_ids , exp , converted_args , loc , call_flags ) in
( call_instr :: instrs , id_map )
in
match instr with
| Sil . Load ( id , Exp . Lvar block_param , _ , _ )
when Mangled . Map . mem ( Pvar . get_name block_param ) substitutions ->
let id_map = Ident . IdentMap . add id ( Pvar . get_name block_param ) id_map in
(* we don't need the load the block param instruction anymore *)
( instrs , id_map )
| Sil . Load ( id , origin_exp , origin_typ , loc ) ->
( Sil . Load ( id , convert_exp origin_exp , origin_typ , loc ) :: instrs , id_map )
| Sil . Store ( assignee_exp , origin_typ , origin_exp , loc ) ->
let set_instr =
Sil . Store ( convert_exp assignee_exp , origin_typ , convert_exp origin_exp , loc )
in
( set_instr :: instrs , id_map )
| Sil . Call ( return_ids , Exp . Var id , origin_args , loc , call_flags ) -> (
try
let block_name , extra_formals =
let block_var = Ident . IdentMap . find id id_map in
Mangled . Map . find block_var substitutions
in
(* once we find the block in the map, it means that we need to subsitute it with the
call to the concrete block , and pass the fresh formals as arguments * )
let ids_typs , load_instrs =
let captured_ids_instrs =
List . map extra_formals ~ f : ( fun ( var , typ ) ->
let id = Ident . create_fresh Ident . knormal in
let pvar = Pvar . mk var resolved_pname in
( ( id , typ ) , Sil . Load ( id , Exp . Lvar pvar , typ , loc ) ) )
in
List . unzip captured_ids_instrs
in
let call_instr =
let id_exps = List . map ~ f : ( fun ( id , typ ) -> ( Exp . Var id , typ ) ) ids_typs in
let converted_args =
List . map ~ f : ( fun ( exp , typ ) -> ( convert_exp exp , typ ) ) origin_args
in
Sil . Call
( return_ids
, Exp . Const ( Const . Cfun block_name )
, id_exps @ converted_args
, loc
, call_flags )
in
let remove_temps_instrs =
let ids = List . map ~ f : ( fun ( id , _ ) -> id ) ids_typs in
Sil . Remove_temps ( ids , loc )
in
let instrs = remove_temps_instrs :: call_instr :: load_instrs @ instrs in
( instrs , id_map )
with Not_found -> convert_generic_call return_ids ( Exp . Var id ) origin_args loc call_flags )
| Sil . Call ( return_ids , origin_call_exp , origin_args , loc , call_flags ) ->
convert_generic_call return_ids origin_call_exp origin_args loc call_flags
| Sil . Prune ( origin_exp , loc , is_true_branch , if_kind ) ->
( Sil . Prune ( convert_exp origin_exp , loc , is_true_branch , if_kind ) :: instrs , id_map )
| Sil . Declare_locals ( typed_vars , loc ) ->
let new_typed_vars =
List . map ~ f : ( fun ( pvar , typ ) -> ( convert_pvar pvar , typ ) ) typed_vars
in
( Sil . Declare_locals ( new_typed_vars , loc ) :: instrs , id_map )
| Sil . Nullify _ | Abstract _ | Sil . Remove_temps _ ->
(* these are generated instructions that will be replaced by the preanalysis *)
( instrs , id_map )
in
let convert_instr_list instrs =
let instrs , _ = List . fold ~ f : convert_instr ~ init : ( [] , Ident . IdentMap . empty ) instrs in
List . rev instrs
in
convert_instr_list
let specialize_with_block_args callee_pdesc pname_with_block_args block_args =
let callee_attributes = Procdesc . get_attributes callee_pdesc in
(* Substitution from a block parameter to the block name and the new formals
that correspond to the captured variables * )
let substitutions : ( Typ . Procname . t * ( Mangled . t * Typ . t ) list ) Mangled . Map . t =
List . fold2_exn callee_attributes . formals block_args ~ init : Mangled . Map . empty ~ f :
( fun subts ( param_name , _ ) block_arg_opt ->
match block_arg_opt with
| Some ( cl : Exp . closure ) ->
let formals_from_captured =
List . map
~ f : ( fun ( _ , var , typ ) ->
(* Here we create fresh names for the new formals, based on the names of the captured
variables annotated with the name of the caller method * )
( Pvar . get_name_of_local_with_procname var , typ ) )
cl . captured_vars
in
Mangled . Map . add param_name ( cl . name , formals_from_captured ) subts
| None ->
subts )
in
(* Extend formals with fresh variables for the captured variables of the block arguments,
without duplications . * )
let new_formals_blocks_captured_vars , extended_formals_annots =
let new_formals_blocks_captured_vars_with_annots =
let formals_annots =
List . zip_exn callee_attributes . formals ( snd callee_attributes . method_annotation )
in
let append_no_duplicates_formals_and_annot list1 list2 =
IList . append_no_duplicates
( fun ( ( name1 , _ ) , _ ) ( ( name2 , _ ) , _ ) -> Mangled . equal name1 name2 )
list1 list2
in
List . fold formals_annots ~ init : [] ~ f : ( fun acc ( ( param_name , typ ) , annot ) ->
try
let _ , captured = Mangled . Map . find param_name substitutions in
append_no_duplicates_formals_and_annot acc
( List . map captured ~ f : ( fun captured_var -> ( captured_var , Annot . Item . empty ) ) )
with Not_found -> append_no_duplicates_formals_and_annot acc [ ( ( param_name , typ ) , annot ) ]
)
in
List . unzip new_formals_blocks_captured_vars_with_annots
in
let source_file_captured =
let pname = Procdesc . get_proc_name callee_pdesc in
match Attributes . find_file_capturing_procedure pname with
| Some ( source_file , _ ) ->
source_file
| None ->
Logging . die InternalError
" specialize_with_block_args ahould only be called with defined procedures, but we cannot find the captured file of procname %a "
Typ . Procname . pp pname
in
let resolved_attributes =
{ callee_attributes with
proc_name = pname_with_block_args
; is_defined = true
; err_log = Errlog . empty ()
; formals = new_formals_blocks_captured_vars
; method_annotation = ( fst callee_attributes . method_annotation , extended_formals_annots )
; source_file_captured }
in
Attributes . store resolved_attributes ;
let resolved_pdesc =
let tmp_cfg = create_cfg () in
create_proc_desc tmp_cfg resolved_attributes
in
Logging . ( debug Analysis Verbose )
" signature of base method %a@. " Procdesc . pp_signature callee_pdesc ;
Logging . ( debug Analysis Verbose )
" signature of specialized method %a@. " Procdesc . pp_signature resolved_pdesc ;
convert_cfg ~ callee_pdesc ~ resolved_pdesc
( specialize_with_block_args_instrs resolved_pdesc substitutions )
let pp_proc_signatures fmt cfg =
F . fprintf fmt " METHOD SIGNATURES@ \n @. " ;
let sorted_procs = List . sort ~ cmp : Procdesc . compare ( get_all_proc s cfg ) in
let sorted_procs = List . sort ~ cmp : Procdesc . compare ( get_all_proc_descs cfg ) in
List . iter ~ f : ( fun pdesc -> F . fprintf fmt " %a@. " Procdesc . pp_signature pdesc ) sorted_procs
let exists_for_source_file source =
(* simplistic implementation that allocates the cfg as this is only used for reactive capture for now *)
load source | > Option . is_some
let get_captured_source_files () =
let db = ResultsDatabase . get_database () in
Sqlite3 . prepare db " SELECT source_file FROM source_files "
| > SqliteUtils . sqlite_result_rev_list_step db ~ log : " getting all source files "
| > List . filter_map ~ f : ( Option . map ~ f : SourceFile . SQLite . deserialize )