4a9e136e5c6eef8096a7b10208abc478afef052b
[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, exprIsOk, 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 alterantive 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 in exprIsOk]
1099 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1100 What predicate should we apply to the argument of an application? We
1101 used to say "exprIsTrivial arg" due to concerns about duplicating
1102 nested constructor applications, but see #4978. The principle here is
1103 that
1104 let x = a +# b in c *# x
1105 should behave equivalently to
1106 c *# (a +# b)
1107 Since lets with cheap RHSs are accepted, so should paps with cheap arguments
1108 -}
1109
1110 --------------------
1111 exprIsCheap :: CoreExpr -> Bool
1112 exprIsCheap = exprIsOk isCheapApp
1113
1114 exprIsExpandable :: CoreExpr -> Bool -- See Note [exprIsExpandable]
1115 exprIsExpandable = exprIsOk isExpandableApp
1116
1117 exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree]
1118 exprIsWorkFree = exprIsOk isWorkFreeApp
1119
1120 --------------------
1121 exprIsOk :: CheapAppFun -> CoreExpr -> Bool
1122 exprIsOk ok_app e
1123 = ok e
1124 where
1125 ok e = go 0 e
1126
1127 -- n is the number of value arguments
1128 go n (Var v) = ok_app v n
1129 go _ (Lit {}) = True
1130 go _ (Type {}) = True
1131 go _ (Coercion {}) = True
1132 go n (Cast e _) = go n e
1133 go n (Case scrut _ _ alts) = foldl (&&) (ok scrut)
1134 [ go n rhs | (_,_,rhs) <- alts ]
1135 go n (Tick t e) | tickishCounts t = False
1136 | otherwise = go n e
1137 go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e
1138 | otherwise = go n e
1139 go n (App f e) | isRuntimeArg e = go (n+1) f && ok e
1140 | otherwise = go n f
1141 go _ (Let {}) = False
1142
1143 -- Case: see Note [Case expressions are work-free]
1144 -- App: see Note [Arguments in exprIsOk]
1145 -- Let: the old exprIsCheap worked through lets
1146
1147
1148 -------------------------------------
1149 type CheapAppFun = Id -> Arity -> Bool
1150 -- Is an application of this function to n *value* args
1151 -- always cheap, assuming the arguments are cheap?
1152 -- True mainly of data constructors, partial applications;
1153 -- but with minor variations:
1154 -- isWorkFreeApp
1155 -- isCheapApp
1156 -- isExpandableApp
1157
1158 -- NB: isCheapApp and isExpandableApp are called from outside
1159 -- this module, so don't be tempted to move the notRedex
1160 -- stuff into the call site in exprIsOk, and remove it
1161 -- from the CheapAppFun implementations
1162
1163
1164 notRedex :: CheapAppFun
1165 notRedex fn n_val_args
1166 = n_val_args == 0 -- No value args
1167 || n_val_args < idArity fn -- Partial application
1168 || isBottomingId fn -- OK to duplicate calls to bottom;
1169 -- it certainly doesn't need to be shared!
1170
1171 isWorkFreeApp :: CheapAppFun
1172 isWorkFreeApp fn n_val_args
1173 | notRedex fn n_val_args
1174 = True
1175 | otherwise
1176 = case idDetails fn of
1177 DataConWorkId {} -> True
1178 _ -> False
1179
1180 isCheapApp :: CheapAppFun
1181 isCheapApp fn n_val_args
1182 | notRedex fn n_val_args
1183 = True
1184 | otherwise
1185 = case idDetails fn of
1186 DataConWorkId {} -> True
1187 RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
1188 ClassOpId {} -> n_val_args == 1
1189 PrimOpId op -> primOpIsCheap op
1190 _ -> False
1191 -- In principle we should worry about primops
1192 -- that return a type variable, since the result
1193 -- might be applied to something, but I'm not going
1194 -- to bother to check the number of args
1195
1196 isExpandableApp :: CheapAppFun
1197 isExpandableApp fn n_val_args
1198 | notRedex fn n_val_args
1199 = True
1200 | isConLikeId fn
1201 = True
1202 | otherwise
1203 = case idDetails fn of
1204 DataConWorkId {} -> True
1205 RecSelId {} -> n_val_args == 1 -- See Note [Record selection]
1206 ClassOpId {} -> n_val_args == 1
1207 PrimOpId {} -> False
1208 _ -> all_pred_args n_val_args (idType fn)
1209
1210 where
1211 -- See if all the arguments are PredTys (implicit params or classes)
1212 -- If so we'll regard it as expandable; see Note [Expandable overloadings]
1213 all_pred_args n_val_args ty
1214 | n_val_args == 0
1215 = True
1216
1217 | Just (bndr, ty) <- splitPiTy_maybe ty
1218 = caseBinder bndr
1219 (\_tv -> all_pred_args n_val_args ty)
1220 (\bndr_ty -> isPredTy bndr_ty && all_pred_args (n_val_args-1) ty)
1221
1222 | otherwise
1223 = False
1224
1225 {- Note [Record selection]
1226 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1227 I'm experimenting with making record selection
1228 look cheap, so we will substitute it inside a
1229 lambda. Particularly for dictionary field selection.
1230
1231 BUT: Take care with (sel d x)! The (sel d) might be cheap, but
1232 there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1)
1233
1234 Note [Expandable overloadings]
1235 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1236 Suppose the user wrote this
1237 {-# RULE forall x. foo (negate x) = h x #-}
1238 f x = ....(foo (negate x))....
1239 He'd expect the rule to fire. But since negate is overloaded, we might
1240 get this:
1241 f = \d -> let n = negate d in \x -> ...foo (n x)...
1242 So we treat the application of a function (negate in this case) to a
1243 *dictionary* as expandable. In effect, every function is CONLIKE when
1244 it's applied only to dictionaries.
1245
1246
1247 ************************************************************************
1248 * *
1249 exprOkForSpeculation
1250 * *
1251 ************************************************************************
1252 -}
1253
1254 -----------------------------
1255 -- | 'exprOkForSpeculation' returns True of an expression that is:
1256 --
1257 -- * Safe to evaluate even if normal order eval might not
1258 -- evaluate the expression at all, or
1259 --
1260 -- * Safe /not/ to evaluate even if normal order would do so
1261 --
1262 -- It is usually called on arguments of unlifted type, but not always
1263 -- In particular, Simplify.rebuildCase calls it on lifted types
1264 -- when a 'case' is a plain 'seq'. See the example in
1265 -- Note [exprOkForSpeculation: case expressions] below
1266 --
1267 -- Precisely, it returns @True@ iff:
1268 -- a) The expression guarantees to terminate,
1269 -- b) soon,
1270 -- c) without causing a write side effect (e.g. writing a mutable variable)
1271 -- d) without throwing a Haskell exception
1272 -- e) without risking an unchecked runtime exception (array out of bounds,
1273 -- divide by zero)
1274 --
1275 -- For @exprOkForSideEffects@ the list is the same, but omitting (e).
1276 --
1277 -- Note that
1278 -- exprIsHNF implies exprOkForSpeculation
1279 -- exprOkForSpeculation implies exprOkForSideEffects
1280 --
1281 -- See Note [PrimOp can_fail and has_side_effects] in PrimOp
1282 -- and Note [Implementation: how can_fail/has_side_effects affect transformations]
1283 --
1284 -- As an example of the considerations in this test, consider:
1285 --
1286 -- > let x = case y# +# 1# of { r# -> I# r# }
1287 -- > in E
1288 --
1289 -- being translated to:
1290 --
1291 -- > case y# +# 1# of { r# ->
1292 -- > let x = I# r#
1293 -- > in E
1294 -- > }
1295 --
1296 -- We can only do this if the @y + 1@ is ok for speculation: it has no
1297 -- side effects, and can't diverge or raise an exception.
1298 exprOkForSpeculation, exprOkForSideEffects :: Expr b -> Bool
1299 exprOkForSpeculation = expr_ok primOpOkForSpeculation
1300 exprOkForSideEffects = expr_ok primOpOkForSideEffects
1301 -- Polymorphic in binder type
1302 -- There is one call at a non-Id binder type, in SetLevels
1303
1304 expr_ok :: (PrimOp -> Bool) -> Expr b -> Bool
1305 expr_ok _ (Lit _) = True
1306 expr_ok _ (Type _) = True
1307 expr_ok _ (Coercion _) = True
1308 expr_ok primop_ok (Var v) = app_ok primop_ok v []
1309 expr_ok primop_ok (Cast e _) = expr_ok primop_ok e
1310
1311 -- Tick annotations that *tick* cannot be speculated, because these
1312 -- are meant to identify whether or not (and how often) the particular
1313 -- source expression was evaluated at runtime.
1314 expr_ok primop_ok (Tick tickish e)
1315 | tickishCounts tickish = False
1316 | otherwise = expr_ok primop_ok e
1317
1318 expr_ok primop_ok (Case e _ _ alts)
1319 = expr_ok primop_ok e -- Note [exprOkForSpeculation: case expressions]
1320 && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts
1321 && altsAreExhaustive alts -- Note [Exhaustive alts]
1322
1323 expr_ok primop_ok other_expr
1324 = case collectArgs other_expr of
1325 (expr, args) | Var f <- stripTicksTopE (not . tickishCounts) expr
1326 -> app_ok primop_ok f args
1327 _ -> False
1328
1329 -----------------------------
1330 app_ok :: (PrimOp -> Bool) -> Id -> [Expr b] -> Bool
1331 app_ok primop_ok fun args
1332 = case idDetails fun of
1333 DFunId new_type -> not new_type
1334 -- DFuns terminate, unless the dict is implemented
1335 -- with a newtype in which case they may not
1336
1337 DataConWorkId {} -> True
1338 -- The strictness of the constructor has already
1339 -- been expressed by its "wrapper", so we don't need
1340 -- to take the arguments into account
1341
1342 PrimOpId op
1343 | isDivOp op
1344 , [arg1, Lit lit] <- args
1345 -> not (isZeroLit lit) && expr_ok primop_ok arg1
1346 -- Special case for dividing operations that fail
1347 -- In general they are NOT ok-for-speculation
1348 -- (which primop_ok will catch), but they ARE OK
1349 -- if the divisor is definitely non-zero.
1350 -- Often there is a literal divisor, and this
1351 -- can get rid of a thunk in an inner loop
1352
1353 | otherwise
1354 -> primop_ok op -- Check the primop itself
1355 && and (zipWith arg_ok arg_tys args) -- Check the arguments
1356
1357 _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF
1358 || idArity fun > n_val_args -- Partial apps
1359 || (n_val_args == 0 &&
1360 isEvaldUnfolding (idUnfolding fun)) -- Let-bound values
1361 where
1362 n_val_args = valArgCount args
1363 where
1364 (arg_tys, _) = splitPiTys (idType fun)
1365
1366 arg_ok :: TyBinder -> Expr b -> Bool
1367 arg_ok (Named _) _ = True -- A type argument
1368 arg_ok (Anon ty) arg -- A term argument
1369 | isUnliftedType ty = expr_ok primop_ok arg
1370 | otherwise = True -- See Note [Primops with lifted arguments]
1371
1372 -----------------------------
1373 altsAreExhaustive :: [Alt b] -> Bool
1374 -- True <=> the case alternatives are definiely exhaustive
1375 -- False <=> they may or may not be
1376 altsAreExhaustive []
1377 = False -- Should not happen
1378 altsAreExhaustive ((con1,_,_) : alts)
1379 = case con1 of
1380 DEFAULT -> True
1381 LitAlt {} -> False
1382 DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)
1383 -- It is possible to have an exhaustive case that does not
1384 -- enumerate all constructors, notably in a GADT match, but
1385 -- we behave conservatively here -- I don't think it's important
1386 -- enough to deserve special treatment
1387
1388 -- | True of dyadic operators that can fail only if the second arg is zero!
1389 isDivOp :: PrimOp -> Bool
1390 -- This function probably belongs in PrimOp, or even in
1391 -- an automagically generated file.. but it's such a
1392 -- special case I thought I'd leave it here for now.
1393 isDivOp IntQuotOp = True
1394 isDivOp IntRemOp = True
1395 isDivOp WordQuotOp = True
1396 isDivOp WordRemOp = True
1397 isDivOp FloatDivOp = True
1398 isDivOp DoubleDivOp = True
1399 isDivOp _ = False
1400
1401 {-
1402 Note [exprOkForSpeculation: case expressions]
1403 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1404 It's always sound for exprOkForSpeculation to return False, and we
1405 don't want it to take too long, so it bales out on complicated-looking
1406 terms. Notably lets, which can be stacked very deeply; and in any
1407 case the argument of exprOkForSpeculation is usually in a strict context,
1408 so any lets will have been floated away.
1409
1410 However, we keep going on case-expressions. An example like this one
1411 showed up in DPH code (Trac #3717):
1412 foo :: Int -> Int
1413 foo 0 = 0
1414 foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
1415
1416 If exprOkForSpeculation doesn't look through case expressions, you get this:
1417 T.$wfoo =
1418 \ (ww :: GHC.Prim.Int#) ->
1419 case ww of ds {
1420 __DEFAULT -> case (case <# ds 5 of _ {
1421 GHC.Types.False -> lvl1;
1422 GHC.Types.True -> lvl})
1423 of _ { __DEFAULT ->
1424 T.$wfoo (GHC.Prim.-# ds_XkE 1) };
1425 0 -> 0
1426 }
1427
1428 The inner case is redundant, and should be nuked.
1429
1430 Note [Exhaustive alts]
1431 ~~~~~~~~~~~~~~~~~~~~~~
1432 We might have something like
1433 case x of {
1434 A -> ...
1435 _ -> ...(case x of { B -> ...; C -> ... })...
1436 Here, the inner case is fine, because the A alternative
1437 can't happen, but it's not ok to float the inner case outside
1438 the outer one (even if we know x is evaluated outside), because
1439 then it would be non-exhaustive. See Trac #5453.
1440
1441 Similarly, this is a valid program (albeit a slightly dodgy one)
1442 let v = case x of { B -> ...; C -> ... }
1443 in case x of
1444 A -> ...
1445 _ -> ...v...v....
1446 But we don't want to speculate the v binding.
1447
1448 One could try to be clever, but the easy fix is simpy to regard
1449 a non-exhaustive case as *not* okForSpeculation.
1450
1451
1452 Note [Primops with lifted arguments]
1453 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1454 Is this ok-for-speculation (see Trac #13027)?
1455 reallyUnsafePtrEq# a b
1456 Well, yes. The primop accepts lifted arguments and does not
1457 evaluate them. Indeed, in general primops are, well, primitive
1458 and do not perform evaluation.
1459
1460 There is one primop, dataToTag#, which does /require/ a lifted
1461 argument to be evaluted. To ensure this, CorePrep adds an
1462 eval if it can't see the the argument is definitely evaluated
1463 (see [dataToTag magic] in CorePrep).
1464
1465 We make no attempt to guarantee that dataToTag#'s argument is
1466 evaluated here. Main reason: it's very fragile to test for the
1467 evaluatedness of a lifted argument. Consider
1468 case x of y -> let v = dataToTag# y in ...
1469
1470 where x/y have type Int, say. 'y' looks evaluated (by the enclosing
1471 case) so all is well. Now the FloatOut pass does a binder-swap (for
1472 very good reasons), changing to
1473 case x of y -> let v = dataToTag# x in ...
1474
1475 See also Note [dataToTag#] in primops.txt.pp.
1476
1477 Bottom line:
1478 * in exprOkForSpeculation we simply ignore all lifted arguments.
1479
1480
1481 ************************************************************************
1482 * *
1483 exprIsHNF, exprIsConLike
1484 * *
1485 ************************************************************************
1486 -}
1487
1488 -- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF]
1489 -- ~~~~~~~~~~~~~~~~
1490 -- | exprIsHNF returns true for expressions that are certainly /already/
1491 -- evaluated to /head/ normal form. This is used to decide whether it's ok
1492 -- to change:
1493 --
1494 -- > case x of _ -> e
1495 --
1496 -- into:
1497 --
1498 -- > e
1499 --
1500 -- and to decide whether it's safe to discard a 'seq'.
1501 --
1502 -- So, it does /not/ treat variables as evaluated, unless they say they are.
1503 -- However, it /does/ treat partial applications and constructor applications
1504 -- as values, even if their arguments are non-trivial, provided the argument
1505 -- type is lifted. For example, both of these are values:
1506 --
1507 -- > (:) (f x) (map f xs)
1508 -- > map (...redex...)
1509 --
1510 -- because 'seq' on such things completes immediately.
1511 --
1512 -- For unlifted argument types, we have to be careful:
1513 --
1514 -- > C (f x :: Int#)
1515 --
1516 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
1517 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
1518 -- unboxed type must be ok-for-speculation (or trivial).
1519 exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
1520 exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
1521
1522 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
1523 -- data constructors. Conlike arguments are considered interesting by the
1524 -- inliner.
1525 exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP
1526 exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
1527
1528 -- | Returns true for values or value-like expressions. These are lambdas,
1529 -- constructors / CONLIKE functions (as determined by the function argument)
1530 -- or PAPs.
1531 --
1532 exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
1533 exprIsHNFlike is_con is_con_unf = is_hnf_like
1534 where
1535 is_hnf_like (Var v) -- NB: There are no value args at this point
1536 = is_con v -- Catches nullary constructors,
1537 -- so that [] and () are values, for example
1538 || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
1539 || is_con_unf (idUnfolding v)
1540 -- Check the thing's unfolding; it might be bound to a value
1541 -- We don't look through loop breakers here, which is a bit conservative
1542 -- but otherwise I worry that if an Id's unfolding is just itself,
1543 -- we could get an infinite loop
1544
1545 is_hnf_like (Lit _) = True
1546 is_hnf_like (Type _) = True -- Types are honorary Values;
1547 -- we don't mind copying them
1548 is_hnf_like (Coercion _) = True -- Same for coercions
1549 is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e
1550 is_hnf_like (Tick tickish e) = not (tickishCounts tickish)
1551 && is_hnf_like e
1552 -- See Note [exprIsHNF Tick]
1553 is_hnf_like (Cast e _) = is_hnf_like e
1554 is_hnf_like (App e a)
1555 | isValArg a = app_is_value e 1
1556 | otherwise = is_hnf_like e
1557 is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us
1558 is_hnf_like _ = False
1559
1560 -- There is at least one value argument
1561 -- 'n' is number of value args to which the expression is applied
1562 app_is_value :: CoreExpr -> Int -> Bool
1563 app_is_value (Var fun) n_val_args
1564 = idArity fun > n_val_args -- Under-applied function
1565 || is_con fun -- or constructor-like
1566 app_is_value (Tick _ f) nva = app_is_value f nva
1567 app_is_value (Cast f _) nva = app_is_value f nva
1568 app_is_value (App f a) nva
1569 | isValArg a = app_is_value f (nva + 1)
1570 | otherwise = app_is_value f nva
1571 app_is_value _ _ = False
1572
1573 {-
1574 Note [exprIsHNF Tick]
1575
1576 We can discard source annotations on HNFs as long as they aren't
1577 tick-like:
1578
1579 scc c (\x . e) => \x . e
1580 scc c (C x1..xn) => C x1..xn
1581
1582 So we regard these as HNFs. Tick annotations that tick are not
1583 regarded as HNF if the expression they surround is HNF, because the
1584 tick is there to tell us that the expression was evaluated, so we
1585 don't want to discard a seq on it.
1586 -}
1587
1588 -- | Can we bind this 'CoreExpr' at the top level?
1589 exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
1590 -- See Note [CoreSyn top-level string literals]
1591 -- Precondition: exprType expr = ty
1592 exprIsTopLevelBindable expr ty
1593 = exprIsLiteralString expr
1594 || not (isUnliftedType ty)
1595
1596 exprIsLiteralString :: CoreExpr -> Bool
1597 exprIsLiteralString (Lit (MachStr _)) = True
1598 exprIsLiteralString _ = False
1599
1600 {-
1601 ************************************************************************
1602 * *
1603 Instantiating data constructors
1604 * *
1605 ************************************************************************
1606
1607 These InstPat functions go here to avoid circularity between DataCon and Id
1608 -}
1609
1610 dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
1611 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
1612
1613 dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv")))
1614 dataConRepFSInstPat = dataConInstPat
1615
1616 dataConInstPat :: [FastString] -- A long enough list of FSs to use for names
1617 -> [Unique] -- An equally long list of uniques, at least one for each binder
1618 -> DataCon
1619 -> [Type] -- Types to instantiate the universally quantified tyvars
1620 -> ([TyVar], [Id]) -- Return instantiated variables
1621 -- dataConInstPat arg_fun fss us con inst_tys returns a tuple
1622 -- (ex_tvs, arg_ids),
1623 --
1624 -- ex_tvs are intended to be used as binders for existential type args
1625 --
1626 -- arg_ids are indended to be used as binders for value arguments,
1627 -- and their types have been instantiated with inst_tys and ex_tys
1628 -- The arg_ids include both evidence and
1629 -- programmer-specified arguments (both after rep-ing)
1630 --
1631 -- Example.
1632 -- The following constructor T1
1633 --
1634 -- data T a where
1635 -- T1 :: forall b. Int -> b -> T(a,b)
1636 -- ...
1637 --
1638 -- has representation type
1639 -- forall a. forall a1. forall b. (a ~ (a1,b)) =>
1640 -- Int -> b -> T a
1641 --
1642 -- dataConInstPat fss us T1 (a1',b') will return
1643 --
1644 -- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
1645 --
1646 -- where the double-primed variables are created with the FastStrings and
1647 -- Uniques given as fss and us
1648 dataConInstPat fss uniqs con inst_tys
1649 = ASSERT( univ_tvs `equalLength` inst_tys )
1650 (ex_bndrs, arg_ids)
1651 where
1652 univ_tvs = dataConUnivTyVars con
1653 ex_tvs = dataConExTyVars con
1654 arg_tys = dataConRepArgTys con
1655 arg_strs = dataConRepStrictness con -- 1-1 with arg_tys
1656 n_ex = length ex_tvs
1657
1658 -- split the Uniques and FastStrings
1659 (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
1660 (ex_fss, id_fss) = splitAt n_ex fss
1661
1662 -- Make the instantiating substitution for universals
1663 univ_subst = zipTvSubst univ_tvs inst_tys
1664
1665 -- Make existential type variables, applyingn and extending the substitution
1666 (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst
1667 (zip3 ex_tvs ex_fss ex_uniqs)
1668
1669 mk_ex_var :: TCvSubst -> (TyVar, FastString, Unique) -> (TCvSubst, TyVar)
1670 mk_ex_var subst (tv, fs, uniq) = (Type.extendTvSubstWithClone subst tv
1671 new_tv
1672 , new_tv)
1673 where
1674 new_tv = mkTyVar (mkSysTvName uniq fs) kind
1675 kind = Type.substTyUnchecked subst (tyVarKind tv)
1676
1677 -- Make value vars, instantiating types
1678 arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs
1679 mk_id_var uniq fs ty str
1680 = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments]
1681 mkLocalIdOrCoVar name (Type.substTy full_subst ty)
1682 where
1683 name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan
1684
1685 {-
1686 Note [Mark evaluated arguments]
1687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1688 When pattern matching on a constructor with strict fields, the binder
1689 can have an 'evaldUnfolding'. Moreover, it *should* have one, so that
1690 when loading an interface file unfolding like:
1691 data T = MkT !Int
1692 f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1
1693 in ... }
1694 we don't want Lint to complain. The 'y' is evaluated, so the
1695 case in the RHS of the binding for 'v' is fine. But only if we
1696 *know* that 'y' is evaluated.
1697
1698 c.f. add_evals in Simplify.simplAlt
1699
1700 ************************************************************************
1701 * *
1702 Equality
1703 * *
1704 ************************************************************************
1705 -}
1706
1707 -- | A cheap equality test which bales out fast!
1708 -- If it returns @True@ the arguments are definitely equal,
1709 -- otherwise, they may or may not be equal.
1710 --
1711 -- See also 'exprIsBig'
1712 cheapEqExpr :: Expr b -> Expr b -> Bool
1713 cheapEqExpr = cheapEqExpr' (const False)
1714
1715 -- | Cheap expression equality test, can ignore ticks by type.
1716 cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool
1717 cheapEqExpr' ignoreTick = go_s
1718 where go_s = go `on` stripTicksTopE ignoreTick
1719 go (Var v1) (Var v2) = v1 == v2
1720 go (Lit lit1) (Lit lit2) = lit1 == lit2
1721 go (Type t1) (Type t2) = t1 `eqType` t2
1722 go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2
1723
1724 go (App f1 a1) (App f2 a2)
1725 = f1 `go_s` f2 && a1 `go_s` a2
1726
1727 go (Cast e1 t1) (Cast e2 t2)
1728 = e1 `go_s` e2 && t1 `eqCoercion` t2
1729
1730 go (Tick t1 e1) (Tick t2 e2)
1731 = t1 == t2 && e1 `go_s` e2
1732
1733 go _ _ = False
1734 {-# INLINE go #-}
1735 {-# INLINE cheapEqExpr' #-}
1736
1737 exprIsBig :: Expr b -> Bool
1738 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
1739 exprIsBig (Lit _) = False
1740 exprIsBig (Var _) = False
1741 exprIsBig (Type _) = False
1742 exprIsBig (Coercion _) = False
1743 exprIsBig (Lam _ e) = exprIsBig e
1744 exprIsBig (App f a) = exprIsBig f || exprIsBig a
1745 exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big!
1746 exprIsBig (Tick _ e) = exprIsBig e
1747 exprIsBig _ = True
1748
1749 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
1750 -- Compares for equality, modulo alpha
1751 eqExpr in_scope e1 e2
1752 = go (mkRnEnv2 in_scope) e1 e2
1753 where
1754 go env (Var v1) (Var v2)
1755 | rnOccL env v1 == rnOccR env v2
1756 = True
1757
1758 go _ (Lit lit1) (Lit lit2) = lit1 == lit2
1759 go env (Type t1) (Type t2) = eqTypeX env t1 t2
1760 go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2
1761 go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2
1762 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2
1763 go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2
1764
1765 go env (Lam b1 e1) (Lam b2 e2)
1766 = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
1767 && go (rnBndr2 env b1 b2) e1 e2
1768
1769 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
1770 = go env r1 r2 -- No need to check binder types, since RHSs match
1771 && go (rnBndr2 env v1 v2) e1 e2
1772
1773 go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
1774 = length ps1 == length ps2
1775 && all2 (go env') rs1 rs2 && go env' e1 e2
1776 where
1777 (bs1,rs1) = unzip ps1
1778 (bs2,rs2) = unzip ps2
1779 env' = rnBndrs2 env bs1 bs2
1780
1781 go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
1782 | null a1 -- See Note [Empty case alternatives] in TrieMap
1783 = null a2 && go env e1 e2 && eqTypeX env t1 t2
1784 | otherwise
1785 = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
1786
1787 go _ _ _ = False
1788
1789 -----------
1790 go_alt env (c1, bs1, e1) (c2, bs2, e2)
1791 = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
1792
1793 eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool
1794 eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)
1795 = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids
1796 eqTickish _ l r = l == r
1797
1798 -- | Finds differences between core expressions, modulo alpha and
1799 -- renaming. Setting @top@ means that the @IdInfo@ of bindings will be
1800 -- checked for differences as well.
1801 diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]
1802 diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = []
1803 diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = []
1804 diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = []
1805 diffExpr _ env (Coercion co1) (Coercion co2)
1806 | eqCoercionX env co1 co2 = []
1807 diffExpr top env (Cast e1 co1) (Cast e2 co2)
1808 | eqCoercionX env co1 co2 = diffExpr top env e1 e2
1809 diffExpr top env (Tick n1 e1) e2
1810 | not (tickishIsCode n1) = diffExpr top env e1 e2
1811 diffExpr top env e1 (Tick n2 e2)
1812 | not (tickishIsCode n2) = diffExpr top env e1 e2
1813 diffExpr top env (Tick n1 e1) (Tick n2 e2)
1814 | eqTickish env n1 n2 = diffExpr top env e1 e2
1815 -- The error message of failed pattern matches will contain
1816 -- generated names, which are allowed to differ.
1817 diffExpr _ _ (App (App (Var absent) _) _)
1818 (App (App (Var absent2) _) _)
1819 | isBottomingId absent && isBottomingId absent2 = []
1820 diffExpr top env (App f1 a1) (App f2 a2)
1821 = diffExpr top env f1 f2 ++ diffExpr top env a1 a2
1822 diffExpr top env (Lam b1 e1) (Lam b2 e2)
1823 | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination
1824 = diffExpr top (rnBndr2 env b1 b2) e1 e2
1825 diffExpr top env (Let bs1 e1) (Let bs2 e2)
1826 = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
1827 in ds ++ diffExpr top env' e1 e2
1828 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
1829 | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2
1830 -- See Note [Empty case alternatives] in TrieMap
1831 = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
1832 where env' = rnBndr2 env b1 b2
1833 diffAlt (c1, bs1, e1) (c2, bs2, e2)
1834 | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]
1835 | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2
1836 diffExpr _ _ e1 e2
1837 = [fsep [ppr e1, text "/=", ppr e2]]
1838
1839 -- | Finds differences between core bindings, see @diffExpr@.
1840 --
1841 -- The main problem here is that while we expect the binds to have the
1842 -- same order in both lists, this is not guaranteed. To do this
1843 -- properly we'd either have to do some sort of unification or check
1844 -- all possible mappings, which would be seriously expensive. So
1845 -- instead we simply match single bindings as far as we can. This
1846 -- leaves us just with mutually recursive and/or mismatching bindings,
1847 -- which we then specuatively match by ordering them. It's by no means
1848 -- perfect, but gets the job done well enough.
1849 diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]
1850 -> ([SDoc], RnEnv2)
1851 diffBinds top env binds1 = go (length binds1) env binds1
1852 where go _ env [] []
1853 = ([], env)
1854 go fuel env binds1 binds2
1855 -- No binds left to compare? Bail out early.
1856 | null binds1 || null binds2
1857 = (warn env binds1 binds2, env)
1858 -- Iterated over all binds without finding a match? Then
1859 -- try speculatively matching binders by order.
1860 | fuel == 0
1861 = if not $ env `inRnEnvL` fst (head binds1)
1862 then let env' = uncurry (rnBndrs2 env) $ unzip $
1863 zip (sort $ map fst binds1) (sort $ map fst binds2)
1864 in go (length binds1) env' binds1 binds2
1865 -- If we have already tried that, give up
1866 else (warn env binds1 binds2, env)
1867 go fuel env ((bndr1,expr1):binds1) binds2
1868 | let matchExpr (bndr,expr) =
1869 (not top || null (diffIdInfo env bndr bndr1)) &&
1870 null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)
1871 , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2
1872 = go (length binds1) (rnBndr2 env bndr1 bndr2)
1873 binds1 (binds2l ++ binds2r)
1874 | otherwise -- No match, so push back (FIXME O(n^2))
1875 = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2
1876 go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough
1877
1878 -- We have tried everything, but couldn't find a good match. So
1879 -- now we just return the comparison results when we pair up
1880 -- the binds in a pseudo-random order.
1881 warn env binds1 binds2 =
1882 concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++
1883 unmatched "unmatched left-hand:" (drop l binds1') ++
1884 unmatched "unmatched right-hand:" (drop l binds2')
1885 where binds1' = sortBy (comparing fst) binds1
1886 binds2' = sortBy (comparing fst) binds2
1887 l = min (length binds1') (length binds2')
1888 unmatched _ [] = []
1889 unmatched txt bs = [text txt $$ ppr (Rec bs)]
1890 diffBind env (bndr1,expr1) (bndr2,expr2)
1891 | ds@(_:_) <- diffExpr top env expr1 expr2
1892 = locBind "in binding" bndr1 bndr2 ds
1893 | otherwise
1894 = diffIdInfo env bndr1 bndr2
1895
1896 -- | Find differences in @IdInfo@. We will especially check whether
1897 -- the unfoldings match, if present (see @diffUnfold@).
1898 diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]
1899 diffIdInfo env bndr1 bndr2
1900 | arityInfo info1 == arityInfo info2
1901 && cafInfo info1 == cafInfo info2
1902 && oneShotInfo info1 == oneShotInfo info2
1903 && inlinePragInfo info1 == inlinePragInfo info2
1904 && occInfo info1 == occInfo info2
1905 && demandInfo info1 == demandInfo info2
1906 && callArityInfo info1 == callArityInfo info2
1907 && levityInfo info1 == levityInfo info2
1908 = locBind "in unfolding of" bndr1 bndr2 $
1909 diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2)
1910 | otherwise
1911 = locBind "in Id info of" bndr1 bndr2
1912 [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]
1913 where info1 = idInfo bndr1; info2 = idInfo bndr2
1914
1915 -- | Find differences in unfoldings. Note that we will not check for
1916 -- differences of @IdInfo@ in unfoldings, as this is generally
1917 -- redundant, and can lead to an exponential blow-up in complexity.
1918 diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]
1919 diffUnfold _ NoUnfolding NoUnfolding = []
1920 diffUnfold _ BootUnfolding BootUnfolding = []
1921 diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
1922 diffUnfold env (DFunUnfolding bs1 c1 a1)
1923 (DFunUnfolding bs2 c2 a2)
1924 | c1 == c2 && length bs1 == length bs2
1925 = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
1926 where env' = rnBndrs2 env bs1 bs2
1927 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
1928 (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2)
1929 | v1 == v2 && cl1 == cl2
1930 && wf1 == wf2 && x1 == x2 && g1 == g2
1931 = diffExpr False env t1 t2
1932 diffUnfold _ uf1 uf2
1933 = [fsep [ppr uf1, text "/=", ppr uf2]]
1934
1935 -- | Add location information to diff messages
1936 locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]
1937 locBind loc b1 b2 diffs = map addLoc diffs
1938 where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc))
1939 bindLoc | b1 == b2 = ppr b1
1940 | otherwise = ppr b1 <> char '/' <> ppr b2
1941
1942 {-
1943 ************************************************************************
1944 * *
1945 Eta reduction
1946 * *
1947 ************************************************************************
1948
1949 Note [Eta reduction conditions]
1950 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1951 We try for eta reduction here, but *only* if we get all the way to an
1952 trivial expression. We don't want to remove extra lambdas unless we
1953 are going to avoid allocating this thing altogether.
1954
1955 There are some particularly delicate points here:
1956
1957 * We want to eta-reduce if doing so leaves a trivial expression,
1958 *including* a cast. For example
1959 \x. f |> co --> f |> co
1960 (provided co doesn't mention x)
1961
1962 * Eta reduction is not valid in general:
1963 \x. bot /= bot
1964 This matters, partly for old-fashioned correctness reasons but,
1965 worse, getting it wrong can yield a seg fault. Consider
1966 f = \x.f x
1967 h y = case (case y of { True -> f `seq` True; False -> False }) of
1968 True -> ...; False -> ...
1969
1970 If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
1971 says f=bottom, and replaces the (f `seq` True) with just
1972 (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it
1973 *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands
1974 the definition again, so that it does not termninate after all.
1975 Result: seg-fault because the boolean case actually gets a function value.
1976 See Trac #1947.
1977
1978 So it's important to do the right thing.
1979
1980 * Note [Arity care]: we need to be careful if we just look at f's
1981 arity. Currently (Dec07), f's arity is visible in its own RHS (see
1982 Note [Arity robustness] in SimplEnv) so we must *not* trust the
1983 arity when checking that 'f' is a value. Otherwise we will
1984 eta-reduce
1985 f = \x. f x
1986 to
1987 f = f
1988 Which might change a terminating program (think (f `seq` e)) to a
1989 non-terminating one. So we check for being a loop breaker first.
1990
1991 However for GlobalIds we can look at the arity; and for primops we
1992 must, since they have no unfolding.
1993
1994 * Regardless of whether 'f' is a value, we always want to
1995 reduce (/\a -> f a) to f
1996 This came up in a RULE: foldr (build (/\a -> g a))
1997 did not match foldr (build (/\b -> ...something complex...))
1998 The type checker can insert these eta-expanded versions,
1999 with both type and dictionary lambdas; hence the slightly
2000 ad-hoc isDictId
2001
2002 * Never *reduce* arity. For example
2003 f = \xy. g x y
2004 Then if h has arity 1 we don't want to eta-reduce because then
2005 f's arity would decrease, and that is bad
2006
2007 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
2008 Alas.
2009
2010 Note [Eta reduction with casted arguments]
2011 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2012 Consider
2013 (\(x:t3). f (x |> g)) :: t3 -> t2
2014 where
2015 f :: t1 -> t2
2016 g :: t3 ~ t1
2017 This should be eta-reduced to
2018
2019 f |> (sym g -> t2)
2020
2021 So we need to accumulate a coercion, pushing it inward (past
2022 variable arguments only) thus:
2023 f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x
2024 f (x:t) |> co --> (f |> (t -> co)) x
2025 f @ a |> co --> (f |> (forall a.co)) @ a
2026 f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2)
2027 These are the equations for ok_arg.
2028
2029 It's true that we could also hope to eta reduce these:
2030 (\xy. (f x |> g) y)
2031 (\xy. (f x y) |> g)
2032 But the simplifier pushes those casts outwards, so we don't
2033 need to address that here.
2034 -}
2035
2036 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
2037 tryEtaReduce bndrs body
2038 = go (reverse bndrs) body (mkRepReflCo (exprType body))
2039 where
2040 incoming_arity = count isId bndrs
2041
2042 go :: [Var] -- Binders, innermost first, types [a3,a2,a1]
2043 -> CoreExpr -- Of type tr
2044 -> Coercion -- Of type tr ~ ts
2045 -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts
2046 -- See Note [Eta reduction with casted arguments]
2047 -- for why we have an accumulating coercion
2048 go [] fun co
2049 | ok_fun fun
2050 , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co
2051 , not (any (`elemVarSet` used_vars) bndrs)
2052 = Just (mkCast fun co) -- Check for any of the binders free in the result
2053 -- including the accumulated coercion
2054
2055 go bs (Tick t e) co
2056 | tickishFloatable t
2057 = fmap (Tick t) $ go bs e co
2058 -- Float app ticks: \x -> Tick t (e x) ==> Tick t e
2059
2060 go (b : bs) (App fun arg) co
2061 | Just (co', ticks) <- ok_arg b arg co
2062 = fmap (flip (foldr mkTick) ticks) $ go bs fun co'
2063 -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e
2064
2065 go _ _ _ = Nothing -- Failure!
2066
2067 ---------------
2068 -- Note [Eta reduction conditions]
2069 ok_fun (App fun (Type {})) = ok_fun fun
2070 ok_fun (Cast fun _) = ok_fun fun
2071 ok_fun (Tick _ expr) = ok_fun expr
2072 ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs
2073 ok_fun _fun = False
2074
2075 ---------------
2076 ok_fun_id fun = fun_arity fun >= incoming_arity
2077
2078 ---------------
2079 fun_arity fun -- See Note [Arity care]
2080 | isLocalId fun
2081 , isStrongLoopBreaker (idOccInfo fun) = 0
2082 | arity > 0 = arity
2083 | isEvaldUnfolding (idUnfolding fun) = 1
2084 -- See Note [Eta reduction of an eval'd function]
2085 | otherwise = 0
2086 where
2087 arity = idArity fun
2088
2089 ---------------
2090 ok_lam v = isTyVar v || isEvVar v
2091
2092 ---------------
2093 ok_arg :: Var -- Of type bndr_t
2094 -> CoreExpr -- Of type arg_t
2095 -> Coercion -- Of kind (t1~t2)
2096 -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2)
2097 -- (and similarly for tyvars, coercion args)
2098 , [Tickish Var])
2099 -- See Note [Eta reduction with casted arguments]
2100 ok_arg bndr (Type ty) co
2101 | Just tv <- getTyVar_maybe ty
2102 , bndr == tv = Just (mkHomoForAllCos [tv] co, [])
2103 ok_arg bndr (Var v) co
2104 | bndr == v = let reflCo = mkRepReflCo (idType bndr)
2105 in Just (mkFunCo Representational reflCo co, [])
2106 ok_arg bndr (Cast e co_arg) co
2107 | (ticks, Var v) <- stripTicksTop tickishFloatable e
2108 , bndr == v
2109 = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks)
2110 -- The simplifier combines multiple casts into one,
2111 -- so we can have a simple-minded pattern match here
2112 ok_arg bndr (Tick t arg) co
2113 | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co
2114 = Just (co', t:ticks)
2115
2116 ok_arg _ _ _ = Nothing
2117
2118 {-
2119 Note [Eta reduction of an eval'd function]
2120 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2121 In Haskell is is not true that f = \x. f x
2122 because f might be bottom, and 'seq' can distinguish them.
2123
2124 But it *is* true that f = f `seq` \x. f x
2125 and we'd like to simplify the latter to the former. This amounts
2126 to the rule that
2127 * when there is just *one* value argument,
2128 * f is not bottom
2129 we can eta-reduce \x. f x ===> f
2130
2131 This turned up in Trac #7542.
2132
2133
2134 ************************************************************************
2135 * *
2136 \subsection{Determining non-updatable right-hand-sides}
2137 * *
2138 ************************************************************************
2139
2140 Top-level constructor applications can usually be allocated
2141 statically, but they can't if the constructor, or any of the
2142 arguments, come from another DLL (because we can't refer to static
2143 labels in other DLLs).
2144
2145 If this happens we simply make the RHS into an updatable thunk,
2146 and 'execute' it rather than allocating it statically.
2147 -}
2148
2149 -- | This function is called only on *top-level* right-hand sides.
2150 -- Returns @True@ if the RHS can be allocated statically in the output,
2151 -- with no thunks involved at all.
2152 rhsIsStatic :: Platform
2153 -> (Name -> Bool) -- Which names are dynamic
2154 -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting)
2155 -- C.f. Note [Disgusting computation of CafRefs]
2156 -- in TidyPgm
2157 -> CoreExpr -> Bool
2158 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
2159 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
2160 -- update flag on it and (iii) in DsExpr to decide how to expand
2161 -- list literals
2162 --
2163 -- The basic idea is that rhsIsStatic returns True only if the RHS is
2164 -- (a) a value lambda
2165 -- (b) a saturated constructor application with static args
2166 --
2167 -- BUT watch out for
2168 -- (i) Any cross-DLL references kill static-ness completely
2169 -- because they must be 'executed' not statically allocated
2170 -- ("DLL" here really only refers to Windows DLLs, on other platforms,
2171 -- this is not necessary)
2172 --
2173 -- (ii) We treat partial applications as redexes, because in fact we
2174 -- make a thunk for them that runs and builds a PAP
2175 -- at run-time. The only applications that are treated as
2176 -- static are *saturated* applications of constructors.
2177
2178 -- We used to try to be clever with nested structures like this:
2179 -- ys = (:) w ((:) w [])
2180 -- on the grounds that CorePrep will flatten ANF-ise it later.
2181 -- But supporting this special case made the function much more
2182 -- complicated, because the special case only applies if there are no
2183 -- enclosing type lambdas:
2184 -- ys = /\ a -> Foo (Baz ([] a))
2185 -- Here the nested (Baz []) won't float out to top level in CorePrep.
2186 --
2187 -- But in fact, even without -O, nested structures at top level are
2188 -- flattened by the simplifier, so we don't need to be super-clever here.
2189 --
2190 -- Examples
2191 --
2192 -- f = \x::Int. x+7 TRUE
2193 -- p = (True,False) TRUE
2194 --
2195 -- d = (fst p, False) FALSE because there's a redex inside
2196 -- (this particular one doesn't happen but...)
2197 --
2198 -- h = D# (1.0## /## 2.0##) FALSE (redex again)
2199 -- n = /\a. Nil a TRUE
2200 --
2201 -- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex)
2202 --
2203 --
2204 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
2205 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
2206 --
2207 -- b) (C x xs), where C is a constructor is updatable if the application is
2208 -- dynamic
2209 --
2210 -- c) don't look through unfolding of f in (f x).
2211
2212 rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
2213 where
2214 is_static :: Bool -- True <=> in a constructor argument; must be atomic
2215 -> CoreExpr -> Bool
2216
2217 is_static False (Lam b e) = isRuntimeVar b || is_static False e
2218 is_static in_arg (Tick n e) = not (tickishIsCode n)
2219 && is_static in_arg e
2220 is_static in_arg (Cast e _) = is_static in_arg e
2221 is_static _ (Coercion {}) = True -- Behaves just like a literal
2222 is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
2223 is_static _ (Lit (MachLabel {})) = False
2224 is_static _ (Lit _) = True
2225 -- A MachLabel (foreign import "&foo") in an argument
2226 -- prevents a constructor application from being static. The
2227 -- reason is that it might give rise to unresolvable symbols
2228 -- in the object file: under Linux, references to "weak"
2229 -- symbols from the data segment give rise to "unresolvable
2230 -- relocation" errors at link time This might be due to a bug
2231 -- in the linker, but we'll work around it here anyway.
2232 -- SDM 24/2/2004
2233
2234 is_static in_arg other_expr = go other_expr 0
2235 where
2236 go (Var f) n_val_args
2237 | (platformOS platform /= OSMinGW32) ||
2238 not (is_dynamic_name (idName f))
2239 = saturated_data_con f n_val_args
2240 || (in_arg && n_val_args == 0)
2241 -- A naked un-applied variable is *not* deemed a static RHS
2242 -- E.g. f = g
2243 -- Reason: better to update so that the indirection gets shorted
2244 -- out, and the true value will be seen
2245 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
2246 -- are always updatable. If you do so, make sure that non-updatable
2247 -- ones have enough space for their static link field!
2248
2249 go (App f a) n_val_args
2250 | isTypeArg a = go f n_val_args
2251 | not in_arg && is_static True a = go f (n_val_args + 1)
2252 -- The (not in_arg) checks that we aren't in a constructor argument;
2253 -- if we are, we don't allow (value) applications of any sort
2254 --
2255 -- NB. In case you wonder, args are sometimes not atomic. eg.
2256 -- x = D# (1.0## /## 2.0##)
2257 -- can't float because /## can fail.
2258
2259 go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args
2260 go (Cast e _) n_val_args = go e n_val_args
2261 go _ _ = False
2262
2263 saturated_data_con f n_val_args
2264 = case isDataConWorkId_maybe f of
2265 Just dc -> n_val_args == dataConRepArity dc
2266 Nothing -> False
2267
2268 {-
2269 ************************************************************************
2270 * *
2271 \subsection{Type utilities}
2272 * *
2273 ************************************************************************
2274 -}
2275
2276 -- | True if the type has no non-bottom elements, e.g. when it is an empty
2277 -- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.
2278 -- See Note [Bottoming expressions]
2279 --
2280 -- See Note [No alternatives lint check] for another use of this function.
2281 isEmptyTy :: Type -> Bool
2282 isEmptyTy ty
2283 -- Data types where, given the particular type parameters, no data
2284 -- constructor matches, are empty.
2285 -- This includes data types with no constructors, e.g. Data.Void.Void.
2286 | Just (tc, inst_tys) <- splitTyConApp_maybe ty
2287 , Just dcs <- tyConDataCons_maybe tc
2288 , all (dataConCannotMatch inst_tys) dcs
2289 = True
2290 | otherwise
2291 = False
2292
2293 {-
2294 *****************************************************
2295 *
2296 * StaticPtr
2297 *
2298 *****************************************************
2299 -}
2300
2301 -- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields
2302 -- @Just (makeStatic, t, srcLoc, e)@.
2303 --
2304 -- Returns @Nothing@ for every other expression.
2305 collectMakeStaticArgs
2306 :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
2307 collectMakeStaticArgs e
2308 | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e
2309 , idName b == makeStaticName = Just (fun, t, loc, arg)
2310 collectMakeStaticArgs _ = Nothing
2311
2312 {-
2313 ************************************************************************
2314 * *
2315 \subsection{Join points}
2316 * *
2317 ************************************************************************
2318 -}
2319
2320 -- | Does this binding bind a join point (or a recursive group of join points)?
2321 isJoinBind :: CoreBind -> Bool
2322 isJoinBind (NonRec b _) = isJoinId b
2323 isJoinBind (Rec ((b, _) : _)) = isJoinId b
2324 isJoinBind _ = False