let compute_call kf ~call_kinstr
(initial_state:Relations_type.Model.t) actuals =
let initial_state = Relations_type.Model.drop_relations initial_state in
let with_formals = actualize_formals kf initial_state actuals in
Db.Value.merge_initial_state kf with_formals;
let stack_without_call = for_callbacks_stack () in
Db.Value.Call_Value_Callbacks.apply
(with_formals, ((kf, call_kinstr) :: stack_without_call));
let name = Kernel_function.get_name kf in
let result =
if Ast_info.is_cea_dump_function name then begin
let l = fst (CurrentLoc.get ()) in
Value_parameters.result
"DUMPING STATE of file %s line %d@\n%a=END OF DUMP=="
l.Lexing.pos_fname l.Lexing.pos_lnum
Relations_type.Model.pretty initial_state;
None, initial_state, Location_Bits.Top_Param.bottom
end
else
try
let abstract_function = Builtins.find_builtin name in
abstract_function initial_state actuals
with Not_found ->
if Ast_info.is_cea_alloc_with_validity name then begin
try
let size = match actuals with
| [_,size,_] -> size
| _ -> raise Invalid_CEA_alloc
in
let size =
try
let size = Cvalue_type.V.project_ival size in
Ival.project_int size
with Ival.Not_Singleton_Int | V.Not_based_on_null ->
raise Invalid_CEA_alloc
in
if Int.le size Int.zero then raise Invalid_CEA_alloc;
let new_name =
Format.sprintf "Frama_C_alloc"
in
let new_name = Cabs2cil.fresh_global new_name in
let bounded_type =
TArray(
charType,
Some (new_exp ~loc:Cil_datatype.Location.unknown
(Const (CInt64 (Int.to_int64 size,IInt ,None)))),
empty_size_cache (),
[])
in
let new_varinfo =
makeGlobalVar ~logic:true new_name bounded_type
in
let size_in_bits = Int.mul (sizeofchar()) size in
let new_offsetmap =
Cvalue_type.V_Offsetmap.sized_zero ~size_in_bits
in
let new_base =
Cvalue_type.Default_offsetmap.create_initialized_var
new_varinfo
(Base.Known (Int.zero, Int.pred size_in_bits))
new_offsetmap
in
let loc_without_size = Location_Bytes.inject new_base Ival.zero in
(Builtins.wrap_ptr loc_without_size),initial_state, Location_Bits.Top_Param.bottom
with Ival.Error_Top | Invalid_CEA_alloc
| Not_found
->
Value_parameters.error
"Invalid argument for Frama_C_alloc_size function";
do_degenerate None;
raise Db.Value.Aborted
end else if Ast_info.is_cea_function name then begin
Value_parameters.result "Called %s%a"
name
pretty_actuals
actuals;
None,initial_state, Location_Bits.Top_Param.bottom
end
else begin
let function_name = Kernel_function.get_name kf in
Value_parameters.feedback
"computing for function %a <-%a.@\nCalled from %a."
!Ast_printer.d_ident function_name
pretty_call_stack (call_stack ())
pretty_loc_simply
(CilE.current_stmt());
Kf_state.mark_as_called kf;
let modular =
Value_parameters.MemExecAll.get ()
|| Datatype.String.Set.mem name (Value_parameters.MemFunctions.get ())
in
let result =
match kf.fundec with
| Definition _ ->
begin try
if not modular then raise Not_modular;
let mem_initial_state, mem_final_state, mem_in, mem_outs =
!Db.Value.memoize kf;
try Mem_Exec.find kf with Not_found -> raise Not_modular
in
try
let instanciation =
Relations_type.Model.is_included_actual_generic
(Zone.join mem_in mem_outs)
with_formals
mem_initial_state
in
Value_parameters.result ~current:true "Instanciation succeeded: %a"
(let module M = Base.Map.Make(Location_Bytes) in
M.pretty)
instanciation;
compute_using_mem kf
initial_state
mem_final_state
mem_outs
instanciation
with Is_not_included ->
Value_parameters.result ~current:true ~once:true
"Failed to see context as an instance of the generic context: inlining call to %a."
Kernel_function.pretty_name kf;
raise Not_modular
with Not_modular ->
compute_with_initial_state kf ~call_kinstr with_formals
end
| Declaration (_,_varinfo,_,_) ->
let stateset = check_fct_preconditions kf with_formals in
let state_with_formals = State_set.join stateset in
let retres_vi, result_state, thing =
compute_using_prototype kf ~state_with_formals in
let result_state =
check_fct_postconditions ~result:retres_vi kf
(State_set.singleton state_with_formals)
(State_set.singleton result_state)
Normal
in
let result_state = State_set.join result_state in
let result, retres =
match retres_vi with
None -> None, None
| Some vi ->
let value_state =
Relations_type.Model.value_state result_state
in
let retres_base = Base.create_varinfo vi in
Some
(Cvalue_type.Model.find_base
retres_base
value_state),
(Some retres_base)
in
let formals = Kernel_function.get_formals kf in
let result_state =
List.fold_left
(fun acc vi ->
Relations_type.Model.remove_base
(Base.create_varinfo vi)
acc)
result_state
formals
in
let result_state =
match retres with
Some retres ->
Relations_type.Model.remove_base retres result_state
| None -> result_state
in
result, result_state, thing
in
Value_parameters.feedback "Done for function %a"
Kernel_function.pretty_name kf;
result
end
in
result