never executed always true always false
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE RankNTypes #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE UndecidableInstances #-}
7
8 {-
9 (c) The University of Glasgow 2006
10 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
11 -}
12
13 {-# OPTIONS_GHC -Wno-orphans #-}
14 -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)
15
16 module GHC.Core.Map.Expr (
17 -- * Maps over Core expressions
18 CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,
19 -- * 'TrieMap' class reexports
20 TrieMap(..), insertTM, deleteTM,
21 lkDFreeVar, xtDFreeVar,
22 lkDNamed, xtDNamed,
23 (>.>), (|>), (|>>),
24 ) where
25
26 import GHC.Prelude
27
28 import GHC.Data.TrieMap
29 import GHC.Core.Map.Type
30 import GHC.Core
31 import GHC.Core.Type
32 import GHC.Types.Tickish
33 import GHC.Types.Var
34
35 import GHC.Utils.Misc
36 import GHC.Utils.Outputable
37
38 import qualified Data.Map as Map
39 import GHC.Types.Name.Env
40 import Control.Monad( (>=>) )
41
42 {-
43 This module implements TrieMaps over Core related data structures
44 like CoreExpr or Type. It is built on the Tries from the TrieMap
45 module.
46
47 The code is very regular and boilerplate-like, but there is
48 some neat handling of *binders*. In effect they are deBruijn
49 numbered on the fly.
50
51
52 -}
53
54 ----------------------
55 -- Recall that
56 -- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
57
58 -- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not
59 -- known when defining GenMap so we can only specialize them here.
60
61 {-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-}
62 {-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-}
63 {-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-}
64 {-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-}
65
66
67 {-
68 ************************************************************************
69 * *
70 CoreMap
71 * *
72 ************************************************************************
73 -}
74
75 {-
76 Note [Binders]
77 ~~~~~~~~~~~~~~
78 * In general we check binders as late as possible because types are
79 less likely to differ than expression structure. That's why
80 cm_lam :: CoreMapG (TypeMapG a)
81 rather than
82 cm_lam :: TypeMapG (CoreMapG a)
83
84 * We don't need to look at the type of some binders, notably
85 - the case binder in (Case _ b _ _)
86 - the binders in an alternative
87 because they are totally fixed by the context
88
89 Note [Empty case alternatives]
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
91 * For a key (Case e b ty (alt:alts)) we don't need to look the return type
92 'ty', because every alternative has that type.
93
94 * For a key (Case e b ty []) we MUST look at the return type 'ty', because
95 otherwise (Case (error () "urk") _ Int []) would compare equal to
96 (Case (error () "urk") _ Bool [])
97 which is utterly wrong (#6097)
98
99 We could compare the return type regardless, but the wildly common case
100 is that it's unnecessary, so we have two fields (cm_case and cm_ecase)
101 for the two possibilities. Only cm_ecase looks at the type.
102
103 See also Note [Empty case alternatives] in GHC.Core.
104 -}
105
106 -- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this
107 -- is the type you want.
108 newtype CoreMap a = CoreMap (CoreMapG a)
109
110 instance TrieMap CoreMap where
111 type Key CoreMap = CoreExpr
112 emptyTM = CoreMap emptyTM
113 lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m
114 alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)
115 foldTM k (CoreMap m) = foldTM k m
116 mapTM f (CoreMap m) = CoreMap (mapTM f m)
117 filterTM f (CoreMap m) = CoreMap (filterTM f m)
118
119 -- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended
120 -- key makes it suitable for recursive traversal, since it can track binders,
121 -- but it is strictly internal to this module. If you are including a 'CoreMap'
122 -- inside another 'TrieMap', this is the type you want.
123 type CoreMapG = GenMap CoreMapX
124
125 -- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without
126 -- the 'GenMap' optimization.
127 data CoreMapX a
128 = CM { cm_var :: VarMap a
129 , cm_lit :: LiteralMap a
130 , cm_co :: CoercionMapG a
131 , cm_type :: TypeMapG a
132 , cm_cast :: CoreMapG (CoercionMapG a)
133 , cm_tick :: CoreMapG (TickishMap a)
134 , cm_app :: CoreMapG (CoreMapG a)
135 , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders]
136 , cm_letn :: CoreMapG (CoreMapG (BndrMap a))
137 , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))
138 , cm_case :: CoreMapG (ListMap AltMap a)
139 , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives]
140 }
141
142 instance Eq (DeBruijn CoreExpr) where
143 D env1 e1 == D env2 e2 = go e1 e2 where
144 go (Var v1) (Var v2)
145 = case (lookupCME env1 v1, lookupCME env2 v2) of
146 (Just b1, Just b2) -> b1 == b2
147 (Nothing, Nothing) -> v1 == v2
148 _ -> False
149 go (Lit lit1) (Lit lit2) = lit1 == lit2
150 go (Type t1) (Type t2) = D env1 t1 == D env2 t2
151 go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2
152 go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2
153 go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2
154 -- This seems a bit dodgy, see 'eqTickish'
155 go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2
156
157 go (Lam b1 e1) (Lam b2 e2)
158 = D env1 (varType b1) == D env2 (varType b2)
159 && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)
160 && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2
161
162 go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
163 = go r1 r2
164 && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
165
166 go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
167 = equalLength ps1 ps2
168 && D env1' rs1 == D env2' rs2
169 && D env1' e1 == D env2' e2
170 where
171 (bs1,rs1) = unzip ps1
172 (bs2,rs2) = unzip ps2
173 env1' = extendCMEs env1 bs1
174 env2' = extendCMEs env2 bs2
175
176 go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
177 | null a1 -- See Note [Empty case alternatives]
178 = null a2 && go e1 e2 && D env1 t1 == D env2 t2
179 | otherwise
180 = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2
181
182 go _ _ = False
183
184 emptyE :: CoreMapX a
185 emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM
186 , cm_co = emptyTM, cm_type = emptyTM
187 , cm_cast = emptyTM, cm_app = emptyTM
188 , cm_lam = emptyTM, cm_letn = emptyTM
189 , cm_letr = emptyTM, cm_case = emptyTM
190 , cm_ecase = emptyTM, cm_tick = emptyTM }
191
192 instance TrieMap CoreMapX where
193 type Key CoreMapX = DeBruijn CoreExpr
194 emptyTM = emptyE
195 lookupTM = lkE
196 alterTM = xtE
197 foldTM = fdE
198 mapTM = mapE
199 filterTM = ftE
200
201 --------------------------
202 mapE :: (a->b) -> CoreMapX a -> CoreMapX b
203 mapE f (CM { cm_var = cvar, cm_lit = clit
204 , cm_co = cco, cm_type = ctype
205 , cm_cast = ccast , cm_app = capp
206 , cm_lam = clam, cm_letn = cletn
207 , cm_letr = cletr, cm_case = ccase
208 , cm_ecase = cecase, cm_tick = ctick })
209 = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit
210 , cm_co = mapTM f cco, cm_type = mapTM f ctype
211 , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp
212 , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn
213 , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase
214 , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }
215
216 ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a
217 ftE f (CM { cm_var = cvar, cm_lit = clit
218 , cm_co = cco, cm_type = ctype
219 , cm_cast = ccast , cm_app = capp
220 , cm_lam = clam, cm_letn = cletn
221 , cm_letr = cletr, cm_case = ccase
222 , cm_ecase = cecase, cm_tick = ctick })
223 = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit
224 , cm_co = filterTM f cco, cm_type = filterTM f ctype
225 , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp
226 , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn
227 , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase
228 , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }
229
230 --------------------------
231 lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a
232 lookupCoreMap cm e = lookupTM e cm
233
234 extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a
235 extendCoreMap m e v = alterTM e (\_ -> Just v) m
236
237 foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b
238 foldCoreMap k z m = foldTM k m z
239
240 emptyCoreMap :: CoreMap a
241 emptyCoreMap = emptyTM
242
243 instance Outputable a => Outputable (CoreMap a) where
244 ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])
245
246 -------------------------
247 fdE :: (a -> b -> b) -> CoreMapX a -> b -> b
248 fdE k m
249 = foldTM k (cm_var m)
250 . foldTM k (cm_lit m)
251 . foldTM k (cm_co m)
252 . foldTM k (cm_type m)
253 . foldTM (foldTM k) (cm_cast m)
254 . foldTM (foldTM k) (cm_tick m)
255 . foldTM (foldTM k) (cm_app m)
256 . foldTM (foldTM k) (cm_lam m)
257 . foldTM (foldTM (foldTM k)) (cm_letn m)
258 . foldTM (foldTM (foldTM k)) (cm_letr m)
259 . foldTM (foldTM k) (cm_case m)
260 . foldTM (foldTM k) (cm_ecase m)
261
262 -- lkE: lookup in trie for expressions
263 lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a
264 lkE (D env expr) cm = go expr cm
265 where
266 go (Var v) = cm_var >.> lkVar env v
267 go (Lit l) = cm_lit >.> lookupTM l
268 go (Type t) = cm_type >.> lkG (D env t)
269 go (Coercion c) = cm_co >.> lkG (D env c)
270 go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c)
271 go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish
272 go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1)
273 go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e)
274 >=> lkBndr env v
275 go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)
276 >=> lkG (D (extendCME env b) e) >=> lkBndr env b
277 go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs
278 env1 = extendCMEs env bndrs
279 in cm_letr
280 >.> lkList (lkG . D env1) rhss
281 >=> lkG (D env1 e)
282 >=> lkList (lkBndr env1) bndrs
283 go (Case e b ty as) -- See Note [Empty case alternatives]
284 | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)
285 | otherwise = cm_case >.> lkG (D env e)
286 >=> lkList (lkA (extendCME env b)) as
287
288 xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a
289 xtE (D env (Var v)) f m = m { cm_var = cm_var m
290 |> xtVar env v f }
291 xtE (D env (Type t)) f m = m { cm_type = cm_type m
292 |> xtG (D env t) f }
293 xtE (D env (Coercion c)) f m = m { cm_co = cm_co m
294 |> xtG (D env c) f }
295 xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f }
296 xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e)
297 |>> xtG (D env c) f }
298 xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e)
299 |>> xtTickish t f }
300 xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2)
301 |>> xtG (D env e1) f }
302 xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m
303 |> xtG (D (extendCME env v) e)
304 |>> xtBndr env v f }
305 xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m
306 |> xtG (D (extendCME env b) e)
307 |>> xtG (D env r)
308 |>> xtBndr env b f }
309 xtE (D env (Let (Rec prs) e)) f m = m { cm_letr =
310 let (bndrs,rhss) = unzip prs
311 env1 = extendCMEs env bndrs
312 in cm_letr m
313 |> xtList (xtG . D env1) rhss
314 |>> xtG (D env1 e)
315 |>> xtList (xtBndr env1)
316 bndrs f }
317 xtE (D env (Case e b ty as)) f m
318 | null as = m { cm_ecase = cm_ecase m |> xtG (D env e)
319 |>> xtG (D env ty) f }
320 | otherwise = m { cm_case = cm_case m |> xtG (D env e)
321 |>> let env1 = extendCME env b
322 in xtList (xtA env1) as f }
323
324 -- TODO: this seems a bit dodgy, see 'eqTickish'
325 type TickishMap a = Map.Map CoreTickish a
326 lkTickish :: CoreTickish -> TickishMap a -> Maybe a
327 lkTickish = lookupTM
328
329 xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a
330 xtTickish = alterTM
331
332 ------------------------
333 data AltMap a -- A single alternative
334 = AM { am_deflt :: CoreMapG a
335 , am_data :: DNameEnv (CoreMapG a)
336 , am_lit :: LiteralMap (CoreMapG a) }
337
338 instance TrieMap AltMap where
339 type Key AltMap = CoreAlt
340 emptyTM = AM { am_deflt = emptyTM
341 , am_data = emptyDNameEnv
342 , am_lit = emptyTM }
343 lookupTM = lkA emptyCME
344 alterTM = xtA emptyCME
345 foldTM = fdA
346 mapTM = mapA
347 filterTM = ftA
348
349 instance Eq (DeBruijn CoreAlt) where
350 D env1 a1 == D env2 a2 = go a1 a2 where
351 go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2)
352 = D env1 rhs1 == D env2 rhs2
353 go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2)
354 = lit1 == lit2 && D env1 rhs1 == D env2 rhs2
355 go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2)
356 = dc1 == dc2 &&
357 D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2
358 go _ _ = False
359
360 mapA :: (a->b) -> AltMap a -> AltMap b
361 mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
362 = AM { am_deflt = mapTM f adeflt
363 , am_data = mapTM (mapTM f) adata
364 , am_lit = mapTM (mapTM f) alit }
365
366 ftA :: (a->Bool) -> AltMap a -> AltMap a
367 ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })
368 = AM { am_deflt = filterTM f adeflt
369 , am_data = mapTM (filterTM f) adata
370 , am_lit = mapTM (filterTM f) alit }
371
372 lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a
373 lkA env (Alt DEFAULT _ rhs) = am_deflt >.> lkG (D env rhs)
374 lkA env (Alt (LitAlt lit) _ rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)
375 lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc
376 >=> lkG (D (extendCMEs env bs) rhs)
377
378 xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a
379 xtA env (Alt DEFAULT _ rhs) f m =
380 m { am_deflt = am_deflt m |> xtG (D env rhs) f }
381 xtA env (Alt (LitAlt l) _ rhs) f m =
382 m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f }
383 xtA env (Alt (DataAlt d) bs rhs) f m =
384 m { am_data = am_data m |> xtDNamed d
385 |>> xtG (D (extendCMEs env bs) rhs) f }
386
387 fdA :: (a -> b -> b) -> AltMap a -> b -> b
388 fdA k m = foldTM k (am_deflt m)
389 . foldTM (foldTM k) (am_data m)
390 . foldTM (foldTM k) (am_lit m)