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