never executed always true always false
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE UndecidableInstances #-}
6
7 {-
8 (c) The University of Glasgow 2006
9 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
10 -}
11 module GHC.Data.TrieMap(
12 -- * Maps over 'Maybe' values
13 MaybeMap,
14 -- * Maps over 'List' values
15 ListMap,
16 -- * Maps over 'Literal's
17 LiteralMap,
18 -- * 'TrieMap' class
19 TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,
20
21 -- * Things helpful for adding additional Instances.
22 (>.>), (|>), (|>>), XT,
23 foldMaybe, filterMaybe,
24 -- * Map for leaf compression
25 GenMap,
26 lkG, xtG, mapG, fdG,
27 xtList, lkList
28
29 ) where
30
31 import GHC.Prelude
32
33 import GHC.Types.Literal
34 import GHC.Types.Unique.DFM
35 import GHC.Types.Unique( Uniquable )
36
37 import qualified Data.Map as Map
38 import qualified Data.IntMap as IntMap
39 import GHC.Utils.Outputable
40 import Control.Monad( (>=>) )
41 import Data.Kind( Type )
42
43 import qualified Data.Semigroup as S
44
45 {-
46 This module implements TrieMaps, which are finite mappings
47 whose key is a structured value like a CoreExpr or Type.
48
49 This file implements tries over general data structures.
50 Implementation for tries over Core Expressions/Types are
51 available in GHC.Core.Map.Expr.
52
53 The regular pattern for handling TrieMaps on data structures was first
54 described (to my knowledge) in Connelly and Morris's 1995 paper "A
55 generalization of the Trie Data Structure"; there is also an accessible
56 description of the idea in Okasaki's book "Purely Functional Data
57 Structures", Section 10.3.2
58
59 ************************************************************************
60 * *
61 The TrieMap class
62 * *
63 ************************************************************************
64 -}
65
66 type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing)
67 -- or an existing elt (Just)
68
69 class TrieMap m where
70 type Key m :: Type
71 emptyTM :: m a
72 lookupTM :: forall b. Key m -> m b -> Maybe b
73 alterTM :: forall b. Key m -> XT b -> m b -> m b
74 mapTM :: (a->b) -> m a -> m b
75 filterTM :: (a -> Bool) -> m a -> m a
76
77 foldTM :: (a -> b -> b) -> m a -> b -> b
78 -- The unusual argument order here makes
79 -- it easy to compose calls to foldTM;
80 -- see for example fdE below
81
82 insertTM :: TrieMap m => Key m -> a -> m a -> m a
83 insertTM k v m = alterTM k (\_ -> Just v) m
84
85 deleteTM :: TrieMap m => Key m -> m a -> m a
86 deleteTM k m = alterTM k (\_ -> Nothing) m
87
88 foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r
89 foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty
90
91 -- This looks inefficient.
92 isEmptyTM :: TrieMap m => m a -> Bool
93 isEmptyTM m = foldTM (\ _ _ -> False) m True
94
95 ----------------------
96 -- Recall that
97 -- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
98
99 (>.>) :: (a -> b) -> (b -> c) -> a -> c
100 -- Reverse function composition (do f first, then g)
101 infixr 1 >.>
102 (f >.> g) x = g (f x)
103 infixr 1 |>, |>>
104
105 (|>) :: a -> (a->b) -> b -- Reverse application
106 x |> f = f x
107
108 ----------------------
109 (|>>) :: TrieMap m2
110 => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a))
111 -> (m2 a -> m2 a)
112 -> m1 (m2 a) -> m1 (m2 a)
113 (|>>) f g = f (Just . g . deMaybe)
114
115 deMaybe :: TrieMap m => Maybe (m a) -> m a
116 deMaybe Nothing = emptyTM
117 deMaybe (Just m) = m
118
119 {-
120 ************************************************************************
121 * *
122 IntMaps
123 * *
124 ************************************************************************
125 -}
126
127 instance TrieMap IntMap.IntMap where
128 type Key IntMap.IntMap = Int
129 emptyTM = IntMap.empty
130 lookupTM k m = IntMap.lookup k m
131 alterTM = xtInt
132 foldTM k m z = IntMap.foldr k z m
133 mapTM f m = IntMap.map f m
134 filterTM f m = IntMap.filter f m
135
136 xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a
137 xtInt k f m = IntMap.alter f k m
138
139 instance Ord k => TrieMap (Map.Map k) where
140 type Key (Map.Map k) = k
141 emptyTM = Map.empty
142 lookupTM = Map.lookup
143 alterTM k f m = Map.alter f k m
144 foldTM k m z = Map.foldr k z m
145 mapTM f m = Map.map f m
146 filterTM f m = Map.filter f m
147
148
149 {-
150 Note [foldTM determinism]
151 ~~~~~~~~~~~~~~~~~~~~~~~~~
152 We want foldTM to be deterministic, which is why we have an instance of
153 TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that
154 go wrong if foldTM is nondeterministic. Consider:
155
156 f a b = return (a <> b)
157
158 Depending on the order that the typechecker generates constraints you
159 get either:
160
161 f :: (Monad m, Monoid a) => a -> a -> m a
162
163 or:
164
165 f :: (Monoid a, Monad m) => a -> a -> m a
166
167 The generated code will be different after desugaring as the dictionaries
168 will be bound in different orders, leading to potential ABI incompatibility.
169
170 One way to solve this would be to notice that the typeclasses could be
171 sorted alphabetically.
172
173 Unfortunately that doesn't quite work with this example:
174
175 f a b = let x = a <> a; y = b <> b in x
176
177 where you infer:
178
179 f :: (Monoid m, Monoid m1) => m1 -> m -> m1
180
181 or:
182
183 f :: (Monoid m1, Monoid m) => m1 -> m -> m1
184
185 Here you could decide to take the order of the type variables in the type
186 according to depth first traversal and use it to order the constraints.
187
188 The real trouble starts when the user enables incoherent instances and
189 the compiler has to make an arbitrary choice. Consider:
190
191 class T a b where
192 go :: a -> b -> String
193
194 instance (Show b) => T Int b where
195 go a b = show a ++ show b
196
197 instance (Show a) => T a Bool where
198 go a b = show a ++ show b
199
200 f = go 10 True
201
202 GHC is free to choose either dictionary to implement f, but for the sake of
203 determinism we'd like it to be consistent when compiling the same sources
204 with the same flags.
205
206 inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it
207 gets converted to a bag of (Wanted) Cts using a fold. Then in
208 solve_simple_wanteds it's merged with other WantedConstraints. We want the
209 conversion to a bag to be deterministic. For that purpose we use UniqDFM
210 instead of UniqFM to implement the TrieMap.
211
212 See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details on how it's made
213 deterministic.
214 -}
215
216 instance forall key. Uniquable key => TrieMap (UniqDFM key) where
217 type Key (UniqDFM key) = key
218 emptyTM = emptyUDFM
219 lookupTM k m = lookupUDFM m k
220 alterTM k f m = alterUDFM f m k
221 foldTM k m z = foldUDFM k z m
222 mapTM f m = mapUDFM f m
223 filterTM f m = filterUDFM f m
224
225 {-
226 ************************************************************************
227 * *
228 Maybes
229 * *
230 ************************************************************************
231
232 If m is a map from k -> val
233 then (MaybeMap m) is a map from (Maybe k) -> val
234 -}
235
236 data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a }
237
238 instance TrieMap m => TrieMap (MaybeMap m) where
239 type Key (MaybeMap m) = Maybe (Key m)
240 emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM }
241 lookupTM = lkMaybe lookupTM
242 alterTM = xtMaybe alterTM
243 foldTM = fdMaybe
244 mapTM = mapMb
245 filterTM = ftMaybe
246
247 instance TrieMap m => Foldable (MaybeMap m) where
248 foldMap = foldMapTM
249
250 mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b
251 mapMb f (MM { mm_nothing = mn, mm_just = mj })
252 = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }
253
254 lkMaybe :: (forall b. k -> m b -> Maybe b)
255 -> Maybe k -> MaybeMap m a -> Maybe a
256 lkMaybe _ Nothing = mm_nothing
257 lkMaybe lk (Just x) = mm_just >.> lk x
258
259 xtMaybe :: (forall b. k -> XT b -> m b -> m b)
260 -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a
261 xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) }
262 xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f }
263
264 fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b
265 fdMaybe k m = foldMaybe k (mm_nothing m)
266 . foldTM k (mm_just m)
267
268 ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a
269 ftMaybe f (MM { mm_nothing = mn, mm_just = mj })
270 = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }
271
272 foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b
273 foldMaybe _ Nothing b = b
274 foldMaybe k (Just a) b = k a b
275
276 filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a
277 filterMaybe _ Nothing = Nothing
278 filterMaybe f input@(Just x) | f x = input
279 | otherwise = Nothing
280
281 {-
282 ************************************************************************
283 * *
284 Lists
285 * *
286 ************************************************************************
287 -}
288
289 data ListMap m a
290 = LM { lm_nil :: Maybe a
291 , lm_cons :: m (ListMap m a) }
292
293 instance TrieMap m => TrieMap (ListMap m) where
294 type Key (ListMap m) = [Key m]
295 emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM }
296 lookupTM = lkList lookupTM
297 alterTM = xtList alterTM
298 foldTM = fdList
299 mapTM = mapList
300 filterTM = ftList
301
302 instance TrieMap m => Foldable (ListMap m) where
303 foldMap = foldMapTM
304
305 instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where
306 ppr m = text "List elts" <+> ppr (foldTM (:) m [])
307
308 mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b
309 mapList f (LM { lm_nil = mnil, lm_cons = mcons })
310 = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons }
311
312 lkList :: TrieMap m => (forall b. k -> m b -> Maybe b)
313 -> [k] -> ListMap m a -> Maybe a
314 lkList _ [] = lm_nil
315 lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs
316
317 xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b)
318 -> [k] -> XT a -> ListMap m a -> ListMap m a
319 xtList _ [] f m = m { lm_nil = f (lm_nil m) }
320 xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f }
321
322 fdList :: forall m a b. TrieMap m
323 => (a -> b -> b) -> ListMap m a -> b -> b
324 fdList k m = foldMaybe k (lm_nil m)
325 . foldTM (fdList k) (lm_cons m)
326
327 ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a
328 ftList f (LM { lm_nil = mnil, lm_cons = mcons })
329 = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }
330
331 {-
332 ************************************************************************
333 * *
334 Basic maps
335 * *
336 ************************************************************************
337 -}
338
339 type LiteralMap a = Map.Map Literal a
340
341 {-
342 ************************************************************************
343 * *
344 GenMap
345 * *
346 ************************************************************************
347
348 Note [Compressed TrieMap]
349 ~~~~~~~~~~~~~~~~~~~~~~~~~
350
351 The GenMap constructor augments TrieMaps with leaf compression. This helps
352 solve the performance problem detailed in #9960: suppose we have a handful
353 H of entries in a TrieMap, each with a very large key, size K. If you fold over
354 such a TrieMap you'd expect time O(H). That would certainly be true of an
355 association list! But with TrieMap we actually have to navigate down a long
356 singleton structure to get to the elements, so it takes time O(K*H). This
357 can really hurt on many type-level computation benchmarks:
358 see for example T9872d.
359
360 The point of a TrieMap is that you need to navigate to the point where only one
361 key remains, and then things should be fast. So the point of a SingletonMap
362 is that, once we are down to a single (key,value) pair, we stop and
363 just use SingletonMap.
364
365 'EmptyMap' provides an even more basic (but essential) optimization: if there is
366 nothing in the map, don't bother building out the (possibly infinite) recursive
367 TrieMap structure!
368
369 Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things
370 as INLINEABLE to permit specialization.
371 -}
372
373 data GenMap m a
374 = EmptyMap
375 | SingletonMap (Key m) a
376 | MultiMap (m a)
377
378 instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where
379 ppr EmptyMap = text "Empty map"
380 ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v
381 ppr (MultiMap m) = ppr m
382
383 -- TODO undecidable instance
384 instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where
385 type Key (GenMap m) = Key m
386 emptyTM = EmptyMap
387 lookupTM = lkG
388 alterTM = xtG
389 foldTM = fdG
390 mapTM = mapG
391 filterTM = ftG
392
393 instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where
394 foldMap = foldMapTM
395
396 --We want to be able to specialize these functions when defining eg
397 --tries over (GenMap CoreExpr) which requires INLINEABLE
398
399 {-# INLINEABLE lkG #-}
400 lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a
401 lkG _ EmptyMap = Nothing
402 lkG k (SingletonMap k' v') | k == k' = Just v'
403 | otherwise = Nothing
404 lkG k (MultiMap m) = lookupTM k m
405
406 {-# INLINEABLE xtG #-}
407 xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a
408 xtG k f EmptyMap
409 = case f Nothing of
410 Just v -> SingletonMap k v
411 Nothing -> EmptyMap
412 xtG k f m@(SingletonMap k' v')
413 | k' == k
414 -- The new key matches the (single) key already in the tree. Hence,
415 -- apply @f@ to @Just v'@ and build a singleton or empty map depending
416 -- on the 'Just'/'Nothing' response respectively.
417 = case f (Just v') of
418 Just v'' -> SingletonMap k' v''
419 Nothing -> EmptyMap
420 | otherwise
421 -- We've hit a singleton tree for a different key than the one we are
422 -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then
423 -- we can just return the old map. If not, we need a map with *two*
424 -- entries. The easiest way to do that is to insert two items into an empty
425 -- map of type @m a@.
426 = case f Nothing of
427 Nothing -> m
428 Just v -> emptyTM |> alterTM k' (const (Just v'))
429 >.> alterTM k (const (Just v))
430 >.> MultiMap
431 xtG k f (MultiMap m) = MultiMap (alterTM k f m)
432
433 {-# INLINEABLE mapG #-}
434 mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b
435 mapG _ EmptyMap = EmptyMap
436 mapG f (SingletonMap k v) = SingletonMap k (f v)
437 mapG f (MultiMap m) = MultiMap (mapTM f m)
438
439 {-# INLINEABLE fdG #-}
440 fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b
441 fdG _ EmptyMap = \z -> z
442 fdG k (SingletonMap _ v) = \z -> k v z
443 fdG k (MultiMap m) = foldTM k m
444
445 {-# INLINEABLE ftG #-}
446 ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a
447 ftG _ EmptyMap = EmptyMap
448 ftG f input@(SingletonMap _ v)
449 | f v = input
450 | otherwise = EmptyMap
451 ftG f (MultiMap m) = MultiMap (filterTM f m)
452 -- we don't have enough information to reconstruct the key to make
453 -- a SingletonMap