CoreUtils.hs 82.6 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
        findDefault, findAlt, isDefaultAlt,
        mergeAlts, trimConArgs, filterAlts,
22

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

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

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

39 40
        -- * Eta reduction
        tryEtaReduce,
41

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

        -- * Working with ticks
        stripTicksTop, stripTicksTopE, stripTicksTopT, stripTicks,
48
    ) where
49

50
#include "HsVersions.h"
51

52
import CoreSyn
Simon Marlow's avatar
Simon Marlow committed
53
import PprCore
54
import CoreFVs( exprFreeVars )
Simon Marlow's avatar
Simon Marlow committed
55 56
import Var
import SrcLoc
57
import VarEnv
58
import VarSet
Simon Marlow's avatar
Simon Marlow committed
59 60 61 62 63 64 65 66 67 68
import Name
import Literal
import DataCon
import PrimOp
import Id
import IdInfo
import Type
import Coercion
import TyCon
import Unique
69
import Outputable
Simon Marlow's avatar
Simon Marlow committed
70
import TysPrim
71
import DynFlags
Simon Marlow's avatar
Simon Marlow committed
72
import FastString
73
import Maybes
74
import Platform
Simon Marlow's avatar
Simon Marlow committed
75
import Util
76
import Pair
Peter Wortmann's avatar
Peter Wortmann committed
77
import Data.Function       ( on )
78
import Data.List
Peter Wortmann's avatar
Peter Wortmann committed
79
import Data.Ord            ( comparing )
Peter Wortmann's avatar
Peter Wortmann committed
80 81 82 83 84
import Control.Applicative
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable    ( traverse )
#endif
import OrdList
85

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

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

113
exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
114

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

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

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

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

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

Various possibilities suggest themselves:

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

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

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

165
applyTypeToArg :: Type -> CoreExpr -> Type
166 167
-- ^ Determines the type resulting from applying an expression with given type
-- to a given argument expression
168
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
169
applyTypeToArg fun_ty _             = funResultTy fun_ty
170

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

    -- go_ty_args: accumulate type arguments so we can instantiate all at once
Simon Peyton Jones's avatar
Simon Peyton Jones committed
184
    go_ty_args op_ty rev_tys (Type ty : args)
185 186 187
       = go_ty_args op_ty (ty:rev_tys) args
    go_ty_args op_ty rev_tys args
       = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args
Simon Peyton Jones's avatar
Simon Peyton Jones committed
188

189 190 191 192
    panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg
    panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e
                     , ptext (sLit "Type:") <+> ppr op_ty
                     , ptext (sLit "Args:") <+> ppr args ]
193

Austin Seipp's avatar
Austin Seipp committed
194 195 196
{-
************************************************************************
*                                                                      *
197
\subsection{Attaching notes}
Austin Seipp's avatar
Austin Seipp committed
198 199 200
*                                                                      *
************************************************************************
-}
201

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

Austin Seipp's avatar
Austin Seipp committed
209
mkCast (Coercion e_co) co
210 211 212 213
  | isCoVarType (pSnd (coercionKind co))
       -- The guard here checks that g has a (~#) on both sides,
       -- otherwise decomposeCo fails.  Can in principle happen
       -- with unsafeCoerce
214
  = Coercion (mkCoCast e_co co)
215 216

mkCast (Cast expr co2) co
217 218 219 220 221 222
  = WARN(let { Pair  from_ty  _to_ty  = coercionKind co;
               Pair _from_ty2  to_ty2 = coercionKind co2} in
            not (from_ty `eqType` to_ty2),
             vcat ([ ptext (sLit "expr:") <+> ppr expr
                   , ptext (sLit "co2:") <+> ppr co2
                   , ptext (sLit "co:") <+> ppr co ]) )
223
    mkCast expr (mkTransCo co2 co)
224

Peter Wortmann's avatar
Peter Wortmann committed
225 226 227
mkCast (Tick t expr) co
   = Tick t (mkCast expr co)

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

236 237 238
-- | 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
239 240 241 242 243
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
244

Peter Wortmann's avatar
Peter Wortmann committed
245 246 247 248 249 250 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 309 310 311 312 313 314 315 316
  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
      | not (isFunTy (idType x)) && tickishPlace t == PlaceCostCentre
      -> orig_expr
      | canSplit
      -> top $ Tick (mkNoScope t) $ rest expr

    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
317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337

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
338

Peter Wortmann's avatar
Peter Wortmann committed
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380
-- | Strip ticks satisfying a predicate from top of an expression
stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicksTop p = go []
  where go ts (Tick t e) | p t = go (t:ts) e
        go ts other            = (reverse ts, other)

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

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

-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
stripTicks :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)
stripTicks p expr = (fromOL ticks, expr')
  where (ticks, expr') = go expr
        -- Note that  OrdList (Tickish Id) is a Monoid, which makes
        -- ((,) (OrdList (Tickish Id))) an Applicative.
        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 <*> pure b <*> pure t
                                   <*> traverse go_a as
        go (Cast e c)       = Cast <$> go e <*> pure c
        go (Tick t e)
          | p t             = let (ts, e') = go e in (t `consOL` ts, e')
          | otherwise       = Tick t <$> go e
        go other            = pure other
        go_bs (NonRec b e)  = NonRec b <$> go e
        go_bs (Rec bs)      = Rec <$> traverse go_b bs
        go_b (b, e)         = (,) <$> pure b <*> go e
        go_a (c,bs,e)       = (,,) <$> pure c <*> pure bs <*> go e

Austin Seipp's avatar
Austin Seipp committed
381 382 383
{-
************************************************************************
*                                                                      *
384
\subsection{Other expression construction}
Austin Seipp's avatar
Austin Seipp committed
385 386 387
*                                                                      *
************************************************************************
-}
388 389

bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
batterseapower's avatar
batterseapower committed
390 391 392 393 394 395 396
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
--
-- or:
--
-- > case r of x { _DEFAULT_ -> b }
397
--
batterseapower's avatar
batterseapower committed
398 399
-- depending on whether we have to use a @case@ or @let@
-- binding for the expression (see 'needsCaseBinding').
400
-- It's used by the desugarer to avoid building bindings
batterseapower's avatar
batterseapower committed
401 402 403
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'MkCore.mkCoreLet'
404
bindNonRec bndr rhs body
batterseapower's avatar
batterseapower committed
405
  | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
406
  | otherwise                          = Let (NonRec bndr rhs) body
407

batterseapower's avatar
batterseapower committed
408 409
-- | 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"
410
needsCaseBinding :: Type -> CoreExpr -> Bool
411
needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
412 413 414
        -- Make a case expression instead of a let
        -- These can arise either from the desugarer,
        -- or from beta reductions: (\x.e) (x +# y)
415

batterseapower's avatar
batterseapower committed
416 417 418 419 420 421
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
422
mkAltExpr (DataAlt con) args inst_tys
423
  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
424 425
mkAltExpr (LitAlt lit) [] []
  = Lit lit
426 427
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
428

Austin Seipp's avatar
Austin Seipp committed
429 430 431
{-
************************************************************************
*                                                                      *
432
\subsection{Taking expressions apart}
Austin Seipp's avatar
Austin Seipp committed
433 434
*                                                                      *
************************************************************************
435

436 437
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
438
-}
439

batterseapower's avatar
batterseapower committed
440
-- | Extract the default case alternative
441
findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)
442
findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
443
findDefault alts                        =                     (alts, Nothing)
444

445
isDefaultAlt :: (AltCon, a, b) -> Bool
446 447 448 449
isDefaultAlt (DEFAULT, _, _) = True
isDefaultAlt _               = False


450
-- | Find the case alternative corresponding to a particular
batterseapower's avatar
batterseapower committed
451
-- constructor: panics if no such constructor exists
452
findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)
453 454
    -- A "Nothing" result *is* legitmiate
    -- See Note [Unreachable code]
455
findAlt con alts
456
  = case alts of
457
        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
458
        _                          -> go alts Nothing
459
  where
460
    go []                     deflt = deflt
461
    go (alt@(con1,_,_) : alts) deflt
462 463 464 465
      = 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
466

467
---------------------------------
468
mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]
batterseapower's avatar
batterseapower committed
469 470
-- ^ Merge alternatives preserving order; alternatives in
-- the first argument shadow ones in the second
471 472 473 474
mergeAlts [] as2 = as2
mergeAlts as1 [] = as1
mergeAlts (a1:as1) (a2:as2)
  = case a1 `cmpAlt` a2 of
475 476 477
        LT -> a1 : mergeAlts as1      (a2:as2)
        EQ -> a1 : mergeAlts as1      as2       -- Discard a2
        GT -> a2 : mergeAlts (a1:as1) as2
478 479 480 481


---------------------------------
trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
batterseapower's avatar
batterseapower committed
482 483 484 485 486 487
-- ^ Given:
--
-- > case (C a b x y) of
-- >        C b x y -> ...
--
-- We want to drop the leading type argument of the scrutinee
488 489 490
-- leaving the arguments to match agains the pattern

trimConArgs DEFAULT      args = ASSERT( null args ) []
491
trimConArgs (LitAlt _)   args = ASSERT( null args ) []
492
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
493

494 495
filterAlts :: [Unique]             -- ^ Supply of uniques used in case we have to manufacture a new AltCon
           -> Type                 -- ^ Type of scrutinee (used to prune possibilities)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
496
           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
497 498 499
           -> [(AltCon, [Var], a)] -- ^ Alternatives
           -> ([AltCon], Bool, [(AltCon, [Var], a)])
             -- Returns:
Austin Seipp's avatar
Austin Seipp committed
500
             --  1. Constructors that will never be encountered by the
Simon Peyton Jones's avatar
Simon Peyton Jones committed
501 502 503 504 505 506 507
             --     *default* case (if any).  A superset of imposs_cons
             --  2. Whether we managed to refine the default alternative into a specific constructor (for statistics only)
             --  3. The new alternatives, trimmed by
             --        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
508 509 510
             --
             -- 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
511
             -- which GHC allows, or if the imposs_cons covers all constructors (after taking
Simon Peyton Jones's avatar
Simon Peyton Jones committed
512
             -- account of GADTs), then no alternatives can match.
513 514 515 516
             --
             -- 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.
Austin Seipp's avatar
Austin Seipp committed
517
filterAlts us ty imposs_cons alts
518 519 520 521
  | Just (tycon, inst_tys) <- splitTyConApp_maybe ty
  = filter_alts tycon inst_tys
  | otherwise
  = (imposs_cons, False, alts)
522 523 524
  where
    (alts_wo_default, maybe_deflt) = findDefault alts
    alt_cons = [con | (con,_,_) <- alts_wo_default]
525

Austin Seipp's avatar
Austin Seipp committed
526
    filter_alts tycon inst_tys
527 528 529 530 531
      = (imposs_deflt_cons, refined_deflt, merged_alts)
     where
       trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default

       imposs_deflt_cons = nub (imposs_cons ++ alt_cons)
Austin Seipp's avatar
Austin Seipp committed
532 533
         -- "imposs_deflt_cons" are handled
         --   EITHER by the context,
534 535 536
         --   OR by a non-DEFAULT branch in this case expression.

       merged_alts  = mergeAlts trimmed_alts (maybeToList maybe_deflt')
Austin Seipp's avatar
Austin Seipp committed
537
         -- We need the mergeAlts in case the new default_alt
538 539 540 541 542 543
         -- has turned into a constructor alternative.
         -- The merge keeps the inner DEFAULT at the front, if there is one
         -- and interleaves the alternatives in the right order

       (refined_deflt, maybe_deflt') = case maybe_deflt of
          Nothing -> (False, Nothing)
Austin Seipp's avatar
Austin Seipp committed
544 545
          Just deflt_rhs
             | isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.
546 547 548 549
             , 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
Austin Seipp's avatar
Austin Seipp committed
550
             , let imposs_data_cons = [con | DataAlt con <- imposs_deflt_cons]   -- We now know it's a data type
551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575
                   impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
             -> case filterOut impossible all_cons of
                  -- Eliminate the default alternative
                  -- altogether if it can't match:
                  []    -> (False, Nothing)
                  -- It matches exactly one constructor, so fill it in:
                  [con] -> (True, Just (DataAlt con, ex_tvs ++ arg_ids, deflt_rhs))
                    where (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys
                  _     -> (False, Just (DEFAULT, [], deflt_rhs))

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

             | otherwise -> (False, Just (DEFAULT, [], deflt_rhs))

    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
576

Austin Seipp's avatar
Austin Seipp committed
577
{-
578 579 580
Note [Unreachable code]
~~~~~~~~~~~~~~~~~~~~~~~
It is possible (although unusual) for GHC to find a case expression
581
that cannot match.  For example:
582 583 584

     data Col = Red | Green | Blue
     x = Red
585
     f v = case x of
586
              Red -> ...
587
              _ -> ...(case x of { Green -> e1; Blue -> e2 })...
588 589 590 591 592 593 594 595

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 })
596
     f v = case x of
597
             Red -> ...
598
             _ -> ...lvl...
599 600 601 602 603 604 605 606 607

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.


Austin Seipp's avatar
Austin Seipp committed
608 609
************************************************************************
*                                                                      *
610
             exprIsTrivial
Austin Seipp's avatar
Austin Seipp committed
611 612
*                                                                      *
************************************************************************
613

614 615
Note [exprIsTrivial]
~~~~~~~~~~~~~~~~~~~~
616
@exprIsTrivial@ is true of expressions we are unconditionally happy to
617 618 619
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
                trivial unless
620

621 622
Note [Variable are trivial]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
623 624
There used to be a gruesome test for (hasNoBinding v) in the
Var case:
625
        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
batterseapower's avatar
batterseapower committed
626
The idea here is that a constructor worker, like \$wJust, is
Gabor Greif's avatar
typos  
Gabor Greif committed
627
really short for (\x -> \$wJust x), because \$wJust has no binding.
628 629 630 631 632 633
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.

634 635
Note [Tick trivial]
~~~~~~~~~~~~~~~~~~~
Peter Wortmann's avatar
Peter Wortmann committed
636 637 638 639 640

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

643
exprIsTrivial :: CoreExpr -> Bool
644
exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
Peter Wortmann's avatar
Peter Wortmann committed
645
exprIsTrivial (Type _)         = True
646
exprIsTrivial (Coercion _)     = True
647 648
exprIsTrivial (Lit lit)        = litIsTrivial lit
exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
Peter Wortmann's avatar
Peter Wortmann committed
649 650
exprIsTrivial (Tick t e)       = not (tickishIsCode t) && exprIsTrivial e
                                 -- See Note [Tick trivial]
651 652 653
exprIsTrivial (Cast e _)       = exprIsTrivial e
exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
exprIsTrivial _                = False
654

Austin Seipp's avatar
Austin Seipp committed
655
{-
656 657 658 659
When substituting in a breakpoint we need to strip away the type cruft
from a trivial expression and get back to the Id.  The invariant is
that the expression we're substituting was originally trivial
according to exprIsTrivial.
Austin Seipp's avatar
Austin Seipp committed
660
-}
661 662 663 664 665

getIdFromTrivialExpr :: CoreExpr -> Id
getIdFromTrivialExpr e = go e
  where go (Var v) = v
        go (App f t) | not (isRuntimeArg t) = go f
666
        go (Tick t e) | not (tickishIsCode t) = go e
667 668 669 670
        go (Cast e _) = go e
        go (Lam b e) | not (isRuntimeVar b) = go e
        go e = pprPanic "getIdFromTrivialExpr" (ppr e)

Austin Seipp's avatar
Austin Seipp committed
671
{-
672
exprIsBottom is a very cheap and cheerful function; it may return
673 674
False for bottoming expressions, but it never costs much to ask.  See
also CoreArity.exprBotStrictness_maybe, but that's a bit more
675
expensive.
Austin Seipp's avatar
Austin Seipp committed
676
-}
677 678

exprIsBottom :: CoreExpr -> Bool
679
exprIsBottom e
680 681
  = go 0 e
  where
682 683 684
    go n (Var v) = isBottomingId v &&  n >= idArity v
    go n (App e a) | isTypeArg a = go n e
                   | otherwise   = go (n+1) e
685
    go n (Tick _ e)              = go n e
686 687 688
    go n (Cast e _)              = go n e
    go n (Let _ e)               = go n e
    go _ _                       = False
689

Austin Seipp's avatar
Austin Seipp committed
690 691 692
{-
************************************************************************
*                                                                      *
693
             exprIsDupable
Austin Seipp's avatar
Austin Seipp committed
694 695
*                                                                      *
************************************************************************
696 697 698

Note [exprIsDupable]
~~~~~~~~~~~~~~~~~~~~
699 700 701
@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.
702

703 704
                That is, exprIsDupable returns True of (f x) even if
                f is very very expensive to call.
705

706 707
                Its only purpose is to avoid fruitless let-binding
                and then inlining of case join points
Austin Seipp's avatar
Austin Seipp committed
708
-}
709

710 711
exprIsDupable :: DynFlags -> CoreExpr -> Bool
exprIsDupable dflags e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
712
  = isJust (go dupAppSize e)
713
  where
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
714
    go :: Int -> CoreExpr -> Maybe Int
715 716 717
    go n (Type {})     = Just n
    go n (Coercion {}) = Just n
    go n (Var {})      = decrement n
718
    go n (Tick _ e)    = go n e
719
    go n (Cast e _)    = go n e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
720
    go n (App f a) | Just n' <- go n a = go n' f
721
    go n (Lit lit) | litIsDupable dflags lit = decrement n
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
722 723 724 725 726
    go _ _ = Nothing

    decrement :: Int -> Maybe Int
    decrement 0 = Nothing
    decrement n = Just (n-1)
727 728

dupAppSize :: Int
729 730 731 732
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.
733

Austin Seipp's avatar
Austin Seipp committed
734 735 736
{-
************************************************************************
*                                                                      *
737
             exprIsCheap, exprIsExpandable
Austin Seipp's avatar
Austin Seipp committed
738 739
*                                                                      *
************************************************************************
740

741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764
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
765 766
going to put up with this, because the previous more aggressive inlining
(which treated 'noFactor' as work-free) was duplicating primops, which
767
in turn was making inner loops of array calculations runs slow (#5623)
Austin Seipp's avatar
Austin Seipp committed
768
-}
769 770 771 772 773 774 775 776 777

exprIsWorkFree :: CoreExpr -> Bool
-- See Note [exprIsWorkFree]
exprIsWorkFree e = go 0 e
  where    -- n is the number of value arguments
    go _ (Lit {})                     = True
    go _ (Type {})                    = True
    go _ (Coercion {})                = True
    go n (Cast e _)                   = go n e
Austin Seipp's avatar
Austin Seipp committed
778
    go n (Case scrut _ _ alts)        = foldl (&&) (exprIsWorkFree scrut)
779 780 781
                                              [ go n rhs | (_,_,rhs) <- alts ]
         -- See Note [Case expressions are work-free]
    go _ (Let {})                     = False
782
    go n (Var v)                      = isCheapApp v n
783 784 785 786 787 788 789
    go n (Tick t e) | tickishCounts t = False
                    | otherwise       = go n e
    go n (Lam x e)  | isRuntimeVar x = n==0 || go (n-1) e
                    | otherwise      = go n e
    go n (App f e)  | isRuntimeArg e = exprIsWorkFree e && go (n+1) f
                    | otherwise      = go n f

Austin Seipp's avatar
Austin Seipp committed
790
{-
791 792 793 794 795 796 797 798 799
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
800
(case x of ....) as work-free if the alternatives are.
801 802


803 804
Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
~~~~~~~~~~~~~~~~~~   in CoreUnfold.lhs
805 806 807 808
@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.]
809 810

By ``cheap'' we mean a computation we're willing to:
811 812
        push inside a lambda, or
        inline at more than one place
813 814 815
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:
816

817 818 819
  *     case e of
          pi -> ei
        (where e, and all the ei are cheap)
820

821 822
  *     let x = e in b
        (where e and b are cheap)
823

824 825
  *     op x1 ... xn
        (where op is a cheap primitive operator)
826

827 828
  *     error "foo"
        (because we are happy to substitute it inside a lambda)
829

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

833 834 835
Note [exprIsCheap and exprIsHNF]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Note that exprIsHNF does not imply exprIsCheap.  Eg
836
        let x = fac 20 in Just x
837 838
This responds True to exprIsHNF (you can discard a seq), but
False to exprIsCheap.
Austin Seipp's avatar
Austin Seipp committed
839
-}
840

841
exprIsCheap :: CoreExpr -> Bool
842
exprIsCheap = exprIsCheap' isCheapApp
843 844

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

847
exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
848
exprIsCheap' _        (Lit _)      = True
849
exprIsCheap' _        (Type _)    = True
850 851 852 853 854
exprIsCheap' _        (Coercion _) = True
exprIsCheap' _        (Var _)      = True
exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
                                  || exprIsCheap' good_app e
855

856 857 858 859 860 861
exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
                                          and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
        -- This improves arities of overloaded functions where
        -- there is only dictionary selection (no construction) involved
862

863 864 865
exprIsCheap' good_app (Tick t e)
  | tickishCounts t = False
  | otherwise       = exprIsCheap' good_app e
Peter Wortmann's avatar
Peter Wortmann committed
866 867 868
     -- never duplicate counting ticks.  If we get this wrong, then
     -- HPC's entry counts will be off (check test in
     -- libraries/hpc/tests/raytrace)
869

870 871 872 873
exprIsCheap' good_app (Let (NonRec _ b) e)
  = exprIsCheap' good_app b && exprIsCheap' good_app e
exprIsCheap' good_app (Let (Rec prs) e)
  = all (exprIsCheap' good_app . snd) prs && exprIsCheap' good_app e
874

875
exprIsCheap' good_app other_expr        -- Applications and variables
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
876
  = go other_expr []
877
  where
878
        -- Accumulate value arguments, then decide
879
    go (Cast e _) val_args                 = go e val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
880
    go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
881
                          | otherwise      = go f val_args
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
882

Austin Seipp's avatar
Austin Seipp committed
883
    go (Var _) [] = True
884 885 886 887 888
         -- Just a type application of a variable
         -- (f t1 t2 t3) counts as WHNF
         -- This case is probably handeld by the good_app case
         -- below, which should have a case for n=0, but putting
         -- it here too is belt and braces; and it's such a common
Austin Seipp's avatar
Austin Seipp committed
889
         -- case that checking for null directly seems like a
890 891
         -- good plan

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
892
    go (Var f) args
Austin Seipp's avatar
Austin Seipp committed