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