CoreUtils.hs 90.3 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
Richard Eisenberg's avatar
Richard Eisenberg committed
25
        exprType, coreAltType, coreAltsType, isExprLevPoly,
26
        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
27
        getIdFromTrivialExpr_maybe,
28
        exprIsCheap, exprIsExpandable, exprIsOk, CheapAppFun,
29
        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
30
31
        exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
32
        exprIsLiteralString, exprIsTopLevelBindable,
33

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

38
39
        -- * Eta reduction
        tryEtaReduce,
40

41
        -- * Manipulating data constructors and types
42
        exprToType, exprToCoercion_maybe,
43
        applyTypeToArgs, applyTypeToArg,
Peter Wortmann's avatar
Peter Wortmann committed
44
        dataConRepInstPat, dataConRepFSInstPat,
45
        isEmptyTy,
Peter Wortmann's avatar
Peter Wortmann committed
46
47

        -- * Working with ticks
48
        stripTicksTop, stripTicksTopE, stripTicksTopT,
49
50
51
        stripTicksE, stripTicksT,

        -- * StaticPtr
lukemaurer's avatar
lukemaurer committed
52
53
54
55
        collectMakeStaticArgs,

        -- * Join points
        isJoinBind
56
    ) where
57

58
#include "HsVersions.h"
59

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

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

102
exprType :: CoreExpr -> Type
batterseapower's avatar
batterseapower committed
103
104
105
-- ^ 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
106
107
108
exprType (Var var)           = idType var
exprType (Lit lit)           = literalType lit
exprType (Coercion co)       = coercionType co
Austin Seipp's avatar
Austin Seipp committed
109
exprType (Let bind body)
110
  | NonRec tv rhs <- bind    -- See Note [Type bindings]
111
  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)
112
  | otherwise                = exprType body
113
exprType (Case _ _ ty _)     = ty
114
exprType (Cast _ co)         = pSnd (coercionKind co)
115
exprType (Tick _ e)          = exprType e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
116
exprType (Lam binder expr)   = mkLamType binder (exprType expr)
117
exprType e@(App _ _)
118
  = case collectArgs e of
119
        (fun, args) -> applyTypeToArgs e (exprType fun) args
120

121
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
122

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

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

Richard Eisenberg's avatar
Richard Eisenberg committed
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
-- | Is this expression levity polymorphic? This should be the
-- same as saying (isKindLevPoly . typeKind . exprType) but
-- much faster.
isExprLevPoly :: CoreExpr -> Bool
isExprLevPoly = go
  where
   go (Var _)                      = False  -- no levity-polymorphic binders
   go (Lit _)                      = False  -- no levity-polymorphic literals
   go e@(App f _) | not (go_app f) = False
                  | otherwise      = check_type e
   go (Lam _ _)                    = False
   go (Let _ e)                    = go e
   go e@(Case {})                  = check_type e -- checking type is fast
   go e@(Cast {})                  = check_type e
   go (Tick _ e)                   = go e
   go e@(Type {})                  = pprPanic "isExprLevPoly ty" (ppr e)
   go (Coercion {})                = False  -- this case can happen in SetLevels

   check_type = isTypeLevPoly . exprType  -- slow approach

      -- if the function is a variable (common case), check its
      -- levityInfo. This might mean we don't need to look up and compute
      -- on the type. Spec of these functions: return False if there is
      -- no possibility, ever, of this expression becoming levity polymorphic,
      -- no matter what it's applied to; return True otherwise.
      -- returning True is always safe. See also Note [Levity info] in
      -- IdInfo
   go_app (Var id)        = not (isNeverLevPolyId id)
   go_app (Lit _)         = False
   go_app (App f _)       = go_app f
   go_app (Lam _ e)       = go_app e
   go_app (Let _ e)       = go_app e
   go_app (Case _ _ ty _) = resultIsLevPoly ty
   go_app (Cast _ co)     = resultIsLevPoly (pSnd $ coercionKind co)
   go_app (Tick _ e)      = go_app e
   go_app e@(Type {})     = pprPanic "isExprLevPoly app ty" (ppr e)
   go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e)


Austin Seipp's avatar
Austin Seipp committed
177
{-
178
179
180
181
182
183
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
184
Given this, exprType must be careful to substitute 'a' in the
185
186
result type (Trac #8522).

187
188
189
Note [Existential variables and silly type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
190
191
192
193
        data T = forall a. T (Funny a)
        type Funny a = Bool
        f :: T -> Bool
        f (T x) = x
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

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.

211
212
Note that there might be existentially quantified coercion variables, too.
-}
213

214
-- Not defined with applyTypeToArg because you can't print from CoreSyn.
215
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
216
217
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
218
219
applyTypeToArgs e op_ty args
  = go op_ty args
220
  where
221
222
223
224
225
    go op_ty []                   = op_ty
    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args
    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args
    go op_ty (_ : args)           | Just (_, res_ty) <- splitFunTy_maybe op_ty
                                  = go res_ty args
226
227
    go _ _ = pprPanic "applyTypeToArgs" panic_msg

228
229
    -- go_ty_args: accumulate type arguments so we can
    -- instantiate all at once with piResultTys
Simon Peyton Jones's avatar
Simon Peyton Jones committed
230
    go_ty_args op_ty rev_tys (Type ty : args)
231
       = go_ty_args op_ty (ty:rev_tys) args
232
233
    go_ty_args op_ty rev_tys (Coercion co : args)
       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args
234
    go_ty_args op_ty rev_tys args
235
       = go (piResultTys op_ty (reverse rev_tys)) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
236

237
238
239
    panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e
                     , text "Type:" <+> ppr op_ty
                     , text "Args:" <+> ppr args ]
240

241

Austin Seipp's avatar
Austin Seipp committed
242
243
244
{-
************************************************************************
*                                                                      *
245
\subsection{Attaching notes}
Austin Seipp's avatar
Austin Seipp committed
246
247
248
*                                                                      *
************************************************************************
-}
249

250
251
-- | Wrap the given expression in the coercion safely, dropping
-- identity coercions and coalescing nested coercions
252
mkCast :: CoreExpr -> Coercion -> CoreExpr
253
254
mkCast e co
  | ASSERT2( coercionRole co == Representational
255
256
           , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast")
             <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) )
257
258
    isReflCo co
  = e
259

Austin Seipp's avatar
Austin Seipp committed
260
mkCast (Coercion e_co) co
261
  | isCoercionType (pSnd (coercionKind co))
262
263
264
       -- The guard here checks that g has a (~#) on both sides,
       -- otherwise decomposeCo fails.  Can in principle happen
       -- with unsafeCoerce
265
  = Coercion (mkCoCast e_co co)
266
267

mkCast (Cast expr co2) co
268
269
270
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
271
272
273
             vcat ([ text "expr:" <+> ppr expr
                   , text "co2:" <+> ppr co2
                   , text "co:" <+> ppr co ]) )
274
    mkCast expr (mkTransCo co2 co)
275

Peter Wortmann's avatar
Peter Wortmann committed
276
277
278
mkCast (Tick t expr) co
   = Tick t (mkCast expr co)

279
mkCast expr co
280
  = let Pair from_ty _to_ty = coercionKind co in
281
282
283
284
285
    WARN( not (from_ty `eqType` exprType expr),
          text "Trying to coerce" <+> text "(" <> ppr expr
          $$ text "::" <+> ppr (exprType expr) <> text ")"
          $$ ppr co $$ ppr (coercionType co) )
    (Cast expr co)
286

287
288
289
-- | 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
290
291
292
293
294
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
295

Peter Wortmann's avatar
Peter Wortmann committed
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
  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
354
      | notFunction && tickishPlace t == PlaceCostCentre
Peter Wortmann's avatar
Peter Wortmann committed
355
      -> orig_expr
Simon Marlow's avatar
Simon Marlow committed
356
      | notFunction && canSplit
Peter Wortmann's avatar
Peter Wortmann committed
357
      -> top $ Tick (mkNoScope t) $ rest expr
Simon Marlow's avatar
Simon Marlow committed
358
359
360
361
362
363
364
365
      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
366
367
368
369
370
371
372
373
374
375

    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
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396

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
397

Peter Wortmann's avatar
Peter Wortmann committed
398
399
400
401
402
403
404
-- | 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,
Gabor Greif's avatar
Gabor Greif committed
405
-- returning the remaining expression
Peter Wortmann's avatar
Peter Wortmann committed
406
407
408
409
410
411
412
413
414
415
416
417
418
419
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!
420
421
422
423
424
425
426
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
427
        go (Tick t e)
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
          | 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
451

Austin Seipp's avatar
Austin Seipp committed
452
453
454
{-
************************************************************************
*                                                                      *
455
\subsection{Other expression construction}
Austin Seipp's avatar
Austin Seipp committed
456
457
458
*                                                                      *
************************************************************************
-}
459
460

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
461
462
463
464
465
466
467
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
468
--
batterseapower's avatar
batterseapower committed
469
470
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
471
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
472
473
474
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
475
bindNonRec bndr rhs body
batterseapower's avatar
batterseapower committed
476
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
477
  | otherwise                          = Let (NonRec bndr rhs) body
478

batterseapower's avatar
batterseapower committed
479
480
-- | 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"
481
needsCaseBinding :: Type -> CoreExpr -> Bool
482
needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs)
483
484
485
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)
486

batterseapower's avatar
batterseapower committed
487
488
489
490
491
492
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
493
mkAltExpr (DataAlt con) args inst_tys
494
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
495
496
mkAltExpr (LitAlt lit) [] []
  = Lit lit
497
498
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
499

Austin Seipp's avatar
Austin Seipp committed
500
501
502
{-
************************************************************************
*                                                                      *
503
               Operations oer case alternatives
Austin Seipp's avatar
Austin Seipp committed
504
505
*                                                                      *
************************************************************************
506

507
508
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
509
-}
510

batterseapower's avatar
batterseapower committed
511
-- | Extract the default case alternative
512
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
513
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
514
findDefault alts                        =                     (alts, Nothing)
515

516
517
518
519
addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]
addDefault alts Nothing    = alts
addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts

520
isDefaultAlt :: (AltCon, a, b) -> Bool
521
522
523
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _               = False

524
-- | Find the case alternative corresponding to a particular
batterseapower's avatar
batterseapower committed
525
-- constructor: panics if no such constructor exists
526
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
527
528
    -- A "Nothing" result *is* legitmiate
    -- See Note [Unreachable code]
529
findAlt con alts
530
  = case alts of
531
        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
532
        _                          -> go alts Nothing
533
  where
534
    go []                     deflt = deflt
535
    go (alt@(con1,_,_) : alts) deflt
536
537
538
539
      = 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
540

541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
{- 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.
-}

571
---------------------------------
572
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
batterseapower's avatar
batterseapower committed
573
574
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
575
576
577
578
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
579
580
581
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
582
583
584
585


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
586
587
588
589
590
591
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
Herbert Valerio Riedel's avatar
Herbert Valerio Riedel committed
592
-- leaving the arguments to match against the pattern
593
594

trimConArgs DEFAULT      args = ASSERT( null args ) []
595
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
596
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
597

598
599
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
600
           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
601
           -> [(AltCon, [Var], a)] -- ^ Alternatives
602
           -> ([AltCon], [(AltCon, [Var], a)])
603
             -- Returns:
Austin Seipp's avatar
Austin Seipp committed
604
             --  1. Constructors that will never be encountered by the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
605
             --     *default* case (if any).  A superset of imposs_cons
606
             --  2. The new alternatives, trimmed by
Simon Peyton Jones's avatar
Simon Peyton Jones committed
607
608
609
610
             --        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
611
612
613
             --
             -- 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
614
             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
Simon Peyton Jones's avatar
Simon Peyton Jones committed
615
             -- account of GADTs), then no alternatives can match.
616
617
618
619
             --
             -- 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.
620
621
filterAlts _tycon inst_tys imposs_cons alts
  = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)
622
623
624
  where
    (alts_wo_default, maybe_deflt) = findDefault alts
    alt_cons = [con | (con,_,_) <- alts_wo_default]
625

626
    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default
627

628
    imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
Austin Seipp's avatar
Austin Seipp committed
629
630
         -- "imposs_deflt_cons" are handled
         --   EITHER by the context,
631
632
633
634
635
636
         --   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
637

Simon Peyton Jones's avatar
Simon Peyton Jones committed
638
refineDefaultAlt :: [Unique] -> TyCon -> [Type]
639
                 -> [AltCon]  -- Constructors that cannot match the DEFAULT (if any)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
640
641
                 -> [CoreAlt]
                 -> (Bool, [CoreAlt])
642
-- Refine the default alternative to a DataAlt,
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
-- 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
672
  = (False, all_alts)
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722

  | 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)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
723
   data T = A | B | C | D
724

Simon Peyton Jones's avatar
Simon Peyton Jones committed
725
      case x::T of   (Imposs-default-cons {A,B})
726
727
728
729
         DEFAULT -> e1
         A -> e2
         B -> e1

Simon Peyton Jones's avatar
Simon Peyton Jones committed
730
731
732
733
734
735
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   (Imposs-default-cons {A})
736
737
         DEFAULT -> e1
         A -> e2
Simon Peyton Jones's avatar
Simon Peyton Jones committed
738

739
740
Then we must be careful to trim the impossible constructors to just {A},
else we risk compiling 'e1' wrong!
741

Simon Peyton Jones's avatar
Simon Peyton Jones committed
742
743
744
745
746
747
748
Not only that, but we take care when there is no DEFAULT beforehand,
because we are introducing one.  Consider

   case x of   (Imposs-default-cons {A,B,C})
     A -> e1
     B -> e2
     C -> e1
749

Simon Peyton Jones's avatar
Simon Peyton Jones committed
750
751
752
753
754
755
756
757
758
759
760
Then when combining the A and C alternatives we get

   case x of   (Imposs-default-cons {B})
     DEFAULT -> e1
     B -> e2

Note that we have a new DEFAULT branch that we didn't have before.  So
we need delete from the "impossible-default-constructors" all the
known-con alternatives that we have eliminated. (In Trac #11172 we
missed the first one.)

761
762
-}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
763
764
765
combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT
                     -> [CoreAlt]
                     -> (Bool,      -- True <=> something happened
Gabor Greif's avatar
Gabor Greif committed
766
                         [AltCon],  -- New constructors that cannot match DEFAULT
Simon Peyton Jones's avatar
Simon Peyton Jones committed
767
                         [CoreAlt]) -- New alternatives
768
769
-- See Note [Combine identical alternatives]
-- True <=> we did some combining, result is a single DEFAULT alternative
Simon Peyton Jones's avatar
Simon Peyton Jones committed
770
combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)
771
  | all isDeadBinder bndrs1    -- Remember the default
Simon Peyton Jones's avatar
Simon Peyton Jones committed
772
773
  , not (null elim_rest) -- alternative comes first
  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)
774
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
775
    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts
776
    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
777
778
779
780
781
782
783

     -- See Note [Care with impossible-constructors when combining alternatives]
    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons
    elim_cons = elim_con1 ++ map fstOf3 elim_rest
    elim_con1 = case con1 of     -- Don't forget con1!
                  DEFAULT -> []  -- See Note [
                  _       -> [con1]
784

785
786
787
    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2
    identical_to_alt1 (_con,bndrs,rhs)
      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1
Simon Peyton Jones's avatar
Simon Peyton Jones committed
788
    tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
789

790
791
combineIdenticalAlts imposs_cons alts
  = (False, imposs_cons, alts)
792

793
{- *********************************************************************
Austin Seipp's avatar
Austin Seipp committed
794
*                                                                      *
795
             exprIsTrivial
Austin Seipp's avatar
Austin Seipp committed
796
797
*                                                                      *
************************************************************************
798

799
800
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
801
@exprIsTrivial@ is true of expressions we are unconditionally happy to
802
803
804
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
805

Joachim Breitner's avatar
Joachim Breitner committed
806
807
Note [Variables are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
808
809
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
810
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
811
The idea here is that a constructor worker, like \$wJust, is
Gabor Greif's avatar
typos    
Gabor Greif committed
812
really short for (\x -> \$wJust x), because \$wJust has no binding.
813
814
815
816
817
818
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.

819
820
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Peter Wortmann's avatar
Peter Wortmann committed
821
822
823
824
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.
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842

Note [Empty case is trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The expression (case (x::Int) Bool of {}) is just a type-changing
case used when we are sure that 'x' will not return.  See
Note [Empty case alternatives] in CoreSyn.

If the scrutinee is trivial, then so is the whole expression; and the
CoreToSTG pass in fact drops the case expression leaving only the
scrutinee.

Having more trivial expressions is good.  Moreover, if we don't treat
it as trivial we may land up with let-bindings like
   let v = case x of {} in ...
and after CoreToSTG that gives
   let v = x in ...
and that confuses the code generator (Trac #11155). So best to kill
it off at source.
Austin Seipp's avatar
Austin Seipp committed
843
-}
844

845
exprIsTrivial :: CoreExpr -> Bool
846
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
Peter Wortmann's avatar
Peter Wortmann committed
847
exprIsTrivial (Type _)         = True
848
exprIsTrivial (Coercion _)     = True
849
850
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
851
exprIsTrivial (Lam b e)        = not (isRuntimeVar b) && exprIsTrivial e
Peter Wortmann's avatar
Peter Wortmann committed
852
853
exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
                                 -- See Note [Tick trivial]
854
exprIsTrivial (Cast e _)       = exprIsTrivial e
855
exprIsTrivial (Case e _ _ [])  = exprIsTrivial e  -- See Note [Empty case is trivial]
856
exprIsTrivial _                = False
857

Austin Seipp's avatar
Austin Seipp committed
858
{-
859
860
Note [getIdFromTrivialExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
861
862
863
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
864
865
866
867
868
869
870
871
872
according to exprIsTrivial, AND the expression is not a literal.
See Note [substTickish] for how breakpoint substitution preserves
this extra invariant.

We also need this functionality in CorePrep to extract out Id of a
function which we are saturating.  However, in this case we don't know
if the variable actually refers to a literal; thus we use
'getIdFromTrivialExpr_maybe' to handle this case.  See test
T12076lit for an example where this matters.
Austin Seipp's avatar
Austin Seipp committed
873
-}
874
875

getIdFromTrivialExpr :: CoreExpr -> Id
876
877
878
879
880
881
882
883
getIdFromTrivialExpr e
    = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))
                (getIdFromTrivialExpr_maybe e)

getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id
-- See Note [getIdFromTrivialExpr]
getIdFromTrivialExpr_maybe e = go e
  where go (Var v) = Just v
884
        go (App f t) | not (isRuntimeArg t) = go f
885
        go (Tick t e) | not (tickishIsCode t) = go e
886
887
        go (Cast e _) = go e
        go (Lam b e) | not (isRuntimeVar b) = go e
888
        go _ = Nothing
889

Austin Seipp's avatar
Austin Seipp committed
890
{-
891
exprIsBottom is a very cheap and cheerful function; it may return
892
893
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
894
expensive.
Austin Seipp's avatar
Austin Seipp committed
895
-}
896
897

exprIsBottom :: CoreExpr -> Bool
898
-- See Note [Bottoming expressions]
899
exprIsBottom e
900
901
902
  | isEmptyTy (exprType e)
  = True
  | otherwise
903
904
  = go 0 e
  where
905
906
907
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
908
    go n (Tick _ e)              = go n e
909
910
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
911
    go n (Lam v e) | isTyVar v   = go n e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
912
913
    go _ (Case _ _ _ alts)       = null alts
       -- See Note [Empty case alternatives] in CoreSyn
914
    go _ _                       = False
915

916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
{- 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
946
947
************************************************************************
*                                                                      *
948
             exprIsDupable
Austin Seipp's avatar
Austin Seipp committed
949
950
*                                                                      *
************************************************************************
951
952
953

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
954
955
956
@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.
957

958
959
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
960

961
962
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
Austin Seipp's avatar
Austin Seipp committed
963
-}
964

965
966
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
967
  = isJust (go dupAppSize e)
968
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
969
    go :: Int -> CoreExpr -> Maybe Int
970
971
972
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
973
    go n (Tick _ e)    = go n e
974
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
975
    go n (App f a) | Just n' <- go n a = go n' f
976
    go n (Lit lit) | litIsDupable dflags lit = decrement n
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
977
978
979
980
981
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
982
983

dupAppSize :: Int
984
985
986
987
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.
988

Austin Seipp's avatar
Austin Seipp committed
989
990
991
{-
************************************************************************
*                                                                      *
992
             exprIsCheap, exprIsExpandable
Austin Seipp's avatar
Austin Seipp committed
993
994
*                                                                      *
************************************************************************
995

996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
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
1020
1021
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
in turn was making inner loops of array calculations runs slow (#5623)

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
1033
(case x of ....) as work-free if the alternatives are.
1034

1035
1036
Moreover it improves arities of overloaded functions where
there is only dictionary selection (no construction) involved
1037

1038
Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
1039
~~~~~~~~~~~~~~~~~~   in CoreUnfold.hs
1040
1041
1042
1043
@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.]
1044
1045

By ``cheap'' we mean a computation we're willing to:
1046
1047
        push inside a lambda, or
        inline at more than one place
1048
1049
1050
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:
1051

1052
1053
1054
  *     case e of
          pi -> ei
        (where e, and all the ei are cheap)
1055

1056
1057
  *     let x = e in b
        (where e and b are cheap)
1058

1059
1060
  *     op x1 ... xn
        (where op is a cheap primitive operator)
1061

1062
1063
  *     error "foo"
        (because we are happy to substitute it inside a lambda)
1064

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

1068
1069
1070
Note [exprIsCheap and exprIsHNF]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that exprIsHNF does not imply exprIsCheap.  Eg
1071
        let x = fac 20 in Just x
1072
1073
This responds True to exprIsHNF (you can discard a seq), but
False to exprIsCheap.
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107

Note [exprIsExpandable]
~~~~~~~~~~~~~~~~~~~~~~~
An expression is "expandable" if we are willing to dupicate it, if doing
so might make a RULE or case-of-constructor fire.  Mainly this means
data-constructor applications, but it's a bit more generous than exprIsCheap
because it is true of "CONLIKE" Ids: see Note [CONLIKE pragma] in BasicTypes.

It is used to set the uf_expandable field of an Unfolding, and that
in turn is used
  * In RULE matching
  * In exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe

But take care: exprIsExpandable should /not/ be true of primops.  I
found this in test T5623a:
    let q = /\a. Ptr a (a +# b)
    in case q @ Float of Ptr v -> ...q...

q's inlining should not be expandable, else exprIsConApp_maybe will
say that (q @ Float) expands to (Ptr a (a +# b)), and that will
duplicate the (a +# b) primop, which we should not do lightly.
(It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)


Note [Arguments in exprIsOk]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What predicate should we apply to the argument of an application?  We
used to say "exprIsTrivial arg" due to concerns about duplicating
nested constructor applications, but see #4978.  The principle here is
that
   let x = a +# b in c *# x
should behave equivalently to
   c *# (a +# b)
Since lets with cheap RHSs are accepted, so should paps with cheap arguments
Austin Seipp's avatar
Austin Seipp committed
1108
-}
1109

1110
--------------------