CoreUtils.hs 87.5 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
        getIdFromTrivialExpr_maybe,
28
        exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
29
        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
30 31
        exprIsBig, exprIsConLike,
        rhsIsStatic, isCheapApp, isExpandableApp,
32

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

37 38
        -- * Eta reduction
        tryEtaReduce,
39

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

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

        -- * StaticPtr
51
        collectStaticPtrSatArgs
52
    ) where
53

54
#include "HsVersions.h"
55

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

Austin Seipp's avatar
Austin Seipp committed
88 89 90
{-
************************************************************************
*                                                                      *
91
\subsection{Find the type of a Core atom/expression}
Austin Seipp's avatar
Austin Seipp committed
92 93 94
*                                                                      *
************************************************************************
-}
95

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

115
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
116

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

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

Austin Seipp's avatar
Austin Seipp committed
132
{-
133 134 135 136 137 138
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
139
Given this, exprType must be careful to substitute 'a' in the
140 141
result type (Trac #8522).

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

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.

166 167
Note that there might be existentially quantified coercion variables, too.
-}
168

169
-- Not defined with applyTypeToArg because you can't print from CoreSyn.
170
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
batterseapower's avatar
batterseapower committed
171 172
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context
173 174
applyTypeToArgs e op_ty args
  = go op_ty args
175
  where
176 177 178 179 180
    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
181 182
    go _ _ = pprPanic "applyTypeToArgs" panic_msg

183 184
    -- go_ty_args: accumulate type arguments so we can
    -- instantiate all at once with piResultTys
Simon Peyton Jones's avatar
Simon Peyton Jones committed
185
    go_ty_args op_ty rev_tys (Type ty : args)
186
       = go_ty_args op_ty (ty:rev_tys) args
187 188
    go_ty_args op_ty rev_tys (Coercion co : args)
       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args
189
    go_ty_args op_ty rev_tys args
190
       = go (piResultTys op_ty (reverse rev_tys)) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
191

192 193 194
    panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e
                     , text "Type:" <+> ppr op_ty
                     , text "Args:" <+> ppr args ]
195

196

Austin Seipp's avatar
Austin Seipp committed
197 198 199
{-
************************************************************************
*                                                                      *
200
\subsection{Attaching notes}
Austin Seipp's avatar
Austin Seipp committed
201 202 203
*                                                                      *
************************************************************************
-}
204

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

Austin Seipp's avatar
Austin Seipp committed
215
mkCast (Coercion e_co) co
216
  | isCoercionType (pSnd (coercionKind co))
217 218 219
       -- 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
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
226 227 228
             vcat ([ text "expr:" <+> ppr expr
                   , text "co2:" <+> ppr co2
                   , text "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
  = let Pair from_ty _to_ty = coercionKind co in
236 237 238 239 240
    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)
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
-- | 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
360
-- returning the remaining expression
Peter Wortmann's avatar
Peter Wortmann committed
361 362 363 364 365 366 367 368 369 370 371 372 373 374
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
Herbert Valerio Riedel's avatar
Herbert Valerio Riedel committed
547
-- leaving the arguments to match against the pattern
548 549

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
593
refineDefaultAlt :: [Unique] -> TyCon -> [Type]
594
                 -> [AltCon]  -- Constructors that cannot match the DEFAULT (if any)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
595 596
                 -> [CoreAlt]
                 -> (Bool, [CoreAlt])
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
-- 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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
627
  = (False, all_alts)
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

  | 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
678
   data T = A | B | C | D
679

Simon Peyton Jones's avatar
Simon Peyton Jones committed
680
      case x::T of   (Imposs-default-cons {A,B})
681 682 683 684
         DEFAULT -> e1
         A -> e2
         B -> e1

Simon Peyton Jones's avatar
Simon Peyton Jones committed
685 686 687 688 689 690
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})
691 692
         DEFAULT -> e1
         A -> e2
Simon Peyton Jones's avatar
Simon Peyton Jones committed
693

694 695
Then we must be careful to trim the impossible constructors to just {A},
else we risk compiling 'e1' wrong!
696

Simon Peyton Jones's avatar
Simon Peyton Jones committed
697 698 699 700 701 702 703
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
704

Simon Peyton Jones's avatar
Simon Peyton Jones committed
705 706 707 708 709 710 711 712 713 714 715
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.)

716 717
-}

Simon Peyton Jones's avatar
Simon Peyton Jones committed
718 719 720
combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT
                     -> [CoreAlt]
                     -> (Bool,      -- True <=> something happened
Gabor Greif's avatar
Gabor Greif committed
721
                         [AltCon],  -- New constructors that cannot match DEFAULT
Simon Peyton Jones's avatar
Simon Peyton Jones committed
722
                         [CoreAlt]) -- New alternatives
723 724
-- 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
725
combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)
726
  | all isDeadBinder bndrs1    -- Remember the default
Simon Peyton Jones's avatar
Simon Peyton Jones committed
727 728
  , not (null elim_rest) -- alternative comes first
  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)
729
  where
Simon Peyton Jones's avatar
Simon Peyton Jones committed
730
    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts
731
    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
732 733 734 735 736 737 738

     -- 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]
739

740 741 742
    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
743
    tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest
744

745 746
combineIdenticalAlts imposs_cons alts
  = (False, imposs_cons, alts)
747

748
{- *********************************************************************
Austin Seipp's avatar
Austin Seipp committed
749
*                                                                      *
750
             exprIsTrivial
Austin Seipp's avatar
Austin Seipp committed
751 752
*                                                                      *
************************************************************************
753

754 755
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
756
@exprIsTrivial@ is true of expressions we are unconditionally happy to
757 758 759
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
760

Joachim Breitner's avatar
Joachim Breitner committed
761 762
Note [Variables are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
763 764
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
765
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
766
The idea here is that a constructor worker, like \$wJust, is
Gabor Greif's avatar
typos  
Gabor Greif committed
767
really short for (\x -> \$wJust x), because \$wJust has no binding.
768 769 770 771 772 773
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.

774 775
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Peter Wortmann's avatar
Peter Wortmann committed
776 777 778 779
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.
780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797

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
798
-}
799

800
exprIsTrivial :: CoreExpr -> Bool
801
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
Peter Wortmann's avatar
Peter Wortmann committed
802
exprIsTrivial (Type _)         = True
803
exprIsTrivial (Coercion _)     = True
804 805
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
806
exprIsTrivial (Lam b e)        = not (isRuntimeVar b) && exprIsTrivial e
Peter Wortmann's avatar
Peter Wortmann committed
807 808
exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
                                 -- See Note [Tick trivial]
809
exprIsTrivial (Cast e _)       = exprIsTrivial e
810
exprIsTrivial (Case e _ _ [])  = exprIsTrivial e  -- See Note [Empty case is trivial]
811
exprIsTrivial _                = False
812

Austin Seipp's avatar
Austin Seipp committed
813
{-
814 815
Note [getIdFromTrivialExpr]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
816 817 818
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
819 820 821 822 823 824 825 826 827
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
828
-}
829 830

getIdFromTrivialExpr :: CoreExpr -> Id
831 832 833 834 835 836 837 838
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
839
        go (App f t) | not (isRuntimeArg t) = go f
840
        go (Tick t e) | not (tickishIsCode t) = go e
841 842
        go (Cast e _) = go e
        go (Lam b e) | not (isRuntimeVar b) = go e
843
        go _ = Nothing
844

Austin Seipp's avatar
Austin Seipp committed
845
{-
846
exprIsBottom is a very cheap and cheerful function; it may return
847 848
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
849
expensive.
Austin Seipp's avatar
Austin Seipp committed
850
-}
851 852

exprIsBottom :: CoreExpr -> Bool
853
-- See Note [Bottoming expressions]
854
exprIsBottom e
855 856 857
  | isEmptyTy (exprType e)
  = True
  | otherwise
858 859
  = go 0 e
  where
860 861 862
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
863
    go n (Tick _ e)              = go n e
864 865
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
866
    go n (Lam v e) | isTyVar v   = go n e
Simon Peyton Jones's avatar
Simon Peyton Jones committed
867 868
    go _ (Case _ _ _ alts)       = null alts
       -- See Note [Empty case alternatives] in CoreSyn
869
    go _ _                       = False
870

871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900
{- 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
901 902
************************************************************************
*                                                                      *
903
             exprIsDupable
Austin Seipp's avatar
Austin Seipp committed
904 905
*                                                                      *
************************************************************************
906 907 908

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
909 910 911
@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.
912

913 914
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
915

916 917
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
Austin Seipp's avatar
Austin Seipp committed
918
-}
919

920 921
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
922
  = isJust (go dupAppSize e)
923
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
924
    go :: Int -> CoreExpr -> Maybe Int
925 926 927
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
928
    go n (Tick _ e)    = go n e
929
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
930
    go n (App f a) | Just n' <- go n a = go n' f
931
    go n (Lit lit) | litIsDupable dflags lit = decrement n
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
932 933 934 935 936
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
937 938

dupAppSize :: Int
939 940 941 942
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.
943

Austin Seipp's avatar
Austin Seipp committed
944 945 946
{-
************************************************************************
*                                                                      *
947
             exprIsCheap, exprIsExpandable
Austin Seipp's avatar
Austin Seipp committed
948 949
*                                                                      *
************************************************************************
950

951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974
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
975 976
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
977
in turn was making inner loops of array calculations runs slow (#5623)
Austin Seipp's avatar
Austin Seipp committed
978
-}
979 980 981