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 if Ast_info.is_cea_alloc name
then begin
try
let file = match actuals with
| [_,file] -> file
| _ -> raise Invalid_CEA_alloc
in
let file_base,_file_offset =
try
Cvalue_type.V.find_lonely_key file
with Not_found -> raise Not_found_lonely_key
in
let file = match file_base with
| Base.String (_,s) -> s
| Base.Var (s,_) | Base.Initialized_Var (s,_) -> s.vname
| Base.Null | Base.Cell_class _ -> raise Invalid_CEA_alloc
in
let loc =
Dynamic_Alloc_Table.memo
(fun file ->
let new_name =
if Extlib.string_prefix ~strict:true "Frama_C_alloc_" file
then file
else Format.sprintf "Frama_C_alloc_%s" file
in
let new_name = Cabs2cil.fresh_global new_name in
let unbounded_type =
TArray(intType,Some (new_exp (Const (CStr "NOSIZE"))),empty_size_cache (),[])
in
let new_varinfo =
makeGlobalVar ~logic:true new_name unbounded_type
in
let new_offsetmap =
Cvalue_type.V_Offsetmap.sized_zero (memory_size ())
in
let new_base =
Cvalue_type.Default_offsetmap.create_initialized_var
new_varinfo
Base.All
new_offsetmap
in
Location_Bytes.inject new_base Ival.zero)
file
in
wrap_ptr loc, initial_state, Location_Bits.Top_Param.bottom
with
| Ival.Error_Top | Invalid_CEA_alloc
| Not_found_lonely_key
-> Value_parameters.error
"Invalid argument for Frama_C_alloc_infinite function";
do_degenerate None;
raise Db.Value.Aborted
| Not_found -> assert false
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.find_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 (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
(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_utils.pp_flowlist (fun fmt (_,x) -> V.pretty fmt x))
actuals;
None,initial_state, Location_Bits.Top_Param.bottom
end
else if name = "Frama_C_memcpy"
then begin
match actuals with
| [exp_dst,dst; _,src ; _,size] ->
begin try
let exp_lv = mkMem ~addr:exp_dst ~off:NoOffset in
let size =
Int.mul
(Int.of_int 8)
(let size = Cvalue_type.V.find_ival size in
Ival.project_int size)
in
let right = loc_bytes_to_loc_bits src in
None,
copy_paste_locations
~with_alarms:(warn_all_quiet_mode ())
~exp_lv
~left:(loc_bytes_to_loc_bits dst)
~right
size
initial_state,
Location_Bits.get_bases right
with
Ival.Not_Singleton_Int | V.Not_based_on_null | Lmap.Cannot_copy ->
Value_parameters.error
"Invalid call to Frama_C_memcpy function(%a, %a, %a)"
Cvalue_type.V.pretty dst
Cvalue_type.V.pretty src
Cvalue_type.V.pretty size;
do_degenerate None;
raise Db.Value.Aborted
end
| _ -> Value_parameters.error
"Invalid argument for Frama_C_memcpy function\n";
do_degenerate None;
raise Db.Value.Aborted
end
else begin
Value_parameters.feedback "computing for function %a <-%a.@\nCalled from %a."
Kernel_function.pretty_name kf
pretty_call_stack !call_stack
pretty_loc_simply
(CilE.current_stmt());
Kf_state.mark_as_called kf;
let modular =
Value_parameters.MemExecAll.get ()
|| Cilutil.StringSet.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"
(BaseUtils.BaseMap.pretty Location_Bytes.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, is_retres =
match retres_vi with
None -> None, (fun _ -> false)
| 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),
(fun b -> Base.equal b retres_base)
in
let result_state =
Relations_type.Model.filter_base
(fun base ->
(not (Base.is_formal_of_prototype base varinfo))
&& not (is_retres base) )
result_state
in
result, result_state, thing
in
Value_parameters.feedback "Done for function %a"
Kernel_function.pretty_name kf;
result
end
in
result