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