compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Utility functions on @Core@ syntax
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 -- | Commonly useful utilites for manipulating the Core language
  17 module CoreUtils (
  18         -- * Constructing expressions
  19         mkSCC, mkCoerce,
  20         bindNonRec, needsCaseBinding,
  21         mkAltExpr, mkPiType, mkPiTypes,
  22
  23         -- * Taking expressions apart
  24         findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
  25
  26         -- * Properties of expressions
  27         exprType, coreAltType, coreAltsType,
  28         exprIsDupable, exprIsTrivial, exprIsBottom,
  29         exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun,
  30         exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
  31         rhsIsStatic, isCheapApp, isExpandableApp,
  32
  33         -- * Expression and bindings size
  34         coreBindsSize, exprSize,
  35         CoreStats(..), coreBindsStats,
  36
  37         -- * Hashing
  38         hashExpr,
  39
  40         -- * Equality
  41         cheapEqExpr, eqExpr, eqExprX,
  42
  43         -- * Eta reduction
  44         tryEtaReduce,
  45
  46         -- * Manipulating data constructors and types
  47         applyTypeToArgs, applyTypeToArg,
  48         dataConRepInstPat, dataConRepFSInstPat
  49     ) where
  50
  51 #include "HsVersions.h"
  52
  53 import CoreSyn
  54 import PprCore
  55 import Var
  56 import SrcLoc
  57 import VarEnv
  58 import VarSet
  59 import Name
  60 import Literal
  61 import DataCon
  62 import PrimOp
  63 import Id
  64 import IdInfo
  65 import Type
  66 import Coercion
  67 import TyCon
  68 import CostCentre
  69 import Unique
  70 import Outputable
  71 import TysPrim
  72 import FastString
  73 import Maybes
  74 import Util
  75 import Pair
  76 import Data.Word
  77 import Data.Bits
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{Find the type of a Core atom/expression}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 exprType :: CoreExpr -> Type
  89 -- ^ Recover the type of a well-typed Core expression. Fails when
  90 -- applied to the actual 'CoreSyn.Type' expression as it cannot
  91 -- really be said to have a type
  92 exprType (Var var)           = idType var
  93 exprType (Lit lit)           = literalType lit
  94 exprType (Coercion co)       = coercionType co
  95 exprType (Let _ body)        = exprType body
  96 exprType (Case _ _ ty _)     = ty
  97 exprType (Cast _ co)         = pSnd (coercionKind co)
  98 exprType (Note _ e)          = exprType e
  99 exprType (Lam binder expr)   = mkPiType binder (exprType expr)
 100 exprType e@(App _ _)
 101   = case collectArgs e of
 102         (fun, args) -> applyTypeToArgs e (exprType fun) args
 103
 104 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 105
 106 coreAltType :: CoreAlt -> Type
 107 -- ^ Returns the type of the alternatives right hand side
 108 coreAltType (_,bs,rhs)
 109   | any bad_binder bs = expandTypeSynonyms ty
 110   | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
 111   where
 112     ty           = exprType rhs
 113     free_tvs     = tyVarsOfType ty
 114     bad_binder b = isTyVar b && b `elemVarSet` free_tvs
 115
 116 coreAltsType :: [CoreAlt] -> Type
 117 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
 118 coreAltsType (alt:_) = coreAltType alt
 119 coreAltsType []      = panic "corAltsType"
 120 \end{code}
 121
 122 Note [Existential variables and silly type synonyms]
 123 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 124 Consider
 125         data T = forall a. T (Funny a)
 126         type Funny a = Bool
 127         f :: T -> Bool
 128         f (T x) = x
 129
 130 Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
 131 That means that 'exprType' and 'coreAltsType' may give a result that *appears*
 132 to mention an out-of-scope type variable.  See Trac #3409 for a more real-world
 133 example.
 134
 135 Various possibilities suggest themselves:
 136
 137  - Ignore the problem, and make Lint not complain about such variables
 138
 139  - Expand all type synonyms (or at least all those that discard arguments)
 140       This is tricky, because at least for top-level things we want to
 141       retain the type the user originally specified.
 142
 143  - Expand synonyms on the fly, when the problem arises. That is what
 144    we are doing here.  It's not too expensive, I think.
 145
 146 \begin{code}
 147 mkPiType  :: Var -> Type -> Type
 148 -- ^ Makes a @(->)@ type or a forall type, depending
 149 -- on whether it is given a type variable or a term variable.
 150 mkPiTypes :: [Var] -> Type -> Type
 151 -- ^ 'mkPiType' for multiple type or value arguments
 152
 153 mkPiType v ty
 154    | isId v    = mkFunTy (idType v) ty
 155    | otherwise = mkForAllTy v ty
 156
 157 mkPiTypes vs ty = foldr mkPiType ty vs
 158 \end{code}
 159
 160 \begin{code}
 161 applyTypeToArg :: Type -> CoreExpr -> Type
 162 -- ^ Determines the type resulting from applying an expression to a function with the given type
 163 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
 164 applyTypeToArg fun_ty _             = funResultTy fun_ty
 165
 166 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 167 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
 168 -- The first argument is just for debugging, and gives some context
 169 applyTypeToArgs _ op_ty [] = op_ty
 170
 171 applyTypeToArgs e op_ty (Type ty : args)
 172   =     -- Accumulate type arguments so we can instantiate all at once
 173     go [ty] args
 174   where
 175     go rev_tys (Type ty : args) = go (ty:rev_tys) args
 176     go rev_tys rest_args         = applyTypeToArgs e op_ty' rest_args
 177                                  where
 178                                    op_ty' = applyTysD msg op_ty (reverse rev_tys)
 179                                    msg = ptext (sLit "applyTypeToArgs") <+>
 180                                          panic_msg e op_ty
 181
 182 applyTypeToArgs e op_ty (_ : args)
 183   = case (splitFunTy_maybe op_ty) of
 184         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 185         Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
 186
 187 panic_msg :: CoreExpr -> Type -> SDoc
 188 panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 189 \end{code}
 190
 191 %************************************************************************
 192 %*                                                                      *
 193 \subsection{Attaching notes}
 194 %*                                                                      *
 195 %************************************************************************
 196
 197 \begin{code}
 198 -- | Wrap the given expression in the coercion safely, dropping
 199 -- identity coercions and coalescing nested coercions
 200 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 201 mkCoerce co e | isReflCo co = e
 202 mkCoerce co (Cast expr co2)
 203   = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co;
 204                  Pair _from_ty2  to_ty2 = coercionKind co2} in
 205            from_ty `eqType` to_ty2 )
 206     mkCoerce (mkTransCo co2 co) expr
 207
 208 mkCoerce co expr
 209   = let Pair from_ty _to_ty = coercionKind co in
 210 --    if to_ty `eqType` from_ty
 211 --    then expr
 212 --    else
 213         WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
 214          (Cast expr co)
 215 \end{code}
 216
 217 \begin{code}
 218 -- | Wraps the given expression in the cost centre unless
 219 -- in a way that maximises their utility to the user
 220 mkSCC :: CostCentre -> Expr b -> Expr b
 221         -- Note: Nested SCC's *are* preserved for the benefit of
 222         --       cost centre stack profiling
 223 mkSCC _  (Lit lit)          = Lit lit
 224 mkSCC cc (Lam x e)          = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
 225 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
 226 mkSCC cc (Note n e)         = Note n (mkSCC cc e) -- Move _scc_ inside notes
 227 mkSCC cc (Cast e co)        = Cast (mkSCC cc e) co -- Move _scc_ inside cast
 228 mkSCC cc expr               = Note (SCC cc) expr
 229 \end{code}
 230
 231
 232 %************************************************************************
 233 %*                                                                      *
 234 \subsection{Other expression construction}
 235 %*                                                                      *
 236 %************************************************************************
 237
 238 \begin{code}
 239 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 240 -- ^ @bindNonRec x r b@ produces either:
 241 --
 242 -- > let x = r in b
 243 --
 244 -- or:
 245 --
 246 -- > case r of x { _DEFAULT_ -> b }
 247 --
 248 -- depending on whether we have to use a @case@ or @let@
 249 -- binding for the expression (see 'needsCaseBinding').
 250 -- It's used by the desugarer to avoid building bindings
 251 -- that give Core Lint a heart attack, although actually
 252 -- the simplifier deals with them perfectly well. See
 253 -- also 'MkCore.mkCoreLet'
 254 bindNonRec bndr rhs body
 255   | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 256   | otherwise                          = Let (NonRec bndr rhs) body
 257
 258 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
 259 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
 260 needsCaseBinding :: Type -> CoreExpr -> Bool
 261 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 262         -- Make a case expression instead of a let
 263         -- These can arise either from the desugarer,
 264         -- or from beta reductions: (\x.e) (x +# y)
 265 \end{code}
 266
 267 \begin{code}
 268 mkAltExpr :: AltCon     -- ^ Case alternative constructor
 269           -> [CoreBndr] -- ^ Things bound by the pattern match
 270           -> [Type]     -- ^ The type arguments to the case alternative
 271           -> CoreExpr
 272 -- ^ This guy constructs the value that the scrutinee must have
 273 -- given that you are in one particular branch of a case
 274 mkAltExpr (DataAlt con) args inst_tys
 275   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 276 mkAltExpr (LitAlt lit) [] []
 277   = Lit lit
 278 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
 279 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 280 \end{code}
 281
 282
 283 %************************************************************************
 284 %*                                                                      *
 285 \subsection{Taking expressions apart}
 286 %*                                                                      *
 287 %************************************************************************
 288
 289 The default alternative must be first, if it exists at all.
 290 This makes it easy to find, though it makes matching marginally harder.
 291
 292 \begin{code}
 293 -- | Extract the default case alternative
 294 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 295 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 296 findDefault alts                        =                     (alts, Nothing)
 297
 298 isDefaultAlt :: CoreAlt -> Bool
 299 isDefaultAlt (DEFAULT, _, _) = True
 300 isDefaultAlt _               = False
 301
 302
 303 -- | Find the case alternative corresponding to a particular
 304 -- constructor: panics if no such constructor exists
 305 findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
 306     -- A "Nothing" result *is* legitmiate
 307     -- See Note [Unreachable code]
 308 findAlt con alts
 309   = case alts of
 310         (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
 311         _                          -> go alts Nothing
 312   where
 313     go []                     deflt = deflt
 314     go (alt@(con1,_,_) : alts) deflt
 315       = case con `cmpAltCon` con1 of
 316           LT -> deflt   -- Missed it already; the alts are in increasing order
 317           EQ -> Just alt
 318           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 319
 320 ---------------------------------
 321 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
 322 -- ^ Merge alternatives preserving order; alternatives in
 323 -- the first argument shadow ones in the second
 324 mergeAlts [] as2 = as2
 325 mergeAlts as1 [] = as1
 326 mergeAlts (a1:as1) (a2:as2)
 327   = case a1 `cmpAlt` a2 of
 328         LT -> a1 : mergeAlts as1      (a2:as2)
 329         EQ -> a1 : mergeAlts as1      as2       -- Discard a2
 330         GT -> a2 : mergeAlts (a1:as1) as2
 331
 332
 333 ---------------------------------
 334 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
 335 -- ^ Given:
 336 --
 337 -- > case (C a b x y) of
 338 -- >        C b x y -> ...
 339 --
 340 -- We want to drop the leading type argument of the scrutinee
 341 -- leaving the arguments to match agains the pattern
 342
 343 trimConArgs DEFAULT      args = ASSERT( null args ) []
 344 trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 345 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 346 \end{code}
 347
 348 Note [Unreachable code]
 349 ~~~~~~~~~~~~~~~~~~~~~~~
 350 It is possible (although unusual) for GHC to find a case expression
 351 that cannot match.  For example:
 352
 353      data Col = Red | Green | Blue
 354      x = Red
 355      f v = case x of
 356               Red -> ...
 357               _ -> ...(case x of { Green -> e1; Blue -> e2 })...
 358
 359 Suppose that for some silly reason, x isn't substituted in the case
 360 expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff
 361 gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce
 362 this
 363
 364      x = Red
 365      lvl = case x of { Green -> e1; Blue -> e2 })
 366      f v = case x of
 367              Red -> ...
 368              _ -> ...lvl...
 369
 370 Now if x gets inlined, we won't be able to find a matching alternative
 371 for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing
 372 we generate (error "Inaccessible alternative").
 373
 374 Similar things can happen (augmented by GADTs) when the Simplifier
 375 filters down the matching alternatives in Simplify.rebuildCase.
 376
 377
 378 %************************************************************************
 379 %*                                                                      *
 380              exprIsTrivial
 381 %*                                                                      *
 382 %************************************************************************
 383
 384 Note [exprIsTrivial]
 385 ~~~~~~~~~~~~~~~~~~~~
 386 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 387                 duplicate; simple variables and constants, and type
 388                 applications.  Note that primop Ids aren't considered
 389                 trivial unless
 390
 391 Note [Variable are trivial]
 392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
 393 There used to be a gruesome test for (hasNoBinding v) in the
 394 Var case:
 395         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 396 The idea here is that a constructor worker, like \$wJust, is
 397 really short for (\x -> \$wJust x), becuase \$wJust has no binding.
 398 So it should be treated like a lambda.  Ditto unsaturated primops.
 399 But now constructor workers are not "have-no-binding" Ids.  And
 400 completely un-applied primops and foreign-call Ids are sufficiently
 401 rare that I plan to allow them to be duplicated and put up with
 402 saturating them.
 403
 404 Note [SCCs are trivial]
 405 ~~~~~~~~~~~~~~~~~~~~~~~
 406 We used not to treat (_scc_ "foo" x) as trivial, because it really
 407 generates code, (and a heap object when it's a function arg) to
 408 capture the cost centre.  However, the profiling system discounts the
 409 allocation costs for such "boxing thunks" whereas the extra costs of
 410 *not* inlining otherwise-trivial bindings can be high, and are hard to
 411 discount.
 412
 413 \begin{code}
 414 exprIsTrivial :: CoreExpr -> Bool
 415 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
 416 exprIsTrivial (Type _)        = True
 417 exprIsTrivial (Coercion _)     = True
 418 exprIsTrivial (Lit lit)        = litIsTrivial lit
 419 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
 420 exprIsTrivial (Note _       e) = exprIsTrivial e  -- See Note [SCCs are trivial]
 421 exprIsTrivial (Cast e _)       = exprIsTrivial e
 422 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 423 exprIsTrivial _                = False
 424 \end{code}
 425
 426 exprIsBottom is a very cheap and cheerful function; it may return
 427 False for bottoming expressions, but it never costs much to ask.
 428 See also CoreArity.exprBotStrictness_maybe, but that's a bit more
 429 expensive.
 430
 431 \begin{code}
 432 exprIsBottom :: CoreExpr -> Bool
 433 exprIsBottom e
 434   = go 0 e
 435   where
 436     go n (Var v) = isBottomingId v &&  n >= idArity v
 437     go n (App e a) | isTypeArg a = go n e
 438                    | otherwise   = go (n+1) e
 439     go n (Note _ e)              = go n e
 440     go n (Cast e _)              = go n e
 441     go n (Let _ e)               = go n e
 442     go _ _                       = False
 443 \end{code}
 444
 445
 446 %************************************************************************
 447 %*                                                                      *
 448              exprIsDupable
 449 %*                                                                      *
 450 %************************************************************************
 451
 452 Note [exprIsDupable]
 453 ~~~~~~~~~~~~~~~~~~~~
 454 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 455                 cost in code size.  This will only happen in different case
 456                 branches, so there's no issue about duplicating work.
 457
 458                 That is, exprIsDupable returns True of (f x) even if
 459                 f is very very expensive to call.
 460
 461                 Its only purpose is to avoid fruitless let-binding
 462                 and then inlining of case join points
 463
 464
 465 \begin{code}
 466 exprIsDupable :: CoreExpr -> Bool
 467 exprIsDupable e
 468   = isJust (go dupAppSize e)
 469   where
 470     go :: Int -> CoreExpr -> Maybe Int
 471     go n (Type {})     = Just n
 472     go n (Coercion {}) = Just n
 473     go n (Var {})      = decrement n
 474     go n (Note _ e)    = go n e
 475     go n (Cast e _)    = go n e
 476     go n (App f a) | Just n' <- go n a = go n' f
 477     go n (Lit lit) | litIsDupable lit = decrement n
 478     go _ _ = Nothing
 479
 480     decrement :: Int -> Maybe Int
 481     decrement 0 = Nothing
 482     decrement n = Just (n-1)
 483
 484 dupAppSize :: Int
 485 dupAppSize = 8   -- Size of term we are prepared to duplicate
 486                  -- This is *just* big enough to make test MethSharing
 487                  -- inline enough join points.  Really it should be
 488                  -- smaller, and could be if we fixed Trac #4960.
 489 \end{code}
 490
 491 %************************************************************************
 492 %*                                                                      *
 493              exprIsCheap, exprIsExpandable
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 Note [exprIsCheap]   See also Note [Interaction of exprIsCheap and lone variables]
 498 ~~~~~~~~~~~~~~~~~~   in CoreUnfold.lhs
 499 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 500 it is obviously in weak head normal form, or is cheap to get to WHNF.
 501 [Note that that's not the same as exprIsDupable; an expression might be
 502 big, and hence not dupable, but still cheap.]
 503
 504 By ``cheap'' we mean a computation we're willing to:
 505         push inside a lambda, or
 506         inline at more than one place
 507 That might mean it gets evaluated more than once, instead of being
 508 shared.  The main examples of things which aren't WHNF but are
 509 ``cheap'' are:
 510
 511   *     case e of
 512           pi -> ei
 513         (where e, and all the ei are cheap)
 514
 515   *     let x = e in b
 516         (where e and b are cheap)
 517
 518   *     op x1 ... xn
 519         (where op is a cheap primitive operator)
 520
 521   *     error "foo"
 522         (because we are happy to substitute it inside a lambda)
 523
 524 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 525 because sharing will make sure it is only evaluated once.
 526
 527 Note [exprIsCheap and exprIsHNF]
 528 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 529 Note that exprIsHNF does not imply exprIsCheap.  Eg
 530         let x = fac 20 in Just x
 531 This responds True to exprIsHNF (you can discard a seq), but
 532 False to exprIsCheap.
 533
 534 \begin{code}
 535 exprIsCheap :: CoreExpr -> Bool
 536 exprIsCheap = exprIsCheap' isCheapApp
 537
 538 exprIsExpandable :: CoreExpr -> Bool
 539 exprIsExpandable = exprIsCheap' isExpandableApp -- See Note [CONLIKE pragma] in BasicTypes
 540
 541 type CheapAppFun = Id -> Int -> Bool
 542 exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
 543 exprIsCheap' _        (Lit _)      = True
 544 exprIsCheap' _        (Type _)    = True
 545 exprIsCheap' _        (Coercion _) = True
 546 exprIsCheap' _        (Var _)      = True
 547 exprIsCheap' good_app (Note _ e)   = exprIsCheap' good_app e
 548 exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
 549 exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
 550                                   || exprIsCheap' good_app e
 551
 552 exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e &&
 553                                           and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
 554         -- Experimentally, treat (case x of ...) as cheap
 555         -- (and case __coerce x etc.)
 556         -- This improves arities of overloaded functions where
 557         -- there is only dictionary selection (no construction) involved
 558
 559 exprIsCheap' good_app (Let (NonRec x _) e)
 560   | isUnLiftedType (idType x) = exprIsCheap' good_app e
 561   | otherwise                 = False
 562         -- Strict lets always have cheap right hand sides,
 563         -- and do no allocation, so just look at the body
 564         -- Non-strict lets do allocation so we don't treat them as cheap
 565         -- See also
 566
 567 exprIsCheap' good_app other_expr        -- Applications and variables
 568   = go other_expr []
 569   where
 570         -- Accumulate value arguments, then decide
 571     go (Cast e _) val_args                 = go e val_args
 572     go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
 573                           | otherwise      = go f val_args
 574
 575     go (Var _) [] = True        -- Just a type application of a variable
 576                                 -- (f t1 t2 t3) counts as WHNF
 577     go (Var f) args
 578         = case idDetails f of
 579                 RecSelId {}                  -> go_sel args
 580                 ClassOpId {}                 -> go_sel args
 581                 PrimOpId op                  -> go_primop op args
 582                 _ | good_app f (length args) -> go_pap args
 583                   | isBottomingId f          -> True
 584                   | otherwise                -> False
 585                         -- Application of a function which
 586                         -- always gives bottom; we treat this as cheap
 587                         -- because it certainly doesn't need to be shared!
 588
 589     go _ _ = False
 590
 591     --------------
 592     go_pap args = all (exprIsCheap' good_app) args
 593         -- Used to be "all exprIsTrivial args" due to concerns about
 594         -- duplicating nested constructor applications, but see #4978.
 595         -- The principle here is that
 596         --    let x = a +# b in c *# x
 597         -- should behave equivalently to
 598         --    c *# (a +# b)
 599         -- Since lets with cheap RHSs are accepted,
 600         -- so should paps with cheap arguments
 601
 602     --------------
 603     go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
 604         -- In principle we should worry about primops
 605         -- that return a type variable, since the result
 606         -- might be applied to something, but I'm not going
 607         -- to bother to check the number of args
 608
 609     --------------
 610     go_sel [arg] = exprIsCheap' good_app arg    -- I'm experimenting with making record selection
 611     go_sel _     = False                -- look cheap, so we will substitute it inside a
 612                                         -- lambda.  Particularly for dictionary field selection.
 613                 -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 614                 --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 615
 616 isCheapApp :: CheapAppFun
 617 isCheapApp fn n_val_args
 618   = isDataConWorkId fn
 619   || n_val_args < idArity fn
 620
 621 isExpandableApp :: CheapAppFun
 622 isExpandableApp fn n_val_args
 623   =  isConLikeId fn
 624   || n_val_args < idArity fn
 625   || go n_val_args (idType fn)
 626   where
 627   -- See if all the arguments are PredTys (implicit params or classes)
 628   -- If so we'll regard it as expandable; see Note [Expandable overloadings]
 629      go 0 _ = True
 630      go n_val_args ty
 631        | Just (_, ty) <- splitForAllTy_maybe ty   = go n_val_args ty
 632        | Just (arg, ty) <- splitFunTy_maybe ty
 633        , isPredTy arg                             = go (n_val_args-1) ty
 634        | otherwise                                = False
 635 \end{code}
 636
 637 Note [Expandable overloadings]
 638 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 639 Suppose the user wrote this
 640    {-# RULE  forall x. foo (negate x) = h x #-}
 641    f x = ....(foo (negate x))....
 642 He'd expect the rule to fire. But since negate is overloaded, we might
 643 get this:
 644     f = \d -> let n = negate d in \x -> ...foo (n x)...
 645 So we treat the application of a function (negate in this case) to a
 646 *dictionary* as expandable.  In effect, every function is CONLIKE when
 647 it's applied only to dictionaries.
 648
 649
 650 %************************************************************************
 651 %*                                                                      *
 652              exprOkForSpeculation
 653 %*                                                                      *
 654 %************************************************************************
 655
 656 \begin{code}
 657 -- | 'exprOkForSpeculation' returns True of an expression that is:
 658 --
 659 --  * Safe to evaluate even if normal order eval might not
 660 --    evaluate the expression at all, or
 661 --
 662 --  * Safe /not/ to evaluate even if normal order would do so
 663 --
 664 -- It is usually called on arguments of unlifted type, but not always
 665 -- In particular, Simplify.rebuildCase calls it on lifted types
 666 -- when a 'case' is a plain 'seq'. See the example in
 667 -- Note [exprOkForSpeculation: case expressions] below
 668 --
 669 -- Precisely, it returns @True@ iff:
 670 --
 671 --  * The expression guarantees to terminate,
 672 --  * soon,
 673 --  * without raising an exception,
 674 --  * without causing a side effect (e.g. writing a mutable variable)
 675 --
 676 -- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
 677 -- As an example of the considerations in this test, consider:
 678 --
 679 -- > let x = case y# +# 1# of { r# -> I# r# }
 680 -- > in E
 681 --
 682 -- being translated to:
 683 --
 684 -- > case y# +# 1# of { r# ->
 685 -- >    let x = I# r#
 686 -- >    in E
 687 -- > }
 688 --
 689 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 690 -- side effects, and can't diverge or raise an exception.
 691 exprOkForSpeculation :: CoreExpr -> Bool
 692 exprOkForSpeculation (Lit _)      = True
 693 exprOkForSpeculation (Type _)     = True
 694 exprOkForSpeculation (Coercion _) = True
 695
 696 exprOkForSpeculation (Var v)
 697   | isTickBoxOp v = False     -- Tick boxes are *not* suitable for speculation
 698   | otherwise     =  isUnLiftedType (idType v)  -- c.f. the Var case of exprIsHNF
 699                   || isDataConWorkId v          -- Nullary constructors
 700                   || idArity v > 0              -- Functions
 701                   || isEvaldUnfolding (idUnfolding v)   -- Let-bound values
 702
 703 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 704 exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
 705
 706 exprOkForSpeculation (Case e _ _ alts)
 707   =  exprOkForSpeculation e  -- Note [exprOkForSpeculation: case expressions]
 708   && all (\(_,_,rhs) -> exprOkForSpeculation rhs) alts
 709
 710 exprOkForSpeculation other_expr
 711   = case collectArgs other_expr of
 712         (Var f, args) -> spec_ok (idDetails f) args
 713         _             -> False
 714
 715   where
 716     spec_ok (DataConWorkId _) _
 717       = True    -- The strictness of the constructor has already
 718                 -- been expressed by its "wrapper", so we don't need
 719                 -- to take the arguments into account
 720
 721     spec_ok (PrimOpId op) args
 722       | isDivOp op,             -- Special case for dividing operations that fail
 723         [arg1, Lit lit] <- args -- only if the divisor is zero
 724       = not (isZeroLit lit) && exprOkForSpeculation arg1
 725                 -- Often there is a literal divisor, and this
 726                 -- can get rid of a thunk in an inner looop
 727
 728       | DataToTagOp <- op      -- See Note [dataToTag speculation]
 729       = True
 730
 731       | otherwise
 732       = primOpOkForSpeculation op &&
 733         all exprOkForSpeculation args
 734                                 -- A bit conservative: we don't really need
 735                                 -- to care about lazy arguments, but this is easy
 736
 737     spec_ok (DFunId _ new_type) _ = not new_type
 738          -- DFuns terminate, unless the dict is implemented with a newtype
 739          -- in which case they may not
 740
 741     spec_ok _ _ = False
 742
 743 -- | True of dyadic operators that can fail only if the second arg is zero!
 744 isDivOp :: PrimOp -> Bool
 745 -- This function probably belongs in PrimOp, or even in
 746 -- an automagically generated file.. but it's such a
 747 -- special case I thought I'd leave it here for now.
 748 isDivOp IntQuotOp        = True
 749 isDivOp IntRemOp         = True
 750 isDivOp WordQuotOp       = True
 751 isDivOp WordRemOp        = True
 752 isDivOp FloatDivOp       = True
 753 isDivOp DoubleDivOp      = True
 754 isDivOp _                = False
 755 \end{code}
 756
 757 Note [exprOkForSpeculation: case expressions]
 758 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 759 It's always sound for exprOkForSpeculation to return False, and we
 760 don't want it to take too long, so it bales out on complicated-looking
 761 terms.  Notably lets, which can be stacked very deeply; and in any
 762 case the argument of exprOkForSpeculation is usually in a strict context,
 763 so any lets will have been floated away.
 764
 765 However, we keep going on case-expressions.  An example like this one
 766 showed up in DPH code (Trac #3717):
 767     foo :: Int -> Int
 768     foo 0 = 0
 769     foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)
 770
 771 If exprOkForSpeculation doesn't look through case expressions, you get this:
 772     T.$wfoo =
 773       \ (ww :: GHC.Prim.Int#) ->
 774         case ww of ds {
 775           __DEFAULT -> case (case <# ds 5 of _ {
 776                           GHC.Types.False -> lvl1;
 777                           GHC.Types.True -> lvl})
 778                        of _ { __DEFAULT ->
 779                        T.$wfoo (GHC.Prim.-# ds_XkE 1) };
 780           0 -> 0
 781         }
 782
 783 The inner case is redundant, and should be nuked.
 784
 785 Note [dataToTag speculation]
 786 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 787 Is this OK?
 788    f x = let v::Int# = dataToTag# x
 789          in ...
 790 We say "yes", even though 'x' may not be evaluated.  Reasons
 791
 792   * dataToTag#'s strictness means that its argument often will be
 793     evaluated, but FloatOut makes that temporarily untrue
 794          case x of y -> let v = dataToTag# y in ...
 795     -->
 796          case x of y -> let v = dataToTag# x in ...
 797     Note that we look at 'x' instead of 'y' (this is to improve
 798     floating in FloatOut).  So Lint complains.
 799
 800     Moreover, it really *might* improve floating to let the
 801     v-binding float out
 802
 803   * CorePrep makes sure dataToTag#'s argument is evaluated, just
 804     before code gen.  Until then, it's not guaranteed
 805
 806
 807 %************************************************************************
 808 %*                                                                      *
 809              exprIsHNF, exprIsConLike
 810 %*                                                                      *
 811 %************************************************************************
 812
 813 \begin{code}
 814 -- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]
 815 -- ~~~~~~~~~~~~~~~~
 816 -- | exprIsHNF returns true for expressions that are certainly /already/
 817 -- evaluated to /head/ normal form.  This is used to decide whether it's ok
 818 -- to change:
 819 --
 820 -- > case x of _ -> e
 821 --
 822 --    into:
 823 --
 824 -- > e
 825 --
 826 -- and to decide whether it's safe to discard a 'seq'.
 827 --
 828 -- So, it does /not/ treat variables as evaluated, unless they say they are.
 829 -- However, it /does/ treat partial applications and constructor applications
 830 -- as values, even if their arguments are non-trivial, provided the argument
 831 -- type is lifted. For example, both of these are values:
 832 --
 833 -- > (:) (f x) (map f xs)
 834 -- > map (...redex...)
 835 --
 836 -- because 'seq' on such things completes immediately.
 837 --
 838 -- For unlifted argument types, we have to be careful:
 839 --
 840 -- > C (f x :: Int#)
 841 --
 842 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
 843 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
 844 -- unboxed type must be ok-for-speculation (or trivial).
 845 exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
 846 exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
 847 \end{code}
 848
 849 \begin{code}
 850 -- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
 851 -- data constructors. Conlike arguments are considered interesting by the
 852 -- inliner.
 853 exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP
 854 exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
 855
 856 -- | Returns true for values or value-like expressions. These are lambdas,
 857 -- constructors / CONLIKE functions (as determined by the function argument)
 858 -- or PAPs.
 859 --
 860 exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
 861 exprIsHNFlike is_con is_con_unf = is_hnf_like
 862   where
 863     is_hnf_like (Var v) -- NB: There are no value args at this point
 864       =  is_con v       -- Catches nullary constructors,
 865                         --      so that [] and () are values, for example
 866       || idArity v > 0  -- Catches (e.g.) primops that don't have unfoldings
 867       || is_con_unf (idUnfolding v)
 868         -- Check the thing's unfolding; it might be bound to a value
 869         -- We don't look through loop breakers here, which is a bit conservative
 870         -- but otherwise I worry that if an Id's unfolding is just itself,
 871         -- we could get an infinite loop
 872
 873     is_hnf_like (Lit _)          = True
 874     is_hnf_like (Type _)        = True       -- Types are honorary Values;
 875                                               -- we don't mind copying them
 876     is_hnf_like (Coercion _)     = True       -- Same for coercions
 877     is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
 878     is_hnf_like (Note _ e)       = is_hnf_like e
 879     is_hnf_like (Cast e _)       = is_hnf_like e
 880     is_hnf_like (App e (Type _))    = is_hnf_like e
 881     is_hnf_like (App e (Coercion _)) = is_hnf_like e
 882     is_hnf_like (App e a)        = app_is_value e [a]
 883     is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
 884     is_hnf_like _                = False
 885
 886     -- There is at least one value argument
 887     app_is_value :: CoreExpr -> [CoreArg] -> Bool
 888     app_is_value (Var fun) args
 889       = idArity fun > valArgCount args    -- Under-applied function
 890         || is_con fun                     --  or constructor-like
 891     app_is_value (Note _ f) as = app_is_value f as
 892     app_is_value (Cast f _) as = app_is_value f as
 893     app_is_value (App f a)  as = app_is_value f (a:as)
 894     app_is_value _          _  = False
 895 \end{code}
 896
 897
 898 %************************************************************************
 899 %*                                                                      *
 900              Instantiating data constructors
 901 %*                                                                      *
 902 %************************************************************************
 903
 904 These InstPat functions go here to avoid circularity between DataCon and Id
 905
 906 \begin{code}
 907 dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 908 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 909
 910 dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))
 911 dataConRepFSInstPat = dataConInstPat
 912
 913 dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names
 914                -> [Unique]              -- An equally long list of uniques, at least one for each binder
 915                -> DataCon
 916                -> [Type]                -- Types to instantiate the universally quantified tyvars
 917                -> ([TyVar], [Id])          -- Return instantiated variables
 918 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
 919 -- (ex_tvs, arg_ids),
 920 --
 921 --   ex_tvs are intended to be used as binders for existential type args
 922 --
 923 --   arg_ids are indended to be used as binders for value arguments,
 924 --     and their types have been instantiated with inst_tys and ex_tys
 925 --     The arg_ids include both evidence and
 926 --     programmer-specified arguments (both after rep-ing)
 927 --
 928 -- Example.
 929 --  The following constructor T1
 930 --
 931 --  data T a where
 932 --    T1 :: forall b. Int -> b -> T(a,b)
 933 --    ...
 934 --
 935 --  has representation type
 936 --   forall a. forall a1. forall b. (a ~ (a1,b)) =>
 937 --     Int -> b -> T a
 938 --
 939 --  dataConInstPat fss us T1 (a1',b') will return
 940 --
 941 --  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])
 942 --
 943 --  where the double-primed variables are created with the FastStrings and
 944 --  Uniques given as fss and us
 945 dataConInstPat fss uniqs con inst_tys
 946   = (ex_bndrs, arg_ids)
 947   where
 948     univ_tvs = dataConUnivTyVars con
 949     ex_tvs   = dataConExTyVars con
 950     arg_tys  = dataConRepArgTys con
 951
 952     n_ex = length ex_tvs
 953
 954       -- split the Uniques and FastStrings
 955     (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
 956     (ex_fss,   id_fss)   = splitAt n_ex fss
 957
 958       -- Make existential type variables
 959     ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
 960     mk_ex_var uniq fs var = mkTyVar new_name kind
 961       where
 962         new_name = mkSysTvName uniq fs
 963         kind     = tyVarKind var
 964
 965       -- Make the instantiating substitution
 966     subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 967
 968       -- Make value vars, instantiating types
 969     mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
 970     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 971 \end{code}
 972
 973 %************************************************************************
 974 %*                                                                      *
 975          Equality
 976 %*                                                                      *
 977 %************************************************************************
 978
 979 \begin{code}
 980 -- | A cheap equality test which bales out fast!
 981 --      If it returns @True@ the arguments are definitely equal,
 982 --      otherwise, they may or may not be equal.
 983 --
 984 -- See also 'exprIsBig'
 985 cheapEqExpr :: Expr b -> Expr b -> Bool
 986
 987 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 988 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 989 cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
 990 cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
 991
 992 cheapEqExpr (App f1 a1) (App f2 a2)
 993   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 994
 995 cheapEqExpr (Cast e1 t1) (Cast e2 t2)
 996   = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
 997
 998 cheapEqExpr _ _ = False
 999 \end{code}
1000
1001 \begin{code}
1002 exprIsBig :: Expr b -> Bool
1003 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
1004 exprIsBig (Lit _)      = False
1005 exprIsBig (Var _)      = False
1006 exprIsBig (Type _)    = False
1007 exprIsBig (Coercion _) = False
1008 exprIsBig (Lam _ e)    = exprIsBig e
1009 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1010 exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!
1011 exprIsBig _            = True
1012 \end{code}
1013
1014 \begin{code}
1015 eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool
1016 -- Compares for equality, modulo alpha
1017 eqExpr in_scope e1 e2
1018   = eqExprX id_unf (mkRnEnv2 in_scope) e1 e2
1019   where
1020     id_unf _ = noUnfolding      -- Don't expand
1021 \end{code}
1022
1023 \begin{code}
1024 eqExprX :: IdUnfoldingFun -> RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1025 -- ^ Compares expressions for equality, modulo alpha.
1026 -- Does /not/ look through newtypes or predicate types
1027 -- Used in rule matching, and also CSE
1028
1029 eqExprX id_unfolding_fun env e1 e2
1030   = go env e1 e2
1031   where
1032     go env (Var v1) (Var v2)
1033       | rnOccL env v1 == rnOccR env v2
1034       = True
1035
1036     -- The next two rules expand non-local variables
1037     -- C.f. Note [Expanding variables] in Rules.lhs
1038     -- and  Note [Do not expand locally-bound variables] in Rules.lhs
1039     go env (Var v1) e2
1040       | not (locallyBoundL env v1)
1041       , Just e1' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v1))
1042       = go (nukeRnEnvL env) e1' e2
1043
1044     go env e1 (Var v2)
1045       | not (locallyBoundR env v2)
1046       , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
1047       = go (nukeRnEnvR env) e1 e2'
1048
1049     go _   (Lit lit1)    (Lit lit2)      = lit1 == lit2
1050     go env (Type t1)    (Type t2)        = eqTypeX env t1 t2
1051     go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
1052     go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
1053     go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2
1054     go env (Note n1 e1)  (Note n2 e2)  = go_note n1 n2 && go env e1 e2
1055
1056     go env (Lam b1 e1)  (Lam b2 e2)
1057       =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
1058       && go (rnBndr2 env b1 b2) e1 e2
1059
1060     go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)
1061       =  go env r1 r2  -- No need to check binder types, since RHSs match
1062       && go (rnBndr2 env v1 v2) e1 e2
1063
1064     go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
1065       = all2 (go env') rs1 rs2 && go env' e1 e2
1066       where
1067         (bs1,rs1) = unzip ps1
1068         (bs2,rs2) = unzip ps2
1069         env' = rnBndrs2 env bs1 bs2
1070
1071     go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
1072       =  go env e1 e2
1073       && eqTypeX env (idType b1) (idType b2)
1074       && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
1075
1076     go _ _ _ = False
1077
1078     -----------
1079     go_alt env (c1, bs1, e1) (c2, bs2, e2)
1080       = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2
1081
1082     -----------
1083     go_note (SCC cc1)     (SCC cc2)      = cc1 == cc2
1084     go_note (CoreNote s1) (CoreNote s2)  = s1 == s2
1085     go_note _             _              = False
1086 \end{code}
1087
1088 Auxiliary functions
1089
1090 \begin{code}
1091 locallyBoundL, locallyBoundR :: RnEnv2 -> Var -> Bool
1092 locallyBoundL rn_env v = inRnEnvL rn_env v
1093 locallyBoundR rn_env v = inRnEnvR rn_env v
1094 \end{code}
1095
1096
1097 %************************************************************************
1098 %*                                                                      *
1099 \subsection{The size of an expression}
1100 %*                                                                      *
1101 %************************************************************************
1102
1103 \begin{code}
1104 coreBindsSize :: [CoreBind] -> Int
1105 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1106
1107 exprSize :: CoreExpr -> Int
1108 -- ^ A measure of the size of the expressions, strictly greater than 0
1109 -- It also forces the expression pretty drastically as a side effect
1110 -- Counts *leaves*, not internal nodes. Types and coercions are not counted.
1111 exprSize (Var v)         = v `seq` 1
1112 exprSize (Lit lit)       = lit `seq` 1
1113 exprSize (App f a)       = exprSize f + exprSize a
1114 exprSize (Lam b e)       = varSize b + exprSize e
1115 exprSize (Let b e)       = bindSize b + exprSize e
1116 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1117 exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e
1118 exprSize (Note n e)      = noteSize n + exprSize e
1119 exprSize (Type t)       = seqType t `seq` 1
1120 exprSize (Coercion co)   = seqCo co `seq` 1
1121
1122 noteSize :: Note -> Int
1123 noteSize (SCC cc)       = cc `seq` 1
1124 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1125
1126 varSize :: Var -> Int
1127 varSize b  | isTyVar b = 1
1128            | otherwise = seqType (idType b)             `seq`
1129                          megaSeqIdInfo (idInfo b)       `seq`
1130                          1
1131
1132 varsSize :: [Var] -> Int
1133 varsSize = sum . map varSize
1134
1135 bindSize :: CoreBind -> Int
1136 bindSize (NonRec b e) = varSize b + exprSize e
1137 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1138
1139 pairSize :: (Var, CoreExpr) -> Int
1140 pairSize (b,e) = varSize b + exprSize e
1141
1142 altSize :: CoreAlt -> Int
1143 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1144 \end{code}
1145
1146 \begin{code}
1147 data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int }
1148
1149 plusCS :: CoreStats -> CoreStats -> CoreStats
1150 plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 })
1151        (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 })
1152   = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 }
1153
1154 zeroCS, oneTM :: CoreStats
1155 zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 }
1156 oneTM  = zeroCS { cs_tm = 1 }
1157
1158 sumCS :: (a -> CoreStats) -> [a] -> CoreStats
1159 sumCS f = foldr (plusCS . f) zeroCS
1160
1161 coreBindsStats :: [CoreBind] -> CoreStats
1162 coreBindsStats = sumCS bindStats
1163
1164 bindStats :: CoreBind -> CoreStats
1165 bindStats (NonRec v r) = bindingStats v r
1166 bindStats (Rec prs)    = sumCS (\(v,r) -> bindingStats v r) prs
1167
1168 bindingStats :: Var -> CoreExpr -> CoreStats
1169 bindingStats v r = bndrStats v `plusCS` exprStats r
1170
1171 bndrStats :: Var -> CoreStats
1172 bndrStats v = oneTM `plusCS` tyStats (varType v)
1173
1174 exprStats :: CoreExpr -> CoreStats
1175 exprStats (Var {})        = oneTM
1176 exprStats (Lit {})        = oneTM
1177 exprStats (Type t)        = tyStats t
1178 exprStats (Coercion c)    = coStats c
1179 exprStats (App f a)       = exprStats f `plusCS` exprStats a
1180 exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e
1181 exprStats (Let b e)       = bindStats b `plusCS` exprStats e
1182 exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
1183 exprStats (Cast e co)     = coStats co `plusCS` exprStats e
1184 exprStats (Note _ e)      = exprStats e
1185
1186 altStats :: CoreAlt -> CoreStats
1187 altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
1188
1189 tyStats :: Type -> CoreStats
1190 tyStats ty = zeroCS { cs_ty = typeSize ty }
1191
1192 coStats :: Coercion -> CoreStats
1193 coStats co = zeroCS { cs_co = coercionSize co }
1194 \end{code}
1195
1196 %************************************************************************
1197 %*                                                                      *
1198 \subsection{Hashing}
1199 %*                                                                      *
1200 %************************************************************************
1201
1202 \begin{code}
1203 hashExpr :: CoreExpr -> Int
1204 -- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
1205 -- Two expressions that hash to the different Ints are definitely unequal.
1206 --
1207 -- The emphasis is on a crude, fast hash, rather than on high precision.
1208 --
1209 -- But unequal here means \"not identical\"; two alpha-equivalent
1210 -- expressions may hash to the different Ints.
1211 --
1212 -- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
1213 -- (at least if we want the above invariant to be true).
1214
1215 hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
1216              -- UniqFM doesn't like negative Ints
1217
1218 type HashEnv = (Int, VarEnv Int)  -- Hash code for bound variables
1219
1220 hash_expr :: HashEnv -> CoreExpr -> Word32
1221 -- Word32, because we're expecting overflows here, and overflowing
1222 -- signed types just isn't cool.  In C it's even undefined.
1223 hash_expr env (Note _ e)              = hash_expr env e
1224 hash_expr env (Cast e _)              = hash_expr env e
1225 hash_expr env (Var v)                 = hashVar env v
1226 hash_expr _   (Lit lit)               = fromIntegral (hashLiteral lit)
1227 hash_expr env (App f e)               = hash_expr env f * fast_hash_expr env e
1228 hash_expr env (Let (NonRec b r) e)    = hash_expr (extend_env env b) e * fast_hash_expr env r
1229 hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
1230 hash_expr env (Case e _ _ _)          = hash_expr env e
1231 hash_expr env (Lam b e)               = hash_expr (extend_env env b) e
1232 hash_expr _   (Type _)                = WARN(True, text "hash_expr: type") 1
1233 -- Shouldn't happen.  Better to use WARN than trace, because trace
1234 -- prevents the CPR optimisation kicking in for hash_expr.
1235 hash_expr _   (Coercion _)            = WARN(True, text "hash_expr: coercion") 1
1236
1237 fast_hash_expr :: HashEnv -> CoreExpr -> Word32
1238 fast_hash_expr env (Var v)       = hashVar env v
1239 fast_hash_expr env (Type t)      = fast_hash_type env t
1240 fast_hash_expr env (Coercion co) = fast_hash_co env co
1241 fast_hash_expr _   (Lit lit)     = fromIntegral (hashLiteral lit)
1242 fast_hash_expr env (Cast e _)    = fast_hash_expr env e
1243 fast_hash_expr env (Note _ e)    = fast_hash_expr env e
1244 fast_hash_expr env (App _ a)     = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
1245 fast_hash_expr _   _             = 1
1246
1247 fast_hash_type :: HashEnv -> Type -> Word32
1248 fast_hash_type env ty
1249   | Just tv <- getTyVar_maybe ty            = hashVar env tv
1250   | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
1251                                               in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
1252   | otherwise                               = 1
1253
1254 fast_hash_co :: HashEnv -> Coercion -> Word32
1255 fast_hash_co env co
1256   | Just cv <- getCoVar_maybe co              = hashVar env cv
1257   | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
1258                                                 in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
1259   | otherwise                                 = 1
1260
1261 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1262 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1263
1264 hashVar :: HashEnv -> Var -> Word32
1265 hashVar (_,env) v
1266  = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
1267 \end{code}
1268
1269
1270 %************************************************************************
1271 %*                                                                      *
1272                 Eta reduction
1273 %*                                                                      *
1274 %************************************************************************
1275
1276 Note [Eta reduction conditions]
1277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1278 We try for eta reduction here, but *only* if we get all the way to an
1279 trivial expression.  We don't want to remove extra lambdas unless we
1280 are going to avoid allocating this thing altogether.
1281
1282 There are some particularly delicate points here:
1283
1284 * Eta reduction is not valid in general:
1285         \x. bot  /=  bot
1286   This matters, partly for old-fashioned correctness reasons but,
1287   worse, getting it wrong can yield a seg fault. Consider
1288         f = \x.f x
1289         h y = case (case y of { True -> f `seq` True; False -> False }) of
1290                 True -> ...; False -> ...
1291
1292   If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
1293   says f=bottom, and replaces the (f `seq` True) with just
1294   (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
1295   *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands
1296   the definition again, so that it does not termninate after all.
1297   Result: seg-fault because the boolean case actually gets a function value.
1298   See Trac #1947.
1299
1300   So it's important to to the right thing.
1301
1302 * Note [Arity care]: we need to be careful if we just look at f's
1303   arity. Currently (Dec07), f's arity is visible in its own RHS (see
1304   Note [Arity robustness] in SimplEnv) so we must *not* trust the
1305   arity when checking that 'f' is a value.  Otherwise we will
1306   eta-reduce
1307       f = \x. f x
1308   to
1309       f = f
1310   Which might change a terminiating program (think (f `seq` e)) to a
1311   non-terminating one.  So we check for being a loop breaker first.
1312
1313   However for GlobalIds we can look at the arity; and for primops we
1314   must, since they have no unfolding.
1315
1316 * Regardless of whether 'f' is a value, we always want to
1317   reduce (/\a -> f a) to f
1318   This came up in a RULE: foldr (build (/\a -> g a))
1319   did not match           foldr (build (/\b -> ...something complex...))
1320   The type checker can insert these eta-expanded versions,
1321   with both type and dictionary lambdas; hence the slightly
1322   ad-hoc isDictId
1323
1324 * Never *reduce* arity. For example
1325       f = \xy. g x y
1326   Then if h has arity 1 we don't want to eta-reduce because then
1327   f's arity would decrease, and that is bad
1328
1329 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
1330 Alas.
1331
1332 Note [Eta reduction with casted arguments]
1333 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1334 Consider
1335     (\(x:t3). f (x |> g)) :: t3 -> t2
1336   where
1337     f :: t1 -> t2
1338     g :: t3 ~ t1
1339 This should be eta-reduced to
1340
1341     f |> (sym g -> t2)
1342
1343 So we need to accumulate a coercion, pushing it inward (past
1344 variable arguments only) thus:
1345    f (x |> co_arg) |> co  -->  (f |> (sym co_arg -> co)) x
1346    f (x:t)         |> co  -->  (f |> (t -> co)) x
1347    f @ a           |> co  -->  (f |> (forall a.co)) @ a
1348    f @ (g:t1~t2)   |> co  -->  (f |> (t1~t2 => co)) @ (g:t1~t2)
1349 These are the equations for ok_arg.
1350
1351 It's true that we could also hope to eta reduce these:
1352     (\xy. (f x |> g) y)
1353     (\xy. (f x y) |> g)
1354 But the simplifier pushes those casts outwards, so we don't
1355 need to address that here.
1356
1357 \begin{code}
1358 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
1359 tryEtaReduce bndrs body
1360   = go (reverse bndrs) body (mkReflCo (exprType body))
1361   where
1362     incoming_arity = count isId bndrs
1363
1364     go :: [Var]            -- Binders, innermost first, types [a3,a2,a1]
1365        -> CoreExpr         -- Of type tr
1366        -> Coercion         -- Of type tr ~ ts
1367        -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts
1368     -- See Note [Eta reduction with casted arguments]
1369     -- for why we have an accumulating coercion
1370     go [] fun co
1371       | ok_fun fun = Just (mkCoerce co fun)
1372
1373     go (b : bs) (App fun arg) co
1374       | Just co' <- ok_arg b arg co
1375       = go bs fun co'
1376
1377     go _ _ _  = Nothing         -- Failure!
1378
1379     ---------------
1380     -- Note [Eta reduction conditions]
1381     ok_fun (App fun (Type ty))
1382         | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
1383         =  ok_fun fun
1384     ok_fun (Var fun_id)
1385         =  not (fun_id `elem` bndrs)
1386         && (ok_fun_id fun_id || all ok_lam bndrs)
1387     ok_fun _fun = False
1388
1389     ---------------
1390     ok_fun_id fun = fun_arity fun >= incoming_arity
1391
1392     ---------------
1393     fun_arity fun             -- See Note [Arity care]
1394        | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
1395        | otherwise = idArity fun
1396
1397     ---------------
1398     ok_lam v = isTyVar v || isEvVar v
1399
1400     ---------------
1401     ok_arg :: Var              -- Of type bndr_t
1402            -> CoreExpr         -- Of type arg_t
1403            -> Coercion         -- Of kind (t1~t2)
1404            -> Maybe Coercion   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
1405                                --   (and similarly for tyvars, coercion args)
1406     -- See Note [Eta reduction with casted arguments]
1407     ok_arg bndr (Type ty) co
1408        | Just tv <- getTyVar_maybe ty
1409        , bndr == tv  = Just (mkForAllCo tv co)
1410     ok_arg bndr (Var v) co
1411        | bndr == v   = Just (mkFunCo (mkReflCo (idType bndr)) co)
1412     ok_arg bndr (Cast (Var v) co_arg) co
1413        | bndr == v  = Just (mkFunCo (mkSymCo co_arg) co)
1414        -- The simplifier combines multiple casts into one,
1415        -- so we can have a simple-minded pattern match here
1416     ok_arg _ _ _ = Nothing
1417 \end{code}
1418
1419
1420 %************************************************************************
1421 %*                                                                      *
1422 \subsection{Determining non-updatable right-hand-sides}
1423 %*                                                                      *
1424 %************************************************************************
1425
1426 Top-level constructor applications can usually be allocated
1427 statically, but they can't if the constructor, or any of the
1428 arguments, come from another DLL (because we can't refer to static
1429 labels in other DLLs).
1430
1431 If this happens we simply make the RHS into an updatable thunk,
1432 and 'execute' it rather than allocating it statically.
1433
1434 \begin{code}
1435 -- | This function is called only on *top-level* right-hand sides.
1436 -- Returns @True@ if the RHS can be allocated statically in the output,
1437 -- with no thunks involved at all.
1438 rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool
1439 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1440 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
1441 -- update flag on it and (iii) in DsExpr to decide how to expand
1442 -- list literals
1443 --
1444 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1445 --      (a) a value lambda
1446 --      (b) a saturated constructor application with static args
1447 --
1448 -- BUT watch out for
1449 --  (i) Any cross-DLL references kill static-ness completely
1450 --      because they must be 'executed' not statically allocated
1451 --      ("DLL" here really only refers to Windows DLLs, on other platforms,
1452 --      this is not necessary)
1453 --
1454 -- (ii) We treat partial applications as redexes, because in fact we
1455 --      make a thunk for them that runs and builds a PAP
1456 --      at run-time.  The only appliations that are treated as
1457 --      static are *saturated* applications of constructors.
1458
1459 -- We used to try to be clever with nested structures like this:
1460 --              ys = (:) w ((:) w [])
1461 -- on the grounds that CorePrep will flatten ANF-ise it later.
1462 -- But supporting this special case made the function much more
1463 -- complicated, because the special case only applies if there are no
1464 -- enclosing type lambdas:
1465 --              ys = /\ a -> Foo (Baz ([] a))
1466 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1467 --
1468 -- But in fact, even without -O, nested structures at top level are
1469 -- flattened by the simplifier, so we don't need to be super-clever here.
1470 --
1471 -- Examples
1472 --
1473 --      f = \x::Int. x+7        TRUE
1474 --      p = (True,False)        TRUE
1475 --
1476 --      d = (fst p, False)      FALSE because there's a redex inside
1477 --                              (this particular one doesn't happen but...)
1478 --
1479 --      h = D# (1.0## /## 2.0##)        FALSE (redex again)
1480 --      n = /\a. Nil a                  TRUE
1481 --
1482 --      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
1483 --
1484 --
1485 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1486 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1487 --
1488 --    b) (C x xs), where C is a contructor is updatable if the application is
1489 --         dynamic
1490 --
1491 --    c) don't look through unfolding of f in (f x).
1492
1493 rhsIsStatic _is_dynamic_name rhs = is_static False rhs
1494   where
1495   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
1496           -> CoreExpr -> Bool
1497
1498   is_static False (Lam b e)   = isRuntimeVar b || is_static False e
1499   is_static in_arg (Note n e) = notSccNote n && is_static in_arg e
1500   is_static in_arg (Cast e _) = is_static in_arg e
1501
1502   is_static _      (Lit lit)
1503     = case lit of
1504         MachLabel _ _ _ -> False
1505         _             -> True
1506         -- A MachLabel (foreign import "&foo") in an argument
1507         -- prevents a constructor application from being static.  The
1508         -- reason is that it might give rise to unresolvable symbols
1509         -- in the object file: under Linux, references to "weak"
1510         -- symbols from the data segment give rise to "unresolvable
1511         -- relocation" errors at link time This might be due to a bug
1512         -- in the linker, but we'll work around it here anyway.
1513         -- SDM 24/2/2004
1514
1515   is_static in_arg other_expr = go other_expr 0
1516    where
1517     go (Var f) n_val_args
1518 #if mingw32_TARGET_OS
1519         | not (_is_dynamic_name (idName f))
1520 #endif
1521         =  saturated_data_con f n_val_args
1522         || (in_arg && n_val_args == 0)
1523                 -- A naked un-applied variable is *not* deemed a static RHS
1524                 -- E.g.         f = g
1525                 -- Reason: better to update so that the indirection gets shorted
1526                 --         out, and the true value will be seen
1527                 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1528                 --     are always updatable.  If you do so, make sure that non-updatable
1529                 --     ones have enough space for their static link field!
1530
1531     go (App f a) n_val_args
1532         | isTypeArg a                    = go f n_val_args
1533         | not in_arg && is_static True a = go f (n_val_args + 1)
1534         -- The (not in_arg) checks that we aren't in a constructor argument;
1535         -- if we are, we don't allow (value) applications of any sort
1536         --
1537         -- NB. In case you wonder, args are sometimes not atomic.  eg.
1538         --   x = D# (1.0## /## 2.0##)
1539         -- can't float because /## can fail.
1540
1541     go (Note n f) n_val_args = notSccNote n && go f n_val_args
1542     go (Cast e _) n_val_args = go e n_val_args
1543     go _          _          = False
1544
1545     saturated_data_con f n_val_args
1546         = case isDataConWorkId_maybe f of
1547             Just dc -> n_val_args == dataConRepArity dc
1548             Nothing -> False
1549 \end{code}