Source file dominators.ml

(**************************************************************************************)
(*  Copyright (C) 2009-2010 Pietro Abate <pietro.abate@pps.jussieu.fr>                *)
(*                      and Jaap Boender <boender@pps.jussieu.fr>                     *)
(*  Copyright (C) 2009-2010 Mancoosi Project                                          *)
(*                                                                                    *)
(*  This library is free software: you can redistribute it and/or modify              *)
(*  it under the terms of the GNU Lesser General Public License as                    *)
(*  published by the Free Software Foundation, either version 3 of the                *)
(*  License, or (at your option) any later version.  A special linking                *)
(*  exception to the GNU Lesser General Public License applies to this                *)
(*  library, see the COPYING file for more information.                               *)
(**************************************************************************************)

open Graph
open Dose_common

let dombar = Util.Progress.create "Algo.dominators"

let domtimer = Util.Timer.create "Algo.Dominators.dominators_direct"

let tjntimer = Util.Timer.create "Algo.Dominators.dominators_tarjan"

let crtimer = Util.Timer.create "Algo.Dominators.cycle_reduction"

let sdtrtimer = Util.Timer.create "Algo.Dominators.sd_transitive_reduction"

let domtrtimer = Util.Timer.create "Algo.Dominators.dom_transitive_reduction"

include Util.Logging (struct
  let label = "dose_algo.dominators"
end)

module G = Defaultgraphs.PackageGraph.G
module O = Defaultgraphs.GraphOper (G)
module S = Defaultgraphs.PackageGraph.S

let impactset (graph, pkg) = G.fold_pred S.add graph pkg (S.singleton pkg)

let scons (graph, pkg) = G.fold_succ S.add graph pkg (S.singleton pkg)

(* the dominators are computed on the strong dependency graph
 * with transitive archs *)
let dominators_direct ?(relative = None) graph =
  debug
    "input graph SD : vertex %d - edges %d"
    (G.nb_vertex graph)
    (G.nb_edges graph) ;
  Util.Progress.set_total dombar (G.nb_vertex graph) ;
  Util.Timer.start domtimer ;
  let domgraph = G.create () in
  G.iter_vertex
    (fun p ->
      Util.Progress.progress dombar ;
      let isp = impactset (graph, p) in
      let sconsp = scons (graph, p) in
      G.iter_succ
        (fun q ->
          if not (CudfAdd.equal p q) then
            let isq = impactset (graph, q) in
            let dfs = S.diff isq sconsp in
            match relative with
            | None -> if S.subset dfs isp then G.add_edge domgraph p q
            | Some threshold ->
                let t =
                  float (S.cardinal (S.diff dfs isp))
                  *. 100.
                  /. float (S.cardinal isp)
                in
                if t <= threshold then G.add_edge domgraph p q)
        graph
        p)
    graph ;
  Util.Timer.stop domtimer () ;
  debug
    "after dominators direct : vertex %d - edges %d"
    (G.nb_vertex domgraph)
    (G.nb_edges domgraph) ;
  Util.Timer.start crtimer ;
  Defaultgraphs.PackageGraph.cycle_reduction domgraph ;
  Util.Timer.stop crtimer () ;
  debug
    "after cycle reduction dominators : vertex %d - edges %d"
    (G.nb_vertex domgraph)
    (G.nb_edges domgraph) ;
  Util.Timer.start domtrtimer ;
  O.transitive_reduction domgraph ;
  Util.Timer.stop domtrtimer () ;
  debug
    "after transitive reduction dominators : vertex %d - edges %d"
    (G.nb_vertex domgraph)
    (G.nb_edges domgraph) ;
  domgraph

(* This function expects a strong dependency graph that might or not contain
 * transitive edges *)
let dominators_tarjan graph =
  debug
    "input graph SD : vertex %d - edges %d"
    (G.nb_vertex graph)
    (G.nb_edges graph) ;
  let start_pkg = { Cudf.default_package with Cudf.package = "START" } in
  let graph = G.copy graph in
  (* all cycles are cliques in the strong dependency graph *)
  Util.Timer.start crtimer ;
  Defaultgraphs.PackageGraph.cycle_reduction graph ;
  Util.Timer.stop crtimer () ;
  debug
    "after cycle reduction SD : vertex %d - edges %d"
    (G.nb_vertex graph)
    (G.nb_edges graph) ;
  Util.Timer.start sdtrtimer ;
  O.transitive_reduction graph ;
  Util.Timer.stop sdtrtimer () ;
  debug
    "after transitive reduction SD : vertex %d - edges %d"
    (G.nb_vertex graph)
    (G.nb_edges graph) ;
  (* connect it to all packages without incoming edges to a start vertex *)
  G.iter_vertex
    (fun v -> if G.in_degree graph v = 0 then G.add_edge graph start_pkg v)
    graph ;
  Util.Timer.start tjntimer ;
  let module Dom = Dominator.Make_graph (struct
    include G

    let empty () = create ()

    let add_edge g v1 v2 =
      add_edge g v1 v2 ;
      g
  end) in
  let idom = Dom.compute_all graph start_pkg in
  let domgr = idom.Dom.dom_graph () in
  Util.Timer.stop tjntimer () ;
  G.remove_vertex graph start_pkg ;
  G.remove_vertex domgr start_pkg ;
  Util.Timer.start domtrtimer ;
  O.transitive_reduction domgr ;
  Util.Timer.stop domtrtimer () ;
  debug
    "after transitive reduction dominators : vertex %d - edges %d"
    (G.nb_vertex domgr)
    (G.nb_edges domgr) ;
  domgr