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_frama_c_base_aligned name then
try begin
match actuals with
[_,x; _,y] ->
let i = Cvalue_type.V.find_ival y in
begin match i with
Ival.Set si ->
Location_Bytes.fold_i
(fun b _o () ->
Ival.O.iter
(fun int ->
if not (Base.is_aligned_by b int)
then raise Found_misaligned_base)
si)
x
();
(wrap_int Cvalue_type.V.singleton_one),
initial_state,
Location_Bits.Top_Param.bottom
| _ -> raise Found_misaligned_base
end
| _ -> raise Invalid_CEA_alloc
end
with Invalid_CEA_alloc ->
Cilmsg.error "Invalid arguments for Frama_C_is_base_aligned function" ;
do_degenerate None;
raise Db.Value.Aborted
| Found_misaligned_base
| Not_found ->
(wrap_int Cvalue_type.V.zero_or_one), initial_state, Location_Bits.Top_Param.bottom
else if Ast_info.is_cea_offset name then
try begin
match actuals with
[_,x] ->
begin
let value =
try
let offsets =
Location_Bytes.fold_i
(fun _b o a -> Ival.join a o)
x
Ival.bottom
in
Cvalue_type.V.inject_ival offsets
with Location_Bytes.Error_Top ->
error
"The builtin %a is applied to a value that is not guaranteed to be an address."
Kernel_function.pretty_name kf;
Cvalue_type.V.top_int
in
(wrap_int value), initial_state, Location_Bits.Top_Param.bottom
end
| _ -> raise Invalid_CEA_alloc
end
with Invalid_CEA_alloc ->
Cilmsg.error "Invalid arguments for Frama_C_offset function" ;
do_degenerate None;
raise Db.Value.Aborted
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 String.length file >= 7 && String.sub file 0 6 = "alloc_"
then file
else Format.sprintf "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 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 "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_sqrt"
then begin
match actuals with
[_, arg] -> begin
let r =
try
let i = Cvalue_type.V.find_ival arg in
let f = Ival.project_float i in
Cvalue_type.V.inject_ival
(Ival.inject_float (Ival.Float_abstract.sqrt_float f))
with Cvalue_type.V.Not_based_on_null ->
Value_parameters.result ~once:true ~current:true "float sqrt applied to address";
Cvalue_type.V.topify_arith_origin arg
in
(wrap_double r), initial_state, Location_Bits.Top_Param.bottom
end
| _ -> Value_parameters.error
"Invalid argument for Frama_C_sqrt function";
do_degenerate None;
raise Db.Value.Aborted
end
else if name = "Frama_C_cos"
then begin
match actuals with
[_, arg] -> begin
let r =
try
let i = Cvalue_type.V.find_ival arg in
let f = Ival.project_float i in
Cvalue_type.V.inject_ival
(Ival.inject_float (Ival.Float_abstract.cos_float f))
with Cvalue_type.V.Not_based_on_null ->
Value_parameters.result ~once:true ~current:true "float cos applied to address";
Cvalue_type.V.topify_arith_origin arg
in
(wrap_double r), initial_state, Location_Bits.Top_Param.bottom
end
| _ -> Value_parameters.error "Invalid argument for Frama_C_cos function";
do_degenerate None;
raise Db.Value.Aborted
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 _ ->
let r = compute_using_prototype kf ~state_with_formals:with_formals in
r
in
Value_parameters.feedback "Done for function %a"
Kernel_function.pretty_name kf;
result
end
in
result