let get_behavior_annots cfg config =
Wp_parameters.feedback ~level:3
"build strategy for %a@." pp_strategy_info config;
let spec = Kernel_function.get_spec config.kf in
let annots = Hannots.create 7 in
let has_inv_prop = ref [] in
let add_on_edges new_acc edges =
if new_acc.p_inv <> [] then has_inv_prop := edges @ !has_inv_prop;
add_on_edges annots new_acc edges
in
let add_loop_annots v s =
let edges_before = Cil2cfg.pred_e cfg v in
let edges_after = Cil2cfg.succ_e cfg v in
let (loop_entry , loop_back , loop_core) =
get_loop_annots config edges_before s
in
let back_edges, entry_edges =
List.partition Cil2cfg.is_back_edge edges_before
in
begin
add_on_edges loop_back back_edges;
add_on_edges loop_entry entry_edges;
add_on_edges loop_core edges_after;
end
in
let add_stmt_annots ?(loop=false) v s =
let edges_before = Cil2cfg.pred_e cfg v in
let edges_after =
try let v' = Cil2cfg.node_after cfg v in Cil2cfg.pred_e cfg v'
with Not_found -> []
in
let l_post = match edges_after with [] -> None
| e::_ ->
match Cil2cfg.get_edge_next_stmt cfg e with
| None -> None
| Some s -> Some (Cil2cfg.mk_logic_label s)
in
let before_annots, (post_annots, exits_annots) =
get_stmt_annots config ~loop edges_before s l_post
in
add_on_edges before_annots edges_before;
if post_annots <> empty_acc then
begin
if edges_after = [] then
Wp_parameters.warning ~once:true
"Ignoring annotation rooted after statement with no succ"
else add_on_edges post_annots edges_after
end;
if exits_annots <> empty_acc then
begin
let edges_exits = Cil2cfg.get_exit_edges cfg v in
if edges_exits = [] then
List.iter (fun (pid,_) -> set_unreachable pid)
exits_annots.p_goal
else add_on_edges exits_annots edges_exits
end;
if loop then add_loop_annots v s
in
let add_fct_pre_annots v =
let edges = Cil2cfg.succ_e cfg v in
let pre = add_fct_pre config empty_acc spec in
let _ = add_on_edges pre edges in
let lp = add_behaviors_props config Kglobal spec empty_acc in
let _ = add_on_edges lp edges in
let _ = get_variant spec in
let _ = get_terminates spec in
()
in
let add_fct_post_annots tkind v =
let edges = Cil2cfg.succ_e cfg v in
let post = get_fct_post config tkind spec in add_on_edges post edges;
let assigns_kind = match tkind with
| Normal -> if Cil2cfg.has_exit cfg then Assigns_FctOut else Assigns_Stmt
| Exits -> Assigns_FctExit
| _ -> assert false
in
let assigns = get_fct_assigns config assigns_kind spec in
add_on_edges assigns edges
in
let get_node_annot v =
Wp_parameters.debug ~level:2 "get_node_annot for node %a" Cil2cfg.pp_node v;
match Cil2cfg.node_type v with
| Cil2cfg.Vstart | Cil2cfg.Vend -> ()
| Cil2cfg.VfctIn -> add_fct_pre_annots v
| Cil2cfg.VfctOut -> add_fct_post_annots Normal v
| Cil2cfg.Vexit -> add_fct_post_annots Exits v
| Cil2cfg.VblkIn (Cil2cfg.Bstmt s, _)
| Cil2cfg.Vstmt s | Cil2cfg.VcallIn (s,_,_,_)
| Cil2cfg.Vswitch (s,_) | Cil2cfg.Vtest (true, s, _)
-> add_stmt_annots v s
| Cil2cfg.Vloop (_, s) ->
add_stmt_annots ~loop:true v s
| Cil2cfg.VblkIn (_, _) | Cil2cfg.VblkOut (_, _) -> ()
| Cil2cfg.Vtest (false, _s, _) -> ()
| Cil2cfg.VcallOut (_s,_,_,_) -> ()
| Cil2cfg.VcallExit (_s,_,_,_) -> ()
in
Cil2cfg.iter_nodes get_node_annot cfg;
!has_inv_prop, annots