Revert "Batch merge"
[ghc.git] / compiler / utils / UnVarGraph.hs
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 UnVarGraph
18 ( UnVarSet
19 , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets
20 , 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 GhcPrelude
32
33 import Id
34 import VarEnv
35 import UniqFM
36 import Outputable
37 import Bag
38 import Unique
39
40 import qualified Data.IntSet as S
41
42 -- We need a type for sets of variables (UnVarSet).
43 -- We do not use VarSet, because for that we need to have the actual variable
44 -- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.
45 -- Therefore, use a IntSet directly (which is likely also a bit more efficient).
46
47 -- Set of uniques, i.e. for adjancet nodes
48 newtype UnVarSet = UnVarSet (S.IntSet)
49 deriving Eq
50
51 k :: Var -> Int
52 k v = getKey (getUnique v)
53
54 emptyUnVarSet :: UnVarSet
55 emptyUnVarSet = UnVarSet S.empty
56
57 elemUnVarSet :: Var -> UnVarSet -> Bool
58 elemUnVarSet v (UnVarSet s) = k v `S.member` s
59
60
61 isEmptyUnVarSet :: UnVarSet -> Bool
62 isEmptyUnVarSet (UnVarSet s) = S.null s
63
64 delUnVarSet :: UnVarSet -> Var -> UnVarSet
65 delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s
66
67 mkUnVarSet :: [Var] -> UnVarSet
68 mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs
69
70 varEnvDom :: VarEnv a -> UnVarSet
71 varEnvDom ae = UnVarSet $ ufmToSet_Directly ae
72
73 unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet
74 unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)
75
76 unionUnVarSets :: [UnVarSet] -> UnVarSet
77 unionUnVarSets = foldr unionUnVarSet emptyUnVarSet
78
79 instance Outputable UnVarSet where
80 ppr (UnVarSet s) = braces $
81 hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]
82
83
84 -- The graph type. A list of complete bipartite graphs
85 data Gen = CBPG UnVarSet UnVarSet -- complete bipartite
86 | CG UnVarSet -- complete
87 newtype UnVarGraph = UnVarGraph (Bag Gen)
88
89 emptyUnVarGraph :: UnVarGraph
90 emptyUnVarGraph = UnVarGraph emptyBag
91
92 unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph
93 {-
94 Premature optimisation, it seems.
95 unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
96 | s1 == s3 && s2 == s4
97 = pprTrace "unionUnVarGraph fired" empty $
98 completeGraph (s1 `unionUnVarSet` s2)
99 unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])
100 | s2 == s3 && s1 == s4
101 = pprTrace "unionUnVarGraph fired2" empty $
102 completeGraph (s1 `unionUnVarSet` s2)
103 -}
104 unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)
105 = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $
106 UnVarGraph (g1 `unionBags` g2)
107
108 unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph
109 unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph
110
111 -- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }
112 completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph
113 completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2
114
115 completeGraph :: UnVarSet -> UnVarGraph
116 completeGraph s = prune $ UnVarGraph $ unitBag $ CG s
117
118 neighbors :: UnVarGraph -> Var -> UnVarSet
119 neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g
120 where go (CG s) = (if v `elemUnVarSet` s then [s] else [])
121 go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++
122 (if v `elemUnVarSet` s2 then [s1] else [])
123
124 -- hasLoopAt G v <=> v--v ∈ G
125 hasLoopAt :: UnVarGraph -> Var -> Bool
126 hasLoopAt (UnVarGraph g) v = any go $ bagToList g
127 where go (CG s) = v `elemUnVarSet` s
128 go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2
129
130
131 delNode :: UnVarGraph -> Var -> UnVarGraph
132 delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g
133 where go (CG s) = CG (s `delUnVarSet` v)
134 go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)
135
136 prune :: UnVarGraph -> UnVarGraph
137 prune (UnVarGraph g) = UnVarGraph $ filterBag go g
138 where go (CG s) = not (isEmptyUnVarSet s)
139 go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)
140
141 instance Outputable Gen where
142 ppr (CG s) = ppr s <> char '²'
143 ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2
144 instance Outputable UnVarGraph where
145 ppr (UnVarGraph g) = ppr g