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