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