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 module CoreUtils (
  10         -- Construction
  11         mkInlineMe, mkSCC, mkCoerce,
  12         bindNonRec, needsCaseBinding,
  13         mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
  14
  15         -- Taking expressions apart
  16         findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
  17
  18         -- Properties of expressions
  19         exprType, coreAltType,
  20         exprIsDupable, exprIsTrivial, exprIsCheap,
  21         exprIsHNF,exprOkForSpeculation, exprIsBig,
  22         exprIsConApp_maybe, exprIsBottom,
  23         rhsIsStatic,
  24
  25         -- Arity and eta expansion
  26         manifestArity, exprArity,
  27         exprEtaExpandArity, etaExpand,
  28
  29         -- Size
  30         coreBindsSize,
  31
  32         -- Hashing
  33         hashExpr,
  34
  35         -- Equality
  36         cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
  37
  38         dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
  39     ) where
  40
  41 #include "HsVersions.h"
  42
  43 import CoreSyn
  44 import CoreFVs
  45 import PprCore
  46 import Var
  47 import SrcLoc
  48 import VarSet
  49 import VarEnv
  50 import Name
  51 #if mingw32_TARGET_OS
  52 import Packages
  53 #endif
  54 import Literal
  55 import DataCon
  56 import PrimOp
  57 import Id
  58 import IdInfo
  59 import NewDemand
  60 import Type
  61 import Coercion
  62 import TyCon
  63 import TysWiredIn
  64 import CostCentre
  65 import BasicTypes
  66 import PackageConfig
  67 import Unique
  68 import Outputable
  69 import DynFlags
  70 import TysPrim
  71 import FastString
  72 import Maybes
  73 import Util
  74 import Data.Word
  75 import Data.Bits
  76
  77 import GHC.Exts         -- For `xori`
  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
  90 exprType (Var var)           = idType var
  91 exprType (Lit lit)           = literalType lit
  92 exprType (Let _ body)        = exprType body
  93 exprType (Case _ _ ty alts)  = ty
  94 exprType (Cast e co)         = snd (coercionKind co)
  95 exprType (Note other_note e) = exprType e
  96 exprType (Lam binder expr)   = mkPiType binder (exprType expr)
  97 exprType e@(App _ _)
  98   = case collectArgs e of
  99         (fun, args) -> applyTypeToArgs e (exprType fun) args
 100
 101 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 102
 103 coreAltType :: CoreAlt -> Type
 104 coreAltType (_,_,rhs) = exprType rhs
 105 \end{code}
 106
 107 @mkPiType@ makes a (->) type or a forall type, depending on whether
 108 it is given a type variable or a term variable.  We cleverly use the
 109 lbvarinfo field to figure out the right annotation for the arrove in
 110 case of a term variable.
 111
 112 \begin{code}
 113 mkPiType  :: Var   -> Type -> Type      -- The more polymorphic version
 114 mkPiTypes :: [Var] -> Type -> Type      --    doesn't work...
 115
 116 mkPiTypes vs ty = foldr mkPiType ty vs
 117
 118 mkPiType v ty
 119    | isId v    = mkFunTy (idType v) ty
 120    | otherwise = mkForAllTy v ty
 121 \end{code}
 122
 123 \begin{code}
 124 applyTypeToArg :: Type -> CoreExpr -> Type
 125 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
 126 applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
 127
 128 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 129 -- A more efficient version of applyTypeToArg
 130 -- when we have several args
 131 -- The first argument is just for debugging
 132 applyTypeToArgs e op_ty [] = op_ty
 133
 134 applyTypeToArgs e op_ty (Type ty : args)
 135   =     -- Accumulate type arguments so we can instantiate all at once
 136     go [ty] args
 137   where
 138     go rev_tys (Type ty : args) = go (ty:rev_tys) args
 139     go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
 140                                 where
 141                                   op_ty' = applyTys op_ty (reverse rev_tys)
 142
 143 applyTypeToArgs e op_ty (other_arg : args)
 144   = case (splitFunTy_maybe op_ty) of
 145         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 146         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
 147 \end{code}
 148
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Attaching notes}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 mkNote removes redundant coercions, and SCCs where possible
 158
 159 \begin{code}
 160 #ifdef UNUSED
 161 mkNote :: Note -> CoreExpr -> CoreExpr
 162 mkNote (SCC cc) expr               = mkSCC cc expr
 163 mkNote InlineMe expr               = mkInlineMe expr
 164 mkNote note     expr               = Note note expr
 165 #endif
 166 \end{code}
 167
 168 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 169 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 170 not be *applied* to anything.
 171
 172 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
 173 bindings like
 174         fw = ...
 175         f  = inline_me (coerce t fw)
 176 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
 177 We want the split, so that the coerces can cancel at the call site.
 178
 179 However, we can get left with tiresome type applications.  Notably, consider
 180         f = /\ a -> let t = e in (t, w)
 181 Then lifting the let out of the big lambda gives
 182         t' = /\a -> e
 183         f = /\ a -> let t = inline_me (t' a) in (t, w)
 184 The inline_me is to stop the simplifier inlining t' right back
 185 into t's RHS.  In the next phase we'll substitute for t (since
 186 its rhs is trivial) and *then* we could get rid of the inline_me.
 187 But it hardly seems worth it, so I don't bother.
 188
 189 \begin{code}
 190 mkInlineMe (Var v) = Var v
 191 mkInlineMe e       = Note InlineMe e
 192 \end{code}
 193
 194
 195
 196 \begin{code}
 197 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 198 mkCoerce co (Cast expr co2)
 199   = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
 200                  (_from_ty2, to_ty2) = coercionKind co2} in
 201            from_ty `coreEqType` to_ty2 )
 202     mkCoerce (mkTransCoercion co2 co) expr
 203
 204 mkCoerce co expr
 205   = let (from_ty, to_ty) = coercionKind co in
 206 --    if to_ty `coreEqType` from_ty
 207 --    then expr
 208 --    else
 209         ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
 210          (Cast expr co)
 211 \end{code}
 212
 213 \begin{code}
 214 mkSCC :: CostCentre -> Expr b -> Expr b
 215         -- Note: Nested SCC's *are* preserved for the benefit of
 216         --       cost centre stack profiling
 217 mkSCC cc (Lit lit)          = Lit lit
 218 mkSCC cc (Lam x e)          = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
 219 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
 220 mkSCC cc (Note n e)         = Note n (mkSCC cc e) -- Move _scc_ inside notes
 221 mkSCC cc (Cast e co)        = Cast (mkSCC cc e) co -- Move _scc_ inside cast
 222 mkSCC cc expr               = Note (SCC cc) expr
 223 \end{code}
 224
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection{Other expression construction}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 \begin{code}
 233 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 234 -- (bindNonRec x r b) produces either
 235 --      let x = r in b
 236 -- or
 237 --      case r of x { _DEFAULT_ -> b }
 238 --
 239 -- depending on whether x is unlifted or not
 240 -- It's used by the desugarer to avoid building bindings
 241 -- that give Core Lint a heart attack.  Actually the simplifier
 242 -- deals with them perfectly well.
 243
 244 bindNonRec bndr rhs body
 245   | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 246   | otherwise                          = Let (NonRec bndr rhs) body
 247
 248 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 249         -- Make a case expression instead of a let
 250         -- These can arise either from the desugarer,
 251         -- or from beta reductions: (\x.e) (x +# y)
 252 \end{code}
 253
 254 \begin{code}
 255 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 256         -- This guy constructs the value that the scrutinee must have
 257         -- when you are in one particular branch of a case
 258 mkAltExpr (DataAlt con) args inst_tys
 259   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 260 mkAltExpr (LitAlt lit) [] []
 261   = Lit lit
 262 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
 263 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 264
 265 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 266 mkIfThenElse guard then_expr else_expr
 267 -- Not going to be refining, so okay to take the type of the "then" clause
 268   = Case guard (mkWildId boolTy) (exprType then_expr)
 269          [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!
 270            (DataAlt trueDataCon,  [], then_expr) ]
 271 \end{code}
 272
 273
 274 %************************************************************************
 275 %*                                                                      *
 276 \subsection{Taking expressions apart}
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 The default alternative must be first, if it exists at all.
 281 This makes it easy to find, though it makes matching marginally harder.
 282
 283 \begin{code}
 284 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 285 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 286 findDefault alts                        =                     (alts, Nothing)
 287
 288 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 289 findAlt con alts
 290   = case alts of
 291         (deflt@(DEFAULT,_,_):alts) -> go alts deflt
 292         other                      -> go alts panic_deflt
 293   where
 294     panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 295
 296     go []                      deflt = deflt
 297     go (alt@(con1,_,_) : alts) deflt
 298       = case con `cmpAltCon` con1 of
 299           LT -> deflt   -- Missed it already; the alts are in increasing order
 300           EQ -> alt
 301           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 302
 303 isDefaultAlt :: CoreAlt -> Bool
 304 isDefaultAlt (DEFAULT, _, _) = True
 305 isDefaultAlt other           = False
 306
 307 ---------------------------------
 308 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
 309 -- Merge preserving order; alternatives in the first arg
 310 -- shadow ones in the second
 311 mergeAlts [] as2 = as2
 312 mergeAlts as1 [] = as1
 313 mergeAlts (a1:as1) (a2:as2)
 314   = case a1 `cmpAlt` a2 of
 315         LT -> a1 : mergeAlts as1      (a2:as2)
 316         EQ -> a1 : mergeAlts as1      as2       -- Discard a2
 317         GT -> a2 : mergeAlts (a1:as1) as2
 318
 319
 320 ---------------------------------
 321 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
 322 -- Given        case (C a b x y) of
 323 --                 C b x y -> ...
 324 -- we want to drop the leading type argument of the scrutinee
 325 -- leaving the arguments to match agains the pattern
 326
 327 trimConArgs DEFAULT      args = ASSERT( null args ) []
 328 trimConArgs (LitAlt lit) args = ASSERT( null args ) []
 329 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 330 \end{code}
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsection{Figuring out things about expressions}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 340                 duplicate; simple variables and constants, and type
 341                 applications.  Note that primop Ids aren't considered
 342                 trivial unless
 343
 344 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 345
 346
 347 There used to be a gruesome test for (hasNoBinding v) in the
 348 Var case:
 349         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 350 The idea here is that a constructor worker, like $wJust, is
 351 really short for (\x -> $wJust x), becuase $wJust has no binding.
 352 So it should be treated like a lambda.  Ditto unsaturated primops.
 353 But now constructor workers are not "have-no-binding" Ids.  And
 354 completely un-applied primops and foreign-call Ids are sufficiently
 355 rare that I plan to allow them to be duplicated and put up with
 356 saturating them.
 357
 358 SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because
 359   a) it really generates code, (and a heap object when it's
 360      a function arg) to capture the cost centre
 361   b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
 362
 363 \begin{code}
 364 exprIsTrivial (Var v)      = True       -- See notes above
 365 exprIsTrivial (Type _)     = True
 366 exprIsTrivial (Lit lit)    = litIsTrivial lit
 367 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 368 exprIsTrivial (Note (SCC _) e) = False          -- See notes above
 369 exprIsTrivial (Note _       e) = exprIsTrivial e
 370 exprIsTrivial (Cast e co)  = exprIsTrivial e
 371 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 372 exprIsTrivial other        = False
 373 \end{code}
 374
 375
 376 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 377                 cost in code size.  This will only happen in different case
 378                 branches, so there's no issue about duplicating work.
 379
 380                 That is, exprIsDupable returns True of (f x) even if
 381                 f is very very expensive to call.
 382
 383                 Its only purpose is to avoid fruitless let-binding
 384                 and then inlining of case join points
 385
 386
 387 \begin{code}
 388 exprIsDupable (Type _)          = True
 389 exprIsDupable (Var v)           = True
 390 exprIsDupable (Lit lit)         = litIsDupable lit
 391 exprIsDupable (Note InlineMe e) = True
 392 exprIsDupable (Note _ e)        = exprIsDupable e
 393 exprIsDupable (Cast e co)       = exprIsDupable e
 394 exprIsDupable expr
 395   = go expr 0
 396   where
 397     go (Var v)   n_args = True
 398     go (App f a) n_args =  n_args < dupAppSize
 399                         && exprIsDupable a
 400                         && go f (n_args+1)
 401     go other n_args     = False
 402
 403 dupAppSize :: Int
 404 dupAppSize = 4          -- Size of application we are prepared to duplicate
 405 \end{code}
 406
 407 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 408 it is obviously in weak head normal form, or is cheap to get to WHNF.
 409 [Note that that's not the same as exprIsDupable; an expression might be
 410 big, and hence not dupable, but still cheap.]
 411
 412 By ``cheap'' we mean a computation we're willing to:
 413         push inside a lambda, or
 414         inline at more than one place
 415 That might mean it gets evaluated more than once, instead of being
 416 shared.  The main examples of things which aren't WHNF but are
 417 ``cheap'' are:
 418
 419   *     case e of
 420           pi -> ei
 421         (where e, and all the ei are cheap)
 422
 423   *     let x = e in b
 424         (where e and b are cheap)
 425
 426   *     op x1 ... xn
 427         (where op is a cheap primitive operator)
 428
 429   *     error "foo"
 430         (because we are happy to substitute it inside a lambda)
 431
 432 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 433 because sharing will make sure it is only evaluated once.
 434
 435 \begin{code}
 436 exprIsCheap :: CoreExpr -> Bool
 437 exprIsCheap (Lit lit)         = True
 438 exprIsCheap (Type _)          = True
 439 exprIsCheap (Var _)           = True
 440 exprIsCheap (Note InlineMe e) = True
 441 exprIsCheap (Note _ e)        = exprIsCheap e
 442 exprIsCheap (Cast e co)       = exprIsCheap e
 443 exprIsCheap (Lam x e)         = isRuntimeVar x || exprIsCheap e
 444 exprIsCheap (Case e _ _ alts) = exprIsCheap e &&
 445                                 and [exprIsCheap rhs | (_,_,rhs) <- alts]
 446         -- Experimentally, treat (case x of ...) as cheap
 447         -- (and case __coerce x etc.)
 448         -- This improves arities of overloaded functions where
 449         -- there is only dictionary selection (no construction) involved
 450 exprIsCheap (Let (NonRec x _) e)
 451       | isUnLiftedType (idType x) = exprIsCheap e
 452       | otherwise                 = False
 453         -- strict lets always have cheap right hand sides,
 454         -- and do no allocation.
 455
 456 exprIsCheap other_expr  -- Applications and variables
 457   = go other_expr []
 458   where
 459         -- Accumulate value arguments, then decide
 460     go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
 461                           | otherwise      = go f val_args
 462
 463     go (Var f) [] = True        -- Just a type application of a variable
 464                                 -- (f t1 t2 t3) counts as WHNF
 465     go (Var f) args
 466         = case globalIdDetails f of
 467                 RecordSelId {} -> go_sel args
 468                 ClassOpId _    -> go_sel args
 469                 PrimOpId op    -> go_primop op args
 470
 471                 DataConWorkId _ -> go_pap args
 472                 other | length args < idArity f -> go_pap args
 473
 474                 other -> isBottomingId f
 475                         -- Application of a function which
 476                         -- always gives bottom; we treat this as cheap
 477                         -- because it certainly doesn't need to be shared!
 478
 479     go other args = False
 480
 481     --------------
 482     go_pap args = all exprIsTrivial args
 483         -- For constructor applications and primops, check that all
 484         -- the args are trivial.  We don't want to treat as cheap, say,
 485         --      (1:2:3:4:5:[])
 486         -- We'll put up with one constructor application, but not dozens
 487
 488     --------------
 489     go_primop op args = primOpIsCheap op && all exprIsCheap args
 490         -- In principle we should worry about primops
 491         -- that return a type variable, since the result
 492         -- might be applied to something, but I'm not going
 493         -- to bother to check the number of args
 494
 495     --------------
 496     go_sel [arg] = exprIsCheap arg      -- I'm experimenting with making record selection
 497     go_sel other = False                -- look cheap, so we will substitute it inside a
 498                                         -- lambda.  Particularly for dictionary field selection.
 499                 -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 500                 --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 501 \end{code}
 502
 503 exprOkForSpeculation returns True of an expression that it is
 504
 505         * safe to evaluate even if normal order eval might not
 506           evaluate the expression at all, or
 507
 508         * safe *not* to evaluate even if normal order would do so
 509
 510 It returns True iff
 511
 512         the expression guarantees to terminate,
 513         soon,
 514         without raising an exception,
 515         without causing a side effect (e.g. writing a mutable variable)
 516
 517 NB: if exprIsHNF e, then exprOkForSpecuation e
 518
 519 E.G.
 520         let x = case y# +# 1# of { r# -> I# r# }
 521         in E
 522 ==>
 523         case y# +# 1# of { r# ->
 524         let x = I# r#
 525         in E
 526         }
 527
 528 We can only do this if the (y+1) is ok for speculation: it has no
 529 side effects, and can't diverge or raise an exception.
 530
 531 \begin{code}
 532 exprOkForSpeculation :: CoreExpr -> Bool
 533 exprOkForSpeculation (Lit _)     = True
 534 exprOkForSpeculation (Type _)    = True
 535     -- Tick boxes are *not* suitable for speculation
 536 exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
 537                                  && not (isTickBoxOp v)
 538 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 539 exprOkForSpeculation (Cast e co) = exprOkForSpeculation e
 540 exprOkForSpeculation other_expr
 541   = case collectArgs other_expr of
 542         (Var f, args) -> spec_ok (globalIdDetails f) args
 543         other         -> False
 544
 545   where
 546     spec_ok (DataConWorkId _) args
 547       = True    -- The strictness of the constructor has already
 548                 -- been expressed by its "wrapper", so we don't need
 549                 -- to take the arguments into account
 550
 551     spec_ok (PrimOpId op) args
 552       | isDivOp op,             -- Special case for dividing operations that fail
 553         [arg1, Lit lit] <- args -- only if the divisor is zero
 554       = not (isZeroLit lit) && exprOkForSpeculation arg1
 555                 -- Often there is a literal divisor, and this
 556                 -- can get rid of a thunk in an inner looop
 557
 558       | otherwise
 559       = primOpOkForSpeculation op &&
 560         all exprOkForSpeculation args
 561                                 -- A bit conservative: we don't really need
 562                                 -- to care about lazy arguments, but this is easy
 563
 564     spec_ok other args = False
 565
 566 isDivOp :: PrimOp -> Bool
 567 -- True of dyadic operators that can fail
 568 -- only if the second arg is zero
 569 -- This function probably belongs in PrimOp, or even in
 570 -- an automagically generated file.. but it's such a
 571 -- special case I thought I'd leave it here for now.
 572 isDivOp IntQuotOp        = True
 573 isDivOp IntRemOp         = True
 574 isDivOp WordQuotOp       = True
 575 isDivOp WordRemOp        = True
 576 isDivOp IntegerQuotRemOp = True
 577 isDivOp IntegerDivModOp  = True
 578 isDivOp FloatDivOp       = True
 579 isDivOp DoubleDivOp      = True
 580 isDivOp other            = False
 581 \end{code}
 582
 583
 584 \begin{code}
 585 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 586 exprIsBottom e = go 0 e
 587                where
 588                 -- n is the number of args
 589                  go n (Note _ e)     = go n e
 590                  go n (Cast e co)    = go n e
 591                  go n (Let _ e)      = go n e
 592                  go n (Case e _ _ _) = go 0 e   -- Just check the scrut
 593                  go n (App e _)      = go (n+1) e
 594                  go n (Var v)        = idAppIsBottom v n
 595                  go n (Lit _)        = False
 596                  go n (Lam _ _)      = False
 597                  go n (Type _)       = False
 598
 599 idAppIsBottom :: Id -> Int -> Bool
 600 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 601 \end{code}
 602
 603 @exprIsHNF@ returns true for expressions that are certainly *already*
 604 evaluated to *head* normal form.  This is used to decide whether it's ok
 605 to change
 606
 607         case x of _ -> e   ===>   e
 608
 609 and to decide whether it's safe to discard a `seq`
 610
 611 So, it does *not* treat variables as evaluated, unless they say they are.
 612
 613 But it *does* treat partial applications and constructor applications
 614 as values, even if their arguments are non-trivial, provided the argument
 615 type is lifted;
 616         e.g.  (:) (f x) (map f xs)      is a value
 617               map (...redex...)         is a value
 618 Because `seq` on such things completes immediately
 619
 620 For unlifted argument types, we have to be careful:
 621                 C (f x :: Int#)
 622 Suppose (f x) diverges; then C (f x) is not a value.  However this can't
 623 happen: see CoreSyn Note [CoreSyn let/app invariant].  Args of unboxed
 624 type must be ok-for-speculation (or trivial).
 625
 626 \begin{code}
 627 exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
 628 exprIsHNF (Var v)       -- NB: There are no value args at this point
 629   =  isDataConWorkId v  -- Catches nullary constructors,
 630                         --      so that [] and () are values, for example
 631   || idArity v > 0      -- Catches (e.g.) primops that don't have unfoldings
 632   || isEvaldUnfolding (idUnfolding v)
 633         -- Check the thing's unfolding; it might be bound to a value
 634         -- A worry: what if an Id's unfolding is just itself:
 635         -- then we could get an infinite loop...
 636
 637 exprIsHNF (Lit l)          = True
 638 exprIsHNF (Type ty)        = True       -- Types are honorary Values;
 639                                         -- we don't mind copying them
 640 exprIsHNF (Lam b e)        = isRuntimeVar b || exprIsHNF e
 641 exprIsHNF (Note _ e)       = exprIsHNF e
 642 exprIsHNF (Cast e co)      = exprIsHNF e
 643 exprIsHNF (App e (Type _)) = exprIsHNF e
 644 exprIsHNF (App e a)        = app_is_value e [a]
 645 exprIsHNF other            = False
 646
 647 -- There is at least one value argument
 648 app_is_value (Var fun) args
 649   = idArity fun > valArgCount args      -- Under-applied function
 650     ||  isDataConWorkId fun             --  or data constructor
 651 app_is_value (Note n f) as = app_is_value f as
 652 app_is_value (Cast f _) as = app_is_value f as
 653 app_is_value (App f a)  as = app_is_value f (a:as)
 654 app_is_value other      as = False
 655 \end{code}
 656
 657 \begin{code}
 658 -- These InstPat functions go here to avoid circularity between DataCon and Id
 659 dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat (FSLIT("ipv")))
 660 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
 661 dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat (FSLIT("ipv")))
 662   where
 663     dc_arg_tys dc = map mkPredTy (dataConTheta dc) ++ dataConOrigArgTys dc
 664         -- Remember to include the existential dictionaries
 665
 666 dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 667                   -> [FastString]          -- A long enough list of FSs to use for names
 668                   -> [Unique]              -- An equally long list of uniques, at least one for each binder
 669                   -> DataCon
 670                   -> [Type]                -- Types to instantiate the universally quantified tyvars
 671                -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
 672 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
 673 -- (ex_tvs, co_tvs, arg_ids),
 674 --
 675 --   ex_tvs are intended to be used as binders for existential type args
 676 --
 677 --   co_tvs are intended to be used as binders for coercion args and the kinds
 678 --     of these vars have been instantiated by the inst_tys and the ex_tys
 679 --
 680 --   arg_ids are indended to be used as binders for value arguments, including
 681 --     dicts, and their types have been instantiated with inst_tys and ex_tys
 682 --
 683 -- Example.
 684 --  The following constructor T1
 685 --
 686 --  data T a where
 687 --    T1 :: forall b. Int -> b -> T(a,b)
 688 --    ...
 689 --
 690 --  has representation type
 691 --   forall a. forall a1. forall b. (a :=: (a1,b)) =>
 692 --     Int -> b -> T a
 693 --
 694 --  dataConInstPat fss us T1 (a1',b') will return
 695 --
 696 --  ([a1'', b''], [c :: (a1', b'):=:(a1'', b'')], [x :: Int, y :: b''])
 697 --
 698 --  where the double-primed variables are created with the FastStrings and
 699 --  Uniques given as fss and us
 700 dataConInstPat arg_fun fss uniqs con inst_tys
 701   = (ex_bndrs, co_bndrs, id_bndrs)
 702   where
 703     univ_tvs = dataConUnivTyVars con
 704     ex_tvs   = dataConExTyVars con
 705     arg_tys  = arg_fun con
 706     eq_spec  = dataConEqSpec con
 707     eq_preds = eqSpecPreds eq_spec
 708
 709     n_ex = length ex_tvs
 710     n_co = length eq_spec
 711
 712       -- split the Uniques and FastStrings
 713     (ex_uniqs, uniqs')   = splitAt n_ex uniqs
 714     (co_uniqs, id_uniqs) = splitAt n_co uniqs'
 715
 716     (ex_fss, fss')     = splitAt n_ex fss
 717     (co_fss, id_fss)   = splitAt n_co fss'
 718
 719       -- Make existential type variables
 720     ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
 721     mk_ex_var uniq fs var = mkTyVar new_name kind
 722       where
 723         new_name = mkSysTvName uniq fs
 724         kind     = tyVarKind var
 725
 726       -- Make the instantiating substitution
 727     subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 728
 729       -- Make new coercion vars, instantiating kind
 730     co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
 731     mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
 732        where
 733          new_name = mkSysTvName uniq fs
 734          co_kind  = substTy subst (mkPredTy eq_pred)
 735
 736       -- make value vars, instantiating types
 737     mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
 738     id_bndrs = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 739
 740 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 741 -- Returns (Just (dc, [x1..xn])) if the argument expression is
 742 -- a constructor application of the form (dc x1 .. xn)
 743 exprIsConApp_maybe (Cast expr co)
 744   =     -- Here we do the PushC reduction rule as described in the FC paper
 745     case exprIsConApp_maybe expr of {
 746         Nothing            -> Nothing ;
 747         Just (dc, dc_args) ->
 748
 749         -- The transformation applies iff we have
 750         --      (C e1 ... en) `cast` co
 751         -- where co :: (T t1 .. tn) :=: (T s1 ..sn)
 752         -- That is, with a T at the top of both sides
 753         -- The left-hand one must be a T, because exprIsConApp returned True
 754         -- but the right-hand one might not be.  (Though it usually will.)
 755
 756     let (from_ty, to_ty)           = coercionKind co
 757         (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
 758                 -- The inner one must be a TyConApp
 759     in
 760     case splitTyConApp_maybe to_ty of {
 761         Nothing -> Nothing ;
 762         Just (to_tc, to_tc_arg_tys)
 763                 | from_tc /= to_tc -> Nothing
 764                 -- These two Nothing cases are possible; we might see
 765                 --      (C x y) `cast` (g :: T a ~ S [a]),
 766                 -- where S is a type function.  In fact, exprIsConApp
 767                 -- will probably not be called in such circumstances,
 768                 -- but there't nothing wrong with it
 769
 770                 | otherwise  ->
 771     let
 772         tc_arity = tyConArity from_tc
 773
 774         (univ_args, rest1)  = splitAt tc_arity dc_args
 775         (ex_args, rest2)    = splitAt n_ex_tvs rest1
 776         (co_args, val_args) = splitAt n_cos rest2
 777
 778         arg_tys             = dataConRepArgTys dc
 779         dc_univ_tyvars      = dataConUnivTyVars dc
 780         dc_ex_tyvars        = dataConExTyVars dc
 781         dc_eq_spec          = dataConEqSpec dc
 782         dc_tyvars           = dc_univ_tyvars ++ dc_ex_tyvars
 783         n_ex_tvs            = length dc_ex_tyvars
 784         n_cos               = length dc_eq_spec
 785
 786         -- Make the "theta" from Fig 3 of the paper
 787         gammas              = decomposeCo tc_arity co
 788         new_tys             = gammas ++ map (\ (Type t) -> t) ex_args
 789         theta               = zipOpenTvSubst dc_tyvars new_tys
 790
 791           -- First we cast the existential coercion arguments
 792         cast_co (tv,ty) (Type co) = Type $ mkSymCoercion (substTyVar theta tv)
 793                                            `mkTransCoercion` co
 794                                            `mkTransCoercion` (substTy theta ty)
 795         new_co_args = zipWith cast_co dc_eq_spec co_args
 796
 797           -- ...and now value arguments
 798         new_val_args = zipWith cast_arg arg_tys val_args
 799         cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
 800
 801     in
 802     ASSERT( length univ_args == tc_arity )
 803     ASSERT( from_tc == dataConTyCon dc )
 804     ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
 805     ASSERT( all isTypeArg (univ_args ++ ex_args) )
 806     ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys  )
 807
 808     Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
 809     }}
 810
 811 {-
 812 -- We do not want to tell the world that we have a
 813 -- Cons, to *stop* Case of Known Cons, which removes
 814 -- the TickBox.
 815 exprIsConApp_maybe (Note (TickBox {}) expr)
 816   = Nothing
 817 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
 818   = Nothing
 819 -}
 820
 821 exprIsConApp_maybe (Note _ expr)
 822   = exprIsConApp_maybe expr
 823     -- We ignore InlineMe notes in case we have
 824     --  x = __inline_me__ (a,b)
 825     -- All part of making sure that INLINE pragmas never hurt
 826     -- Marcin tripped on this one when making dictionaries more inlinable
 827     --
 828     -- In fact, we ignore all notes.  For example,
 829     --          case _scc_ "foo" (C a b) of
 830     --                  C a b -> e
 831     -- should be optimised away, but it will be only if we look
 832     -- through the SCC note.
 833
 834 exprIsConApp_maybe expr = analyse (collectArgs expr)
 835   where
 836     analyse (Var fun, args)
 837         | Just con <- isDataConWorkId_maybe fun,
 838           args `lengthAtLeast` dataConRepArity con
 839                 -- Might be > because the arity excludes type args
 840         = Just (con,args)
 841
 842         -- Look through unfoldings, but only cheap ones, because
 843         -- we are effectively duplicating the unfolding
 844     analyse (Var fun, [])
 845         | let unf = idUnfolding fun,
 846           isCheapUnfolding unf
 847         = exprIsConApp_maybe (unfoldingTemplate unf)
 848
 849     analyse other = Nothing
 850 \end{code}
 851
 852
 853
 854 %************************************************************************
 855 %*                                                                      *
 856 \subsection{Eta reduction and expansion}
 857 %*                                                                      *
 858 %************************************************************************
 859
 860 \begin{code}
 861 exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity
 862 {- The Arity returned is the number of value args the
 863    thing can be applied to without doing much work
 864
 865 exprEtaExpandArity is used when eta expanding
 866         e  ==>  \xy -> e x y
 867
 868 It returns 1 (or more) to:
 869         case x of p -> \s -> ...
 870 because for I/O ish things we really want to get that \s to the top.
 871 We are prepared to evaluate x each time round the loop in order to get that
 872
 873 It's all a bit more subtle than it looks:
 874
 875 1.  One-shot lambdas
 876
 877 Consider one-shot lambdas
 878                 let x = expensive in \y z -> E
 879 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
 880 Hence the ArityType returned by arityType
 881
 882 2.  The state-transformer hack
 883
 884 The one-shot lambda special cause is particularly important/useful for
 885 IO state transformers, where we often get
 886         let x = E in \ s -> ...
 887
 888 and the \s is a real-world state token abstraction.  Such abstractions
 889 are almost invariably 1-shot, so we want to pull the \s out, past the
 890 let x=E, even if E is expensive.  So we treat state-token lambdas as
 891 one-shot even if they aren't really.  The hack is in Id.isOneShotBndr.
 892
 893 3.  Dealing with bottom
 894
 895 Consider also
 896         f = \x -> error "foo"
 897 Here, arity 1 is fine.  But if it is
 898         f = \x -> case x of
 899                         True  -> error "foo"
 900                         False -> \y -> x+y
 901 then we want to get arity 2.  Tecnically, this isn't quite right, because
 902         (f True) `seq` 1
 903 should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
 904 do so; it improves some programs significantly, and increasing convergence
 905 isn't a bad thing.  Hence the ABot/ATop in ArityType.
 906
 907 Actually, the situation is worse.  Consider
 908         f = \x -> case x of
 909                         True  -> \y -> x+y
 910                         False -> \y -> x-y
 911 Can we eta-expand here?  At first the answer looks like "yes of course", but
 912 consider
 913         (f bot) `seq` 1
 914 This should diverge!  But if we eta-expand, it won't.   Again, we ignore this
 915 "problem", because being scrupulous would lose an important transformation for
 916 many programs.
 917
 918
 919 4. Newtypes
 920
 921 Non-recursive newtypes are transparent, and should not get in the way.
 922 We do (currently) eta-expand recursive newtypes too.  So if we have, say
 923
 924         newtype T = MkT ([T] -> Int)
 925
 926 Suppose we have
 927         e = coerce T f
 928 where f has arity 1.  Then: etaExpandArity e = 1;
 929 that is, etaExpandArity looks through the coerce.
 930
 931 When we eta-expand e to arity 1: eta_expand 1 e T
 932 we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 933
 934 HOWEVER, note that if you use coerce bogusly you can ge
 935         coerce Int negate
 936 And since negate has arity 2, you might try to eta expand.  But you can't
 937 decopose Int to a function type.   Hence the final case in eta_expand.
 938 -}
 939
 940
 941 exprEtaExpandArity dflags e = arityDepth (arityType dflags e)
 942
 943 -- A limited sort of function type
 944 data ArityType = AFun Bool ArityType    -- True <=> one-shot
 945                | ATop                   -- Know nothing
 946                | ABot                   -- Diverges
 947
 948 arityDepth :: ArityType -> Arity
 949 arityDepth (AFun _ ty) = 1 + arityDepth ty
 950 arityDepth ty          = 0
 951
 952 andArityType ABot           at2           = at2
 953 andArityType ATop           at2           = ATop
 954 andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
 955 andArityType at1            at2           = andArityType at2 at1
 956
 957 arityType :: DynFlags -> CoreExpr -> ArityType
 958         -- (go1 e) = [b1,..,bn]
 959         -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
 960         -- where bi is True <=> the lambda is one-shot
 961
 962 arityType dflags (Note n e) = arityType dflags e
 963 --      Not needed any more: etaExpand is cleverer
 964 --  | ok_note n = arityType dflags e
 965 --  | otherwise = ATop
 966
 967 arityType dflags (Cast e co) = arityType dflags e
 968
 969 arityType dflags (Var v)
 970   = mk (idArity v) (arg_tys (idType v))
 971   where
 972     mk :: Arity -> [Type] -> ArityType
 973         -- The argument types are only to steer the "state hack"
 974         -- Consider case x of
 975         --              True  -> foo
 976         --              False -> \(s:RealWorld) -> e
 977         -- where foo has arity 1.  Then we want the state hack to
 978         -- apply to foo too, so we can eta expand the case.
 979     mk 0 tys | isBottomingId v                     = ABot
 980              | (ty:tys) <- tys, isStateHackType ty = AFun True ATop
 981              | otherwise                           = ATop
 982     mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
 983     mk n []       = AFun False                (mk (n-1) [])
 984
 985     arg_tys :: Type -> [Type]   -- Ignore for-alls
 986     arg_tys ty
 987         | Just (_, ty')  <- splitForAllTy_maybe ty = arg_tys ty'
 988         | Just (arg,res) <- splitFunTy_maybe ty    = arg : arg_tys res
 989         | otherwise                                = []
 990
 991         -- Lambdas; increase arity
 992 arityType dflags (Lam x e)
 993   | isId x    = AFun (isOneShotBndr x) (arityType dflags e)
 994   | otherwise = arityType dflags e
 995
 996         -- Applications; decrease arity
 997 arityType dflags (App f (Type _)) = arityType dflags f
 998 arityType dflags (App f a)        = case arityType dflags f of
 999                                         AFun one_shot xs | exprIsCheap a -> xs
1000                                         other                            -> ATop
1001
1002         -- Case/Let; keep arity if either the expression is cheap
1003         -- or it's a 1-shot lambda
1004         -- The former is not really right for Haskell
1005         --      f x = case x of { (a,b) -> \y. e }
1006         --  ===>
1007         --      f x y = case x of { (a,b) -> e }
1008         -- The difference is observable using 'seq'
1009 arityType dflags (Case scrut _ _ alts)
1010   = case foldr1 andArityType [arityType dflags rhs | (_,_,rhs) <- alts] of
1011         xs | exprIsCheap scrut          -> xs
1012         xs@(AFun one_shot _) | one_shot -> AFun True ATop
1013         other                           -> ATop
1014
1015 arityType dflags (Let b e)
1016   = case arityType dflags e of
1017         xs                   | cheap_bind b -> xs
1018         xs@(AFun one_shot _) | one_shot     -> AFun True ATop
1019         other                               -> ATop
1020   where
1021     cheap_bind (NonRec b e) = is_cheap (b,e)
1022     cheap_bind (Rec prs)    = all is_cheap prs
1023     is_cheap (b,e) = (dopt Opt_DictsCheap dflags && isDictId b)
1024                    || exprIsCheap e
1025         -- If the experimental -fdicts-cheap flag is on, we eta-expand through
1026         -- dictionary bindings.  This improves arities. Thereby, it also
1027         -- means that full laziness is less prone to floating out the
1028         -- application of a function to its dictionary arguments, which
1029         -- can thereby lose opportunities for fusion.  Example:
1030         --      foo :: Ord a => a -> ...
1031         --      foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....
1032         --              -- So foo has arity 1
1033         --
1034         --      f = \x. foo dInt $ bar x
1035         --
1036         -- The (foo DInt) is floated out, and makes ineffective a RULE
1037         --      foo (bar x) = ...
1038         --
1039         -- One could go further and make exprIsCheap reply True to any
1040         -- dictionary-typed expression, but that's more work.
1041
1042 arityType dflags other = ATop
1043
1044 {- NOT NEEDED ANY MORE: etaExpand is cleverer
1045 ok_note InlineMe = False
1046 ok_note other    = True
1047     -- Notice that we do not look through __inline_me__
1048     -- This may seem surprising, but consider
1049     --          f = _inline_me (\x -> e)
1050     -- We DO NOT want to eta expand this to
1051     --          f = \x -> (_inline_me (\x -> e)) x
1052     -- because the _inline_me gets dropped now it is applied,
1053     -- giving just
1054     --          f = \x -> e
1055     -- A Bad Idea
1056 -}
1057 \end{code}
1058
1059
1060 \begin{code}
1061 etaExpand :: Arity              -- Result should have this number of value args
1062           -> [Unique]
1063           -> CoreExpr -> Type   -- Expression and its type
1064           -> CoreExpr
1065 -- (etaExpand n us e ty) returns an expression with
1066 -- the same meaning as 'e', but with arity 'n'.
1067 --
1068 -- Given e' = etaExpand n us e ty
1069 -- We should have
1070 --      ty = exprType e = exprType e'
1071 --
1072 -- Note that SCCs are not treated specially.  If we have
1073 --      etaExpand 2 (\x -> scc "foo" e)
1074 --      = (\xy -> (scc "foo" e) y)
1075 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
1076
1077 etaExpand n us expr ty
1078   | manifestArity expr >= n = expr              -- The no-op case
1079   | otherwise
1080   = eta_expand n us expr ty
1081   where
1082
1083 -- manifestArity sees how many leading value lambdas there are
1084 manifestArity :: CoreExpr -> Arity
1085 manifestArity (Lam v e) | isId v    = 1 + manifestArity e
1086                         | otherwise = manifestArity e
1087 manifestArity (Note _ e)            = manifestArity e
1088 manifestArity (Cast e _)            = manifestArity e
1089 manifestArity e                     = 0
1090
1091 -- etaExpand deals with for-alls. For example:
1092 --              etaExpand 1 E
1093 -- where  E :: forall a. a -> a
1094 -- would return
1095 --      (/\b. \y::a -> E b y)
1096 --
1097 -- It deals with coerces too, though they are now rare
1098 -- so perhaps the extra code isn't worth it
1099
1100 eta_expand n us expr ty
1101   | n == 0 &&
1102     -- The ILX code generator requires eta expansion for type arguments
1103     -- too, but alas the 'n' doesn't tell us how many of them there
1104     -- may be.  So we eagerly eta expand any big lambdas, and just
1105     -- cross our fingers about possible loss of sharing in the ILX case.
1106     -- The Right Thing is probably to make 'arity' include
1107     -- type variables throughout the compiler.  (ToDo.)
1108     not (isForAllTy ty)
1109     -- Saturated, so nothing to do
1110   = expr
1111
1112         -- Short cut for the case where there already
1113         -- is a lambda; no point in gratuitously adding more
1114 eta_expand n us (Lam v body) ty
1115   | isTyVar v
1116   = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
1117
1118   | otherwise
1119   = Lam v (eta_expand (n-1) us body (funResultTy ty))
1120
1121 -- We used to have a special case that stepped inside Coerces here,
1122 -- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _
1123 --              = Note note (eta_expand n us e ty)
1124 -- BUT this led to an infinite loop
1125 -- Example:     newtype T = MkT (Int -> Int)
1126 --      eta_expand 1 (coerce (Int->Int) e)
1127 --      --> coerce (Int->Int) (eta_expand 1 T e)
1128 --              by the bogus eqn
1129 --      --> coerce (Int->Int) (coerce T
1130 --              (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
1131 --              by the splitNewType_maybe case below
1132 --      and round we go
1133
1134 eta_expand n us expr ty
1135   = ASSERT2 (exprType expr `coreEqType` ty, ppr (exprType expr) $$ ppr ty)
1136     case splitForAllTy_maybe ty of {
1137           Just (tv,ty') ->
1138
1139               Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
1140                   where
1141                     lam_tv = setVarName tv (mkSysTvName uniq FSLIT("etaT"))
1142                         -- Using tv as a base retains its tyvar/covar-ness
1143                     (uniq:us2) = us
1144         ; Nothing ->
1145
1146         case splitFunTy_maybe ty of {
1147           Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
1148                                 where
1149                                    arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
1150                                    (uniq:us2) = us
1151
1152         ; Nothing ->
1153
1154                 -- Given this:
1155                 --      newtype T = MkT ([T] -> Int)
1156                 -- Consider eta-expanding this
1157                 --      eta_expand 1 e T
1158                 -- We want to get
1159                 --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
1160
1161         case splitNewTypeRepCo_maybe ty of {
1162           Just(ty1,co) ->
1163               mkCoerce (mkSymCoercion co) (eta_expand n us (mkCoerce co expr) ty1) ;
1164           Nothing  ->
1165
1166         -- We have an expression of arity > 0, but its type isn't a function
1167         -- This *can* legitmately happen: e.g.  coerce Int (\x. x)
1168         -- Essentially the programmer is playing fast and loose with types
1169         -- (Happy does this a lot).  So we simply decline to eta-expand.
1170         expr
1171         }}}
1172 \end{code}
1173
1174 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
1175 It tells how many things the expression can be applied to before doing
1176 any work.  It doesn't look inside cases, lets, etc.  The idea is that
1177 exprEtaExpandArity will do the hard work, leaving something that's easy
1178 for exprArity to grapple with.  In particular, Simplify uses exprArity to
1179 compute the ArityInfo for the Id.
1180
1181 Originally I thought that it was enough just to look for top-level lambdas, but
1182 it isn't.  I've seen this
1183
1184         foo = PrelBase.timesInt
1185
1186 We want foo to get arity 2 even though the eta-expander will leave it
1187 unchanged, in the expectation that it'll be inlined.  But occasionally it
1188 isn't, because foo is blacklisted (used in a rule).
1189
1190 Similarly, see the ok_note check in exprEtaExpandArity.  So
1191         f = __inline_me (\x -> e)
1192 won't be eta-expanded.
1193
1194 And in any case it seems more robust to have exprArity be a bit more intelligent.
1195 But note that   (\x y z -> f x y z)
1196 should have arity 3, regardless of f's arity.
1197
1198 \begin{code}
1199 exprArity :: CoreExpr -> Arity
1200 exprArity e = go e
1201             where
1202               go (Var v)                   = idArity v
1203               go (Lam x e) | isId x        = go e + 1
1204                            | otherwise     = go e
1205               go (Note n e)                = go e
1206               go (Cast e _)                = go e
1207               go (App e (Type t))          = go e
1208               go (App f a) | exprIsCheap a = (go f - 1) `max` 0
1209                 -- NB: exprIsCheap a!
1210                 --      f (fac x) does not have arity 2,
1211                 --      even if f has arity 3!
1212                 -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
1213                 --               unknown, hence arity 0
1214               go _                         = 0
1215 \end{code}
1216
1217 %************************************************************************
1218 %*                                                                      *
1219 \subsection{Equality}
1220 %*                                                                      *
1221 %************************************************************************
1222
1223 @cheapEqExpr@ is a cheap equality test which bales out fast!
1224         True  => definitely equal
1225         False => may or may not be equal
1226
1227 \begin{code}
1228 cheapEqExpr :: Expr b -> Expr b -> Bool
1229
1230 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
1231 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1232 cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
1233
1234 cheapEqExpr (App f1 a1) (App f2 a2)
1235   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1236
1237 cheapEqExpr _ _ = False
1238
1239 exprIsBig :: Expr b -> Bool
1240 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1241 exprIsBig (Lit _)      = False
1242 exprIsBig (Var v)      = False
1243 exprIsBig (Type t)     = False
1244 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1245 exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!
1246 exprIsBig other        = True
1247 \end{code}
1248
1249
1250 \begin{code}
1251 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1252 -- Used in rule matching, so does *not* look through
1253 -- newtypes, predicate types; hence tcEqExpr
1254
1255 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1256   where
1257     rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1258
1259 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1260 tcEqExprX env (Var v1)     (Var v2)     = rnOccL env v1 == rnOccR env v2
1261 tcEqExprX env (Lit lit1)   (Lit lit2)   = lit1 == lit2
1262 tcEqExprX env (App f1 a1)  (App f2 a2)  = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1263 tcEqExprX env (Lam v1 e1)  (Lam v2 e2)  = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1264 tcEqExprX env (Let (NonRec v1 r1) e1)
1265               (Let (NonRec v2 r2) e2)   = tcEqExprX env r1 r2
1266                                        && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1267 tcEqExprX env (Let (Rec ps1) e1)
1268               (Let (Rec ps2) e2)        =  equalLength ps1 ps2
1269                                         && and (zipWith eq_rhs ps1 ps2)
1270                                         && tcEqExprX env' e1 e2
1271                                      where
1272                                        env' = foldl2 rn_bndr2 env ps2 ps2
1273                                        rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1274                                        eq_rhs       (_,r1) (_,r2) = tcEqExprX env' r1 r2
1275 tcEqExprX env (Case e1 v1 t1 a1)
1276               (Case e2 v2 t2 a2)     =  tcEqExprX env e1 e2
1277                                      && tcEqTypeX env t1 t2
1278                                      && equalLength a1 a2
1279                                      && and (zipWith (eq_alt env') a1 a2)
1280                                      where
1281                                        env' = rnBndr2 env v1 v2
1282
1283 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1284 tcEqExprX env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && tcEqExprX env e1 e2
1285 tcEqExprX env (Type t1)    (Type t2)    = tcEqTypeX env t1 t2
1286 tcEqExprX env e1                e2      = False
1287
1288 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1  vs2) r1 r2
1289
1290 eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
1291 eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
1292 eq_note env other1             other2     = False
1293 \end{code}
1294
1295
1296 %************************************************************************
1297 %*                                                                      *
1298 \subsection{The size of an expression}
1299 %*                                                                      *
1300 %************************************************************************
1301
1302 \begin{code}
1303 coreBindsSize :: [CoreBind] -> Int
1304 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1305
1306 exprSize :: CoreExpr -> Int
1307         -- A measure of the size of the expressions
1308         -- It also forces the expression pretty drastically as a side effect
1309 exprSize (Var v)         = v `seq` 1
1310 exprSize (Lit lit)       = lit `seq` 1
1311 exprSize (App f a)       = exprSize f + exprSize a
1312 exprSize (Lam b e)       = varSize b + exprSize e
1313 exprSize (Let b e)       = bindSize b + exprSize e
1314 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1315 exprSize (Cast e co)     = (seqType co `seq` 1) + exprSize e
1316 exprSize (Note n e)      = noteSize n + exprSize e
1317 exprSize (Type t)        = seqType t `seq` 1
1318
1319 noteSize (SCC cc)       = cc `seq` 1
1320 noteSize InlineMe       = 1
1321 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1322
1323 varSize :: Var -> Int
1324 varSize b  | isTyVar b = 1
1325            | otherwise = seqType (idType b)             `seq`
1326                          megaSeqIdInfo (idInfo b)       `seq`
1327                          1
1328
1329 varsSize = foldr ((+) . varSize) 0
1330
1331 bindSize (NonRec b e) = varSize b + exprSize e
1332 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1333
1334 pairSize (b,e) = varSize b + exprSize e
1335
1336 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1337 \end{code}
1338
1339
1340 %************************************************************************
1341 %*                                                                      *
1342 \subsection{Hashing}
1343 %*                                                                      *
1344 %************************************************************************
1345
1346 \begin{code}
1347 hashExpr :: CoreExpr -> Int
1348 -- Two expressions that hash to the same Int may be equal (but may not be)
1349 -- Two expressions that hash to the different Ints are definitely unequal
1350 --
1351 -- But "unequal" here means "not identical"; two alpha-equivalent
1352 -- expressions may hash to the different Ints
1353 --
1354 -- The emphasis is on a crude, fast hash, rather than on high precision
1355 --
1356 -- We must be careful that \x.x and \y.y map to the same hash code,
1357 -- (at least if we want the above invariant to be true)
1358
1359 hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
1360              -- UniqFM doesn't like negative Ints
1361
1362 type HashEnv = (Int, VarEnv Int)        -- Hash code for bound variables
1363
1364 hash_expr :: HashEnv -> CoreExpr -> Word32
1365 -- Word32, because we're expecting overflows here, and overflowing
1366 -- signed types just isn't cool.  In C it's even undefined.
1367 hash_expr env (Note _ e)              = hash_expr env e
1368 hash_expr env (Cast e co)             = hash_expr env e
1369 hash_expr env (Var v)                 = hashVar env v
1370 hash_expr env (Lit lit)               = fromIntegral (hashLiteral lit)
1371 hash_expr env (App f e)               = hash_expr env f * fast_hash_expr env e
1372 hash_expr env (Let (NonRec b r) e)    = hash_expr (extend_env env b) e * fast_hash_expr env r
1373 hash_expr env (Let (Rec ((b,r):_)) e) = hash_expr (extend_env env b) e
1374 hash_expr env (Case e _ _ _)          = hash_expr env e
1375 hash_expr env (Lam b e)               = hash_expr (extend_env env b) e
1376 hash_expr env (Type t)                = WARN(True, text "hash_expr: type") 1
1377 -- Shouldn't happen.  Better to use WARN than trace, because trace
1378 -- prevents the CPR optimisation kicking in for hash_expr.
1379
1380 fast_hash_expr env (Var v)      = hashVar env v
1381 fast_hash_expr env (Type t)     = fast_hash_type env t
1382 fast_hash_expr env (Lit lit)    = fromIntegral (hashLiteral lit)
1383 fast_hash_expr env (Cast e co)  = fast_hash_expr env e
1384 fast_hash_expr env (Note n e)   = fast_hash_expr env e
1385 fast_hash_expr env (App f a)    = fast_hash_expr env a  -- A bit idiosyncratic ('a' not 'f')!
1386 fast_hash_expr env other        = 1
1387
1388 fast_hash_type :: HashEnv -> Type -> Word32
1389 fast_hash_type env ty
1390   | Just tv <- getTyVar_maybe ty            = hashVar env tv
1391   | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
1392                                               in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
1393   | otherwise                               = 1
1394
1395 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1396 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1397
1398 hashVar :: HashEnv -> Var -> Word32
1399 hashVar (_,env) v
1400  = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
1401 \end{code}
1402
1403 %************************************************************************
1404 %*                                                                      *
1405 \subsection{Determining non-updatable right-hand-sides}
1406 %*                                                                      *
1407 %************************************************************************
1408
1409 Top-level constructor applications can usually be allocated
1410 statically, but they can't if the constructor, or any of the
1411 arguments, come from another DLL (because we can't refer to static
1412 labels in other DLLs).
1413
1414 If this happens we simply make the RHS into an updatable thunk,
1415 and 'exectute' it rather than allocating it statically.
1416
1417 \begin{code}
1418 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1419 -- This function is called only on *top-level* right-hand sides
1420 -- Returns True if the RHS can be allocated statically, with
1421 -- no thunks involved at all.
1422 --
1423 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1424 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1425 -- update flag on it.
1426 --
1427 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1428 --      (a) a value lambda
1429 --      (b) a saturated constructor application with static args
1430 --
1431 -- BUT watch out for
1432 --  (i) Any cross-DLL references kill static-ness completely
1433 --      because they must be 'executed' not statically allocated
1434 --      ("DLL" here really only refers to Windows DLLs, on other platforms,
1435 --      this is not necessary)
1436 --
1437 -- (ii) We treat partial applications as redexes, because in fact we
1438 --      make a thunk for them that runs and builds a PAP
1439 --      at run-time.  The only appliations that are treated as
1440 --      static are *saturated* applications of constructors.
1441
1442 -- We used to try to be clever with nested structures like this:
1443 --              ys = (:) w ((:) w [])
1444 -- on the grounds that CorePrep will flatten ANF-ise it later.
1445 -- But supporting this special case made the function much more
1446 -- complicated, because the special case only applies if there are no
1447 -- enclosing type lambdas:
1448 --              ys = /\ a -> Foo (Baz ([] a))
1449 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1450 --
1451 -- But in fact, even without -O, nested structures at top level are
1452 -- flattened by the simplifier, so we don't need to be super-clever here.
1453 --
1454 -- Examples
1455 --
1456 --      f = \x::Int. x+7        TRUE
1457 --      p = (True,False)        TRUE
1458 --
1459 --      d = (fst p, False)      FALSE because there's a redex inside
1460 --                              (this particular one doesn't happen but...)
1461 --
1462 --      h = D# (1.0## /## 2.0##)        FALSE (redex again)
1463 --      n = /\a. Nil a                  TRUE
1464 --
1465 --      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
1466 --
1467 --
1468 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1469 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1470 --
1471 --    b) (C x xs), where C is a contructors is updatable if the application is
1472 --         dynamic
1473 --
1474 --    c) don't look through unfolding of f in (f x).
1475 --
1476 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1477 -- them as making the RHS re-entrant (non-updatable).
1478
1479 rhsIsStatic this_pkg rhs = is_static False rhs
1480   where
1481   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
1482           -> CoreExpr -> Bool
1483
1484   is_static False (Lam b e) = isRuntimeVar b || is_static False e
1485
1486   is_static in_arg (Note (SCC _) e) = False
1487   is_static in_arg (Note _ e)       = is_static in_arg e
1488   is_static in_arg (Cast e co)      = is_static in_arg e
1489
1490   is_static in_arg (Lit lit)
1491     = case lit of
1492         MachLabel _ _ -> False
1493         other         -> True
1494         -- A MachLabel (foreign import "&foo") in an argument
1495         -- prevents a constructor application from being static.  The
1496         -- reason is that it might give rise to unresolvable symbols
1497         -- in the object file: under Linux, references to "weak"
1498         -- symbols from the data segment give rise to "unresolvable
1499         -- relocation" errors at link time This might be due to a bug
1500         -- in the linker, but we'll work around it here anyway.
1501         -- SDM 24/2/2004
1502
1503   is_static in_arg other_expr = go other_expr 0
1504    where
1505     go (Var f) n_val_args
1506 #if mingw32_TARGET_OS
1507         | not (isDllName this_pkg (idName f))
1508 #endif
1509         =  saturated_data_con f n_val_args
1510         || (in_arg && n_val_args == 0)
1511                 -- A naked un-applied variable is *not* deemed a static RHS
1512                 -- E.g.         f = g
1513                 -- Reason: better to update so that the indirection gets shorted
1514                 --         out, and the true value will be seen
1515                 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1516                 --     are always updatable.  If you do so, make sure that non-updatable
1517                 --     ones have enough space for their static link field!
1518
1519     go (App f a) n_val_args
1520         | isTypeArg a                    = go f n_val_args
1521         | not in_arg && is_static True a = go f (n_val_args + 1)
1522         -- The (not in_arg) checks that we aren't in a constructor argument;
1523         -- if we are, we don't allow (value) applications of any sort
1524         --
1525         -- NB. In case you wonder, args are sometimes not atomic.  eg.
1526         --   x = D# (1.0## /## 2.0##)
1527         -- can't float because /## can fail.
1528
1529     go (Note (SCC _) f) n_val_args = False
1530     go (Note _ f) n_val_args       = go f n_val_args
1531     go (Cast e co) n_val_args      = go e n_val_args
1532
1533     go other n_val_args = False
1534
1535     saturated_data_con f n_val_args
1536         = case isDataConWorkId_maybe f of
1537             Just dc -> n_val_args == dataConRepArity dc
1538             Nothing -> False
1539 \end{code}