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)