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