compiler: de-lhs utils/
[ghc.git] / compiler / utils / UniqFM.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The AQUA Project, Glasgow University, 1994-1998
4
5
6 UniqFM: Specialised finite maps, for things with @Uniques@.
7
8 Basically, the things need to be in class @Uniquable@, and we use the
9 @getUnique@ method to grab their @Uniques@.
10
11 (A similar thing to @UniqSet@, as opposed to @Set@.)
12
13 The interface is based on @FiniteMap@s, but the implementation uses
14 @Data.IntMap@, which is both maintained and faster than the past
15 implementation (see commit log).
16
17 The @UniqFM@ interface maps directly to Data.IntMap, only
18 ``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased
19 and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order
20 of arguments of combining function.
21 -}
22
23 {-# LANGUAGE CPP #-}
24 {-# LANGUAGE DeriveDataTypeable #-}
25 {-# LANGUAGE DeriveTraversable #-}
26 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
27 {-# OPTIONS_GHC -Wall #-}
28
29 module UniqFM (
30 -- * Unique-keyed mappings
31 UniqFM, -- abstract type
32
33 -- ** Manipulating those mappings
34 emptyUFM,
35 unitUFM,
36 unitDirectlyUFM,
37 listToUFM,
38 listToUFM_Directly,
39 listToUFM_C,
40 addToUFM,addToUFM_C,addToUFM_Acc,
41 addListToUFM,addListToUFM_C,
42 addToUFM_Directly,
43 addListToUFM_Directly,
44 adjustUFM, alterUFM,
45 adjustUFM_Directly,
46 delFromUFM,
47 delFromUFM_Directly,
48 delListFromUFM,
49 plusUFM,
50 plusUFM_C,
51 plusUFM_CD,
52 minusUFM,
53 intersectUFM,
54 intersectUFM_C,
55 foldUFM, foldUFM_Directly,
56 mapUFM, mapUFM_Directly,
57 elemUFM, elemUFM_Directly,
58 filterUFM, filterUFM_Directly, partitionUFM,
59 sizeUFM,
60 isNullUFM,
61 lookupUFM, lookupUFM_Directly,
62 lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
63 eltsUFM, keysUFM, splitUFM,
64 ufmToSet_Directly,
65 ufmToList,
66 joinUFM, pprUniqFM
67 ) where
68
69 import FastString
70 import Unique ( Uniquable(..), Unique, getKey )
71 import Outputable
72
73 import Compiler.Hoopl hiding (Unique)
74
75 import qualified Data.IntMap as M
76 import qualified Data.IntSet as S
77 import qualified Data.Foldable as Foldable
78 import qualified Data.Traversable as Traversable
79 import Data.Typeable
80 import Data.Data
81 #if __GLASGOW_HASKELL__ < 709
82 import Data.Monoid
83 #endif
84
85 {-
86 ************************************************************************
87 * *
88 \subsection{The signature of the module}
89 * *
90 ************************************************************************
91 -}
92
93 emptyUFM :: UniqFM elt
94 isNullUFM :: UniqFM elt -> Bool
95 unitUFM :: Uniquable key => key -> elt -> UniqFM elt
96 unitDirectlyUFM -- got the Unique already
97 :: Unique -> elt -> UniqFM elt
98 listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt
99 listToUFM_Directly
100 :: [(Unique, elt)] -> UniqFM elt
101 listToUFM_C :: Uniquable key => (elt -> elt -> elt)
102 -> [(key, elt)]
103 -> UniqFM elt
104
105 addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt
106 addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt
107 addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt
108 addToUFM_Directly
109 :: UniqFM elt -> Unique -> elt -> UniqFM elt
110
111 addToUFM_C :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result
112 -> UniqFM elt -- old
113 -> key -> elt -- new
114 -> UniqFM elt -- result
115
116 addToUFM_Acc :: Uniquable key =>
117 (elt -> elts -> elts) -- Add to existing
118 -> (elt -> elts) -- New element
119 -> UniqFM elts -- old
120 -> key -> elt -- new
121 -> UniqFM elts -- result
122
123 alterUFM :: Uniquable key =>
124 (Maybe elt -> Maybe elt) -- How to adjust
125 -> UniqFM elt -- old
126 -> key -- new
127 -> UniqFM elt -- result
128
129 addListToUFM_C :: Uniquable key => (elt -> elt -> elt)
130 -> UniqFM elt -> [(key,elt)]
131 -> UniqFM elt
132
133 adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt
134 adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt
135
136 delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt
137 delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt
138 delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt
139
140 -- Bindings in right argument shadow those in the left
141 plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
142
143 plusUFM_C :: (elt -> elt -> elt)
144 -> UniqFM elt -> UniqFM elt -> UniqFM elt
145
146 -- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the
147 -- combinding function and `d1` resp. `d2` as the default value if
148 -- there is no entry in `m1` reps. `m2`. The domain is the union of
149 -- the domains of `m1` and `m2`.
150 --
151 -- Representative example:
152 --
153 -- @
154 -- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42
155 -- == {A: f 1 42, B: f 2 3, C: f 23 4 }
156 -- @
157 plusUFM_CD :: (elt -> elt -> elt)
158 -> UniqFM elt -> elt -> UniqFM elt -> elt -> UniqFM elt
159
160 minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1
161
162 intersectUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt
163 intersectUFM_C :: (elt1 -> elt2 -> elt3)
164 -> UniqFM elt1 -> UniqFM elt2 -> UniqFM elt3
165
166 foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a
167 foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a
168 mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
169 mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2
170 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt
171 filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt
172 partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt)
173
174 sizeUFM :: UniqFM elt -> Int
175 --hashUFM :: UniqFM elt -> Int
176 elemUFM :: Uniquable key => key -> UniqFM elt -> Bool
177 elemUFM_Directly:: Unique -> UniqFM elt -> Bool
178
179 splitUFM :: Uniquable key => UniqFM elt -> key -> (UniqFM elt, Maybe elt, UniqFM elt)
180 -- Splits a UFM into things less than, equal to, and greater than the key
181 lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt
182 lookupUFM_Directly -- when you've got the Unique already
183 :: UniqFM elt -> Unique -> Maybe elt
184 lookupWithDefaultUFM
185 :: Uniquable key => UniqFM elt -> elt -> key -> elt
186 lookupWithDefaultUFM_Directly
187 :: UniqFM elt -> elt -> Unique -> elt
188 keysUFM :: UniqFM elt -> [Unique] -- Get the keys
189 eltsUFM :: UniqFM elt -> [elt]
190 ufmToSet_Directly :: UniqFM elt -> S.IntSet
191 ufmToList :: UniqFM elt -> [(Unique, elt)]
192
193 {-
194 ************************************************************************
195 * *
196 \subsection{Monoid interface}
197 * *
198 ************************************************************************
199 -}
200
201 instance Monoid (UniqFM a) where
202 mempty = emptyUFM
203 mappend = plusUFM
204
205 {-
206 ************************************************************************
207 * *
208 \subsection{Implementation using ``Data.IntMap''}
209 * *
210 ************************************************************************
211 -}
212
213 newtype UniqFM ele = UFM (M.IntMap ele)
214 deriving (Data, Eq, Foldable.Foldable, Functor, Traversable.Traversable,
215 Typeable)
216
217 emptyUFM = UFM M.empty
218 isNullUFM (UFM m) = M.null m
219 unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v)
220 unitDirectlyUFM u v = UFM (M.singleton (getKey u) v)
221 listToUFM = foldl (\m (k, v) -> addToUFM m k v) emptyUFM
222 listToUFM_Directly = foldl (\m (u, v) -> addToUFM_Directly m u v) emptyUFM
223 listToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) emptyUFM
224
225 alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m)
226 addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)
227 addListToUFM = foldl (\m (k, v) -> addToUFM m k v)
228 addListToUFM_Directly = foldl (\m (k, v) -> addToUFM_Directly m k v)
229 addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m)
230
231 -- Arguments of combining function of M.insertWith and addToUFM_C are flipped.
232 addToUFM_C f (UFM m) k v =
233 UFM (M.insertWith (flip f) (getKey $ getUnique k) v m)
234 addToUFM_Acc exi new (UFM m) k v =
235 UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m)
236 addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v)
237
238 adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m)
239 adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m)
240
241 delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m)
242 delListFromUFM = foldl delFromUFM
243 delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m)
244
245 -- M.union is left-biased, plusUFM should be right-biased.
246 plusUFM (UFM x) (UFM y) = UFM (M.union y x)
247 -- Note (M.union y x), with arguments flipped
248 -- M.union is left-biased, plusUFM should be right-biased.
249
250 plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y)
251
252 plusUFM_CD f (UFM xm) dx (UFM ym) dy
253 = UFM $ M.mergeWithKey
254 (\_ x y -> Just (x `f` y))
255 (M.map (\x -> x `f` dy))
256 (M.map (\y -> dx `f` y))
257 xm ym
258 minusUFM (UFM x) (UFM y) = UFM (M.difference x y)
259 intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y)
260 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y)
261
262 foldUFM k z (UFM m) = M.fold k z m
263 foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m
264 mapUFM f (UFM m) = UFM (M.map f m)
265 mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m)
266 filterUFM p (UFM m) = UFM (M.filter p m)
267 filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m)
268 partitionUFM p (UFM m) = case M.partition p m of
269 (left, right) -> (UFM left, UFM right)
270
271 sizeUFM (UFM m) = M.size m
272 elemUFM k (UFM m) = M.member (getKey $ getUnique k) m
273 elemUFM_Directly u (UFM m) = M.member (getKey u) m
274
275 splitUFM (UFM m) k = case M.splitLookup (getKey $ getUnique k) m of
276 (less, equal, greater) -> (UFM less, equal, UFM greater)
277 lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m
278 lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m
279 lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m
280 lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m
281 keysUFM (UFM m) = map getUnique $ M.keys m
282 eltsUFM (UFM m) = M.elems m
283 ufmToSet_Directly (UFM m) = M.keysSet m
284 ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m
285
286 -- Hoopl
287 joinUFM :: JoinFun v -> JoinFun (UniqFM v)
288 joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new
289 where add k new_v (ch, joinmap) =
290 case lookupUFM_Directly joinmap k of
291 Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v)
292 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
293 (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v')
294 (NoChange, _) -> (ch, joinmap)
295
296 {-
297 ************************************************************************
298 * *
299 \subsection{Output-ery}
300 * *
301 ************************************************************************
302 -}
303
304 instance Outputable a => Outputable (UniqFM a) where
305 ppr ufm = pprUniqFM ppr ufm
306
307 pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc
308 pprUniqFM ppr_elt ufm
309 = brackets $ fsep $ punctuate comma $
310 [ ppr uq <+> ptext (sLit ":->") <+> ppr_elt elt
311 | (uq, elt) <- ufmToList ufm ]