havlak.ml

type loop_type = Self | Irreducible | Reducible | Nonheader                        
                                                                                   
let analyze_loops g =                                                              
  let uf = UF.init () in                                                           
  let types = H.create 1337 in                                                     
  let headers = H.create 1337 in                                                   
  let preds = H.create 1337 in                                                     
  let dfs_tree = DfsTree.create g in                                               
  let is_ancestor = DfsTree.isAncestor dfs_tree in                                 
  let compute_preds w = G.fold_pred (fun v (bp,nbp) -> if is_ancestor w v          
                                                       then (v::bp,nbp)            
                                                       else (bp,v::nbp)            
                                    ) g w ([],[]) in                               
  let () = Dfs.prefix_component (fun v -> H.add headers v start_vertex;            
                                          H.add types v Nonheader;                 
                                          H.add preds v (compute_preds v);         
                                          UF.add uf v                              
                                ) g start_vertex in                                
  (* we are now at c: in Havlak 1997 *)                                            
  let next_block w =                                                               
    let (backPreds_w,nonBackPreds_w) = H.find preds w in                           
    let p = ref (List.fold_left (fun p v -> if G.V.equal w v                       
                                       then begin H.replace types w Self; p end 
                                       else (UF.find uf v)::p                      
                                ) [] backPreds_w) in                                    
    let () = match !p with | [] -> ()                                              
                           | _ -> (H.replace types w Reducible) in                  
    let rec while_loop wl = match wl with                                          
        | [] -> ()                                                                 
        | x::rest -> let (_,nonBackPreds_x) = H.find preds x in                    
        let (new_work_list,new_nonBackPreds_w) =                                   
          List.fold_left (fun (nwl,nbp_w) y ->                                     
            let y_p = UF.find uf y in                                              
            if not(is_ancestor w y_p) then                                         
              (H.replace types w Irreducible; (nwl,y_p::nbp_w))                    
            else if ((List.for_all (fun p -> not(G.V.equal p y_p)) !p)             
                    && not(G.V.equal y_p w)) then begin                            
                      p := y_p::!p; (y_p::nwl,nbp_w)                               
                    end                                                            
            else                                                                   
              (nwl,nbp_w)) (rest,nonBackPreds_w) nonBackPreds_x                    
        in                                                                         
          H.replace preds w (backPreds_w, new_nonBackPreds_w);                     
          while_loop new_work_list in                                              
    while_loop !p; List.iter (fun x -> H.replace headers x w; UF.union uf x w) !p in
                                                                                
  let () = Dfs.postfix_component next_block g start_vertex in                      
  (types,headers)