CoreUtils.hs 91.9 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5
6

Utility functions on @Core@ syntax
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
10
{-# LANGUAGE CPP #-}

batterseapower's avatar
batterseapower committed
11
-- | Commonly useful utilites for manipulating the Core language
12
module CoreUtils (
13
        -- * Constructing expressions
14
        mkCast,
Peter Wortmann's avatar
Peter Wortmann committed
15
        mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,
Simon Marlow's avatar
Simon Marlow committed
16
        bindNonRec, needsCaseBinding,
17
        mkAltExpr,
18

19
        -- * Taking expressions apart
20
21
22
        findDefault, addDefault, findAlt, isDefaultAlt,
        mergeAlts, trimConArgs,
        filterAlts, combineIdenticalAlts, refineDefaultAlt,
23

24
        -- * Properties of expressions
Simon Marlow's avatar
Simon Marlow committed
25
        exprType, coreAltType, coreAltsType,
26
        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
27
        exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
28
        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
29
30
        exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
31

32
33
34
        -- * Expression and bindings size
        coreBindsSize, exprSize,
        CoreStats(..), coreBindsStats,
35

36
        -- * Equality
Peter Wortmann's avatar
Peter Wortmann committed
37
        cheapEqExpr, cheapEqExpr', eqExpr,
Peter Wortmann's avatar
Peter Wortmann committed
38
        diffExpr, diffBinds,
39

40
41
        -- * Eta reduction
        tryEtaReduce,
42

43
44
45
46
        -- * Seq
        seqExpr, seqExprs, seqUnfolding, seqRules,
        seqIdInfo, megaSeqIdInfo, seqSpecInfo, seqBinds,

47
48
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
Peter Wortmann's avatar
Peter Wortmann committed
49
        dataConRepInstPat, dataConRepFSInstPat,
50
        isEmptyTy,
Peter Wortmann's avatar
Peter Wortmann committed
51
52

        -- * Working with ticks
53
54
        stripTicksTop, stripTicksTopE, stripTicksTopT,
        stripTicksE, stripTicksT
55
    ) where
56

57
#include "HsVersions.h"
58

59
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
60
import PprCore
61
import CoreFVs( exprFreeVars )
Simon Marlow's avatar
Simon Marlow committed
62
63
import Var
import SrcLoc
64
import VarEnv
65
import VarSet
Simon Marlow's avatar
Simon Marlow committed
66
67
68
69
import Name
import Literal
import DataCon
import PrimOp
70
71
import Demand( seqDemand, seqStrictSig )
import BasicTypes( seqOccInfo )
Simon Marlow's avatar
Simon Marlow committed
72
73
74
75
76
77
import Id
import IdInfo
import Type
import Coercion
import TyCon
import Unique
78
import Outputable
Simon Marlow's avatar
Simon Marlow committed
79
import TysPrim
80
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
81
import FastString
82
import Maybes
83
import ListSetOps       ( minusList )
84
import Platform
Simon Marlow's avatar
Simon Marlow committed
85
import Util
86
import Pair
Peter Wortmann's avatar
Peter Wortmann committed
87
import Data.Function       ( on )
88
import Data.List
Peter Wortmann's avatar
Peter Wortmann committed
89
import Data.Ord            ( comparing )
Peter Wortmann's avatar
Peter Wortmann committed
90
import OrdList
91

Austin Seipp's avatar
Austin Seipp committed
92
93
94
{-
************************************************************************
*                                                                      *
95
\subsection{Find the type of a Core atom/expression}
Austin Seipp's avatar
Austin Seipp committed
96
97
98
*                                                                      *
************************************************************************
-}
99

100
exprType :: CoreExpr -> Type
batterseapower's avatar
batterseapower committed
101
102
103
-- ^ Recover the type of a well-typed Core expression. Fails when
-- applied to the actual 'CoreSyn.Type' expression as it cannot
-- really be said to have a type
104
105
106
exprType (Var var)           = idType var
exprType (Lit lit)           = literalType lit
exprType (Coercion co)       = coercionType co
Austin Seipp's avatar
Austin Seipp committed
107
exprType (Let bind body)
108
109
110
  | NonRec tv rhs <- bind    -- See Note [Type bindings]
  , Type ty <- rhs           = substTyWith [tv] [ty] (exprType body)
  | otherwise                = exprType body
111
exprType (Case _ _ ty _)     = ty
112
exprType (Cast _ co)         = pSnd (coercionKind co)
113
exprType (Tick _ e)          = exprType e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
114
exprType (Lam binder expr)   = mkPiType binder (exprType expr)
115
exprType e@(App _ _)
116
  = case collectArgs e of
117
        (fun, args) -> applyTypeToArgs e (exprType fun) args
118

119
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
120

121
coreAltType :: CoreAlt -> Type
batterseapower's avatar
batterseapower committed
122
-- ^ Returns the type of the alternatives right hand side
123
coreAltType (_,bs,rhs)
124
125
126
127
128
  | any bad_binder bs = expandTypeSynonyms ty
  | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
  where
    ty           = exprType rhs
    free_tvs     = tyVarsOfType ty
129
    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
130
131

coreAltsType :: [CoreAlt] -> Type
batterseapower's avatar
batterseapower committed
132
-- ^ Returns the type of the first alternative, which should be the same as for all alternatives
133
coreAltsType (alt:_) = coreAltType alt
134
coreAltsType []      = panic "corAltsType"
135

Austin Seipp's avatar
Austin Seipp committed
136
{-
137
138
139
140
141
142
Note [Type bindings]
~~~~~~~~~~~~~~~~~~~~
Core does allow type bindings, although such bindings are
not much used, except in the output of the desuguarer.
Example:
     let a = Int in (\x:a. x)
Austin Seipp's avatar
Austin Seipp committed
143
Given this, exprType must be careful to substitute 'a' in the
144
145
result type (Trac #8522).

146
147
148
Note [Existential variables and silly type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
149
150
151
152
        data T = forall a. T (Funny a)
        type Funny a = Bool
        f :: T -> Bool
        f (T x) = x
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168

Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
That means that 'exprType' and 'coreAltsType' may give a result that *appears*
to mention an out-of-scope type variable.  See Trac #3409 for a more real-world
example.

Various possibilities suggest themselves:

 - Ignore the problem, and make Lint not complain about such variables

 - Expand all type synonyms (or at least all those that discard arguments)
      This is tricky, because at least for top-level things we want to
      retain the type the user originally specified.

 - Expand synonyms on the fly, when the problem arises. That is what
   we are doing here.  It's not too expensive, I think.
Austin Seipp's avatar
Austin Seipp committed
169
-}
170

171
applyTypeToArg :: Type -> CoreExpr -> Type
172
173
-- ^ Determines the type resulting from applying an expression with given type
-- to a given argument expression
174
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
175
applyTypeToArg fun_ty _             = funResultTy fun_ty
176

177
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
178
179
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
180
181
applyTypeToArgs e op_ty args
  = go op_ty args
182
  where
183
184
185
186
187
188
189
    go op_ty []               = op_ty
    go op_ty (Type ty : args) = go_ty_args op_ty [ty] args
    go op_ty (_ : args)       | Just (_, res_ty) <- splitFunTy_maybe op_ty
                              = go res_ty args
    go _ _ = pprPanic "applyTypeToArgs" panic_msg

    -- go_ty_args: accumulate type arguments so we can instantiate all at once
Simon Peyton Jones's avatar
Simon Peyton Jones committed
190
    go_ty_args op_ty rev_tys (Type ty : args)
191
192
193
       = go_ty_args op_ty (ty:rev_tys) args
    go_ty_args op_ty rev_tys args
       = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
194

195
196
197
198
    panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg
    panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e
                     , ptext (sLit "Type:") <+> ppr op_ty
                     , ptext (sLit "Args:") <+> ppr args ]
199

Austin Seipp's avatar
Austin Seipp committed
200
201
202
{-
************************************************************************
*                                                                      *
203
\subsection{Attaching notes}
Austin Seipp's avatar
Austin Seipp committed
204
205
206
*                                                                      *
************************************************************************
-}
207

208
209
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
210
mkCast :: CoreExpr -> Coercion -> CoreExpr
211
212
mkCast e co | ASSERT2( coercionRole co == Representational
                     , ptext (sLit "coercion") <+> ppr co <+> ptext (sLit "passed to mkCast") <+> ppr e <+> ptext (sLit "has wrong role") <+> ppr (coercionRole co) )
213
              isReflCo co = e
214

Austin Seipp's avatar
Austin Seipp committed
215
mkCast (Coercion e_co) co
216
217
218
219
  | isCoVarType (pSnd (coercionKind co))
       -- The guard here checks that g has a (~#) on both sides,
       -- otherwise decomposeCo fails.  Can in principle happen
       -- with unsafeCoerce
220
  = Coercion (mkCoCast e_co co)
221
222

mkCast (Cast expr co2) co
223
224
225
226
227
228
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
             vcat ([ ptext (sLit "expr:") <+> ppr expr
                   , ptext (sLit "co2:") <+> ppr co2
                   , ptext (sLit "co:") <+> ppr co ]) )
229
    mkCast expr (mkTransCo co2 co)
230

Peter Wortmann's avatar
Peter Wortmann committed
231
232
233
mkCast (Tick t expr) co
   = Tick t (mkCast expr co)

234
mkCast expr co
235
236
  = let Pair from_ty _to_ty = coercionKind co in
--    if to_ty `eqType` from_ty
237
--    then expr
238
--    else
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
239
        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
240
         (Cast expr co)
241

242
243
244
-- | Wraps the given expression in the source annotation, dropping the
-- annotation if possible.
mkTick :: Tickish Id -> CoreExpr -> CoreExpr
Peter Wortmann's avatar
Peter Wortmann committed
245
246
247
248
249
mkTick t orig_expr = mkTick' id id orig_expr
 where
  -- Some ticks (cost-centres) can be split in two, with the
  -- non-counting part having laxer placement properties.
  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t
250

Peter Wortmann's avatar
Peter Wortmann committed
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
  mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through)
          -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with)
          -> CoreExpr               -- ^ current expression
          -> CoreExpr
  mkTick' top rest expr = case expr of

    -- Cost centre ticks should never be reordered relative to each
    -- other. Therefore we can stop whenever two collide.
    Tick t2 e
      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr

    -- Otherwise we assume that ticks of different placements float
    -- through each other.
      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e

    -- For annotations this is where we make sure to not introduce
    -- redundant ticks.
      | tickishContains t t2              -> mkTick' top rest e
      | tickishContains t2 t              -> orig_expr
      | otherwise                         -> mkTick' top (rest . Tick t2) e

    -- Ticks don't care about types, so we just float all ticks
    -- through them. Note that it's not enough to check for these
    -- cases top-level. While mkTick will never produce Core with type
    -- expressions below ticks, such constructs can be the result of
    -- unfoldings. We therefore make an effort to put everything into
    -- the right place no matter what we start with.
    Cast e co   -> mkTick' (top . flip Cast co) rest e
    Coercion co -> Coercion co

    Lam x e
      -- Always float through type lambdas. Even for non-type lambdas,
      -- floating is allowed for all but the most strict placement rule.
      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime
      -> mkTick' (top . Lam x) rest e

      -- If it is both counting and scoped, we split the tick into its
      -- two components, often allowing us to keep the counting tick on
      -- the outside of the lambda and push the scoped tick inside.
      -- The point of this is that the counting tick can probably be
      -- floated, and the lambda may then be in a position to be
      -- beta-reduced.
      | canSplit
      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e

    App f arg
      -- Always float through type applications.
      | not (isRuntimeArg arg)
      -> mkTick' (top . flip App arg) rest f

      -- We can also float through constructor applications, placement
      -- permitting. Again we can split.
      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)
      -> if tickishPlace t == PlaceCostCentre
         then top $ rest $ tickHNFArgs t expr
         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr

    Var x
Simon Marlow's avatar
Simon Marlow committed
309
      | notFunction && tickishPlace t == PlaceCostCentre
Peter Wortmann's avatar
Peter Wortmann committed
310
      -> orig_expr
Simon Marlow's avatar
Simon Marlow committed
311
      | notFunction && canSplit
Peter Wortmann's avatar
Peter Wortmann committed
312
      -> top $ Tick (mkNoScope t) $ rest expr
Simon Marlow's avatar
Simon Marlow committed
313
314
315
316
317
318
319
320
      where
        -- SCCs can be eliminated on variables provided the variable
        -- is not a function.  In these cases the SCC makes no difference:
        -- the cost of evaluating the variable will be attributed to its
        -- definition site.  When the variable refers to a function, however,
        -- an SCC annotation on the variable affects the cost-centre stack
        -- when the function is called, so we must retain those.
        notFunction = not (isFunTy (idType x))
Peter Wortmann's avatar
Peter Wortmann committed
321
322
323
324
325
326
327
328
329
330

    Lit{}
      | tickishPlace t == PlaceCostCentre
      -> orig_expr

    -- Catch-all: Annotate where we stand
    _any -> top $ Tick t $ rest expr

mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr
mkTicks ticks expr = foldr mkTick expr ticks
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351

isSaturatedConApp :: CoreExpr -> Bool
isSaturatedConApp e = go e []
  where go (App f a) as = go f (a:as)
        go (Var fun) args
           = isConLikeId fun && idArity fun == valArgCount args
        go (Cast f _) as = go f as
        go _ _ = False

mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr
mkTickNoHNF t e
  | exprIsHNF e = tickHNFArgs t e
  | otherwise   = mkTick t e

-- push a tick into the arguments of a HNF (call or constructor app)
tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr
tickHNFArgs t e = push t e
 where
  push t (App f (Type u)) = App (push t f) (Type u)
  push t (App f arg) = App (push t f) (mkTick t arg)
  push _t e = e
352

Peter Wortmann's avatar
Peter Wortmann committed
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
-- | Strip ticks satisfying a predicate from top of an expression
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop p = go []
  where go ts (Tick t e) | p t = go (t:ts) e
        go ts other            = (reverse ts, other)

-- | Strip ticks satisfying a predicate from top of an expression,
-- returning the remaining expresion
stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksTopE p = go
  where go (Tick t e) | p t = go e
        go other            = other

-- | Strip ticks satisfying a predicate from top of an expression,
-- returning the ticks
stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksTopT p = go []
  where go ts (Tick t e) | p t = go (t:ts) e
        go ts _                = ts

-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
375
376
377
378
379
380
381
stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b
stripTicksE p expr = go expr
  where go (App e a)        = App (go e) (go a)
        go (Lam b e)        = Lam b (go e)
        go (Let b e)        = Let (go_bs b) (go e)
        go (Case e b t as)  = Case (go e) b t (map go_a as)
        go (Cast e c)       = Cast (go e) c
Peter Wortmann's avatar
Peter Wortmann committed
382
        go (Tick t e)
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
          | p t             = go e
          | otherwise       = Tick t (go e)
        go other            = other
        go_bs (NonRec b e)  = NonRec b (go e)
        go_bs (Rec bs)      = Rec (map go_b bs)
        go_b (b, e)         = (b, go e)
        go_a (c,bs,e)       = (c,bs, go e)

stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]
stripTicksT p expr = fromOL $ go expr
  where go (App e a)        = go e `appOL` go a
        go (Lam _ e)        = go e
        go (Let b e)        = go_bs b `appOL` go e
        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)
        go (Cast e _)       = go e
        go (Tick t e)
          | p t             = t `consOL` go e
          | otherwise       = go e
        go _                = nilOL
        go_bs (NonRec _ e)  = go e
        go_bs (Rec bs)      = concatOL (map go_b bs)
        go_b (_, e)         = go e
        go_a (_, _, e)      = go e
Peter Wortmann's avatar
Peter Wortmann committed
406

Austin Seipp's avatar
Austin Seipp committed
407
408
409
{-
************************************************************************
*                                                                      *
410
\subsection{Other expression construction}
Austin Seipp's avatar
Austin Seipp committed
411
412
413
*                                                                      *
************************************************************************
-}
414
415

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
416
417
418
419
420
421
422
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
423
--
batterseapower's avatar
batterseapower committed
424
425
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
426
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
427
428
429
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
430
bindNonRec bndr rhs body
batterseapower's avatar
batterseapower committed
431
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
432
  | otherwise                          = Let (NonRec bndr rhs) body
433

batterseapower's avatar
batterseapower committed
434
435
-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
436
needsCaseBinding :: Type -> CoreExpr -> Bool
437
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
438
439
440
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)
441

batterseapower's avatar
batterseapower committed
442
443
444
445
446
447
mkAltExpr :: AltCon     -- ^ Case alternative constructor
          -> [CoreBndr] -- ^ Things bound by the pattern match
          -> [Type]     -- ^ The type arguments to the case alternative
          -> CoreExpr
-- ^ This guy constructs the value that the scrutinee must have
-- given that you are in one particular branch of a case
448
mkAltExpr (DataAlt con) args inst_tys
449
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
450
451
mkAltExpr (LitAlt lit) [] []
  = Lit lit
452
453
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
454

Austin Seipp's avatar
Austin Seipp committed
455
456
457
{-
************************************************************************
*                                                                      *
458
               Operations oer case alternatives
Austin Seipp's avatar
Austin Seipp committed
459
460
*                                                                      *
************************************************************************
461

462
463
The default alternative must be first, if it exists at all.
This makes it easy to find, though it makes matching marginally harder.
Austin Seipp's avatar
Austin Seipp committed
464
-}
465

batterseapower's avatar
batterseapower committed
466
-- | Extract the default case alternative
467
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
468
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
469
findDefault alts                        =                     (alts, Nothing)
470

471
472
473
474
addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault alts Nothing    = alts
addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts

475
isDefaultAlt :: (AltCon, a, b) -> Bool
476
477
478
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _               = False

479
-- | Find the case alternative corresponding to a particular
batterseapower's avatar
batterseapower committed
480
-- constructor: panics if no such constructor exists
481
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
482
483
    -- A "Nothing" result *is* legitmiate
    -- See Note [Unreachable code]
484
findAlt con alts
485
  = case alts of
486
        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
487
        _                          -> go alts Nothing
488
  where
489
    go []                     deflt = deflt
490
    go (alt@(con1,_,_) : alts) deflt
491
492
493
494
      = case con `cmpAltCon` con1 of
          LT -> deflt   -- Missed it already; the alts are in increasing order
          EQ -> Just alt
          GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
495

496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
{- Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~~~~
It is possible (although unusual) for GHC to find a case expression
that cannot match.  For example:

     data Col = Red | Green | Blue
     x = Red
     f v = case x of
              Red -> ...
              _ -> ...(case x of { Green -> e1; Blue -> e2 })...

Suppose that for some silly reason, x isn't substituted in the case
expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff
gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce
this

     x = Red
     lvl = case x of { Green -> e1; Blue -> e2 })
     f v = case x of
             Red -> ...
             _ -> ...lvl...

Now if x gets inlined, we won't be able to find a matching alternative
for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing
we generate (error "Inaccessible alternative").

Similar things can happen (augmented by GADTs) when the Simplifier
filters down the matching alternatives in Simplify.rebuildCase.
-}

526
---------------------------------
527
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
batterseapower's avatar
batterseapower committed
528
529
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
530
531
532
533
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
534
535
536
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
537
538
539
540


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
541
542
543
544
545
546
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
547
548
549
-- leaving the arguments to match agains the pattern

trimConArgs DEFAULT      args = ASSERT( null args ) []
550
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
551
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
552

553
554
filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)
           -> [Type]               -- ^ And its type arguments
Simon Peyton Jones's avatar
Simon Peyton Jones committed
555
           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
556
           -> [(AltCon, [Var], a)] -- ^ Alternatives
557
           -> ([AltCon], [(AltCon, [Var], a)])
558
             -- Returns:
Austin Seipp's avatar
Austin Seipp committed
559
             --  1. Constructors that will never be encountered by the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
560
             --     *default* case (if any).  A superset of imposs_cons
561
             --  2. The new alternatives, trimmed by
Simon Peyton Jones's avatar
Simon Peyton Jones committed
562
563
564
565
             --        a) remove imposs_cons
             --        b) remove constructors which can't match because of GADTs
             --      and with the DEFAULT expanded to a DataAlt if there is exactly
             --      remaining constructor that can match
566
567
568
             --
             -- NB: the final list of alternatives may be empty:
             -- This is a tricky corner case.  If the data type has no constructors,
Austin Seipp's avatar
Austin Seipp committed
569
             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
Simon Peyton Jones's avatar
Simon Peyton Jones committed
570
             -- account of GADTs), then no alternatives can match.
571
572
573
574
             --
             -- If callers need to preserve the invariant that there is always at least one branch
             -- in a "case" statement then they will need to manually add a dummy case branch that just
             -- calls "error" or similar.
575
576
filterAlts _tycon inst_tys imposs_cons alts
  = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)
577
578
579
  where
    (alts_wo_default, maybe_deflt) = findDefault alts
    alt_cons = [con | (con,_,_) <- alts_wo_default]
580

581
    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default
582

583
    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
Austin Seipp's avatar
Austin Seipp committed
584
585
         -- "imposs_deflt_cons" are handled
         --   EITHER by the context,
586
587
588
589
590
591
         --   OR by a non-DEFAULT branch in this case expression.

    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool
    impossible_alt _ (con, _, _) | con `elem` imposs_cons = True
    impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con
    impossible_alt _  _                         = False
592

593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
refineDefaultAlt :: [Unique] -> TyCon -> [Type] -> [AltCon] -> [CoreAlt] -> (Bool, [CoreAlt])
-- Refine the default alterantive to a DataAlt,
-- if there is a unique way to do so
refineDefaultAlt us tycon tys imposs_deflt_cons all_alts
  | (DEFAULT,_,rhs) : rest_alts <- all_alts
  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.
  , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:
                                --      case x of { DEFAULT -> e }
                                -- and we don't want to fill in a default for them!
  , Just all_cons <- tyConDataCons_maybe tycon
  , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type
        impossible con   = con `elem` imposs_data_cons || dataConCannotMatch tys con
  = case filterOut impossible all_cons of
       -- Eliminate the default alternative
       -- altogether if it can't match:
       []    -> (False, rest_alts)

       -- It matches exactly one constructor, so fill it in:
       [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)])
                       -- We need the mergeAlts to keep the alternatives in the right order
             where
                (ex_tvs, arg_ids) = dataConRepInstPat us con tys

       -- It matches more than one, so do nothing
       _  -> (False, all_alts)

  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)
  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
        -- Check for no data constructors
        -- This can legitimately happen for abstract types and type families,
        -- so don't report that
  = pprTrace "prepareDefault" (ppr tycon) (False, all_alts)

  | otherwise      -- The common case
  = (False, all_alts)

{- Note [Combine identical alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If several alternatives are identical, merge them into a single
DEFAULT alternative.  I've occasionally seen this making a big
difference:

     case e of               =====>     case e of
       C _ -> f x                         D v -> ....v....
       D v -> ....v....                   DEFAULT -> f x
       DEFAULT -> f x

The point is that we merge common RHSs, at least for the DEFAULT case.
[One could do something more elaborate but I've never seen it needed.]
To avoid an expensive test, we just merge branches equal to the *first*
alternative; this picks up the common cases
     a) all branches equal
     b) some branches equal to the DEFAULT (which occurs first)

The case where Combine Identical Alternatives transformation showed up
was like this (base/Foreign/C/Err/Error.hs):

        x | p `is` 1 -> e1
          | p `is` 2 -> e2
        ...etc...

where @is@ was something like

        p `is` n = p /= (-1) && p == n

This gave rise to a horrible sequence of cases

        case p of
          (-1) -> $j p
          1    -> e1
          DEFAULT -> $j p

and similarly in cascade for all the join points!

NB: it's important that all this is done in [InAlt], *before* we work
on the alternatives themselves, because Simpify.simplAlt may zap the
occurrence info on the binders in the alternatives, which in turn
defeats combineIdenticalAlts (see Trac #7360).

Note [Care with impossible-constructors when combining alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have (Trac #10538)
   data T = A | B | C

   ... case x::T of
         DEFAULT -> e1
         A -> e2
         B -> e1

When calling combineIdentialAlts, we'll have computed that the "impossible
constructors" for the DEFAULT alt is {A,B}, since if x is A or B we'll
take the other alternatives.  But suppose we combine B into the DEFAULT,
to get
   ... case x::T of
         DEFAULT -> e1
         A -> e2
Then we must be careful to trim the impossible constructors to just {A},
else we risk compiling 'e1' wrong!
-}
692
693


694
695
696
697
698
699
700
701
702
703
704
705
combineIdenticalAlts :: [AltCon] -> [CoreAlt] -> (Bool, [AltCon], [CoreAlt])
-- See Note [Combine identical alternatives]
-- See Note [Care with impossible-constructors when combining alternatives]
-- True <=> we did some combining, result is a single DEFAULT alternative
combineIdenticalAlts imposs_cons ((_con1,bndrs1,rhs1) : con_alts)
  | all isDeadBinder bndrs1    -- Remember the default
  , not (null eliminated_alts) -- alternative comes first
  = (True, imposs_cons', deflt_alt : filtered_alts)
  where
    (eliminated_alts, filtered_alts) = partition identical_to_alt1 con_alts
    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
    imposs_cons' = imposs_cons `minusList` map fstOf3 eliminated_alts
706

707
708
709
710
    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
    identical_to_alt1 (_con,bndrs,rhs)
      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
    tickss = map (stripTicksT tickishFloatable . thirdOf3) eliminated_alts
711

712
713
combineIdenticalAlts imposs_cons alts
  = (False, imposs_cons, alts)
714

715
{- *********************************************************************
Austin Seipp's avatar
Austin Seipp committed
716
*                                                                      *
717
             exprIsTrivial
Austin Seipp's avatar
Austin Seipp committed
718
719
*                                                                      *
************************************************************************
720

721
722
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
723
@exprIsTrivial@ is true of expressions we are unconditionally happy to
724
725
726
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
727

728
729
Note [Variable are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
730
731
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
732
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
733
The idea here is that a constructor worker, like \$wJust, is
Gabor Greif's avatar
typos    
Gabor Greif committed
734
really short for (\x -> \$wJust x), because \$wJust has no binding.
735
736
737
738
739
740
So it should be treated like a lambda.  Ditto unsaturated primops.
But now constructor workers are not "have-no-binding" Ids.  And
completely un-applied primops and foreign-call Ids are sufficiently
rare that I plan to allow them to be duplicated and put up with
saturating them.

741
742
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Peter Wortmann's avatar
Peter Wortmann committed
743
744
745
746
747

Ticks are only trivial if they are pure annotations. If we treat
"tick<n> x" as trivial, it will be inlined inside lambdas and the
entry count will be skewed, for example.  Furthermore "scc<n> x" will
turn into just "x" in mkTick.
Austin Seipp's avatar
Austin Seipp committed
748
-}
749

750
exprIsTrivial :: CoreExpr -> Bool
751
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
Peter Wortmann's avatar
Peter Wortmann committed
752
exprIsTrivial (Type _)         = True
753
exprIsTrivial (Coercion _)     = True
754
755
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
Peter Wortmann's avatar
Peter Wortmann committed
756
757
exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
                                 -- See Note [Tick trivial]
758
759
760
exprIsTrivial (Cast e _)       = exprIsTrivial e
exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _                = False
761

Austin Seipp's avatar
Austin Seipp committed
762
{-
763
764
765
766
When substituting in a breakpoint we need to strip away the type cruft
from a trivial expression and get back to the Id.  The invariant is
that the expression we're substituting was originally trivial
according to exprIsTrivial.
Austin Seipp's avatar
Austin Seipp committed
767
-}
768
769
770
771
772

getIdFromTrivialExpr :: CoreExpr -> Id
getIdFromTrivialExpr e = go e
  where go (Var v) = v
        go (App f t) | not (isRuntimeArg t) = go f
773
        go (Tick t e) | not (tickishIsCode t) = go e
774
775
776
777
        go (Cast e _) = go e
        go (Lam b e) | not (isRuntimeVar b) = go e
        go e = pprPanic "getIdFromTrivialExpr" (ppr e)

Austin Seipp's avatar
Austin Seipp committed
778
{-
779
exprIsBottom is a very cheap and cheerful function; it may return
780
781
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
782
expensive.
Austin Seipp's avatar
Austin Seipp committed
783
-}
784
785

exprIsBottom :: CoreExpr -> Bool
786
-- See Note [Bottoming expressions]
787
exprIsBottom e
788
789
790
  | isEmptyTy (exprType e)
  = True
  | otherwise
791
792
  = go 0 e
  where
793
794
795
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
796
    go n (Tick _ e)              = go n e
797
798
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
799
    go n (Lam v e) | isTyVar v   = go n e
800
    go _ _                       = False
801

802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
{- Note [Bottoming expressions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A bottoming expression is guaranteed to diverge, or raise an
exception.  We can test for it in two different ways, and exprIsBottom
checks for both of these situations:

* Visibly-bottom computations.  For example
      (error Int "Hello")
  is visibly bottom.  The strictness analyser also finds out if
  a function diverges or raises an exception, and puts that info
  in its strictness signature.

* Empty types.  If a type is empty, its only inhabitant is bottom.
  For example:
      data T
      f :: T -> Bool
      f = \(x:t). case x of Bool {}
  Since T has no data constructors, the case alternatives are of course
  empty.  However note that 'x' is not bound to a visibly-bottom value;
  it's the *type* that tells us it's going to diverge.

A GADT may also be empty even though it has constructors:
        data T a where
          T1 :: a -> T Bool
          T2 :: T Int
        ...(case (x::T Char) of {})...
Here (T Char) is uninhabited.  A more realistic case is (Int ~ Bool),
which is likewise uninhabited.


Austin Seipp's avatar
Austin Seipp committed
832
833
************************************************************************
*                                                                      *
834
             exprIsDupable
Austin Seipp's avatar
Austin Seipp committed
835
836
*                                                                      *
************************************************************************
837
838
839

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
840
841
842
@exprIsDupable@ is true of expressions that can be duplicated at a modest
                cost in code size.  This will only happen in different case
                branches, so there's no issue about duplicating work.
843

844
845
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
846

847
848
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
Austin Seipp's avatar
Austin Seipp committed
849
-}
850

851
852
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
853
  = isJust (go dupAppSize e)
854
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
855
    go :: Int -> CoreExpr -> Maybe Int
856
857
858
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
859
    go n (Tick _ e)    = go n e
860
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
861
    go n (App f a) | Just n' <- go n a = go n' f
862
    go n (Lit lit) | litIsDupable dflags lit = decrement n
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
863
864
865
866
867
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
868
869

dupAppSize :: Int
870
871
872
873
dupAppSize = 8   -- Size of term we are prepared to duplicate
                 -- This is *just* big enough to make test MethSharing
                 -- inline enough join points.  Really it should be
                 -- smaller, and could be if we fixed Trac #4960.
874

Austin Seipp's avatar
Austin Seipp committed
875
876
877
{-
************************************************************************
*                                                                      *
878
             exprIsCheap, exprIsExpandable
Austin Seipp's avatar
Austin Seipp committed
879
880
*                                                                      *
************************************************************************
881

882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
Note [exprIsWorkFree]
~~~~~~~~~~~~~~~~~~~~~
exprIsWorkFree is used when deciding whether to inline something; we
don't inline it if doing so might duplicate work, by peeling off a
complete copy of the expression.  Here we do not want even to
duplicate a primop (Trac #5623):
   eg   let x = a #+ b in x +# x
   we do not want to inline/duplicate x

Previously we were a bit more liberal, which led to the primop-duplicating
problem.  However, being more conservative did lead to a big regression in
one nofib benchmark, wheel-sieve1.  The situation looks like this:

   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool
       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->
         case GHC.Prim.<=# x_aRs 2 of _ {
           GHC.Types.False -> notDivBy ps_adM qs_adN;
           GHC.Types.True -> lvl_r2Eb }}
       go = \x. ...(noFactor (I# y))....(go x')...

The function 'noFactor' is heap-allocated and then called.  Turns out
that 'notDivBy' is strict in its THIRD arg, but that is invisible to
the caller of noFactor, which therefore cannot do w/w and
heap-allocates noFactor's argument.  At the moment (May 12) we are just
Austin Seipp's avatar
Austin Seipp committed
906
907
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
908
in turn was making inner loops of array calculations runs slow (#5623)
Austin Seipp's avatar
Austin Seipp committed
909
-}
910
911
912
913
914
915
916
917
918

exprIsWorkFree :: CoreExpr -> Bool
-- See Note [exprIsWorkFree]
exprIsWorkFree e = go 0 e
  where    -- n is the number of value arguments
    go _ (Lit {})                     = True
    go _ (Type {})                    = True
    go _ (Coercion {})                = True
    go n (Cast e _)                   = go n e
Austin Seipp's avatar
Austin Seipp committed
919
    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut)
920
921
922
                                              [ go n rhs | (_,_,rhs) <- alts ]
         -- See Note [Case expressions are work-free]
    go _ (Let {})                     = False
923
    go n (Var v)                      = isCheapApp v n
924
925
926
927
928
929
930
    go n (Tick t e) | tickishCounts t = False
                    | otherwise       = go n e
    go n (Lam x e)  | isRuntimeVar x = n==0 || go (n-1) e
                    | otherwise      = go n e
    go n (App f e)  | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
                    | otherwise      = go n f

Austin Seipp's avatar
Austin Seipp committed
931
{-
932
933
934
935
936
937
938
939
940
Note [Case expressions are work-free]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Are case-expressions work-free?  Consider
    let v = case x of (p,q) -> p
        go = \y -> ...case v of ...
Should we inline 'v' at its use site inside the loop?  At the moment
we do.  I experimented with saying that case are *not* work-free, but
that increased allocation slightly.  It's a fairly small effect, and at
the moment we go for the slightly more aggressive version which treats
Krzysztof Gogolewski's avatar
Typos    
Krzysztof Gogolewski committed
941
(case x of ....) as work-free if the alternatives are.
942
943


944
Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
945
~~~~~~~~~~~~~~~~~~   in CoreUnfold.hs
946
947
948
949
@exprIsCheap@ looks at a Core expression and returns \tr{True} if
it is obviously in weak head normal form, or is cheap to get to WHNF.
[Note that that's not the same as exprIsDupable; an expression might be
big, and hence not dupable, but still cheap.]
950
951

By ``cheap'' we mean a computation we're willing to:
952
953
        push inside a lambda, or
        inline at more than one place
954
955
956
That might mean it gets evaluated more than once, instead of being
shared.  The main examples of things which aren't WHNF but are
``cheap'' are:
957

958
959
960
  *     case e of
          pi -> ei
        (where e, and all the ei are cheap)
961

962
963
  *     let x = e in b
        (where e and b are cheap)
964

965
966
  *     op x1 ... xn
        (where op is a cheap primitive operator)
967

968
969
  *     error "foo"
        (because we are happy to substitute it inside a lambda)
970

971
972
973
Notice that a variable is considered 'cheap': we can push it inside a lambda,
because sharing will make sure it is only evaluated once.

974
975
976
Note [exprIsCheap and exprIsHNF]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that exprIsHNF does not imply exprIsCheap.  Eg
977
        let x = fac 20 in Just x
978
979
This responds True to exprIsHNF (you can discard a seq), but
False to exprIsCheap.
Austin Seipp's avatar
Austin Seipp committed
980
-}
981

982
exprIsCheap :: CoreExpr -> Bool
983
exprIsCheap = exprIsCheap' isCheapApp
984
985

exprIsExpandable :: CoreExpr -> Bool
986
exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
987

988
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
989
exprIsCheap' _        (Lit _)      = True
990
exprIsCheap' _        (Type _)    = True
991
992
993
994
995
exprIsCheap' _        (Coercion _) = True
exprIsCheap' _        (Var _)      = True
exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
                                  || exprIsCheap' good_app e
996

997
998
999
1000
1001
1002
exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
                                          and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
        -- This improves arities of overloaded functions where
        -- there is only dictionary selection (no construction) involved
1003

1004
1005
1006
exprIsCheap' good_app (Tick t e)
  | tickishCounts t = False
  | otherwise       = exprIsCheap' good_app e
Peter Wortmann's avatar
Peter Wortmann committed
1007
1008
1009
     -- never duplicate counting ticks.  If we get this wrong, then
     -- HPC's entry counts will be off (check test in
     -- libraries/hpc/tests/raytrace)
1010

1011
1012
1013
1014
exprIsCheap' good_app (Let (NonRec _ b) e)
  = exprIsCheap' good_app b && exprIsCheap' good_app e
exprIsCheap' good_app (Let (Rec prs) e)
  = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e
1015

1016
exprIsCheap' good_app other_expr        -- Applications and variables
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1017
  = go other_expr []
1018
  where
1019
        -- Accumulate value arguments, then decide
1020
    go (Cast e _) val_args                 = go e val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1021
    go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
1022
                          | otherwise      = go f val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1023

Austin Seipp's avatar
Austin Seipp committed
1024
    go (Var _) [] = True
1025
1026
1027
1028
1029
         -- Just a type application of a variable
         -- (f t1 t2 t3) counts as WHNF
         -- This case is probably handeld by the good_app case
         -- below, which should have a case for n=0, but putting
         -- it here too is belt and braces; and it's such a common
Austin Seipp's avatar
Austin Seipp committed
1030
         -- case that checking for null directly seems like a
1031
1032
         -- good plan

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1033
    go (Var f) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1034
1035
       | good_app f (length args)  -- Typically holds of data constructor applications
       = go_pap args               -- E.g. good_app = isCheapApp below
1036
1037

       | otherwise
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1038
        = case idDetails f of
1039
1040
1041
1042
1043
                RecSelId {}         -> go_sel args
                ClassOpId {}        -> go_sel args
                PrimOpId op         -> go_primop op args
                _ | isBottomingId f -> True
                  | otherwise       -> False
1044
1045
1046
1047
                        -- Application of a function which
                        -- always gives bottom; we treat this as cheap
                        -- because it certainly doesn't need to be shared!

Peter Wortmann's avatar
Peter Wortmann committed
1048
1049
1050
1051
    go (Tick t e) args
      | not (tickishCounts t) -- don't duplicate counting ticks, see above
      = go e args

1052
    go _ _ = False
1053

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1054
    --------------
1055
1056
1057
    go_pap args = all (exprIsCheap' good_app) args
        -- Used to be "all exprIsTrivial args" due to concerns about
        -- duplicating nested constructor applications, but see #4978.
1058
1059
        -- The principle here is that
        --    let x = a +# b in c *# x
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1060
1061
        -- should behave equivalently to
        --    c *# (a +# b)
1062
        -- Since lets with cheap RHSs are accepted,
Simon Peyton Jones's avatar
Simon Peyton Jones committed
1063
        -- so should paps with cheap arguments
1064

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1065
    --------------
1066
    go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
1067
1068
1069
1070
1071
        -- In principle we should worry about primops
        -- that return a type variable, since the result
        -- might be applied to something, but I'm not going
        -- to bother to check the number of args

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
1072
    --------------
1073
1074
1075
1076