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