let mark_loops cfg =
let kf = cfg_kf cfg in
let env = Mloop.identify_loops cfg in
let mark_loop_back_edge h = match node_stmt_opt h with
| None -> false
| Some h_stmt ->
let mark_back_edge e =
let n = edge_src e in
let is_back_edge =
try
let n_stmt = node_stmt_exn n in
!Db.Dominators.is_dominator kf ~opening:h_stmt ~closing:n_stmt
with Not_found -> false
in
if is_back_edge then set_back_edge e;
debug "to loop edge %a@." pp_edge e
in iter_pred_e mark_back_edge cfg h; true
in
let mark_loop loops h =
debug "loop head in %a@." VL.pretty h;
let is_natural =
if (LoopInfo.is_irreducible env h) then
(debug "irreducible loop detected in %a@." VL.pretty h; false)
else true
in let back_edges_ok =
if is_natural then mark_loop_back_edge h else true
in
let loop = match node_type h with
| Vloop (_, h_stmt) ->
assert (back_edges_ok);
h := { !h with kind = Vloop (Some is_natural, h_stmt)};
h
| _ -> match node_stmt_opt h with
| Some h_stmt when back_edges_ok ->
insert_loop_node cfg h (Vloop (Some is_natural, h_stmt))
| None when back_edges_ok ->
let n = cfg.loop_cpt in cfg.loop_cpt <- n + 1;
insert_loop_node cfg h (Vloop2 (is_natural, n))
| _ ->
let n = cfg.loop_cpt in cfg.loop_cpt <- n + 1;
insert_loop_node cfg h (Vloop2 (false, n))
in loop::loops
in
let loops = List.fold_left mark_loop [] env.LoopInfo.loop_headers in
debug2 "unstructuredness coef = %f@." (LoopInfo.unstructuredness env);
{ cfg with loop_nodes = Some loops }