never executed always true always false
    1 -- (c) The University of Glasgow 2006
    2 
    3 
    4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    5 {-# LANGUAGE ScopedTypeVariables #-}
    6 {-# LANGUAGE ViewPatterns #-}
    7 
    8 module GHC.Data.Graph.Directed (
    9         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,
   10 
   11         SCC(..), Node(..), flattenSCC, flattenSCCs,
   12         stronglyConnCompG,
   13         topologicalSortG,
   14         verticesG, edgesG, hasVertexG,
   15         reachableG, reachablesG, transposeG, allReachable, outgoingG,
   16         emptyG,
   17 
   18         findCycle,
   19 
   20         -- For backwards compatibility with the simpler version of Digraph
   21         stronglyConnCompFromEdgedVerticesOrd,
   22         stronglyConnCompFromEdgedVerticesOrdR,
   23         stronglyConnCompFromEdgedVerticesUniq,
   24         stronglyConnCompFromEdgedVerticesUniqR,
   25 
   26         -- Simple way to classify edges
   27         EdgeType(..), classifyEdges
   28         ) where
   29 
   30 ------------------------------------------------------------------------------
   31 -- A version of the graph algorithms described in:
   32 --
   33 -- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell''
   34 --   by David King and John Launchbury
   35 --
   36 -- Also included is some additional code for printing tree structures ...
   37 --
   38 -- If you ever find yourself in need of algorithms for classifying edges,
   39 -- or finding connected/biconnected components, consult the history; Sigbjorn
   40 -- Finne contributed some implementations in 1997, although we've since
   41 -- removed them since they were not used anywhere in GHC.
   42 ------------------------------------------------------------------------------
   43 
   44 
   45 import GHC.Prelude
   46 
   47 import GHC.Utils.Misc ( minWith, count )
   48 import GHC.Utils.Outputable
   49 import GHC.Utils.Panic
   50 import GHC.Data.Maybe ( expectJust )
   51 
   52 -- std interfaces
   53 import Data.Maybe
   54 import Data.Array
   55 import Data.List ( sort )
   56 import qualified Data.Map as Map
   57 import qualified Data.Set as Set
   58 
   59 import qualified Data.Graph as G
   60 import Data.Graph hiding (Graph, Edge, transposeG, reachable)
   61 import Data.Tree
   62 import GHC.Types.Unique
   63 import GHC.Types.Unique.FM
   64 import qualified Data.IntMap as IM
   65 import qualified Data.IntSet as IS
   66 import qualified Data.Map as M
   67 
   68 {-
   69 ************************************************************************
   70 *                                                                      *
   71 *      Graphs and Graph Construction
   72 *                                                                      *
   73 ************************************************************************
   74 
   75 Note [Nodes, keys, vertices]
   76 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   77  * A 'node' is a big blob of client-stuff
   78 
   79  * Each 'node' has a unique (client) 'key', but the latter
   80         is in Ord and has fast comparison
   81 
   82  * Digraph then maps each 'key' to a Vertex (Int) which is
   83         arranged densely in 0.n
   84 -}
   85 
   86 data Graph node = Graph {
   87     gr_int_graph      :: IntGraph,
   88     gr_vertex_to_node :: Vertex -> node,
   89     gr_node_to_vertex :: node -> Maybe Vertex
   90   }
   91 
   92 data Edge node = Edge node node
   93 
   94 {-| Representation for nodes of the Graph.
   95 
   96  * The @payload@ is user data, just carried around in this module
   97 
   98  * The @key@ is the node identifier.
   99    Key has an Ord instance for performance reasons.
  100 
  101  * The @[key]@ are the dependencies of the node;
  102    it's ok to have extra keys in the dependencies that
  103    are not the key of any Node in the graph
  104 -}
  105 data Node key payload = DigraphNode {
  106       node_payload :: payload, -- ^ User data
  107       node_key :: key, -- ^ User defined node id
  108       node_dependencies :: [key] -- ^ Dependencies/successors of the node
  109   }
  110 
  111 
  112 instance (Outputable a, Outputable b) => Outputable (Node a b) where
  113   ppr (DigraphNode a b c) = ppr (a, b, c)
  114 
  115 emptyGraph :: Graph a
  116 emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing)
  117 
  118 -- See Note [Deterministic SCC]
  119 graphFromEdgedVertices
  120         :: ReduceFn key payload
  121         -> [Node key payload]           -- The graph; its ok for the
  122                                         -- out-list to contain keys which aren't
  123                                         -- a vertex key, they are ignored
  124         -> Graph (Node key payload)
  125 graphFromEdgedVertices _reduceFn []            = emptyGraph
  126 graphFromEdgedVertices reduceFn edged_vertices =
  127   Graph graph vertex_fn (key_vertex . key_extractor)
  128   where key_extractor = node_key
  129         (bounds, vertex_fn, key_vertex, numbered_nodes) =
  130           reduceFn edged_vertices key_extractor
  131         graph = array bounds [ (v, sort $ mapMaybe key_vertex ks)
  132                              | (v, (node_dependencies -> ks)) <- numbered_nodes]
  133                 -- We normalize outgoing edges by sorting on node order, so
  134                 -- that the result doesn't depend on the order of the edges
  135 
  136 -- See Note [Deterministic SCC]
  137 -- See Note [reduceNodesIntoVertices implementations]
  138 graphFromEdgedVerticesOrd
  139         :: Ord key
  140         => [Node key payload]           -- The graph; its ok for the
  141                                         -- out-list to contain keys which aren't
  142                                         -- a vertex key, they are ignored
  143         -> Graph (Node key payload)
  144 graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd
  145 
  146 -- See Note [Deterministic SCC]
  147 -- See Note [reduceNodesIntoVertices implementations]
  148 graphFromEdgedVerticesUniq
  149         :: Uniquable key
  150         => [Node key payload]           -- The graph; its ok for the
  151                                         -- out-list to contain keys which aren't
  152                                         -- a vertex key, they are ignored
  153         -> Graph (Node key payload)
  154 graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq
  155 
  156 type ReduceFn key payload =
  157   [Node key payload] -> (Node key payload -> key) ->
  158     (Bounds, Vertex -> Node key payload
  159     , key -> Maybe Vertex, [(Vertex, Node key payload)])
  160 
  161 {-
  162 Note [reduceNodesIntoVertices implementations]
  163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  164 reduceNodesIntoVertices is parameterized by the container type.
  165 This is to accommodate key types that don't have an Ord instance
  166 and hence preclude the use of Data.Map. An example of such type
  167 would be Unique, there's no way to implement Ord Unique
  168 deterministically.
  169 
  170 For such types, there's a version with a Uniquable constraint.
  171 This leaves us with two versions of every function that depends on
  172 reduceNodesIntoVertices, one with Ord constraint and the other with
  173 Uniquable constraint.
  174 For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq.
  175 
  176 The Uniq version should be a tiny bit more efficient since it uses
  177 Data.IntMap internally.
  178 -}
  179 reduceNodesIntoVertices
  180   :: ([(key, Vertex)] -> m)
  181   -> (key -> m -> Maybe Vertex)
  182   -> ReduceFn key payload
  183 reduceNodesIntoVertices fromList lookup nodes key_extractor =
  184   (bounds, (!) vertex_map, key_vertex, numbered_nodes)
  185   where
  186     max_v           = length nodes - 1
  187     bounds          = (0, max_v) :: (Vertex, Vertex)
  188 
  189     -- Keep the order intact to make the result depend on input order
  190     -- instead of key order
  191     numbered_nodes  = zip [0..] nodes
  192     vertex_map      = array bounds numbered_nodes
  193 
  194     key_map = fromList
  195       [ (key_extractor node, v) | (v, node) <- numbered_nodes ]
  196     key_vertex k = lookup k key_map
  197 
  198 -- See Note [reduceNodesIntoVertices implementations]
  199 reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload
  200 reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup
  201 
  202 -- See Note [reduceNodesIntoVertices implementations]
  203 reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload
  204 reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM)
  205 
  206 {-
  207 ************************************************************************
  208 *                                                                      *
  209 *      SCC
  210 *                                                                      *
  211 ************************************************************************
  212 -}
  213 
  214 type WorkItem key payload
  215   = (Node key payload,  -- Tip of the path
  216      [payload])         -- Rest of the path;
  217                         --  [a,b,c] means c depends on b, b depends on a
  218 
  219 -- | Find a reasonably short cycle a->b->c->a, in a strongly
  220 -- connected component.  The input nodes are presumed to be
  221 -- a SCC, so you can start anywhere.
  222 findCycle :: forall payload key. Ord key
  223           => [Node key payload]     -- The nodes.  The dependencies can
  224                                     -- contain extra keys, which are ignored
  225           -> Maybe [payload]        -- A cycle, starting with node
  226                                     -- so each depends on the next
  227 findCycle graph
  228   = go Set.empty (new_work root_deps []) []
  229   where
  230     env :: Map.Map key (Node key payload)
  231     env = Map.fromList [ (node_key node, node) | node <- graph ]
  232 
  233     -- Find the node with fewest dependencies among the SCC modules
  234     -- This is just a heuristic to find some plausible root module
  235     root :: Node key payload
  236     root = fst (minWith snd [ (node, count (`Map.member` env)
  237                                            (node_dependencies node))
  238                             | node <- graph ])
  239     DigraphNode root_payload root_key root_deps = root
  240 
  241 
  242     -- 'go' implements Dijkstra's algorithm, more or less
  243     go :: Set.Set key   -- Visited
  244        -> [WorkItem key payload]        -- Work list, items length n
  245        -> [WorkItem key payload]        -- Work list, items length n+1
  246        -> Maybe [payload]               -- Returned cycle
  247        -- Invariant: in a call (go visited ps qs),
  248        --            visited = union (map tail (ps ++ qs))
  249 
  250     go _       [] [] = Nothing  -- No cycles
  251     go visited [] qs = go visited qs []
  252     go visited (((DigraphNode payload key deps), path) : ps) qs
  253        | key == root_key           = Just (root_payload : reverse path)
  254        | key `Set.member` visited  = go visited ps qs
  255        | key `Map.notMember` env   = go visited ps qs
  256        | otherwise                 = go (Set.insert key visited)
  257                                         ps (new_qs ++ qs)
  258        where
  259          new_qs = new_work deps (payload : path)
  260 
  261     new_work :: [key] -> [payload] -> [WorkItem key payload]
  262     new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ]
  263 
  264 {-
  265 ************************************************************************
  266 *                                                                      *
  267 *      Strongly Connected Component wrappers for Graph
  268 *                                                                      *
  269 ************************************************************************
  270 
  271 Note: the components are returned topologically sorted: later components
  272 depend on earlier ones, but not vice versa i.e. later components only have
  273 edges going from them to earlier ones.
  274 -}
  275 
  276 {-
  277 Note [Deterministic SCC]
  278 ~~~~~~~~~~~~~~~~~~~~~~~~
  279 stronglyConnCompFromEdgedVerticesUniq,
  280 stronglyConnCompFromEdgedVerticesUniqR,
  281 stronglyConnCompFromEdgedVerticesOrd and
  282 stronglyConnCompFromEdgedVerticesOrdR
  283 provide a following guarantee:
  284 Given a deterministically ordered list of nodes it returns a deterministically
  285 ordered list of strongly connected components, where the list of vertices
  286 in an SCC is also deterministically ordered.
  287 Note that the order of edges doesn't need to be deterministic for this to work.
  288 We use the order of nodes to normalize the order of edges.
  289 -}
  290 
  291 stronglyConnCompG :: Graph node -> [SCC node]
  292 stronglyConnCompG graph = decodeSccs graph forest
  293   where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph)
  294 
  295 decodeSccs :: Graph node -> Forest Vertex -> [SCC node]
  296 decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest
  297   = map decode forest
  298   where
  299     decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v]
  300                        | otherwise         = AcyclicSCC (vertex_fn v)
  301     decode other = CyclicSCC (dec other [])
  302       where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts
  303     mentions_itself v = v `elem` (graph ! v)
  304 
  305 
  306 -- The following two versions are provided for backwards compatibility:
  307 -- See Note [Deterministic SCC]
  308 -- See Note [reduceNodesIntoVertices implementations]
  309 stronglyConnCompFromEdgedVerticesOrd
  310         :: Ord key
  311         => [Node key payload]
  312         -> [SCC payload]
  313 stronglyConnCompFromEdgedVerticesOrd
  314   = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR
  315 
  316 -- The following two versions are provided for backwards compatibility:
  317 -- See Note [Deterministic SCC]
  318 -- See Note [reduceNodesIntoVertices implementations]
  319 stronglyConnCompFromEdgedVerticesUniq
  320         :: Uniquable key
  321         => [Node key payload]
  322         -> [SCC payload]
  323 stronglyConnCompFromEdgedVerticesUniq
  324   = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR
  325 
  326 -- The "R" interface is used when you expect to apply SCC to
  327 -- (some of) the result of SCC, so you don't want to lose the dependency info
  328 -- See Note [Deterministic SCC]
  329 -- See Note [reduceNodesIntoVertices implementations]
  330 stronglyConnCompFromEdgedVerticesOrdR
  331         :: Ord key
  332         => [Node key payload]
  333         -> [SCC (Node key payload)]
  334 stronglyConnCompFromEdgedVerticesOrdR =
  335   stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd
  336 
  337 -- The "R" interface is used when you expect to apply SCC to
  338 -- (some of) the result of SCC, so you don't want to lose the dependency info
  339 -- See Note [Deterministic SCC]
  340 -- See Note [reduceNodesIntoVertices implementations]
  341 stronglyConnCompFromEdgedVerticesUniqR
  342         :: Uniquable key
  343         => [Node key payload]
  344         -> [SCC (Node key payload)]
  345 stronglyConnCompFromEdgedVerticesUniqR =
  346   stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq
  347 
  348 {-
  349 ************************************************************************
  350 *                                                                      *
  351 *      Misc wrappers for Graph
  352 *                                                                      *
  353 ************************************************************************
  354 -}
  355 
  356 topologicalSortG :: Graph node -> [node]
  357 topologicalSortG graph = map (gr_vertex_to_node graph) result
  358   where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph)
  359 
  360 reachableG :: Graph node -> node -> [node]
  361 reachableG graph from = map (gr_vertex_to_node graph) result
  362   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
  363         result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
  364 
  365 outgoingG :: Graph node -> node -> [node]
  366 outgoingG graph from = map (gr_vertex_to_node graph) result
  367   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
  368         result = gr_int_graph graph ! from_vertex
  369 
  370 -- | Given a list of roots return all reachable nodes.
  371 reachablesG :: Graph node -> [node] -> [node]
  372 reachablesG graph froms = map (gr_vertex_to_node graph) result
  373   where result = {-# SCC "Digraph.reachable" #-}
  374                  reachable (gr_int_graph graph) vs
  375         vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
  376 
  377 allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key [key]
  378 allReachable (Graph g from _) conv =  M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) : vs) [] vs) | (v, vs) <- IM.toList int_graph]
  379   where
  380     int_graph = reachableGraph g
  381 
  382 hasVertexG :: Graph node -> node -> Bool
  383 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
  384 
  385 verticesG :: Graph node -> [node]
  386 verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph)
  387 
  388 edgesG :: Graph node -> [Edge node]
  389 edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph)
  390   where v2n = gr_vertex_to_node graph
  391 
  392 transposeG :: Graph node -> Graph node
  393 transposeG graph = Graph (G.transposeG (gr_int_graph graph))
  394                          (gr_vertex_to_node graph)
  395                          (gr_node_to_vertex graph)
  396 
  397 emptyG :: Graph node -> Bool
  398 emptyG g = graphEmpty (gr_int_graph g)
  399 
  400 {-
  401 ************************************************************************
  402 *                                                                      *
  403 *      Showing Graphs
  404 *                                                                      *
  405 ************************************************************************
  406 -}
  407 
  408 instance Outputable node => Outputable (Graph node) where
  409     ppr graph = vcat [
  410                   hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),
  411                   hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))
  412                 ]
  413 
  414 instance Outputable node => Outputable (Edge node) where
  415     ppr (Edge from to) = ppr from <+> text "->" <+> ppr to
  416 
  417 graphEmpty :: G.Graph -> Bool
  418 graphEmpty g = lo > hi
  419   where (lo, hi) = bounds g
  420 
  421 {-
  422 ************************************************************************
  423 *                                                                      *
  424 *      IntGraphs
  425 *                                                                      *
  426 ************************************************************************
  427 -}
  428 
  429 type IntGraph = G.Graph
  430 
  431 {-
  432 ------------------------------------------------------------
  433 -- Depth first search numbering
  434 ------------------------------------------------------------
  435 -}
  436 
  437 -- Data.Tree has flatten for Tree, but nothing for Forest
  438 preorderF           :: Forest a -> [a]
  439 preorderF ts         = concatMap flatten ts
  440 
  441 {-
  442 ------------------------------------------------------------
  443 -- Finding reachable vertices
  444 ------------------------------------------------------------
  445 -}
  446 
  447 -- This generalizes reachable which was found in Data.Graph
  448 reachable    :: IntGraph -> [Vertex] -> [Vertex]
  449 reachable g vs = preorderF (dfs g vs)
  450 
  451 reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
  452 reachableGraph g = res
  453   where
  454     do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))
  455     res = IM.fromList [(v, do_one v) | v <- vertices g]
  456 
  457 {-
  458 ************************************************************************
  459 *                                                                      *
  460 *                         Classify Edge Types
  461 *                                                                      *
  462 ************************************************************************
  463 -}
  464 
  465 -- Remark: While we could generalize this algorithm this comes at a runtime
  466 -- cost and with no advantages. If you find yourself using this with graphs
  467 -- not easily represented using Int nodes please consider rewriting this
  468 -- using the more general Graph type.
  469 
  470 -- | Edge direction based on DFS Classification
  471 data EdgeType
  472   = Forward
  473   | Cross
  474   | Backward -- ^ Loop back towards the root node.
  475              -- Eg backjumps in loops
  476   | SelfLoop -- ^ v -> v
  477    deriving (Eq,Ord)
  478 
  479 instance Outputable EdgeType where
  480   ppr Forward = text "Forward"
  481   ppr Cross = text "Cross"
  482   ppr Backward = text "Backward"
  483   ppr SelfLoop = text "SelfLoop"
  484 
  485 newtype Time = Time Int deriving (Eq,Ord,Num,Outputable)
  486 
  487 --Allow for specialization
  488 {-# INLINEABLE classifyEdges #-}
  489 
  490 -- | Given a start vertex, a way to get successors from a node
  491 -- and a list of (directed) edges classify the types of edges.
  492 classifyEdges :: forall key. Uniquable key => key -> (key -> [key])
  493               -> [(key,key)] -> [((key, key), EdgeType)]
  494 classifyEdges root getSucc edges =
  495     --let uqe (from,to) = (getUnique from, getUnique to)
  496     --in pprTrace "Edges:" (ppr $ map uqe edges) $
  497     zip edges $ map classify edges
  498   where
  499     (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root
  500     classify :: (key,key) -> EdgeType
  501     classify (from,to)
  502       | startFrom < startTo
  503       , endFrom   > endTo
  504       = Forward
  505       | startFrom > startTo
  506       , endFrom   < endTo
  507       = Backward
  508       | startFrom > startTo
  509       , endFrom   > endTo
  510       = Cross
  511       | getUnique from == getUnique to
  512       = SelfLoop
  513       | otherwise
  514       = pprPanic "Failed to classify edge of Graph"
  515                  (ppr (getUnique from, getUnique to))
  516 
  517       where
  518         getTime event node
  519           | Just time <- lookupUFM event node
  520           = time
  521           | otherwise
  522           = pprPanic "Failed to classify edge of CFG - not not timed"
  523             (text "edges" <> ppr (getUnique from, getUnique to)
  524                           <+> ppr starts <+> ppr ends )
  525         startFrom = getTime starts from
  526         startTo   = getTime starts to
  527         endFrom   = getTime ends   from
  528         endTo     = getTime ends   to
  529 
  530     addTimes :: (Time, UniqFM key Time, UniqFM key Time) -> key
  531              -> (Time, UniqFM key Time, UniqFM key Time)
  532     addTimes (time,starts,ends) n
  533       --Dont reenter nodes
  534       | elemUFM n starts
  535       = (time,starts,ends)
  536       | otherwise =
  537         let
  538           starts' = addToUFM starts n time
  539           time' = time + 1
  540           succs = getSucc n :: [key]
  541           (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs
  542           ends'' = addToUFM ends' n time''
  543         in
  544         (time'' + 1, starts'', ends'')