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