ghc/compiler/utils/Digraph.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[Digraph]{An implementation of directed graphs}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module Digraph (
  10          stronglyConnComp,
  11          topologicalSort,
  12          dfs,
  13          MaybeErr,
  14
  15          -- alternative interface
  16          findSCCs, SCC(..), Bag
  17     ) where
  18
  19 CHK_Ubiq() -- debugging consistency check
  20
  21 import Maybes           ( Maybe, MaybeErr(..), maybeToBool )
  22 import Bag              ( Bag, filterBag, bagToList, listToBag )
  23 import FiniteMap        ( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM )
  24 import Util
  25 \end{code}
  26
  27 This module implements at least part of an abstract data type for
  28 directed graphs.  The part implemented is what we need for doing
  29 dependency analyses.
  30
  31 >type Edge  vertex = (vertex, vertex)
  32 >type Cycle vertex = [vertex]
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 %*      Strongly connected components                                   *
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 John Launchbury provided the basic code for doing strongly-connected
  41 components.
  42
  43 The result is a list of cycles (each of which is a list of vertices),
  44 and these cycles are topologically sorted, so that if there is an edge from
  45 cycle A to cycle B, then A occurs after B in the result list.
  46
  47 \begin{code}
  48 stronglyConnComp :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex] -> [[vertex]]
  49
  50 stronglyConnComp eq edges vertices
  51   = snd (span_tree (new_range reversed_edges)
  52                     ([],[])
  53                    ( snd (dfs (new_range edges) ([],[]) vertices) )
  54         )
  55   where
  56     reversed_edges = map swap edges
  57
  58     swap (x,y) = (y,x)
  59
  60     -- new_range :: Eq v => [Edge v] -> v -> [v]
  61
  62     new_range    []       w = []
  63     new_range ((x,y):xys) w
  64          = if x `eq` w
  65            then (y : (new_range xys w))
  66            else (new_range xys w)
  67
  68     elem x []     = False
  69     elem x (y:ys) = x `eq` y || x `elem` ys
  70
  71 {-  span_tree :: Eq v => (v -> [v])
  72                       -> ([v], [[v]])
  73                       -> [v]
  74                       -> ([v], [[v]])
  75 -}
  76     span_tree r (vs,ns) []   = (vs,ns)
  77     span_tree r (vs,ns) (x:xs)
  78          | x `elem` vs = span_tree r (vs,ns) xs
  79          | True        = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
  80                          span_tree r (vs',(x:ns'):ns) xs }
  81
  82 {-  dfs :: Eq v => (v -> [v])
  83                 -> ([v], [v])
  84                 -> [v]
  85                 -> ([v], [v])
  86 -}
  87     dfs r (vs,ns)   []   = (vs,ns)
  88     dfs r (vs,ns) (x:xs) | x `elem` vs = dfs r (vs,ns) xs
  89                          | True        = case (dfs r (x:vs,[]) (r x)) of { (vs',ns') ->
  90                                          dfs r (vs',(x:ns')++ns) xs }
  91 \end{code}
  92
  93 \begin{code}
  94 dfs :: (v -> v -> Bool)
  95     -> (v -> [v])
  96     -> ([v], [v])
  97     -> [v]
  98     -> ([v], [v])
  99
 100 dfs eq r (vs,ns)   []   = (vs,ns)
 101 dfs eq r (vs,ns) (x:xs)
 102         | any (eq x) vs = dfs eq r (vs,ns) xs
 103         | True          = case (dfs eq r (x:vs,[]) (r x)) of
 104                                 (vs',ns') -> dfs eq r (vs',(x:ns')++ns) xs
 105 \end{code}
 106
 107 \begin{code}
 108 findSCCs :: Ord key
 109          => (vertex -> (key, Bag key))  -- Give key of vertex, and keys of thing's
 110                                         -- immediate neighbours.  It's ok for the
 111                                         -- list to contain keys which don't correspond
 112                                         -- to any vertex; they are ignored.
 113          -> Bag vertex          -- Stuff to be SCC'd
 114          -> [SCC vertex]        -- The union of all these is the original bag
 115
 116 data SCC thing = AcyclicSCC thing
 117                | CyclicSCC  (Bag thing)
 118
 119 findSCCs v_info vs
 120   = let
 121         (keys, keys_of, edgess) = unzip3 (map do_vertex (bagToList vs))
 122         key_map = listToFM keys_of
 123         edges   = concat edgess
 124
 125         do_vertex v = (k, (k, (v, ok_ns)), ok_edges)
 126           where
 127             (k, ns)  = v_info v
 128             ok_ns    = filter key_in_graph (bagToList ns)
 129             ok_edges = map (\n->(k,n)) ok_ns
 130
 131         key_in_graph n = maybeToBool (lookupFM key_map n)
 132
 133         the_sccs = stronglyConnComp (==) edges keys
 134
 135         cnv_sccs = map cnv_scc the_sccs
 136
 137         cnv_scc []  = panic "findSCCs: empty component"
 138         cnv_scc [k] | singlecycle k
 139                     = AcyclicSCC (get_vertex k)
 140         cnv_scc ks  = CyclicSCC (listToBag (map get_vertex ks))
 141
 142         singlecycle k = not (isIn "cycle" k (get_neighs k))
 143
 144         get_vertex k = fst (lookupWithDefaultFM key_map vpanic k)
 145         get_neighs k = snd (lookupWithDefaultFM key_map vpanic k)
 146
 147         vpanic = panic "Digraph: vertix not found from key"
 148     in
 149     cnv_sccs
 150 \end{code}
 151
 152 %************************************************************************
 153 %*                                                                      *
 154 %*      Topological sort                                                *
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 Topological sort fails if it finds any cycles, returning the offending cycles.
 159
 160 If it succeeds, the result is a list of vertices, such that if there is
 161 an edge from vertex A to vertex B then A occurs after B in the result list.
 162
 163 \begin{code}
 164 topologicalSort :: (vertex->vertex->Bool) -> [Edge vertex] -> [vertex]
 165         -> MaybeErr [vertex]    -- Success: the sorted list
 166                     [[vertex]]  -- Failure: the cycles
 167
 168 topologicalSort eq edges vertices
 169   = case (stronglyConnComp eq edges vertices) of { sccs ->
 170     case (partition (is_cyclic edges) sccs)   of { (cycles, singletons) ->
 171     if null cycles
 172     then Succeeded [ v | [v] <- singletons ]
 173     else Failed cycles
 174     }}
 175   where
 176     is_cyclic es []  = panic "is_cyclic: empty component"
 177     is_cyclic es [v] = (v,v) `elem` es
 178     is_cyclic es vs  = True
 179
 180     elem (x,y)   []         = False
 181     elem z@(x,y) ((a,b):cs) = (x `eq` a && y `eq` b) || z `elem` cs
 182 \end{code}