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