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