never executed always true always false
    1 {-
    2 
    3 Copyright (c) 2014 Joachim Breitner
    4 
    5 A data structure for undirected graphs of variables
    6 (or in plain terms: Sets of unordered pairs of numbers)
    7 
    8 
    9 This is very specifically tailored for the use in CallArity. In particular it
   10 stores the graph as a union of complete and complete bipartite graph, which
   11 would be very expensive to store as sets of edges or as adjanceny lists.
   12 
   13 It does not normalize the graphs. This means that g `unionUnVarGraph` g is
   14 equal to g, but twice as expensive and large.
   15 
   16 -}
   17 module GHC.Data.Graph.UnVar
   18     ( UnVarSet
   19     , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
   20     , extendUnVarSet, delUnVarSet
   21     , elemUnVarSet, isEmptyUnVarSet
   22     , UnVarGraph
   23     , emptyUnVarGraph
   24     , unionUnVarGraph, unionUnVarGraphs
   25     , completeGraph, completeBipartiteGraph
   26     , neighbors
   27     , hasLoopAt
   28     , delNode
   29     ) where
   30 
   31 import GHC.Prelude
   32 
   33 import GHC.Types.Id
   34 import GHC.Types.Var.Env
   35 import GHC.Types.Unique.FM
   36 import GHC.Utils.Outputable
   37 import GHC.Types.Unique
   38 
   39 import qualified Data.IntSet as S
   40 
   41 -- We need a type for sets of variables (UnVarSet).
   42 -- We do not use VarSet, because for that we need to have the actual variable
   43 -- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
   44 -- Therefore, use a IntSet directly (which is likely also a bit more efficient).
   45 
   46 -- Set of uniques, i.e. for adjancet nodes
   47 newtype UnVarSet = UnVarSet (S.IntSet)
   48     deriving Eq
   49 
   50 k :: Var -> Int
   51 k v = getKey (getUnique v)
   52 
   53 emptyUnVarSet :: UnVarSet
   54 emptyUnVarSet = UnVarSet S.empty
   55 
   56 elemUnVarSet :: Var -> UnVarSet -> Bool
   57 elemUnVarSet v (UnVarSet s) = k v `S.member` s
   58 
   59 
   60 isEmptyUnVarSet :: UnVarSet -> Bool
   61 isEmptyUnVarSet (UnVarSet s) = S.null s
   62 
   63 delUnVarSet :: UnVarSet -> Var -> UnVarSet
   64 delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
   65 
   66 minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
   67 minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'
   68 
   69 sizeUnVarSet :: UnVarSet -> Int
   70 sizeUnVarSet (UnVarSet s) = S.size s
   71 
   72 mkUnVarSet :: [Var] -> UnVarSet
   73 mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
   74 
   75 varEnvDom :: VarEnv a -> UnVarSet
   76 varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
   77 
   78 extendUnVarSet :: Var -> UnVarSet -> UnVarSet
   79 extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s
   80 
   81 unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
   82 unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
   83 
   84 unionUnVarSets :: [UnVarSet] -> UnVarSet
   85 unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet
   86 
   87 instance Outputable UnVarSet where
   88     ppr (UnVarSet s) = braces $
   89         hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
   90 
   91 data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph
   92                 | CG    !UnVarSet           -- ^ complete graph
   93                 | Union UnVarGraph UnVarGraph
   94                 | Del   !UnVarSet UnVarGraph
   95 
   96 emptyUnVarGraph :: UnVarGraph
   97 emptyUnVarGraph = CG emptyUnVarSet
   98 
   99 unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
  100 {-
  101 Premature optimisation, it seems.
  102 unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
  103     | s1 == s3 && s2 == s4
  104     = pprTrace "unionUnVarGraph fired" empty $
  105       completeGraph (s1 `unionUnVarSet` s2)
  106 unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
  107     | s2 == s3 && s1 == s4
  108     = pprTrace "unionUnVarGraph fired2" empty $
  109       completeGraph (s1 `unionUnVarSet` s2)
  110 -}
  111 unionUnVarGraph a b
  112   | is_null a = b
  113   | is_null b = a
  114   | otherwise = Union a b
  115 
  116 unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
  117 unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
  118 
  119 -- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
  120 completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
  121 completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2
  122 
  123 completeGraph :: UnVarSet -> UnVarGraph
  124 completeGraph s = prune $ CG s
  125 
  126 -- (v' ∈ neighbors G v) <=> v--v' ∈ G
  127 neighbors :: UnVarGraph -> Var -> UnVarSet
  128 neighbors = go
  129   where
  130     go (Del d g) v
  131       | v `elemUnVarSet` d = emptyUnVarSet
  132       | otherwise          = go g v `minusUnVarSet` d
  133     go (Union g1 g2) v     = go g1 v `unionUnVarSet` go g2 v
  134     go (CG s) v            = if v `elemUnVarSet` s then s else emptyUnVarSet
  135     go (CBPG s1 s2) v      = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`
  136                              (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)
  137 
  138 -- hasLoopAt G v <=> v--v ∈ G
  139 hasLoopAt :: UnVarGraph -> Var -> Bool
  140 hasLoopAt = go
  141   where
  142     go (Del d g) v
  143       | v `elemUnVarSet` d  = False
  144       | otherwise           = go g v
  145     go (Union g1 g2) v      = go g1 v || go g2 v
  146     go (CG s) v             = v `elemUnVarSet` s
  147     go (CBPG s1 s2) v       = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
  148 
  149 delNode :: UnVarGraph -> Var -> UnVarGraph
  150 delNode (Del d g) v = Del (extendUnVarSet v d) g
  151 delNode g         v
  152   | is_null g       = emptyUnVarGraph
  153   | otherwise       = Del (mkUnVarSet [v]) g
  154 
  155 -- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …`
  156 prune :: UnVarGraph -> UnVarGraph
  157 prune = go emptyUnVarSet
  158   where
  159     go :: UnVarSet -> UnVarGraph -> UnVarGraph
  160     go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g
  161     go dels (Union g1 g2)
  162       | is_null g1' = g2'
  163       | is_null g2' = g1'
  164       | otherwise   = Union g1' g2'
  165       where
  166         g1' = go dels g1
  167         g2' = go dels g2
  168     go dels (CG s)        = CG (s `minusUnVarSet` dels)
  169     go dels (CBPG s1 s2)  = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels)
  170 
  171 -- | Shallow empty check.
  172 is_null :: UnVarGraph -> Bool
  173 is_null (CBPG s1 s2)  = isEmptyUnVarSet s1 || isEmptyUnVarSet s2
  174 is_null (CG   s)      = isEmptyUnVarSet s
  175 is_null _             = False
  176 
  177 instance Outputable UnVarGraph where
  178     ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)
  179     ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)
  180     ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)
  181     ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)