let rec get_wp_edge ((_kf, cfg, strategy, res, wenv) as env) e =
!Db.progress ();
let v = Cil2cfg.edge_dst e in
debug "[get_wp_edge] get wp before %a@." Cil2cfg.pp_node v;
try
let res = R.find res e in
debug "[get_wp_edge] %a already computed@." Cil2cfg.pp_node v;
res
with Not_found ->
let cutp =
if R.is_pass1 res
then WpStrategy.get_cut (WpStrategy.get_annots strategy e)
else []
in
match cutp with
| [] ->
let wp = compute_wp_edge env e in
R.set strategy wenv res e wp
| cutp ->
debug "[get_wp_edge] cut at node %a@." Cil2cfg.pp_node v;
let add_cut_goal (g,p) acc =
if g then add_goal wenv acc p else acc
in
let edge_annot = List.fold_right add_cut_goal cutp W.empty in
let edge_annot = R.set strategy wenv res e edge_annot in
let wp = compute_wp_edge env e in
let add_cut_hyp (_,p) acc = add_hyp wenv acc p in
let oblig = List.fold_right add_cut_hyp cutp wp in
let oblig = W.tag "InLoop" oblig in
if test_edge_loop_ok cfg None e
then R.add_memo res e oblig
else R.add_oblig res Clabels.Pre (W.close wenv oblig);
edge_annot
and get_only_succ env cfg v = match Cil2cfg.succ_e cfg v with
| [e'] -> get_wp_edge env e'
| ls -> Wp_parameters.fatal "CFG node %a has %d successors instead of 1@."
Cil2cfg.pp_node v (List.length ls)
and compute_wp_edge ((kf, cfg, _annots, res, wenv) as env) e =
let v = Cil2cfg.edge_dst e in
debug "[compute_edge] before %a go...@." Cil2cfg.pp_node v;
let old_loc = Cil.CurrentLoc.get () in
let () = match Cil2cfg.node_stmt_opt v with
| Some s -> Cil.CurrentLoc.set (Stmt.loc s)
| None -> ()
in
let formals = Kernel_function.get_formals kf in
let res = match Cil2cfg.node_type v with
| Cil2cfg.Vstart ->
Wp_parameters.fatal "No CFG edge can lead to Vstart"
| Cil2cfg.VfctIn ->
let obj = get_only_succ env cfg v in
let obj = wp_scope wenv formals Mcfg.SC_Function_in obj in
let obj = wp_scope wenv [] Mcfg.SC_Global obj in
obj
| Cil2cfg.VblkIn (Cil2cfg.Bfct, b) ->
let obj = get_only_succ env cfg v in
let obj = wp_scope wenv b.blocals Mcfg.SC_Block_in obj in
wp_scope wenv formals Mcfg.SC_Function_frame obj
| Cil2cfg.VblkIn (_, b) ->
let obj = get_only_succ env cfg v in
wp_scope wenv b.blocals Mcfg.SC_Block_in obj
| Cil2cfg.VblkOut (_, _b) ->
let obj = get_only_succ env cfg v in
obj
| Cil2cfg.Vstmt s ->
let obj = get_only_succ env cfg v in
wp_stmt wenv s obj
| Cil2cfg.Vcall (stmt, res, fct, args) ->
let en, ee = Cil2cfg.get_call_out_edges cfg v in
let objn = get_wp_edge env en in
let obje = get_wp_edge env ee in
wp_call env v stmt res fct args objn obje
| Cil2cfg.Vtest (true, _, c) ->
let et, ef = Cil2cfg.get_test_edges cfg v in
let t_obj = get_wp_edge env et in
let f_obj = get_wp_edge env ef in
W.test wenv c t_obj f_obj
| Cil2cfg.Vtest (false, _, _) ->
get_only_succ env cfg v
| Cil2cfg.Vswitch (_, e) ->
let cases, def_edge = Cil2cfg.get_switch_edges cfg v in
let cases_obj = List.map (fun (c,e) -> c, get_wp_edge env e) cases in
let def_obj = get_wp_edge env def_edge in
W.switch wenv e cases_obj def_obj
| Cil2cfg.Vloop _ | Cil2cfg.Vloop2 _ ->
let get_loop_head = fun n -> get_only_succ env cfg n in
wp_loop env res v e get_loop_head
| Cil2cfg.VfctOut
| Cil2cfg.Vexit ->
let obj = get_only_succ env cfg v in
wp_scope wenv formals Mcfg.SC_Function_out obj
| Cil2cfg.Vend ->
W.empty
in
let res =
let blks = Cil2cfg.blocks_closed_by_edge cfg e in
let free_locals res b = wp_scope wenv b.blocals Mcfg.SC_Block_out res in
List.fold_left free_locals res blks
in
debug "[compute_edge] before %a done@." Cil2cfg.pp_node v;
Cil.CurrentLoc.set old_loc;
res