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