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