be9f463eb7b1dcd3954ad275b2be91fcd81f96a6
[ghc.git] / compiler / coreSyn / CoreUtils.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Utility functions on @Core@ syntax
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 -- | Commonly useful utilites for manipulating the Core language
12 module CoreUtils (
13 -- * Constructing expressions
14 mkCast,
15 mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
16 bindNonRec, needsCaseBinding,
17 mkAltExpr,
18
19 -- * Taking expressions apart
20 findDefault, addDefault, findAlt, isDefaultAlt,
21 mergeAlts, trimConArgs,
22 filterAlts, combineIdenticalAlts, refineDefaultAlt,
23
24 -- * Properties of expressions
25 exprType, coreAltType, coreAltsType,
26 exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
27 exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
28 exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
29 exprIsBig, exprIsConLike,
30 rhsIsStatic, isCheapApp, isExpandableApp,
31
32 -- * Equality
33 cheapEqExpr, cheapEqExpr', eqExpr,
34 diffExpr, diffBinds,
35
36 -- * Eta reduction
37 tryEtaReduce,
38
39 -- * Manipulating data constructors and types
40 exprToType, exprToCoercion_maybe,
41 applyTypeToArgs, applyTypeToArg,
42 dataConRepInstPat, dataConRepFSInstPat,
43 isEmptyTy,
44
45 -- * Working with ticks
46 stripTicksTop, stripTicksTopE, stripTicksTopT,
47 stripTicksE, stripTicksT
48 ) where
49
50 #include "HsVersions.h"
51
52 import CoreSyn
53 import PprCore
54 import CoreFVs( exprFreeVars )
55 import Var
56 import SrcLoc
57 import VarEnv
58 import VarSet
59 import Name
60 import Literal
61 import DataCon
62 import PrimOp
63 import Id
64 import IdInfo
65 import Type
66 import Coercion
67 import TyCon
68 import Unique
69 import Outputable
70 import TysPrim
71 import DynFlags
72 import FastString
73 import Maybes
74 import ListSetOps ( minusList )
75 import Platform
76 import Util
77 import Pair
78 import Data.Function ( on )
79 import Data.List
80 import Data.Ord ( comparing )
81 import OrdList
82
83 {-
84 ************************************************************************
85 * *
86 \subsection{Find the type of a Core atom/expression}
87 * *
88 ************************************************************************
89 -}
90
91 exprType :: CoreExpr -> Type
92 -- ^ Recover the type of a well-typed Core expression. Fails when
93 -- applied to the actual 'CoreSyn.Type' expression as it cannot
94 -- really be said to have a type
95 exprType (Var var) = idType var
96 exprType (Lit lit) = literalType lit
97 exprType (Coercion co) = coercionType co
98 exprType (Let bind body)
99 | NonRec tv rhs <- bind -- See Note [Type bindings]
100 , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body)
101 | otherwise = exprType body
102 exprType (Case _ _ ty _) = ty
103 exprType (Cast _ co) = pSnd (coercionKind co)
104 exprType (Tick _ e) = exprType e
105 exprType (Lam binder expr) = mkPiType binder (exprType expr)
106 exprType e@(App _ _)
107 = case collectArgs e of
108 (fun, args) -> applyTypeToArgs e (exprType fun) args
109
110 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
111
112 coreAltType :: CoreAlt -> Type
113 -- ^ Returns the type of the alternatives right hand side
114 coreAltType (_,bs,rhs)
115 | any bad_binder bs = expandTypeSynonyms ty
116 | otherwise = ty -- Note [Existential variables and silly type synonyms]
117 where
118 ty = exprType rhs
119 free_tvs = tyCoVarsOfType ty
120 bad_binder b = b `elemVarSet` free_tvs
121
122 coreAltsType :: [CoreAlt] -> Type
123 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
124 coreAltsType (alt:_) = coreAltType alt
125 coreAltsType [] = panic "corAltsType"
126
127 {-
128 Note [Type bindings]
129 ~~~~~~~~~~~~~~~~~~~~
130 Core does allow type bindings, although such bindings are
131 not much used, except in the output of the desuguarer.
132 Example:
133 let a = Int in (\x:a. x)
134 Given this, exprType must be careful to substitute 'a' in the
135 result type (Trac #8522).
136
137 Note [Existential variables and silly type synonyms]
138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
139 Consider
140 data T = forall a. T (Funny a)
141 type Funny a = Bool
142 f :: T -> Bool
143 f (T x) = x
144
145 Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
146 That means that 'exprType' and 'coreAltsType' may give a result that *appears*
147 to mention an out-of-scope type variable. See Trac #3409 for a more real-world
148 example.
149
150 Various possibilities suggest themselves:
151
152 - Ignore the problem, and make Lint not complain about such variables
153
154 - Expand all type synonyms (or at least all those that discard arguments)
155 This is tricky, because at least for top-level things we want to
156 retain the type the user originally specified.
157
158 - Expand synonyms on the fly, when the problem arises. That is what
159 we are doing here. It's not too expensive, I think.
160
161 Note that there might be existentially quantified coercion variables, too.
162 -}
163
164 -- Not defined with applyTypeToArg because you can't print from CoreSyn.
165 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
166 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
167 -- The first argument is just for debugging, and gives some context
168 applyTypeToArgs e op_ty args
169 = go op_ty args
170 where
171 go op_ty [] = op_ty
172 go op_ty (Type ty : args) = go_ty_args op_ty [ty] args
173 go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args
174 go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty
175 = go res_ty args
176 go _ _ = pprPanic "applyTypeToArgs" panic_msg
177
178 -- go_ty_args: accumulate type arguments so we can instantiate all at once
179 go_ty_args op_ty rev_tys (Type ty : args)
180 = go_ty_args op_ty (ty:rev_tys) args
181 go_ty_args op_ty rev_tys (Coercion co : args)
182 = go_ty_args op_ty (mkCoercionTy co : rev_tys) args
183 go_ty_args op_ty rev_tys args
184 = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args
185
186 panic_msg_w_hdr = hang (text "applyTypeToArgs") 2 panic_msg
187 panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e
188 , text "Type:" <+> ppr op_ty
189 , text "Args:" <+> ppr args ]
190
191
192 {-
193 ************************************************************************
194 * *
195 \subsection{Attaching notes}
196 * *
197 ************************************************************************
198 -}
199
200 -- | Wrap the given expression in the coercion safely, dropping
201 -- identity coercions and coalescing nested coercions
202 mkCast :: CoreExpr -> Coercion -> CoreExpr
203 mkCast e co
204 | ASSERT2( coercionRole co == Representational
205 , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")
206 <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )
207 isReflCo co
208 = e
209
210 mkCast (Coercion e_co) co
211 | isCoercionType (pSnd (coercionKind co))
212 -- The guard here checks that g has a (~#) on both sides,
213 -- otherwise decomposeCo fails. Can in principle happen
214 -- with unsafeCoerce
215 = Coercion (mkCoCast e_co co)
216
217 mkCast (Cast expr co2) co
218 = WARN(let { Pair from_ty _to_ty = coercionKind co;
219 Pair _from_ty2 to_ty2 = coercionKind co2} in
220 not (from_ty `eqType` to_ty2),
221 vcat ([ text "expr:" <+> ppr expr
222 , text "co2:" <+> ppr co2
223 , text "co:" <+> ppr co ]) )
224 mkCast expr (mkTransCo co2 co)
225
226 mkCast (Tick t expr) co
227 = Tick t (mkCast expr co)
228
229 mkCast expr co
230 = let Pair from_ty _to_ty = coercionKind co in
231 WARN( not (from_ty `eqType` exprType expr),
232 text "Trying to coerce" <+> text "(" <> ppr expr
233 $$ text "::" <+> ppr (exprType expr) <> text ")"
234 $$ ppr co $$ ppr (coercionType co) )
235 (Cast expr co)
236
237 -- | Wraps the given expression in the source annotation, dropping the
238 -- annotation if possible.
239 mkTick :: Tickish Id -> CoreExpr -> CoreExpr
240 mkTick t orig_expr = mkTick' id id orig_expr
241 where
242 -- Some ticks (cost-centres) can be split in two, with the
243 -- non-counting part having laxer placement properties.
244 canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
245
246 mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)
247 -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)
248 -> CoreExpr -- ^ current expression
249 -> CoreExpr
250 mkTick' top rest expr = case expr of
251
252 -- Cost centre ticks should never be reordered relative to each
253 -- other. Therefore we can stop whenever two collide.
254 Tick t2 e
255 | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr
256
257 -- Otherwise we assume that ticks of different placements float
258 -- through each other.
259 | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e
260
261 -- For annotations this is where we make sure to not introduce
262 -- redundant ticks.
263 | tickishContains t t2 -> mkTick' top rest e
264 | tickishContains t2 t -> orig_expr
265 | otherwise -> mkTick' top (rest . Tick t2) e
266
267 -- Ticks don't care about types, so we just float all ticks
268 -- through them. Note that it's not enough to check for these
269 -- cases top-level. While mkTick will never produce Core with type
270 -- expressions below ticks, such constructs can be the result of
271 -- unfoldings. We therefore make an effort to put everything into
272 -- the right place no matter what we start with.
273 Cast e co -> mkTick' (top . flip Cast co) rest e
274 Coercion co -> Coercion co
275
276 Lam x e
277 -- Always float through type lambdas. Even for non-type lambdas,
278 -- floating is allowed for all but the most strict placement rule.
279 | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
280 -> mkTick' (top . Lam x) rest e
281
282 -- If it is both counting and scoped, we split the tick into its
283 -- two components, often allowing us to keep the counting tick on
284 -- the outside of the lambda and push the scoped tick inside.
285 -- The point of this is that the counting tick can probably be
286 -- floated, and the lambda may then be in a position to be
287 -- beta-reduced.
288 | canSplit
289 -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e
290
291 App f arg
292 -- Always float through type applications.
293 | not (isRuntimeArg arg)
294 -> mkTick' (top . flip App arg) rest f
295
296 -- We can also float through constructor applications, placement
297 -- permitting. Again we can split.
298 | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
299 -> if tickishPlace t == PlaceCostCentre
300 then top $ rest $ tickHNFArgs t expr
301 else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr
302
303 Var x
304 | notFunction && tickishPlace t == PlaceCostCentre
305 -> orig_expr
306 | notFunction && canSplit
307 -> top $ Tick (mkNoScope t) $ rest expr
308 where
309 -- SCCs can be eliminated on variables provided the variable
310 -- is not a function. In these cases the SCC makes no difference:
311 -- the cost of evaluating the variable will be attributed to its
312 -- definition site. When the variable refers to a function, however,
313 -- an SCC annotation on the variable affects the cost-centre stack
314 -- when the function is called, so we must retain those.
315 notFunction = not (isFunTy (idType x))
316
317 Lit{}
318 | tickishPlace t == PlaceCostCentre
319 -> orig_expr
320
321 -- Catch-all: Annotate where we stand
322 _any -> top $ Tick t $ rest expr
323
324 mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
325 mkTicks ticks expr = foldr mkTick expr ticks
326
327 isSaturatedConApp :: CoreExpr -> Bool
328 isSaturatedConApp e = go e []
329 where go (App f a) as = go f (a:as)
330 go (Var fun) args
331 = isConLikeId fun && idArity fun == valArgCount args
332 go (Cast f _) as = go f as
333 go _ _ = False
334
335 mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr
336 mkTickNoHNF t e
337 | exprIsHNF e = tickHNFArgs t e
338 | otherwise = mkTick t e
339
340 -- push a tick into the arguments of a HNF (call or constructor app)
341 tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
342 tickHNFArgs t e = push t e
343 where
344 push t (App f (Type u)) = App (push t f) (Type u)
345 push t (App f arg) = App (push t f) (mkTick t arg)
346 push _t e = e
347
348 -- | Strip ticks satisfying a predicate from top of an expression
349 stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
350 stripTicksTop p = go []
351 where go ts (Tick t e) | p t = go (t:ts) e
352 go ts other = (reverse ts, other)
353
354 -- | Strip ticks satisfying a predicate from top of an expression,
355 -- returning the remaining expresion
356 stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
357 stripTicksTopE p = go
358 where go (Tick t e) | p t = go e
359 go other = other
360
361 -- | Strip ticks satisfying a predicate from top of an expression,
362 -- returning the ticks
363 stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
364 stripTicksTopT p = go []
365 where go ts (Tick t e) | p t = go (t:ts) e
366 go ts _ = ts
367
368 -- | Completely strip ticks satisfying a predicate from an
369 -- expression. Note this is O(n) in the size of the expression!
370 stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
371 stripTicksE p expr = go expr
372 where go (App e a) = App (go e) (go a)
373 go (Lam b e) = Lam b (go e)
374 go (Let b e) = Let (go_bs b) (go e)
375 go (Case e b t as) = Case (go e) b t (map go_a as)
376 go (Cast e c) = Cast (go e) c
377 go (Tick t e)
378 | p t = go e
379 | otherwise = Tick t (go e)
380 go other = other
381 go_bs (NonRec b e) = NonRec b (go e)
382 go_bs (Rec bs) = Rec (map go_b bs)
383 go_b (b, e) = (b, go e)
384 go_a (c,bs,e) = (c,bs, go e)
385
386 stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
387 stripTicksT p expr = fromOL $ go expr
388 where go (App e a) = go e `appOL` go a
389 go (Lam _ e) = go e
390 go (Let b e) = go_bs b `appOL` go e
391 go (Case e _ _ as) = go e `appOL` concatOL (map go_a as)
392 go (Cast e _) = go e
393 go (Tick t e)
394 | p t = t `consOL` go e
395 | otherwise = go e
396 go _ = nilOL
397 go_bs (NonRec _ e) = go e
398 go_bs (Rec bs) = concatOL (map go_b bs)
399 go_b (_, e) = go e
400 go_a (_, _, e) = go e
401
402 {-
403 ************************************************************************
404 * *
405 \subsection{Other expression construction}
406 * *
407 ************************************************************************
408 -}
409
410 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
411 -- ^ @bindNonRec x r b@ produces either:
412 --
413 -- > let x = r in b
414 --
415 -- or:
416 --
417 -- > case r of x { _DEFAULT_ -> b }
418 --
419 -- depending on whether we have to use a @case@ or @let@
420 -- binding for the expression (see 'needsCaseBinding').
421 -- It's used by the desugarer to avoid building bindings
422 -- that give Core Lint a heart attack, although actually
423 -- the simplifier deals with them perfectly well. See
424 -- also 'MkCore.mkCoreLet'
425 bindNonRec bndr rhs body
426 | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
427 | otherwise = Let (NonRec bndr rhs) body
428
429 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
430 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
431 needsCaseBinding :: Type -> CoreExpr -> Bool
432 needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs)
433 -- Make a case expression instead of a let
434 -- These can arise either from the desugarer,
435 -- or from beta reductions: (\x.e) (x +# y)
436
437 mkAltExpr :: AltCon -- ^ Case alternative constructor
438 -> [CoreBndr] -- ^ Things bound by the pattern match
439 -> [Type] -- ^ The type arguments to the case alternative
440 -> CoreExpr
441 -- ^ This guy constructs the value that the scrutinee must have
442 -- given that you are in one particular branch of a case
443 mkAltExpr (DataAlt con) args inst_tys
444 = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
445 mkAltExpr (LitAlt lit) [] []
446 = Lit lit
447 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
448 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
449
450 {-
451 ************************************************************************
452 * *
453 Operations oer case alternatives
454 * *
455 ************************************************************************
456
457 The default alternative must be first, if it exists at all.
458 This makes it easy to find, though it makes matching marginally harder.
459 -}
460
461 -- | Extract the default case alternative
462 findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
463 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
464 findDefault alts = (alts, Nothing)
465
466 addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
467 addDefault alts Nothing = alts
468 addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts
469
470 isDefaultAlt :: (AltCon, a, b) -> Bool
471 isDefaultAlt (DEFAULT, _, _) = True
472 isDefaultAlt _ = False
473
474 -- | Find the case alternative corresponding to a particular
475 -- constructor: panics if no such constructor exists
476 findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
477 -- A "Nothing" result *is* legitmiate
478 -- See Note [Unreachable code]
479 findAlt con alts
480 = case alts of
481 (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
482 _ -> go alts Nothing
483 where
484 go [] deflt = deflt
485 go (alt@(con1,_,_) : alts) deflt
486 = case con `cmpAltCon` con1 of
487 LT -> deflt -- Missed it already; the alts are in increasing order
488 EQ -> Just alt
489 GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
490
491 {- Note [Unreachable code]
492 ~~~~~~~~~~~~~~~~~~~~~~~~~~
493 It is possible (although unusual) for GHC to find a case expression
494 that cannot match. For example:
495
496 data Col = Red | Green | Blue
497 x = Red
498 f v = case x of
499 Red -> ...
500 _ -> ...(case x of { Green -> e1; Blue -> e2 })...
501
502 Suppose that for some silly reason, x isn't substituted in the case
503 expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff
504 gets in the way; cf Trac #3118.) Then the full-lazines pass might produce
505 this
506
507 x = Red
508 lvl = case x of { Green -> e1; Blue -> e2 })
509 f v = case x of
510 Red -> ...
511 _ -> ...lvl...
512
513 Now if x gets inlined, we won't be able to find a matching alternative
514 for 'Red'. That's because 'lvl' is unreachable. So rather than crashing
515 we generate (error "Inaccessible alternative").
516
517 Similar things can happen (augmented by GADTs) when the Simplifier
518 filters down the matching alternatives in Simplify.rebuildCase.
519 -}
520
521 ---------------------------------
522 mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
523 -- ^ Merge alternatives preserving order; alternatives in
524 -- the first argument shadow ones in the second
525 mergeAlts [] as2 = as2
526 mergeAlts as1 [] = as1
527 mergeAlts (a1:as1) (a2:as2)
528 = case a1 `cmpAlt` a2 of
529 LT -> a1 : mergeAlts as1 (a2:as2)
530 EQ -> a1 : mergeAlts as1 as2 -- Discard a2
531 GT -> a2 : mergeAlts (a1:as1) as2
532
533
534 ---------------------------------
535 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
536 -- ^ Given:
537 --
538 -- > case (C a b x y) of
539 -- > C b x y -> ...
540 --
541 -- We want to drop the leading type argument of the scrutinee
542 -- leaving the arguments to match against the pattern
543
544 trimConArgs DEFAULT args = ASSERT( null args ) []
545 trimConArgs (LitAlt _) args = ASSERT( null args ) []
546 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
547
548 filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities)
549 -> [Type] -- ^ And its type arguments
550 -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
551 -> [(AltCon, [Var], a)] -- ^ Alternatives
552 -> ([AltCon], [(AltCon, [Var], a)])
553 -- Returns:
554 -- 1. Constructors that will never be encountered by the
555 -- *default* case (if any). A superset of imposs_cons
556 -- 2. The new alternatives, trimmed by
557 -- a) remove imposs_cons
558 -- b) remove constructors which can't match because of GADTs
559 -- and with the DEFAULT expanded to a DataAlt if there is exactly
560 -- remaining constructor that can match
561 --
562 -- NB: the final list of alternatives may be empty:
563 -- This is a tricky corner case. If the data type has no constructors,
564 -- which GHC allows, or if the imposs_cons covers all constructors (after taking
565 -- account of GADTs), then no alternatives can match.
566 --
567 -- If callers need to preserve the invariant that there is always at least one branch
568 -- in a "case" statement then they will need to manually add a dummy case branch that just
569 -- calls "error" or similar.
570 filterAlts _tycon inst_tys imposs_cons alts
571 = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)
572 where
573 (alts_wo_default, maybe_deflt) = findDefault alts
574 alt_cons = [con | (con,_,_) <- alts_wo_default]
575
576 trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default
577
578 imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
579 -- "imposs_deflt_cons" are handled
580 -- EITHER by the context,
581 -- OR by a non-DEFAULT branch in this case expression.
582
583 impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
584 impossible_alt _ (con, _, _) | con `elem` imposs_cons = True
585 impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
586 impossible_alt _ _ = False
587
588 refineDefaultAlt :: [Unique] -> TyCon -> [Type]
589 -> [AltCon] -- Constructors tha cannot match the DEFAULT (if any)
590 -> [CoreAlt]
591 -> (Bool, [CoreAlt])
592 -- Refine the default alterantive to a DataAlt,
593 -- if there is a unique way to do so
594 refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
595 | (DEFAULT,_,rhs) : rest_alts <- all_alts
596 , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples.
597 , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval:
598 -- case x of { DEFAULT -> e }
599 -- and we don't want to fill in a default for them!
600 , Just all_cons <- tyConDataCons_maybe tycon
601 , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons] -- We now know it's a data type
602 impossible con = con `elem` imposs_data_cons || dataConCannotMatch tys con
603 = case filterOut impossible all_cons of
604 -- Eliminate the default alternative
605 -- altogether if it can't match:
606 [] -> (False, rest_alts)
607
608 -- It matches exactly one constructor, so fill it in:
609 [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)])
610 -- We need the mergeAlts to keep the alternatives in the right order
611 where
612 (ex_tvs, arg_ids) = dataConRepInstPat us con tys
613
614 -- It matches more than one, so do nothing
615 _ -> (False, all_alts)
616
617 | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)
618 , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
619 -- Check for no data constructors
620 -- This can legitimately happen for abstract types and type families,
621 -- so don't report that
622 = (False, all_alts)
623
624 | otherwise -- The common case
625 = (False, all_alts)
626
627 {- Note [Combine identical alternatives]
628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
629 If several alternatives are identical, merge them into a single
630 DEFAULT alternative. I've occasionally seen this making a big
631 difference:
632
633 case e of =====> case e of
634 C _ -> f x D v -> ....v....
635 D v -> ....v.... DEFAULT -> f x
636 DEFAULT -> f x
637
638 The point is that we merge common RHSs, at least for the DEFAULT case.
639 [One could do something more elaborate but I've never seen it needed.]
640 To avoid an expensive test, we just merge branches equal to the *first*
641 alternative; this picks up the common cases
642 a) all branches equal
643 b) some branches equal to the DEFAULT (which occurs first)
644
645 The case where Combine Identical Alternatives transformation showed up
646 was like this (base/Foreign/C/Err/Error.hs):
647
648 x | p `is` 1 -> e1
649 | p `is` 2 -> e2
650 ...etc...
651
652 where @is@ was something like
653
654 p `is` n = p /= (-1) && p == n
655
656 This gave rise to a horrible sequence of cases
657
658 case p of
659 (-1) -> $j p
660 1 -> e1
661 DEFAULT -> $j p
662
663 and similarly in cascade for all the join points!
664
665 NB: it's important that all this is done in [InAlt], *before* we work
666 on the alternatives themselves, because Simpify.simplAlt may zap the
667 occurrence info on the binders in the alternatives, which in turn
668 defeats combineIdenticalAlts (see Trac #7360).
669
670 Note [Care with impossible-constructors when combining alternatives]
671 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
672 Suppose we have (Trac #10538)
673 data T = A | B | C | D
674
675 case x::T of (Imposs-default-cons {A,B})
676 DEFAULT -> e1
677 A -> e2
678 B -> e1
679
680 When calling combineIdentialAlts, we'll have computed that the
681 "impossible constructors" for the DEFAULT alt is {A,B}, since if x is
682 A or B we'll take the other alternatives. But suppose we combine B
683 into the DEFAULT, to get
684
685 case x::T of (Imposs-default-cons {A})
686 DEFAULT -> e1
687 A -> e2
688
689 Then we must be careful to trim the impossible constructors to just {A},
690 else we risk compiling 'e1' wrong!
691
692 Not only that, but we take care when there is no DEFAULT beforehand,
693 because we are introducing one. Consider
694
695 case x of (Imposs-default-cons {A,B,C})
696 A -> e1
697 B -> e2
698 C -> e1
699
700 Then when combining the A and C alternatives we get
701
702 case x of (Imposs-default-cons {B})
703 DEFAULT -> e1
704 B -> e2
705
706 Note that we have a new DEFAULT branch that we didn't have before. So
707 we need delete from the "impossible-default-constructors" all the
708 known-con alternatives that we have eliminated. (In Trac #11172 we
709 missed the first one.)
710
711 -}
712
713 combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT
714 -> [CoreAlt]
715 -> (Bool, -- True <=> something happened
716 [AltCon], -- New contructors that cannot match DEFAULT
717 [CoreAlt]) -- New alternatives
718 -- See Note [Combine identical alternatives]
719 -- True <=> we did some combining, result is a single DEFAULT alternative
720 combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)
721 | all isDeadBinder bndrs1 -- Remember the default
722 , not (null elim_rest) -- alternative comes first
723 = (True, imposs_deflt_cons', deflt_alt : filtered_rest)
724 where
725 (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts
726 deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
727
728 -- See Note [Care with impossible-constructors when combining alternatives]
729 imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons
730 elim_cons = elim_con1 ++ map fstOf3 elim_rest
731 elim_con1 = case con1 of -- Don't forget con1!
732 DEFAULT -> [] -- See Note [
733 _ -> [con1]
734
735 cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
736 identical_to_alt1 (_con,bndrs,rhs)
737 = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
738 tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
739
740 combineIdenticalAlts imposs_cons alts
741 = (False, imposs_cons, alts)
742
743 {- *********************************************************************
744 * *
745 exprIsTrivial
746 * *
747 ************************************************************************
748
749 Note [exprIsTrivial]
750 ~~~~~~~~~~~~~~~~~~~~
751 @exprIsTrivial@ is true of expressions we are unconditionally happy to
752 duplicate; simple variables and constants, and type
753 applications. Note that primop Ids aren't considered
754 trivial unless
755
756 Note [Variable are trivial]
757 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
758 There used to be a gruesome test for (hasNoBinding v) in the
759 Var case:
760 exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
761 The idea here is that a constructor worker, like \$wJust, is
762 really short for (\x -> \$wJust x), because \$wJust has no binding.
763 So it should be treated like a lambda. Ditto unsaturated primops.
764 But now constructor workers are not "have-no-binding" Ids. And
765 completely un-applied primops and foreign-call Ids are sufficiently
766 rare that I plan to allow them to be duplicated and put up with
767 saturating them.
768
769 Note [Tick trivial]
770 ~~~~~~~~~~~~~~~~~~~
771 Ticks are only trivial if they are pure annotations. If we treat
772 "tick<n> x" as trivial, it will be inlined inside lambdas and the
773 entry count will be skewed, for example. Furthermore "scc<n> x" will
774 turn into just "x" in mkTick.
775
776 Note [Empty case is trivial]
777 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
778 The expression (case (x::Int) Bool of {}) is just a type-changing
779 case used when we are sure that 'x' will not return. See
780 Note [Empty case alternatives] in CoreSyn.
781
782 If the scrutinee is trivial, then so is the whole expression; and the
783 CoreToSTG pass in fact drops the case expression leaving only the
784 scrutinee.
785
786 Having more trivial expressions is good. Moreover, if we don't treat
787 it as trivial we may land up with let-bindings like
788 let v = case x of {} in ...
789 and after CoreToSTG that gives
790 let v = x in ...
791 and that confuses the code generator (Trac #11155). So best to kill
792 it off at source.
793 -}
794
795 exprIsTrivial :: CoreExpr -> Bool
796 exprIsTrivial (Var _) = True -- See Note [Variables are trivial]
797 exprIsTrivial (Type _) = True
798 exprIsTrivial (Coercion _) = True
799 exprIsTrivial (Lit lit) = litIsTrivial lit
800 exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e
801 exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e
802 -- See Note [Tick trivial]
803 exprIsTrivial (Cast e _) = exprIsTrivial e
804 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
805 exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial]
806 exprIsTrivial _ = False
807
808 {-
809 When substituting in a breakpoint we need to strip away the type cruft
810 from a trivial expression and get back to the Id. The invariant is
811 that the expression we're substituting was originally trivial
812 according to exprIsTrivial.
813 -}
814
815 getIdFromTrivialExpr :: CoreExpr -> Id
816 getIdFromTrivialExpr e = go e
817 where go (Var v) = v
818 go (App f t) | not (isRuntimeArg t) = go f
819 go (Tick t e) | not (tickishIsCode t) = go e
820 go (Cast e _) = go e
821 go (Lam b e) | not (isRuntimeVar b) = go e
822 go e = pprPanic "getIdFromTrivialExpr" (ppr e)
823
824 {-
825 exprIsBottom is a very cheap and cheerful function; it may return
826 False for bottoming expressions, but it never costs much to ask. See
827 also CoreArity.exprBotStrictness_maybe, but that's a bit more
828 expensive.
829 -}
830
831 exprIsBottom :: CoreExpr -> Bool
832 -- See Note [Bottoming expressions]
833 exprIsBottom e
834 | isEmptyTy (exprType e)
835 = True
836 | otherwise
837 = go 0 e
838 where
839 go n (Var v) = isBottomingId v && n >= idArity v
840 go n (App e a) | isTypeArg a = go n e
841 | otherwise = go (n+1) e
842 go n (Tick _ e) = go n e
843 go n (Cast e _) = go n e
844 go n (Let _ e) = go n e
845 go n (Lam v e) | isTyVar v = go n e
846 go _ (Case _ _ _ alts) = null alts
847 -- See Note [Empty case alternatives] in CoreSyn
848 go _ _ = False
849
850 {- Note [Bottoming expressions]
851 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
852 A bottoming expression is guaranteed to diverge, or raise an
853 exception. We can test for it in two different ways, and exprIsBottom
854 checks for both of these situations:
855
856 * Visibly-bottom computations. For example
857 (error Int "Hello")
858 is visibly bottom. The strictness analyser also finds out if
859 a function diverges or raises an exception, and puts that info
860 in its strictness signature.
861
862 * Empty types. If a type is empty, its only inhabitant is bottom.
863 For example:
864 data T
865 f :: T -> Bool
866 f = \(x:t). case x of Bool {}
867 Since T has no data constructors, the case alternatives are of course
868 empty. However note that 'x' is not bound to a visibly-bottom value;
869 it's the *type* that tells us it's going to diverge.
870
871 A GADT may also be empty even though it has constructors:
872 data T a where
873 T1 :: a -> T Bool
874 T2 :: T Int
875 ...(case (x::T Char) of {})...
876 Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool),
877 which is likewise uninhabited.
878
879
880 ************************************************************************
881 * *
882 exprIsDupable
883 * *
884 ************************************************************************
885
886 Note [exprIsDupable]
887 ~~~~~~~~~~~~~~~~~~~~
888 @exprIsDupable@ is true of expressions that can be duplicated at a modest
889 cost in code size. This will only happen in different case
890 branches, so there's no issue about duplicating work.
891
892 That is, exprIsDupable returns True of (f x) even if
893 f is very very expensive to call.
894
895 Its only purpose is to avoid fruitless let-binding
896 and then inlining of case join points
897 -}
898
899 exprIsDupable :: DynFlags -> CoreExpr -> Bool
900 exprIsDupable dflags e
901 = isJust (go dupAppSize e)
902 where
903 go :: Int -> CoreExpr -> Maybe Int
904 go n (Type {}) = Just n
905 go n (Coercion {}) = Just n
906 go n (Var {}) = decrement n
907 go n (Tick _ e) = go n e
908 go n (Cast e _) = go n e
909 go n (App f a) | Just n' <- go n a = go n' f
910 go n (Lit lit) | litIsDupable dflags lit = decrement n
911 go _ _ = Nothing
912
913 decrement :: Int -> Maybe Int
914 decrement 0 = Nothing
915 decrement n = Just (n-1)
916
917 dupAppSize :: Int
918 dupAppSize = 8 -- Size of term we are prepared to duplicate
919 -- This is *just* big enough to make test MethSharing
920 -- inline enough join points. Really it should be
921 -- smaller, and could be if we fixed Trac #4960.
922
923 {-
924 ************************************************************************
925 * *
926 exprIsCheap, exprIsExpandable
927 * *
928 ************************************************************************
929
930 Note [exprIsWorkFree]
931 ~~~~~~~~~~~~~~~~~~~~~
932 exprIsWorkFree is used when deciding whether to inline something; we
933 don't inline it if doing so might duplicate work, by peeling off a
934 complete copy of the expression. Here we do not want even to
935 duplicate a primop (Trac #5623):
936 eg let x = a #+ b in x +# x
937 we do not want to inline/duplicate x
938
939 Previously we were a bit more liberal, which led to the primop-duplicating
940 problem. However, being more conservative did lead to a big regression in
941 one nofib benchmark, wheel-sieve1. The situation looks like this:
942
943 let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool
944 noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->
945 case GHC.Prim.<=# x_aRs 2 of _ {
946 GHC.Types.False -> notDivBy ps_adM qs_adN;
947 GHC.Types.True -> lvl_r2Eb }}
948 go = \x. ...(noFactor (I# y))....(go x')...
949
950 The function 'noFactor' is heap-allocated and then called. Turns out
951 that 'notDivBy' is strict in its THIRD arg, but that is invisible to
952 the caller of noFactor, which therefore cannot do w/w and
953 heap-allocates noFactor's argument. At the moment (May 12) we are just
954 going to put up with this, because the previous more aggressive inlining
955 (which treated 'noFactor' as work-free) was duplicating primops, which
956 in turn was making inner loops of array calculations runs slow (#5623)
957 -}
958
959 exprIsWorkFree :: CoreExpr -> Bool
960 -- See Note [exprIsWorkFree]
961 exprIsWorkFree e = go 0 e
962 where -- n is the number of value arguments
963 go _ (Lit {}) = True
964 go _ (Type {}) = True
965 go _ (Coercion {}) = True
966 go n (Cast e _) = go n e
967 go n (Case scrut _ _ alts) = foldl (&&) (exprIsWorkFree scrut)
968 [ go n rhs | (_,_,rhs) <- alts ]
969 -- See Note [Case expressions are work-free]
970 go _ (Let {}) = False
971 go n (Var v) = isCheapApp v n
972 go n (Tick t e) | tickishCounts t = False
973 | otherwise = go n e
974 go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
975 | otherwise = go n e
976 go n (App f e) | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
977 | otherwise = go n f
978
979 {-
980 Note [Case expressions are work-free]
981 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
982 Are case-expressions work-free? Consider
983 let v = case x of (p,q) -> p
984 go = \y -> ...case v of ...
985 Should we inline 'v' at its use site inside the loop? At the moment
986 we do. I experimented with saying that case are *not* work-free, but
987 that increased allocation slightly. It's a fairly small effect, and at
988 the moment we go for the slightly more aggressive version which treats
989 (case x of ....) as work-free if the alternatives are.
990
991
992 Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables]
993 ~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs
994 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
995 it is obviously in weak head normal form, or is cheap to get to WHNF.
996 [Note that that's not the same as exprIsDupable; an expression might be
997 big, and hence not dupable, but still cheap.]
998
999 By ``cheap'' we mean a computation we're willing to:
1000 push inside a lambda, or
1001 inline at more than one place
1002 That might mean it gets evaluated more than once, instead of being
1003 shared. The main examples of things which aren't WHNF but are
1004 ``cheap'' are:
1005
1006 * case e of
1007 pi -> ei
1008 (where e, and all the ei are cheap)
1009
1010 * let x = e in b
1011 (where e and b are cheap)
1012
1013 * op x1 ... xn
1014 (where op is a cheap primitive operator)
1015
1016 * error "foo"
1017 (because we are happy to substitute it inside a lambda)
1018
1019 Notice that a variable is considered 'cheap': we can push it inside a lambda,
1020 because sharing will make sure it is only evaluated once.
1021
1022 Note [exprIsCheap and exprIsHNF]
1023 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1024 Note that exprIsHNF does not imply exprIsCheap. Eg
1025 let x = fac 20 in Just x
1026 This responds True to exprIsHNF (you can discard a seq), but
1027 False to exprIsCheap.
1028 -}
1029
1030 exprIsCheap :: CoreExpr -> Bool
1031 exprIsCheap = exprIsCheap' isCheapApp
1032
1033 exprIsExpandable :: CoreExpr -> Bool
1034 exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
1035
1036 exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
1037 exprIsCheap' _ (Lit _) = True
1038 exprIsCheap' _ (Type _) = True
1039 exprIsCheap' _ (Coercion _) = True
1040 exprIsCheap' _ (Var _) = True
1041 exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e
1042 exprIsCheap' good_app (Lam x e) = isRuntimeVar x
1043 || exprIsCheap' good_app e
1044
1045 exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
1046 and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
1047 -- Experimentally, treat (case x of ...) as cheap
1048 -- (and case __coerce x etc.)
1049 -- This improves arities of overloaded functions where
1050 -- there is only dictionary selection (no construction) involved
1051
1052 exprIsCheap' good_app (Tick t e)
1053 | tickishCounts t = False
1054 | otherwise = exprIsCheap' good_app e
1055 -- never duplicate counting ticks. If we get this wrong, then
1056 -- HPC's entry counts will be off (check test in
1057 -- libraries/hpc/tests/raytrace)
1058
1059 exprIsCheap' good_app (Let (NonRec _ b) e)
1060 = exprIsCheap' good_app b && exprIsCheap' good_app e
1061 exprIsCheap' good_app (Let (Rec prs) e)
1062 = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e
1063
1064 exprIsCheap' good_app other_expr -- Applications and variables
1065 = go other_expr []
1066 where
1067 -- Accumulate value arguments, then decide
1068 go (Cast e _) val_args = go e val_args
1069 go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
1070 | otherwise = go f val_args
1071
1072 go (Var _) [] = True
1073 -- Just a type application of a variable
1074 -- (f t1 t2 t3) counts as WHNF
1075 -- This case is probably handeld by the good_app case
1076 -- below, which should have a case for n=0, but putting
1077 -- it here too is belt and braces; and it's such a common
1078 -- case that checking for null directly seems like a
1079 -- good plan
1080
1081 go (Var f) args
1082 | good_app f (length args) -- Typically holds of data constructor applications
1083 = go_pap args -- E.g. good_app = isCheapApp below
1084
1085 | otherwise
1086 = case idDetails f of
1087 RecSelId {} -> go_sel args
1088 ClassOpId {} -> go_sel args
1089 PrimOpId op -> go_primop op args
1090 _ | isBottomingId f -> True
1091 | otherwise -> False
1092 -- Application of a function which
1093 -- always gives bottom; we treat this as cheap
1094 -- because it certainly doesn't need to be shared!
1095
1096 go (Tick t e) args
1097 | not (tickishCounts t) -- don't duplicate counting ticks, see above
1098 = go e args
1099
1100 go _ _ = False
1101
1102 --------------
1103 go_pap args = all (exprIsCheap' good_app) args
1104 -- Used to be "all exprIsTrivial args" due to concerns about
1105 -- duplicating nested constructor applications, but see #4978.
1106 -- The principle here is that
1107 -- let x = a +# b in c *# x
1108 -- should behave equivalently to
1109 -- c *# (a +# b)
1110 -- Since lets with cheap RHSs are accepted,
1111 -- so should paps with cheap arguments
1112
1113 --------------
1114 go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
1115 -- In principle we should worry about primops
1116 -- that return a type variable, since the result
1117 -- might be applied to something, but I'm not going
1118 -- to bother to check the number of args
1119
1120 --------------
1121 go_sel [arg] = exprIsCheap' good_app arg -- I'm experimenting with making record selection
1122 go_sel _ = False -- look cheap, so we will substitute it inside a
1123 -- lambda. Particularly for dictionary field selection.
1124 -- BUT: Take care with (sel d x)! The (sel d) might be cheap, but
1125 -- there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
1126
1127 -------------------------------------
1128 type CheapAppFun = Id -> Int -> Bool
1129 -- Is an application of this function to n *value* args
1130 -- always cheap, assuming the arguments are cheap?
1131 -- Mainly true of partial applications, data constructors,
1132 -- and of course true if the number of args is zero
1133
1134 isCheapApp :: CheapAppFun
1135 isCheapApp fn n_val_args
1136 = isDataConWorkId fn
1137 || n_val_args == 0
1138 || n_val_args < idArity fn
1139
1140 isExpandableApp :: CheapAppFun
1141 isExpandableApp fn n_val_args
1142 = isConLikeId fn
1143 || n_val_args < idArity fn
1144 || go n_val_args (idType fn)
1145 where
1146 -- See if all the arguments are PredTys (implicit params or classes)
1147 -- If so we'll regard it as expandable; see Note [Expandable overloadings]
1148 -- This incidentally picks up the (n_val_args = 0) case
1149 go 0 _ = True
1150 go n_val_args ty
1151 | Just (bndr, ty) <- splitPiTy_maybe ty
1152 = caseBinder bndr
1153 (\_tv -> go n_val_args ty)
1154 (\bndr_ty -> isPredTy bndr_ty && go (n_val_args-1) ty)
1155 | otherwise
1156 = False
1157
1158 {-
1159 Note [Expandable overloadings]
1160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1161 Suppose the user wrote this
1162 {-# RULE forall x. foo (negate x) = h x #-}
1163 f x = ....(foo (negate x))....
1164 He'd expect the rule to fire. But since negate is overloaded, we might
1165 get this:
1166 f = \d -> let n = negate d in \x -> ...foo (n x)...
1167 So we treat the application of a function (negate in this case) to a
1168 *dictionary* as expandable. In effect, every function is CONLIKE when
1169 it's applied only to dictionaries.
1170
1171
1172 ************************************************************************
1173 * *
1174 exprOkForSpeculation
1175 * *
1176 ************************************************************************
1177 -}
1178
1179 -----------------------------
1180 -- | 'exprOkForSpeculation' returns True of an expression that is:
1181 --
1182 -- * Safe to evaluate even if normal order eval might not
1183 -- evaluate the expression at all, or
1184 --
1185 -- * Safe /not/ to evaluate even if normal order would do so
1186 --
1187 -- It is usually called on arguments of unlifted type, but not always
1188 -- In particular, Simplify.rebuildCase calls it on lifted types
1189 -- when a 'case' is a plain 'seq'. See the example in
1190 -- Note [exprOkForSpeculation: case expressions] below
1191 --
1192 -- Precisely, it returns @True@ iff:
1193 -- a) The expression guarantees to terminate,
1194 -- b) soon,
1195 -- c) without causing a write side effect (e.g. writing a mutable variable)
1196 -- d) without throwing a Haskell exception
1197 -- e) without risking an unchecked runtime exception (array out of bounds,
1198 -- divide by zero)
1199 --
1200 -- For @exprOkForSideEffects@ the list is the same, but omitting (e).
1201 --
1202 -- Note that
1203 -- exprIsHNF implies exprOkForSpeculation
1204 -- exprOkForSpeculation implies exprOkForSideEffects
1205 --
1206 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
1207 -- and Note [Implementation: how can_fail/has_side_effects affect transformations]
1208 --
1209 -- As an example of the considerations in this test, consider:
1210 --
1211 -- > let x = case y# +# 1# of { r# -> I# r# }
1212 -- > in E
1213 --
1214 -- being translated to:
1215 --
1216 -- > case y# +# 1# of { r# ->
1217 -- > let x = I# r#
1218 -- > in E
1219 -- > }
1220 --
1221 -- We can only do this if the @y + 1@ is ok for speculation: it has no
1222 -- side effects, and can't diverge or raise an exception.
1223 exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
1224 exprOkForSpeculation = expr_ok primOpOkForSpeculation
1225 exprOkForSideEffects = expr_ok primOpOkForSideEffects
1226 -- Polymorphic in binder type
1227 -- There is one call at a non-Id binder type, in SetLevels
1228
1229 expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
1230 expr_ok _ (Lit _) = True
1231 expr_ok _ (Type _) = True
1232 expr_ok _ (Coercion _) = True
1233 expr_ok primop_ok (Var v) = app_ok primop_ok v []
1234 expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
1235
1236 -- Tick annotations that *tick* cannot be speculated, because these
1237 -- are meant to identify whether or not (and how often) the particular
1238 -- source expression was evaluated at runtime.
1239 expr_ok primop_ok (Tick tickish e)
1240 | tickishCounts tickish = False
1241 | otherwise = expr_ok primop_ok e
1242
1243 expr_ok primop_ok (Case e _ _ alts)
1244 = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions]
1245 && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
1246 && altsAreExhaustive alts -- Note [Exhaustive alts]
1247
1248 expr_ok primop_ok other_expr
1249 = case collectArgs other_expr of
1250 (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr
1251 -> app_ok primop_ok f args
1252 _ -> False
1253
1254 -----------------------------
1255 app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
1256 app_ok primop_ok fun args
1257 = case idDetails fun of
1258 DFunId new_type -> not new_type
1259 -- DFuns terminate, unless the dict is implemented
1260 -- with a newtype in which case they may not
1261
1262 DataConWorkId {} -> True
1263 -- The strictness of the constructor has already
1264 -- been expressed by its "wrapper", so we don't need
1265 -- to take the arguments into account
1266
1267 PrimOpId op
1268 | isDivOp op -- Special case for dividing operations that fail
1269 , [arg1, Lit lit] <- args -- only if the divisor is zero
1270 -> not (isZeroLit lit) && expr_ok primop_ok arg1
1271 -- Often there is a literal divisor, and this
1272 -- can get rid of a thunk in an inner looop
1273
1274 | DataToTagOp <- op -- See Note [dataToTag speculation]
1275 -> True
1276
1277 | otherwise
1278 -> primop_ok op -- A bit conservative: we don't really need
1279 && all (expr_ok primop_ok) args -- to care about lazy arguments, but this is easy
1280
1281 _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF
1282 || idArity fun > n_val_args -- Partial apps
1283 || (n_val_args == 0 &&
1284 isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
1285 where
1286 n_val_args = valArgCount args
1287
1288 -----------------------------
1289 altsAreExhaustive :: [Alt b] -> Bool
1290 -- True <=> the case alternatives are definiely exhaustive
1291 -- False <=> they may or may not be
1292 altsAreExhaustive []
1293 = False -- Should not happen
1294 altsAreExhaustive ((con1,_,_) : alts)
1295 = case con1 of
1296 DEFAULT -> True
1297 LitAlt {} -> False
1298 DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)
1299 -- It is possible to have an exhaustive case that does not
1300 -- enumerate all constructors, notably in a GADT match, but
1301 -- we behave conservatively here -- I don't think it's important
1302 -- enough to deserve special treatment
1303
1304 -- | True of dyadic operators that can fail only if the second arg is zero!
1305 isDivOp :: PrimOp -> Bool
1306 -- This function probably belongs in PrimOp, or even in
1307 -- an automagically generated file.. but it's such a
1308 -- special case I thought I'd leave it here for now.
1309 isDivOp IntQuotOp = True
1310 isDivOp IntRemOp = True
1311 isDivOp WordQuotOp = True
1312 isDivOp WordRemOp = True
1313 isDivOp FloatDivOp = True
1314 isDivOp DoubleDivOp = True
1315 isDivOp _ = False
1316
1317 {-
1318 Note [exprOkForSpeculation: case expressions]
1319 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1320 It's always sound for exprOkForSpeculation to return False, and we
1321 don't want it to take too long, so it bales out on complicated-looking
1322 terms. Notably lets, which can be stacked very deeply; and in any
1323 case the argument of exprOkForSpeculation is usually in a strict context,
1324 so any lets will have been floated away.
1325
1326 However, we keep going on case-expressions. An example like this one
1327 showed up in DPH code (Trac #3717):
1328 foo :: Int -> Int
1329 foo 0 = 0
1330 foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
1331
1332 If exprOkForSpeculation doesn't look through case expressions, you get this:
1333 T.$wfoo =
1334 \ (ww :: GHC.Prim.Int#) ->
1335 case ww of ds {
1336 __DEFAULT -> case (case <# ds 5 of _ {
1337 GHC.Types.False -> lvl1;
1338 GHC.Types.True -> lvl})
1339 of _ { __DEFAULT ->
1340 T.$wfoo (GHC.Prim.-# ds_XkE 1) };
1341 0 -> 0
1342 }
1343
1344 The inner case is redundant, and should be nuked.
1345
1346 Note [Exhaustive alts]
1347 ~~~~~~~~~~~~~~~~~~~~~~
1348 We might have something like
1349 case x of {
1350 A -> ...
1351 _ -> ...(case x of { B -> ...; C -> ... })...
1352 Here, the inner case is fine, because the A alternative
1353 can't happen, but it's not ok to float the inner case outside
1354 the outer one (even if we know x is evaluated outside), because
1355 then it would be non-exhaustive. See Trac #5453.
1356
1357 Similarly, this is a valid program (albeit a slightly dodgy one)
1358 let v = case x of { B -> ...; C -> ... }
1359 in case x of
1360 A -> ...
1361 _ -> ...v...v....
1362 But we don't want to speculate the v binding.
1363
1364 One could try to be clever, but the easy fix is simpy to regard
1365 a non-exhaustive case as *not* okForSpeculation.
1366
1367
1368 Note [dataToTag speculation]
1369 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1370 Is this OK?
1371 f x = let v::Int# = dataToTag# x
1372 in ...
1373 We say "yes", even though 'x' may not be evaluated. Reasons
1374
1375 * dataToTag#'s strictness means that its argument often will be
1376 evaluated, but FloatOut makes that temporarily untrue
1377 case x of y -> let v = dataToTag# y in ...
1378 -->
1379 case x of y -> let v = dataToTag# x in ...
1380 Note that we look at 'x' instead of 'y' (this is to improve
1381 floating in FloatOut). So Lint complains.
1382
1383 Moreover, it really *might* improve floating to let the
1384 v-binding float out
1385
1386 * CorePrep makes sure dataToTag#'s argument is evaluated, just
1387 before code gen. Until then, it's not guaranteed
1388
1389
1390 ************************************************************************
1391 * *
1392 exprIsHNF, exprIsConLike
1393 * *
1394 ************************************************************************
1395 -}
1396
1397 -- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF]
1398 -- ~~~~~~~~~~~~~~~~
1399 -- | exprIsHNF returns true for expressions that are certainly /already/
1400 -- evaluated to /head/ normal form. This is used to decide whether it's ok
1401 -- to change:
1402 --
1403 -- > case x of _ -> e
1404 --
1405 -- into:
1406 --
1407 -- > e
1408 --
1409 -- and to decide whether it's safe to discard a 'seq'.
1410 --
1411 -- So, it does /not/ treat variables as evaluated, unless they say they are.
1412 -- However, it /does/ treat partial applications and constructor applications
1413 -- as values, even if their arguments are non-trivial, provided the argument
1414 -- type is lifted. For example, both of these are values:
1415 --
1416 -- > (:) (f x) (map f xs)
1417 -- > map (...redex...)
1418 --
1419 -- because 'seq' on such things completes immediately.
1420 --
1421 -- For unlifted argument types, we have to be careful:
1422 --
1423 -- > C (f x :: Int#)
1424 --
1425 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
1426 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
1427 -- unboxed type must be ok-for-speculation (or trivial).
1428 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
1429 exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
1430
1431 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
1432 -- data constructors. Conlike arguments are considered interesting by the
1433 -- inliner.
1434 exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP
1435 exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
1436
1437 -- | Returns true for values or value-like expressions. These are lambdas,
1438 -- constructors / CONLIKE functions (as determined by the function argument)
1439 -- or PAPs.
1440 --
1441 exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
1442 exprIsHNFlike is_con is_con_unf = is_hnf_like
1443 where
1444 is_hnf_like (Var v) -- NB: There are no value args at this point
1445 = is_con v -- Catches nullary constructors,
1446 -- so that [] and () are values, for example
1447 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
1448 || is_con_unf (idUnfolding v)
1449 -- Check the thing's unfolding; it might be bound to a value
1450 -- We don't look through loop breakers here, which is a bit conservative
1451 -- but otherwise I worry that if an Id's unfolding is just itself,
1452 -- we could get an infinite loop
1453
1454 is_hnf_like (Lit _) = True
1455 is_hnf_like (Type _) = True -- Types are honorary Values;
1456 -- we don't mind copying them
1457 is_hnf_like (Coercion _) = True -- Same for coercions
1458 is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e
1459 is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
1460 && is_hnf_like e
1461 -- See Note [exprIsHNF Tick]
1462 is_hnf_like (Cast e _) = is_hnf_like e
1463 is_hnf_like (App e a)
1464 | isValArg a = app_is_value e 1
1465 | otherwise = is_hnf_like e
1466 is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
1467 is_hnf_like _ = False
1468
1469 -- There is at least one value argument
1470 -- 'n' is number of value args to which the expression is applied
1471 app_is_value :: CoreExpr -> Int -> Bool
1472 app_is_value (Var fun) n_val_args
1473 = idArity fun > n_val_args -- Under-applied function
1474 || is_con fun -- or constructor-like
1475 app_is_value (Tick _ f) nva = app_is_value f nva
1476 app_is_value (Cast f _) nva = app_is_value f nva
1477 app_is_value (App f a) nva
1478 | isValArg a = app_is_value f (nva + 1)
1479 | otherwise = app_is_value f nva
1480 app_is_value _ _ = False
1481
1482 {-
1483 Note [exprIsHNF Tick]
1484
1485 We can discard source annotations on HNFs as long as they aren't
1486 tick-like:
1487
1488 scc c (\x . e) => \x . e
1489 scc c (C x1..xn) => C x1..xn
1490
1491 So we regard these as HNFs. Tick annotations that tick are not
1492 regarded as HNF if the expression they surround is HNF, because the
1493 tick is there to tell us that the expression was evaluated, so we
1494 don't want to discard a seq on it.
1495 -}
1496
1497 {-
1498 ************************************************************************
1499 * *
1500 Instantiating data constructors
1501 * *
1502 ************************************************************************
1503
1504 These InstPat functions go here to avoid circularity between DataCon and Id
1505 -}
1506
1507 dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
1508 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
1509
1510 dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv")))
1511 dataConRepFSInstPat = dataConInstPat
1512
1513 dataConInstPat :: [FastString] -- A long enough list of FSs to use for names
1514 -> [Unique] -- An equally long list of uniques, at least one for each binder
1515 -> DataCon
1516 -> [Type] -- Types to instantiate the universally quantified tyvars
1517 -> ([TyVar], [Id]) -- Return instantiated variables
1518 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
1519 -- (ex_tvs, arg_ids),
1520 --
1521 -- ex_tvs are intended to be used as binders for existential type args
1522 --
1523 -- arg_ids are indended to be used as binders for value arguments,
1524 -- and their types have been instantiated with inst_tys and ex_tys
1525 -- The arg_ids include both evidence and
1526 -- programmer-specified arguments (both after rep-ing)
1527 --
1528 -- Example.
1529 -- The following constructor T1
1530 --
1531 -- data T a where
1532 -- T1 :: forall b. Int -> b -> T(a,b)
1533 -- ...
1534 --
1535 -- has representation type
1536 -- forall a. forall a1. forall b. (a ~ (a1,b)) =>
1537 -- Int -> b -> T a
1538 --
1539 -- dataConInstPat fss us T1 (a1',b') will return
1540 --
1541 -- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
1542 --
1543 -- where the double-primed variables are created with the FastStrings and
1544 -- Uniques given as fss and us
1545 dataConInstPat fss uniqs con inst_tys
1546 = ASSERT( univ_tvs `equalLength` inst_tys )
1547 (ex_bndrs, arg_ids)
1548 where
1549 univ_tvs = dataConUnivTyVars con
1550 ex_tvs = dataConExTyVars con
1551 arg_tys = dataConRepArgTys con
1552 arg_strs = dataConRepStrictness con -- 1-1 with arg_tys
1553 n_ex = length ex_tvs
1554
1555 -- split the Uniques and FastStrings
1556 (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
1557 (ex_fss, id_fss) = splitAt n_ex fss
1558
1559 -- Make the instantiating substitution for universals
1560 univ_subst = zipTvSubst univ_tvs inst_tys
1561
1562 -- Make existential type variables, applyingn and extending the substitution
1563 (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
1564 (zip3 ex_tvs ex_fss ex_uniqs)
1565
1566 mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar)
1567 mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubst subst tv
1568 (mkTyVarTy new_tv)
1569 , new_tv)
1570 where
1571 new_tv = mkTyVar (mkSysTvName uniq fs) kind
1572 kind = Type.substTyUnchecked subst (tyVarKind tv)
1573
1574 -- Make value vars, instantiating types
1575 arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
1576 mk_id_var uniq fs ty str
1577 = mkLocalIdOrCoVarWithInfo name (Type.substTyUnchecked full_subst ty) info
1578 where
1579 name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
1580 info | isMarkedStrict str = vanillaIdInfo `setUnfoldingInfo` evaldUnfolding
1581 | otherwise = vanillaIdInfo
1582 -- See Note [Mark evaluated arguments]
1583
1584 {-
1585 Note [Mark evaluated arguments]
1586 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1587 When pattern matching on a constructor with strict fields, the binder
1588 can have an 'evaldUnfolding'. Moreover, it *should* have one, so that
1589 when loading an interface file unfolding like:
1590 data T = MkT !Int
1591 f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1
1592 in ... }
1593 we don't want Lint to complain. The 'y' is evaluated, so the
1594 case in the RHS of the binding for 'v' is fine. But only if we
1595 *know* that 'y' is evaluated.
1596
1597 c.f. add_evals in Simplify.simplAlt
1598
1599 ************************************************************************
1600 * *
1601 Equality
1602 * *
1603 ************************************************************************
1604 -}
1605
1606 -- | A cheap equality test which bales out fast!
1607 -- If it returns @True@ the arguments are definitely equal,
1608 -- otherwise, they may or may not be equal.
1609 --
1610 -- See also 'exprIsBig'
1611 cheapEqExpr :: Expr b -> Expr b -> Bool
1612 cheapEqExpr = cheapEqExpr' (const False)
1613
1614 -- | Cheap expression equality test, can ignore ticks by type.
1615 cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
1616 cheapEqExpr' ignoreTick = go_s
1617 where go_s = go `on` stripTicksTopE ignoreTick
1618 go (Var v1) (Var v2) = v1 == v2
1619 go (Lit lit1) (Lit lit2) = lit1 == lit2
1620 go (Type t1) (Type t2) = t1 `eqType` t2
1621 go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2
1622
1623 go (App f1 a1) (App f2 a2)
1624 = f1 `go_s` f2 && a1 `go_s` a2
1625
1626 go (Cast e1 t1) (Cast e2 t2)
1627 = e1 `go_s` e2 && t1 `eqCoercion` t2
1628
1629 go (Tick t1 e1) (Tick t2 e2)
1630 = t1 == t2 && e1 `go_s` e2
1631
1632 go _ _ = False
1633 {-# INLINE go #-}
1634 {-# INLINE cheapEqExpr' #-}
1635
1636 exprIsBig :: Expr b -> Bool
1637 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
1638 exprIsBig (Lit _) = False
1639 exprIsBig (Var _) = False
1640 exprIsBig (Type _) = False
1641 exprIsBig (Coercion _) = False
1642 exprIsBig (Lam _ e) = exprIsBig e
1643 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1644 exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
1645 exprIsBig (Tick _ e) = exprIsBig e
1646 exprIsBig _ = True
1647
1648 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
1649 -- Compares for equality, modulo alpha
1650 eqExpr in_scope e1 e2
1651 = go (mkRnEnv2 in_scope) e1 e2
1652 where
1653 go env (Var v1) (Var v2)
1654 | rnOccL env v1 == rnOccR env v2
1655 = True
1656
1657 go _ (Lit lit1) (Lit lit2) = lit1 == lit2
1658 go env (Type t1) (Type t2) = eqTypeX env t1 t2
1659 go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2
1660 go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2
1661 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2
1662 go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2
1663
1664 go env (Lam b1 e1) (Lam b2 e2)
1665 = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
1666 && go (rnBndr2 env b1 b2) e1 e2
1667
1668 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
1669 = go env r1 r2 -- No need to check binder types, since RHSs match
1670 && go (rnBndr2 env v1 v2) e1 e2
1671
1672 go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
1673 = length ps1 == length ps2
1674 && all2 (go env') rs1 rs2 && go env' e1 e2
1675 where
1676 (bs1,rs1) = unzip ps1
1677 (bs2,rs2) = unzip ps2
1678 env' = rnBndrs2 env bs1 bs2
1679
1680 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
1681 | null a1 -- See Note [Empty case alternatives] in TrieMap
1682 = null a2 && go env e1 e2 && eqTypeX env t1 t2
1683 | otherwise
1684 = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
1685
1686 go _ _ _ = False
1687
1688 -----------
1689 go_alt env (c1, bs1, e1) (c2, bs2, e2)
1690 = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
1691
1692 eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
1693 eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)
1694 = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids
1695 eqTickish _ l r = l == r
1696
1697 -- | Finds differences between core expressions, modulo alpha and
1698 -- renaming. Setting @top@ means that the @IdInfo@ of bindings will be
1699 -- checked for differences as well.
1700 diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
1701 diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = []
1702 diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = []
1703 diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = []
1704 diffExpr _ env (Coercion co1) (Coercion co2)
1705 | eqCoercionX env co1 co2 = []
1706 diffExpr top env (Cast e1 co1) (Cast e2 co2)
1707 | eqCoercionX env co1 co2 = diffExpr top env e1 e2
1708 diffExpr top env (Tick n1 e1) e2
1709 | not (tickishIsCode n1) = diffExpr top env e1 e2
1710 diffExpr top env e1 (Tick n2 e2)
1711 | not (tickishIsCode n2) = diffExpr top env e1 e2
1712 diffExpr top env (Tick n1 e1) (Tick n2 e2)
1713 | eqTickish env n1 n2 = diffExpr top env e1 e2
1714 -- The error message of failed pattern matches will contain
1715 -- generated names, which are allowed to differ.
1716 diffExpr _ _ (App (App (Var absent) _) _)
1717 (App (App (Var absent2) _) _)
1718 | isBottomingId absent && isBottomingId absent2 = []
1719 diffExpr top env (App f1 a1) (App f2 a2)
1720 = diffExpr top env f1 f2 ++ diffExpr top env a1 a2
1721 diffExpr top env (Lam b1 e1) (Lam b2 e2)
1722 | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
1723 = diffExpr top (rnBndr2 env b1 b2) e1 e2
1724 diffExpr top env (Let bs1 e1) (Let bs2 e2)
1725 = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
1726 in ds ++ diffExpr top env' e1 e2
1727 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
1728 | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2
1729 -- See Note [Empty case alternatives] in TrieMap
1730 = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
1731 where env' = rnBndr2 env b1 b2
1732 diffAlt (c1, bs1, e1) (c2, bs2, e2)
1733 | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]
1734 | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2
1735 diffExpr _ _ e1 e2
1736 = [fsep [ppr e1, text "/=", ppr e2]]
1737
1738 -- | Finds differences between core bindings, see @diffExpr@.
1739 --
1740 -- The main problem here is that while we expect the binds to have the
1741 -- same order in both lists, this is not guaranteed. To do this
1742 -- properly we'd either have to do some sort of unification or check
1743 -- all possible mappings, which would be seriously expensive. So
1744 -- instead we simply match single bindings as far as we can. This
1745 -- leaves us just with mutually recursive and/or mismatching bindings,
1746 -- which we then specuatively match by ordering them. It's by no means
1747 -- perfect, but gets the job done well enough.
1748 diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
1749 -> ([SDoc], RnEnv2)
1750 diffBinds top env binds1 = go (length binds1) env binds1
1751 where go _ env [] []
1752 = ([], env)
1753 go fuel env binds1 binds2
1754 -- No binds left to compare? Bail out early.
1755 | null binds1 || null binds2
1756 = (warn env binds1 binds2, env)
1757 -- Iterated over all binds without finding a match? Then
1758 -- try speculatively matching binders by order.
1759 | fuel == 0
1760 = if not $ env `inRnEnvL` fst (head binds1)
1761 then let env' = uncurry (rnBndrs2 env) $ unzip $
1762 zip (sort $ map fst binds1) (sort $ map fst binds2)
1763 in go (length binds1) env' binds1 binds2
1764 -- If we have already tried that, give up
1765 else (warn env binds1 binds2, env)
1766 go fuel env ((bndr1,expr1):binds1) binds2
1767 | let matchExpr (bndr,expr) =
1768 (not top || null (diffIdInfo env bndr bndr1)) &&
1769 null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)
1770 , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2
1771 = go (length binds1) (rnBndr2 env bndr1 bndr2)
1772 binds1 (binds2l ++ binds2r)
1773 | otherwise -- No match, so push back (FIXME O(n^2))
1774 = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2
1775 go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough
1776
1777 -- We have tried everything, but couldn't find a good match. So
1778 -- now we just return the comparison results when we pair up
1779 -- the binds in a pseudo-random order.
1780 warn env binds1 binds2 =
1781 concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++
1782 unmatched "unmatched left-hand:" (drop l binds1') ++
1783 unmatched "unmatched right-hand:" (drop l binds2')
1784 where binds1' = sortBy (comparing fst) binds1
1785 binds2' = sortBy (comparing fst) binds2
1786 l = min (length binds1') (length binds2')
1787 unmatched _ [] = []
1788 unmatched txt bs = [text txt $$ ppr (Rec bs)]
1789 diffBind env (bndr1,expr1) (bndr2,expr2)
1790 | ds@(_:_) <- diffExpr top env expr1 expr2
1791 = locBind "in binding" bndr1 bndr2 ds
1792 | otherwise
1793 = diffIdInfo env bndr1 bndr2
1794
1795 -- | Find differences in @IdInfo@. We will especially check whether
1796 -- the unfoldings match, if present (see @diffUnfold@).
1797 diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
1798 diffIdInfo env bndr1 bndr2
1799 | arityInfo info1 == arityInfo info2
1800 && cafInfo info1 == cafInfo info2
1801 && oneShotInfo info1 == oneShotInfo info2
1802 && inlinePragInfo info1 == inlinePragInfo info2
1803 && occInfo info1 == occInfo info2
1804 && demandInfo info1 == demandInfo info2
1805 && callArityInfo info1 == callArityInfo info2
1806 = locBind "in unfolding of" bndr1 bndr2 $
1807 diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)
1808 | otherwise
1809 = locBind "in Id info of" bndr1 bndr2
1810 [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]
1811 where info1 = idInfo bndr1; info2 = idInfo bndr2
1812
1813 -- | Find differences in unfoldings. Note that we will not check for
1814 -- differences of @IdInfo@ in unfoldings, as this is generally
1815 -- redundant, and can lead to an exponential blow-up in complexity.
1816 diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
1817 diffUnfold _ NoUnfolding NoUnfolding = []
1818 diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
1819 diffUnfold env (DFunUnfolding bs1 c1 a1)
1820 (DFunUnfolding bs2 c2 a2)
1821 | c1 == c2 && length bs1 == length bs2
1822 = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
1823 where env' = rnBndrs2 env bs1 bs2
1824 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
1825 (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
1826 | v1 == v2 && cl1 == cl2
1827 && wf1 == wf2 && x1 == x2 && g1 == g2
1828 = diffExpr False env t1 t2
1829 diffUnfold _ uf1 uf2
1830 = [fsep [ppr uf1, text "/=", ppr uf2]]
1831
1832 -- | Add location information to diff messages
1833 locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
1834 locBind loc b1 b2 diffs = map addLoc diffs
1835 where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc))
1836 bindLoc | b1 == b2 = ppr b1
1837 | otherwise = ppr b1 <> char '/' <> ppr b2
1838
1839 {-
1840 ************************************************************************
1841 * *
1842 Eta reduction
1843 * *
1844 ************************************************************************
1845
1846 Note [Eta reduction conditions]
1847 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1848 We try for eta reduction here, but *only* if we get all the way to an
1849 trivial expression. We don't want to remove extra lambdas unless we
1850 are going to avoid allocating this thing altogether.
1851
1852 There are some particularly delicate points here:
1853
1854 * We want to eta-reduce if doing so leaves a trivial expression,
1855 *including* a cast. For example
1856 \x. f |> co --> f |> co
1857 (provided co doesn't mention x)
1858
1859 * Eta reduction is not valid in general:
1860 \x. bot /= bot
1861 This matters, partly for old-fashioned correctness reasons but,
1862 worse, getting it wrong can yield a seg fault. Consider
1863 f = \x.f x
1864 h y = case (case y of { True -> f `seq` True; False -> False }) of
1865 True -> ...; False -> ...
1866
1867 If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
1868 says f=bottom, and replaces the (f `seq` True) with just
1869 (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it
1870 *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands
1871 the definition again, so that it does not termninate after all.
1872 Result: seg-fault because the boolean case actually gets a function value.
1873 See Trac #1947.
1874
1875 So it's important to do the right thing.
1876
1877 * Note [Arity care]: we need to be careful if we just look at f's
1878 arity. Currently (Dec07), f's arity is visible in its own RHS (see
1879 Note [Arity robustness] in SimplEnv) so we must *not* trust the
1880 arity when checking that 'f' is a value. Otherwise we will
1881 eta-reduce
1882 f = \x. f x
1883 to
1884 f = f
1885 Which might change a terminating program (think (f `seq` e)) to a
1886 non-terminating one. So we check for being a loop breaker first.
1887
1888 However for GlobalIds we can look at the arity; and for primops we
1889 must, since they have no unfolding.
1890
1891 * Regardless of whether 'f' is a value, we always want to
1892 reduce (/\a -> f a) to f
1893 This came up in a RULE: foldr (build (/\a -> g a))
1894 did not match foldr (build (/\b -> ...something complex...))
1895 The type checker can insert these eta-expanded versions,
1896 with both type and dictionary lambdas; hence the slightly
1897 ad-hoc isDictId
1898
1899 * Never *reduce* arity. For example
1900 f = \xy. g x y
1901 Then if h has arity 1 we don't want to eta-reduce because then
1902 f's arity would decrease, and that is bad
1903
1904 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
1905 Alas.
1906
1907 Note [Eta reduction with casted arguments]
1908 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1909 Consider
1910 (\(x:t3). f (x |> g)) :: t3 -> t2
1911 where
1912 f :: t1 -> t2
1913 g :: t3 ~ t1
1914 This should be eta-reduced to
1915
1916 f |> (sym g -> t2)
1917
1918 So we need to accumulate a coercion, pushing it inward (past
1919 variable arguments only) thus:
1920 f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x
1921 f (x:t) |> co --> (f |> (t -> co)) x
1922 f @ a |> co --> (f |> (forall a.co)) @ a
1923 f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2)
1924 These are the equations for ok_arg.
1925
1926 It's true that we could also hope to eta reduce these:
1927 (\xy. (f x |> g) y)
1928 (\xy. (f x y) |> g)
1929 But the simplifier pushes those casts outwards, so we don't
1930 need to address that here.
1931 -}
1932
1933 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
1934 tryEtaReduce bndrs body
1935 = go (reverse bndrs) body (mkRepReflCo (exprType body))
1936 where
1937 incoming_arity = count isId bndrs
1938
1939 go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
1940 -> CoreExpr -- Of type tr
1941 -> Coercion -- Of type tr ~ ts
1942 -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
1943 -- See Note [Eta reduction with casted arguments]
1944 -- for why we have an accumulating coercion
1945 go [] fun co
1946 | ok_fun fun
1947 , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co
1948 , not (any (`elemVarSet` used_vars) bndrs)
1949 = Just (mkCast fun co) -- Check for any of the binders free in the result
1950 -- including the accumulated coercion
1951
1952 go bs (Tick t e) co
1953 | tickishFloatable t
1954 = fmap (Tick t) $ go bs e co
1955 -- Float app ticks: \x -> Tick t (e x) ==> Tick t e
1956
1957 go (b : bs) (App fun arg) co
1958 | Just (co', ticks) <- ok_arg b arg co
1959 = fmap (flip (foldr mkTick) ticks) $ go bs fun co'
1960 -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e
1961
1962 go _ _ _ = Nothing -- Failure!
1963
1964 ---------------
1965 -- Note [Eta reduction conditions]
1966 ok_fun (App fun (Type {})) = ok_fun fun
1967 ok_fun (Cast fun _) = ok_fun fun
1968 ok_fun (Tick _ expr) = ok_fun expr
1969 ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs
1970 ok_fun _fun = False
1971
1972 ---------------
1973 ok_fun_id fun = fun_arity fun >= incoming_arity
1974
1975 ---------------
1976 fun_arity fun -- See Note [Arity care]
1977 | isLocalId fun
1978 , isStrongLoopBreaker (idOccInfo fun) = 0
1979 | arity > 0 = arity
1980 | isEvaldUnfolding (idUnfolding fun) = 1
1981 -- See Note [Eta reduction of an eval'd function]
1982 | otherwise = 0
1983 where
1984 arity = idArity fun
1985
1986 ---------------
1987 ok_lam v = isTyVar v || isEvVar v
1988
1989 ---------------
1990 ok_arg :: Var -- Of type bndr_t
1991 -> CoreExpr -- Of type arg_t
1992 -> Coercion -- Of kind (t1~t2)
1993 -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
1994 -- (and similarly for tyvars, coercion args)
1995 , [Tickish Var])
1996 -- See Note [Eta reduction with casted arguments]
1997 ok_arg bndr (Type ty) co
1998 | Just tv <- getTyVar_maybe ty
1999 , bndr == tv = Just (mkHomoForAllCos [tv] co, [])
2000 ok_arg bndr (Var v) co
2001 | bndr == v = let reflCo = mkRepReflCo (idType bndr)
2002 in Just (mkFunCo Representational reflCo co, [])
2003 ok_arg bndr (Cast e co_arg) co
2004 | (ticks, Var v) <- stripTicksTop tickishFloatable e
2005 , bndr == v
2006 = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks)
2007 -- The simplifier combines multiple casts into one,
2008 -- so we can have a simple-minded pattern match here
2009 ok_arg bndr (Tick t arg) co
2010 | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co
2011 = Just (co', t:ticks)
2012
2013 ok_arg _ _ _ = Nothing
2014
2015 {-
2016 Note [Eta reduction of an eval'd function]
2017 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2018 In Haskell is is not true that f = \x. f x
2019 because f might be bottom, and 'seq' can distinguish them.
2020
2021 But it *is* true that f = f `seq` \x. f x
2022 and we'd like to simplify the latter to the former. This amounts
2023 to the rule that
2024 * when there is just *one* value argument,
2025 * f is not bottom
2026 we can eta-reduce \x. f x ===> f
2027
2028 This turned up in Trac #7542.
2029
2030
2031 ************************************************************************
2032 * *
2033 \subsection{Determining non-updatable right-hand-sides}
2034 * *
2035 ************************************************************************
2036
2037 Top-level constructor applications can usually be allocated
2038 statically, but they can't if the constructor, or any of the
2039 arguments, come from another DLL (because we can't refer to static
2040 labels in other DLLs).
2041
2042 If this happens we simply make the RHS into an updatable thunk,
2043 and 'execute' it rather than allocating it statically.
2044 -}
2045
2046 -- | This function is called only on *top-level* right-hand sides.
2047 -- Returns @True@ if the RHS can be allocated statically in the output,
2048 -- with no thunks involved at all.
2049 rhsIsStatic :: Platform
2050 -> (Name -> Bool) -- Which names are dynamic
2051 -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting)
2052 -- C.f. Note [Disgusting computation of CafRefs]
2053 -- in TidyPgm
2054 -> CoreExpr -> Bool
2055 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
2056 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
2057 -- update flag on it and (iii) in DsExpr to decide how to expand
2058 -- list literals
2059 --
2060 -- The basic idea is that rhsIsStatic returns True only if the RHS is
2061 -- (a) a value lambda
2062 -- (b) a saturated constructor application with static args
2063 --
2064 -- BUT watch out for
2065 -- (i) Any cross-DLL references kill static-ness completely
2066 -- because they must be 'executed' not statically allocated
2067 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
2068 -- this is not necessary)
2069 --
2070 -- (ii) We treat partial applications as redexes, because in fact we
2071 -- make a thunk for them that runs and builds a PAP
2072 -- at run-time. The only appliations that are treated as
2073 -- static are *saturated* applications of constructors.
2074
2075 -- We used to try to be clever with nested structures like this:
2076 -- ys = (:) w ((:) w [])
2077 -- on the grounds that CorePrep will flatten ANF-ise it later.
2078 -- But supporting this special case made the function much more
2079 -- complicated, because the special case only applies if there are no
2080 -- enclosing type lambdas:
2081 -- ys = /\ a -> Foo (Baz ([] a))
2082 -- Here the nested (Baz []) won't float out to top level in CorePrep.
2083 --
2084 -- But in fact, even without -O, nested structures at top level are
2085 -- flattened by the simplifier, so we don't need to be super-clever here.
2086 --
2087 -- Examples
2088 --
2089 -- f = \x::Int. x+7 TRUE
2090 -- p = (True,False) TRUE
2091 --
2092 -- d = (fst p, False) FALSE because there's a redex inside
2093 -- (this particular one doesn't happen but...)
2094 --
2095 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
2096 -- n = /\a. Nil a TRUE
2097 --
2098 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
2099 --
2100 --
2101 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
2102 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
2103 --
2104 -- b) (C x xs), where C is a contructor is updatable if the application is
2105 -- dynamic
2106 --
2107 -- c) don't look through unfolding of f in (f x).
2108
2109 rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
2110 where
2111 is_static :: Bool -- True <=> in a constructor argument; must be atomic
2112 -> CoreExpr -> Bool
2113
2114 is_static False (Lam b e) = isRuntimeVar b || is_static False e
2115 is_static in_arg (Tick n e) = not (tickishIsCode n)
2116 && is_static in_arg e
2117 is_static in_arg (Cast e _) = is_static in_arg e
2118 is_static _ (Coercion {}) = True -- Behaves just like a literal
2119 is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
2120 is_static _ (Lit (MachLabel {})) = False
2121 is_static _ (Lit _) = True
2122 -- A MachLabel (foreign import "&foo") in an argument
2123 -- prevents a constructor application from being static. The
2124 -- reason is that it might give rise to unresolvable symbols
2125 -- in the object file: under Linux, references to "weak"
2126 -- symbols from the data segment give rise to "unresolvable
2127 -- relocation" errors at link time This might be due to a bug
2128 -- in the linker, but we'll work around it here anyway.
2129 -- SDM 24/2/2004
2130
2131 is_static in_arg other_expr = go other_expr 0
2132 where
2133 go (Var f) n_val_args
2134 | (platformOS platform /= OSMinGW32) ||
2135 not (is_dynamic_name (idName f))
2136 = saturated_data_con f n_val_args
2137 || (in_arg && n_val_args == 0)
2138 -- A naked un-applied variable is *not* deemed a static RHS
2139 -- E.g. f = g
2140 -- Reason: better to update so that the indirection gets shorted
2141 -- out, and the true value will be seen
2142 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
2143 -- are always updatable. If you do so, make sure that non-updatable
2144 -- ones have enough space for their static link field!
2145
2146 go (App f a) n_val_args
2147 | isTypeArg a = go f n_val_args
2148 | not in_arg && is_static True a = go f (n_val_args + 1)
2149 -- The (not in_arg) checks that we aren't in a constructor argument;
2150 -- if we are, we don't allow (value) applications of any sort
2151 --
2152 -- NB. In case you wonder, args are sometimes not atomic. eg.
2153 -- x = D# (1.0## /## 2.0##)
2154 -- can't float because /## can fail.
2155
2156 go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args
2157 go (Cast e _) n_val_args = go e n_val_args
2158 go _ _ = False
2159
2160 saturated_data_con f n_val_args
2161 = case isDataConWorkId_maybe f of
2162 Just dc -> n_val_args == dataConRepArity dc
2163 Nothing -> False
2164
2165 {-
2166 ************************************************************************
2167 * *
2168 \subsection{Type utilities}
2169 * *
2170 ************************************************************************
2171 -}
2172
2173 -- | True if the type has no non-bottom elements, e.g. when it is an empty
2174 -- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.
2175 -- See Note [Bottoming expressions]
2176 --
2177 -- See Note [No alternatives lint check] for another use of this function.
2178 isEmptyTy :: Type -> Bool
2179 isEmptyTy ty
2180 -- Data types where, given the particular type parameters, no data
2181 -- constructor matches, are empty.
2182 -- This includes data types with no constructors, e.g. Data.Void.Void.
2183 | Just (tc, inst_tys) <- splitTyConApp_maybe ty
2184 , Just dcs <- tyConDataCons_maybe tc
2185 , all (dataConCannotMatch inst_tys) dcs
2186 = True
2187 | otherwise
2188 = False