ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         -- Construction
   9         mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
  10         bindNonRec, needsCaseBinding,
  11         mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
  12
  13         -- Taking expressions apart
  14         findDefault, findAlt, isDefaultAlt,
  15
  16         -- Properties of expressions
  17         exprType, coreAltType,
  18         exprIsDupable, exprIsTrivial, exprIsCheap,
  19         exprIsHNF,exprOkForSpeculation, exprIsBig,
  20         exprIsConApp_maybe, exprIsBottom,
  21         rhsIsStatic,
  22
  23         -- Arity and eta expansion
  24         manifestArity, exprArity,
  25         exprEtaExpandArity, etaExpand,
  26
  27         -- Size
  28         coreBindsSize,
  29
  30         -- Hashing
  31         hashExpr,
  32
  33         -- Equality
  34         cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg
  35     ) where
  36
  37 #include "HsVersions.h"
  38
  39
  40 import GLAEXTS          -- For `xori`
  41
  42 import CoreSyn
  43 import CoreFVs          ( exprFreeVars )
  44 import PprCore          ( pprCoreExpr )
  45 import Var              ( Var )
  46 import VarSet           ( unionVarSet )
  47 import VarEnv
  48 import Name             ( hashName )
  49 import Packages         ( isDllName, HomeModules )
  50 import Literal          ( hashLiteral, literalType, litIsDupable,
  51                           litIsTrivial, isZeroLit, Literal( MachLabel ) )
  52 import DataCon          ( DataCon, dataConRepArity, dataConArgTys,
  53                           isVanillaDataCon, dataConTyCon )
  54 import PrimOp           ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
  55 import Id               ( Id, idType, globalIdDetails, idNewStrictness,
  56                           mkWildId, idArity, idName, idUnfolding, idInfo,
  57                           isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
  58                           isDataConWorkId, isBottomingId
  59                         )
  60 import IdInfo           ( GlobalIdDetails(..), megaSeqIdInfo )
  61 import NewDemand        ( appIsBottom )
  62 import Type             ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
  63                           splitFunTy, tcEqTypeX,
  64                           applyTys, isUnLiftedType, seqType, mkTyVarTy,
  65                           splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
  66                           splitTyConApp_maybe, coreEqType, funResultTy, applyTy
  67                         )
  68 import TyCon            ( tyConArity )
  69 -- gaw 2004
  70 import TysWiredIn       ( boolTy, trueDataCon, falseDataCon )
  71 import CostCentre       ( CostCentre )
  72 import BasicTypes       ( Arity )
  73 import Unique           ( Unique )
  74 import Outputable
  75 import TysPrim          ( alphaTy )     -- Debugging only
  76 import Util             ( equalLength, lengthAtLeast, foldl2 )
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Find the type of a Core atom/expression}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 exprType :: CoreExpr -> Type
  88
  89 exprType (Var var)              = idType var
  90 exprType (Lit lit)              = literalType lit
  91 exprType (Let _ body)           = exprType body
  92 exprType (Case _ _ ty alts)     = ty
  93 exprType (Note (Coerce ty _) e) = ty  --  **! should take usage from e
  94 exprType (Note other_note e)    = exprType e
  95 exprType (Lam binder expr)      = mkPiType binder (exprType expr)
  96 exprType e@(App _ _)
  97   = case collectArgs e of
  98         (fun, args) -> applyTypeToArgs e (exprType fun) args
  99
 100 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 101
 102 coreAltType :: CoreAlt -> Type
 103 coreAltType (_,_,rhs) = exprType rhs
 104 \end{code}
 105
 106 @mkPiType@ makes a (->) type or a forall type, depending on whether
 107 it is given a type variable or a term variable.  We cleverly use the
 108 lbvarinfo field to figure out the right annotation for the arrove in
 109 case of a term variable.
 110
 111 \begin{code}
 112 mkPiType  :: Var   -> Type -> Type      -- The more polymorphic version
 113 mkPiTypes :: [Var] -> Type -> Type      --    doesn't work...
 114
 115 mkPiTypes vs ty = foldr mkPiType ty vs
 116
 117 mkPiType v ty
 118    | isId v    = mkFunTy (idType v) ty
 119    | otherwise = mkForAllTy v ty
 120 \end{code}
 121
 122 \begin{code}
 123 applyTypeToArg :: Type -> CoreExpr -> Type
 124 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
 125 applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
 126
 127 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 128 -- A more efficient version of applyTypeToArg
 129 -- when we have several args
 130 -- The first argument is just for debugging
 131 applyTypeToArgs e op_ty [] = op_ty
 132
 133 applyTypeToArgs e op_ty (Type ty : args)
 134   =     -- Accumulate type arguments so we can instantiate all at once
 135     go [ty] args
 136   where
 137     go rev_tys (Type ty : args) = go (ty:rev_tys) args
 138     go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
 139                                 where
 140                                   op_ty' = applyTys op_ty (reverse rev_tys)
 141
 142 applyTypeToArgs e op_ty (other_arg : args)
 143   = case (splitFunTy_maybe op_ty) of
 144         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 145         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
 146 \end{code}
 147
 148
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsection{Attaching notes}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 mkNote removes redundant coercions, and SCCs where possible
 157
 158 \begin{code}
 159 #ifdef UNUSED
 160 mkNote :: Note -> CoreExpr -> CoreExpr
 161 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
 162 mkNote (SCC cc) expr               = mkSCC cc expr
 163 mkNote InlineMe expr               = mkInlineMe expr
 164 mkNote note     expr               = Note note expr
 165 #endif
 166
 167 -- Slide InlineCall in around the function
 168 --      No longer necessary I think (SLPJ Apr 99)
 169 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 170 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 171 -- mkNote InlineCall expr      = expr
 172 \end{code}
 173
 174 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 175 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 176 not be *applied* to anything.
 177
 178 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
 179 bindings like
 180         fw = ...
 181         f  = inline_me (coerce t fw)
 182 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
 183 We want the split, so that the coerces can cancel at the call site.
 184
 185 However, we can get left with tiresome type applications.  Notably, consider
 186         f = /\ a -> let t = e in (t, w)
 187 Then lifting the let out of the big lambda gives
 188         t' = /\a -> e
 189         f = /\ a -> let t = inline_me (t' a) in (t, w)
 190 The inline_me is to stop the simplifier inlining t' right back
 191 into t's RHS.  In the next phase we'll substitute for t (since
 192 its rhs is trivial) and *then* we could get rid of the inline_me.
 193 But it hardly seems worth it, so I don't bother.
 194
 195 \begin{code}
 196 mkInlineMe (Var v) = Var v
 197 mkInlineMe e       = Note InlineMe e
 198 \end{code}
 199
 200
 201
 202 \begin{code}
 203 mkCoerce :: Type -> CoreExpr -> CoreExpr
 204 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
 205
 206 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
 207 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 208   = ASSERT( from_ty `coreEqType` to_ty2 )
 209     mkCoerce2 to_ty from_ty2 expr
 210
 211 mkCoerce2 to_ty from_ty expr
 212   | to_ty `coreEqType` from_ty = expr
 213   | otherwise              = ASSERT( from_ty `coreEqType` exprType expr )
 214                              Note (Coerce to_ty from_ty) expr
 215 \end{code}
 216
 217 \begin{code}
 218 mkSCC :: CostCentre -> Expr b -> Expr b
 219         -- Note: Nested SCC's *are* preserved for the benefit of
 220         --       cost centre stack profiling
 221 mkSCC cc (Lit lit)          = Lit lit
 222 mkSCC cc (Lam x e)          = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
 223 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
 224 mkSCC cc (Note n e)         = Note n (mkSCC cc e) -- Move _scc_ inside notes
 225 mkSCC cc expr               = Note (SCC cc) expr
 226 \end{code}
 227
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{Other expression construction}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 \begin{code}
 236 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 237 -- (bindNonRec x r b) produces either
 238 --      let x = r in b
 239 -- or
 240 --      case r of x { _DEFAULT_ -> b }
 241 --
 242 -- depending on whether x is unlifted or not
 243 -- It's used by the desugarer to avoid building bindings
 244 -- that give Core Lint a heart attack.  Actually the simplifier
 245 -- deals with them perfectly well.
 246
 247 bindNonRec bndr rhs body
 248   | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 249   | otherwise                          = Let (NonRec bndr rhs) body
 250
 251 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 252         -- Make a case expression instead of a let
 253         -- These can arise either from the desugarer,
 254         -- or from beta reductions: (\x.e) (x +# y)
 255 \end{code}
 256
 257 \begin{code}
 258 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 259         -- This guy constructs the value that the scrutinee must have
 260         -- when you are in one particular branch of a case
 261 mkAltExpr (DataAlt con) args inst_tys
 262   = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
 263 mkAltExpr (LitAlt lit) [] []
 264   = Lit lit
 265
 266 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 267 mkIfThenElse guard then_expr else_expr
 268 -- Not going to be refining, so okay to take the type of the "then" clause
 269   = Case guard (mkWildId boolTy) (exprType then_expr)
 270          [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!
 271            (DataAlt trueDataCon,  [], then_expr) ]
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection{Taking expressions apart}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 The default alternative must be first, if it exists at all.
 282 This makes it easy to find, though it makes matching marginally harder.
 283
 284 \begin{code}
 285 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 286 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 287 findDefault alts                        =                     (alts, Nothing)
 288
 289 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 290 findAlt con alts
 291   = case alts of
 292         (deflt@(DEFAULT,_,_):alts) -> go alts deflt
 293         other                      -> go alts panic_deflt
 294   where
 295     panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 296
 297     go []                      deflt = deflt
 298     go (alt@(con1,_,_) : alts) deflt
 299       = case con `cmpAltCon` con1 of
 300           LT -> deflt   -- Missed it already; the alts are in increasing order
 301           EQ -> alt
 302           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 303
 304 isDefaultAlt :: CoreAlt -> Bool
 305 isDefaultAlt (DEFAULT, _, _) = True
 306 isDefaultAlt other           = False
 307 \end{code}
 308
 309
 310 %************************************************************************
 311 %*                                                                      *
 312 \subsection{Figuring out things about expressions}
 313 %*                                                                      *
 314 %************************************************************************
 315
 316 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 317                 duplicate; simple variables and constants, and type
 318                 applications.  Note that primop Ids aren't considered
 319                 trivial unless
 320
 321 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 322
 323
 324 There used to be a gruesome test for (hasNoBinding v) in the
 325 Var case:
 326         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 327 The idea here is that a constructor worker, like $wJust, is
 328 really short for (\x -> $wJust x), becuase $wJust has no binding.
 329 So it should be treated like a lambda.  Ditto unsaturated primops.
 330 But now constructor workers are not "have-no-binding" Ids.  And
 331 completely un-applied primops and foreign-call Ids are sufficiently
 332 rare that I plan to allow them to be duplicated and put up with
 333 saturating them.
 334
 335 SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because
 336   a) it really generates code, (and a heap object when it's
 337      a function arg) to capture the cost centre
 338   b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
 339
 340 \begin{code}
 341 exprIsTrivial (Var v)      = True       -- See notes above
 342 exprIsTrivial (Type _)     = True
 343 exprIsTrivial (Lit lit)    = litIsTrivial lit
 344 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 345 exprIsTrivial (Note (SCC _) e) = False          -- See notes above
 346 exprIsTrivial (Note _       e) = exprIsTrivial e
 347 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 348 exprIsTrivial other        = False
 349 \end{code}
 350
 351
 352 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 353                 cost in code size.  This will only happen in different case
 354                 branches, so there's no issue about duplicating work.
 355
 356                 That is, exprIsDupable returns True of (f x) even if
 357                 f is very very expensive to call.
 358
 359                 Its only purpose is to avoid fruitless let-binding
 360                 and then inlining of case join points
 361
 362
 363 \begin{code}
 364 exprIsDupable (Type _)          = True
 365 exprIsDupable (Var v)           = True
 366 exprIsDupable (Lit lit)         = litIsDupable lit
 367 exprIsDupable (Note InlineMe e) = True
 368 exprIsDupable (Note _ e)        = exprIsDupable e
 369 exprIsDupable expr
 370   = go expr 0
 371   where
 372     go (Var v)   n_args = True
 373     go (App f a) n_args =  n_args < dupAppSize
 374                         && exprIsDupable a
 375                         && go f (n_args+1)
 376     go other n_args     = False
 377
 378 dupAppSize :: Int
 379 dupAppSize = 4          -- Size of application we are prepared to duplicate
 380 \end{code}
 381
 382 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 383 it is obviously in weak head normal form, or is cheap to get to WHNF.
 384 [Note that that's not the same as exprIsDupable; an expression might be
 385 big, and hence not dupable, but still cheap.]
 386
 387 By ``cheap'' we mean a computation we're willing to:
 388         push inside a lambda, or
 389         inline at more than one place
 390 That might mean it gets evaluated more than once, instead of being
 391 shared.  The main examples of things which aren't WHNF but are
 392 ``cheap'' are:
 393
 394   *     case e of
 395           pi -> ei
 396         (where e, and all the ei are cheap)
 397
 398   *     let x = e in b
 399         (where e and b are cheap)
 400
 401   *     op x1 ... xn
 402         (where op is a cheap primitive operator)
 403
 404   *     error "foo"
 405         (because we are happy to substitute it inside a lambda)
 406
 407 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 408 because sharing will make sure it is only evaluated once.
 409
 410 \begin{code}
 411 exprIsCheap :: CoreExpr -> Bool
 412 exprIsCheap (Lit lit)               = True
 413 exprIsCheap (Type _)                = True
 414 exprIsCheap (Var _)                 = True
 415 exprIsCheap (Note InlineMe e)       = True
 416 exprIsCheap (Note _ e)              = exprIsCheap e
 417 exprIsCheap (Lam x e)               = isRuntimeVar x || exprIsCheap e
 418 exprIsCheap (Case e _ _ alts)       = exprIsCheap e &&
 419                                     and [exprIsCheap rhs | (_,_,rhs) <- alts]
 420         -- Experimentally, treat (case x of ...) as cheap
 421         -- (and case __coerce x etc.)
 422         -- This improves arities of overloaded functions where
 423         -- there is only dictionary selection (no construction) involved
 424 exprIsCheap (Let (NonRec x _) e)
 425       | isUnLiftedType (idType x) = exprIsCheap e
 426       | otherwise                 = False
 427         -- strict lets always have cheap right hand sides, and
 428         -- do no allocation.
 429
 430 exprIsCheap other_expr
 431   = go other_expr 0 True
 432   where
 433     go (Var f) n_args args_cheap
 434         = (idAppIsCheap f n_args && args_cheap)
 435                         -- A constructor, cheap primop, or partial application
 436
 437           || idAppIsBottom f n_args
 438                         -- Application of a function which
 439                         -- always gives bottom; we treat this as cheap
 440                         -- because it certainly doesn't need to be shared!
 441
 442     go (App f a) n_args args_cheap
 443         | not (isRuntimeArg a) = go f n_args      args_cheap
 444         | otherwise            = go f (n_args + 1) (exprIsCheap a && args_cheap)
 445
 446     go other   n_args args_cheap = False
 447
 448 idAppIsCheap :: Id -> Int -> Bool
 449 idAppIsCheap id n_val_args
 450   | n_val_args == 0 = True      -- Just a type application of
 451                                 -- a variable (f t1 t2 t3)
 452                                 -- counts as WHNF
 453   | otherwise
 454   = case globalIdDetails id of
 455         DataConWorkId _ -> True
 456         RecordSelId _ _ -> n_val_args == 1      -- I'm experimenting with making record selection
 457         ClassOpId _     -> n_val_args == 1      -- look cheap, so we will substitute it inside a
 458                                                 -- lambda.  Particularly for dictionary field selection.
 459                 -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 460                 --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 461
 462         PrimOpId op   -> primOpIsCheap op       -- In principle we should worry about primops
 463                                                 -- that return a type variable, since the result
 464                                                 -- might be applied to something, but I'm not going
 465                                                 -- to bother to check the number of args
 466         other         -> n_val_args < idArity id
 467 \end{code}
 468
 469 exprOkForSpeculation returns True of an expression that it is
 470
 471         * safe to evaluate even if normal order eval might not
 472           evaluate the expression at all, or
 473
 474         * safe *not* to evaluate even if normal order would do so
 475
 476 It returns True iff
 477
 478         the expression guarantees to terminate,
 479         soon,
 480         without raising an exception,
 481         without causing a side effect (e.g. writing a mutable variable)
 482
 483 E.G.
 484         let x = case y# +# 1# of { r# -> I# r# }
 485         in E
 486 ==>
 487         case y# +# 1# of { r# ->
 488         let x = I# r#
 489         in E
 490         }
 491
 492 We can only do this if the (y+1) is ok for speculation: it has no
 493 side effects, and can't diverge or raise an exception.
 494
 495 \begin{code}
 496 exprOkForSpeculation :: CoreExpr -> Bool
 497 exprOkForSpeculation (Lit _)    = True
 498 exprOkForSpeculation (Type _)   = True
 499 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 500 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 501 exprOkForSpeculation other_expr
 502   = case collectArgs other_expr of
 503         (Var f, args) -> spec_ok (globalIdDetails f) args
 504         other         -> False
 505
 506   where
 507     spec_ok (DataConWorkId _) args
 508       = True    -- The strictness of the constructor has already
 509                 -- been expressed by its "wrapper", so we don't need
 510                 -- to take the arguments into account
 511
 512     spec_ok (PrimOpId op) args
 513       | isDivOp op,             -- Special case for dividing operations that fail
 514         [arg1, Lit lit] <- args -- only if the divisor is zero
 515       = not (isZeroLit lit) && exprOkForSpeculation arg1
 516                 -- Often there is a literal divisor, and this
 517                 -- can get rid of a thunk in an inner looop
 518
 519       | otherwise
 520       = primOpOkForSpeculation op &&
 521         all exprOkForSpeculation args
 522                                 -- A bit conservative: we don't really need
 523                                 -- to care about lazy arguments, but this is easy
 524
 525     spec_ok other args = False
 526
 527 isDivOp :: PrimOp -> Bool
 528 -- True of dyadic operators that can fail
 529 -- only if the second arg is zero
 530 -- This function probably belongs in PrimOp, or even in
 531 -- an automagically generated file.. but it's such a
 532 -- special case I thought I'd leave it here for now.
 533 isDivOp IntQuotOp        = True
 534 isDivOp IntRemOp         = True
 535 isDivOp WordQuotOp       = True
 536 isDivOp WordRemOp        = True
 537 isDivOp IntegerQuotRemOp = True
 538 isDivOp IntegerDivModOp  = True
 539 isDivOp FloatDivOp       = True
 540 isDivOp DoubleDivOp      = True
 541 isDivOp other            = False
 542 \end{code}
 543
 544
 545 \begin{code}
 546 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 547 exprIsBottom e = go 0 e
 548                where
 549                 -- n is the number of args
 550                  go n (Note _ e)     = go n e
 551                  go n (Let _ e)      = go n e
 552                  go n (Case e _ _ _) = go 0 e   -- Just check the scrut
 553                  go n (App e _)      = go (n+1) e
 554                  go n (Var v)        = idAppIsBottom v n
 555                  go n (Lit _)        = False
 556                  go n (Lam _ _)      = False
 557                  go n (Type _)       = False
 558
 559 idAppIsBottom :: Id -> Int -> Bool
 560 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 561 \end{code}
 562
 563 @exprIsHNF@ returns true for expressions that are certainly *already*
 564 evaluated to *head* normal form.  This is used to decide whether it's ok
 565 to change
 566
 567         case x of _ -> e   ===>   e
 568
 569 and to decide whether it's safe to discard a `seq`
 570
 571 So, it does *not* treat variables as evaluated, unless they say they are.
 572
 573 But it *does* treat partial applications and constructor applications
 574 as values, even if their arguments are non-trivial, provided the argument
 575 type is lifted;
 576         e.g.  (:) (f x) (map f xs)      is a value
 577               map (...redex...)         is a value
 578 Because `seq` on such things completes immediately
 579
 580 For unlifted argument types, we have to be careful:
 581                 C (f x :: Int#)
 582 Suppose (f x) diverges; then C (f x) is not a value.  True, but
 583 this form is illegal (see the invariants in CoreSyn).  Args of unboxed
 584 type must be ok-for-speculation (or trivial).
 585
 586 \begin{code}
 587 exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
 588 exprIsHNF (Var v)       -- NB: There are no value args at this point
 589   =  isDataConWorkId v  -- Catches nullary constructors,
 590                         --      so that [] and () are values, for example
 591   || idArity v > 0      -- Catches (e.g.) primops that don't have unfoldings
 592   || isEvaldUnfolding (idUnfolding v)
 593         -- Check the thing's unfolding; it might be bound to a value
 594         -- A worry: what if an Id's unfolding is just itself:
 595         -- then we could get an infinite loop...
 596
 597 exprIsHNF (Lit l)            = True
 598 exprIsHNF (Type ty)          = True     -- Types are honorary Values;
 599                                         -- we don't mind copying them
 600 exprIsHNF (Lam b e)          = isRuntimeVar b || exprIsHNF e
 601 exprIsHNF (Note _ e)         = exprIsHNF e
 602 exprIsHNF (App e (Type _)) = exprIsHNF e
 603 exprIsHNF (App e a)        = app_is_value e [a]
 604 exprIsHNF other      = False
 605
 606 -- There is at least one value argument
 607 app_is_value (Var fun) args
 608   |  isDataConWorkId fun                        -- Constructor apps are values
 609   || idArity fun > valArgCount args     -- Under-applied function
 610   = check_args (idType fun) args
 611 app_is_value (App f a) as = app_is_value f (a:as)
 612 app_is_value other     as = False
 613
 614         -- 'check_args' checks that unlifted-type args
 615         -- are in fact guaranteed non-divergent
 616 check_args fun_ty []              = True
 617 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
 618                                       Just (_, ty) -> check_args ty args
 619 check_args fun_ty (arg : args)
 620   | isUnLiftedType arg_ty = exprOkForSpeculation arg
 621   | otherwise             = check_args res_ty args
 622   where
 623     (arg_ty, res_ty) = splitFunTy fun_ty
 624 \end{code}
 625
 626 \begin{code}
 627 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 628 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
 629   =     -- Maybe this is over the top, but here we try to turn
 630         --      coerce (S,T) ( x, y )
 631         -- effectively into
 632         --      ( coerce S x, coerce T y )
 633         -- This happens in anger in PrelArrExts which has a coerce
 634         --      case coerce memcpy a b of
 635         --        (# r, s #) -> ...
 636         -- where the memcpy is in the IO monad, but the call is in
 637         -- the (ST s) monad
 638     case exprIsConApp_maybe expr of {
 639         Nothing           -> Nothing ;
 640         Just (dc, args)   ->
 641
 642     case splitTyConApp_maybe to_ty of {
 643         Nothing -> Nothing ;
 644         Just (tc, tc_arg_tys) | tc /= dataConTyCon dc     -> Nothing
 645                               | not (isVanillaDataCon dc) -> Nothing
 646                               | otherwise                 ->
 647                 -- Type constructor must match
 648                 -- We knock out existentials to keep matters simple(r)
 649     let
 650         arity            = tyConArity tc
 651         val_args         = drop arity args
 652         to_arg_tys       = dataConArgTys dc tc_arg_tys
 653         mk_coerce ty arg = mkCoerce ty arg
 654         new_val_args     = zipWith mk_coerce to_arg_tys val_args
 655     in
 656     ASSERT( all isTypeArg (take arity args) )
 657     ASSERT( equalLength val_args to_arg_tys )
 658     Just (dc, map Type tc_arg_tys ++ new_val_args)
 659     }}
 660
 661 exprIsConApp_maybe (Note _ expr)
 662   = exprIsConApp_maybe expr
 663     -- We ignore InlineMe notes in case we have
 664     --  x = __inline_me__ (a,b)
 665     -- All part of making sure that INLINE pragmas never hurt
 666     -- Marcin tripped on this one when making dictionaries more inlinable
 667     --
 668     -- In fact, we ignore all notes.  For example,
 669     --          case _scc_ "foo" (C a b) of
 670     --                  C a b -> e
 671     -- should be optimised away, but it will be only if we look
 672     -- through the SCC note.
 673
 674 exprIsConApp_maybe expr = analyse (collectArgs expr)
 675   where
 676     analyse (Var fun, args)
 677         | Just con <- isDataConWorkId_maybe fun,
 678           args `lengthAtLeast` dataConRepArity con
 679                 -- Might be > because the arity excludes type args
 680         = Just (con,args)
 681
 682         -- Look through unfoldings, but only cheap ones, because
 683         -- we are effectively duplicating the unfolding
 684     analyse (Var fun, [])
 685         | let unf = idUnfolding fun,
 686           isCheapUnfolding unf
 687         = exprIsConApp_maybe (unfoldingTemplate unf)
 688
 689     analyse other = Nothing
 690 \end{code}
 691
 692
 693
 694 %************************************************************************
 695 %*                                                                      *
 696 \subsection{Eta reduction and expansion}
 697 %*                                                                      *
 698 %************************************************************************
 699
 700 \begin{code}
 701 exprEtaExpandArity :: CoreExpr -> Arity
 702 {- The Arity returned is the number of value args the
 703    thing can be applied to without doing much work
 704
 705 exprEtaExpandArity is used when eta expanding
 706         e  ==>  \xy -> e x y
 707
 708 It returns 1 (or more) to:
 709         case x of p -> \s -> ...
 710 because for I/O ish things we really want to get that \s to the top.
 711 We are prepared to evaluate x each time round the loop in order to get that
 712
 713 It's all a bit more subtle than it looks:
 714
 715 1.  One-shot lambdas
 716
 717 Consider one-shot lambdas
 718                 let x = expensive in \y z -> E
 719 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
 720 Hence the ArityType returned by arityType
 721
 722 2.  The state-transformer hack
 723
 724 The one-shot lambda special cause is particularly important/useful for
 725 IO state transformers, where we often get
 726         let x = E in \ s -> ...
 727
 728 and the \s is a real-world state token abstraction.  Such abstractions
 729 are almost invariably 1-shot, so we want to pull the \s out, past the
 730 let x=E, even if E is expensive.  So we treat state-token lambdas as
 731 one-shot even if they aren't really.  The hack is in Id.isOneShotBndr.
 732
 733 3.  Dealing with bottom
 734
 735 Consider also
 736         f = \x -> error "foo"
 737 Here, arity 1 is fine.  But if it is
 738         f = \x -> case x of
 739                         True  -> error "foo"
 740                         False -> \y -> x+y
 741 then we want to get arity 2.  Tecnically, this isn't quite right, because
 742         (f True) `seq` 1
 743 should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
 744 do so; it improves some programs significantly, and increasing convergence
 745 isn't a bad thing.  Hence the ABot/ATop in ArityType.
 746
 747 Actually, the situation is worse.  Consider
 748         f = \x -> case x of
 749                         True  -> \y -> x+y
 750                         False -> \y -> x-y
 751 Can we eta-expand here?  At first the answer looks like "yes of course", but
 752 consider
 753         (f bot) `seq` 1
 754 This should diverge!  But if we eta-expand, it won't.   Again, we ignore this
 755 "problem", because being scrupulous would lose an important transformation for
 756 many programs.
 757 -}
 758
 759
 760 exprEtaExpandArity e = arityDepth (arityType e)
 761
 762 -- A limited sort of function type
 763 data ArityType = AFun Bool ArityType    -- True <=> one-shot
 764                | ATop                   -- Know nothing
 765                | ABot                   -- Diverges
 766
 767 arityDepth :: ArityType -> Arity
 768 arityDepth (AFun _ ty) = 1 + arityDepth ty
 769 arityDepth ty          = 0
 770
 771 andArityType ABot           at2           = at2
 772 andArityType ATop           at2           = ATop
 773 andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
 774 andArityType at1            at2           = andArityType at2 at1
 775
 776 arityType :: CoreExpr -> ArityType
 777         -- (go1 e) = [b1,..,bn]
 778         -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
 779         -- where bi is True <=> the lambda is one-shot
 780
 781 arityType (Note n e) = arityType e
 782 --      Not needed any more: etaExpand is cleverer
 783 --  | ok_note n = arityType e
 784 --  | otherwise = ATop
 785
 786 arityType (Var v)
 787   = mk (idArity v) (arg_tys (idType v))
 788   where
 789     mk :: Arity -> [Type] -> ArityType
 790         -- The argument types are only to steer the "state hack"
 791         -- Consider case x of
 792         --              True  -> foo
 793         --              False -> \(s:RealWorld) -> e
 794         -- where foo has arity 1.  Then we want the state hack to
 795         -- apply to foo too, so we can eta expand the case.
 796     mk 0 tys | isBottomingId v  = ABot
 797              | otherwise        = ATop
 798     mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
 799     mk n []       = AFun False                (mk (n-1) [])
 800
 801     arg_tys :: Type -> [Type]   -- Ignore for-alls
 802     arg_tys ty
 803         | Just (_, ty')  <- splitForAllTy_maybe ty = arg_tys ty'
 804         | Just (arg,res) <- splitFunTy_maybe ty    = arg : arg_tys res
 805         | otherwise                                = []
 806
 807         -- Lambdas; increase arity
 808 arityType (Lam x e) | isId x    = AFun (isOneShotBndr x) (arityType e)
 809                     | otherwise = arityType e
 810
 811         -- Applications; decrease arity
 812 arityType (App f (Type _)) = arityType f
 813 arityType (App f a)        = case arityType f of
 814                                 AFun one_shot xs | exprIsCheap a -> xs
 815                                 other                            -> ATop
 816
 817         -- Case/Let; keep arity if either the expression is cheap
 818         -- or it's a 1-shot lambda
 819         -- The former is not really right for Haskell
 820         --      f x = case x of { (a,b) -> \y. e }
 821         --  ===>
 822         --      f x y = case x of { (a,b) -> e }
 823         -- The difference is observable using 'seq'
 824 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
 825                                   xs@(AFun one_shot _) | one_shot -> xs
 826                                   xs | exprIsCheap scrut          -> xs
 827                                      | otherwise                  -> ATop
 828
 829 arityType (Let b e) = case arityType e of
 830                         xs@(AFun one_shot _) | one_shot                       -> xs
 831                         xs                   | all exprIsCheap (rhssOfBind b) -> xs
 832                                              | otherwise                      -> ATop
 833
 834 arityType other = ATop
 835
 836 {- NOT NEEDED ANY MORE: etaExpand is cleverer
 837 ok_note InlineMe = False
 838 ok_note other    = True
 839     -- Notice that we do not look through __inline_me__
 840     -- This may seem surprising, but consider
 841     --          f = _inline_me (\x -> e)
 842     -- We DO NOT want to eta expand this to
 843     --          f = \x -> (_inline_me (\x -> e)) x
 844     -- because the _inline_me gets dropped now it is applied,
 845     -- giving just
 846     --          f = \x -> e
 847     -- A Bad Idea
 848 -}
 849 \end{code}
 850
 851
 852 \begin{code}
 853 etaExpand :: Arity              -- Result should have this number of value args
 854           -> [Unique]
 855           -> CoreExpr -> Type   -- Expression and its type
 856           -> CoreExpr
 857 -- (etaExpand n us e ty) returns an expression with
 858 -- the same meaning as 'e', but with arity 'n'.
 859 --
 860 -- Given e' = etaExpand n us e ty
 861 -- We should have
 862 --      ty = exprType e = exprType e'
 863 --
 864 -- Note that SCCs are not treated specially.  If we have
 865 --      etaExpand 2 (\x -> scc "foo" e)
 866 --      = (\xy -> (scc "foo" e) y)
 867 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 868
 869 etaExpand n us expr ty
 870   | manifestArity expr >= n = expr              -- The no-op case
 871   | otherwise               = eta_expand n us expr ty
 872   where
 873
 874 -- manifestArity sees how many leading value lambdas there are
 875 manifestArity :: CoreExpr -> Arity
 876 manifestArity (Lam v e) | isId v    = 1 + manifestArity e
 877                         | otherwise = manifestArity e
 878 manifestArity (Note _ e)            = manifestArity e
 879 manifestArity e                     = 0
 880
 881 -- etaExpand deals with for-alls. For example:
 882 --              etaExpand 1 E
 883 -- where  E :: forall a. a -> a
 884 -- would return
 885 --      (/\b. \y::a -> E b y)
 886 --
 887 -- It deals with coerces too, though they are now rare
 888 -- so perhaps the extra code isn't worth it
 889
 890 eta_expand n us expr ty
 891   | n == 0 &&
 892     -- The ILX code generator requires eta expansion for type arguments
 893     -- too, but alas the 'n' doesn't tell us how many of them there
 894     -- may be.  So we eagerly eta expand any big lambdas, and just
 895     -- cross our fingers about possible loss of sharing in the ILX case.
 896     -- The Right Thing is probably to make 'arity' include
 897     -- type variables throughout the compiler.  (ToDo.)
 898     not (isForAllTy ty)
 899     -- Saturated, so nothing to do
 900   = expr
 901
 902         -- Short cut for the case where there already
 903         -- is a lambda; no point in gratuitously adding more
 904 eta_expand n us (Lam v body) ty
 905   | isTyVar v
 906   = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
 907
 908   | otherwise
 909   = Lam v (eta_expand (n-1) us body (funResultTy ty))
 910
 911 -- We used to have a special case that stepped inside Coerces here,
 912 -- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _
 913 --              = Note note (eta_expand n us e ty)
 914 -- BUT this led to an infinite loop
 915 -- Example:     newtype T = MkT (Int -> Int)
 916 --      eta_expand 1 (coerce (Int->Int) e)
 917 --      --> coerce (Int->Int) (eta_expand 1 T e)
 918 --              by the bogus eqn
 919 --      --> coerce (Int->Int) (coerce T
 920 --              (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
 921 --              by the splitNewType_maybe case below
 922 --      and round we go
 923
 924 eta_expand n us expr ty
 925   = case splitForAllTy_maybe ty of {
 926           Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
 927
 928         ; Nothing ->
 929
 930         case splitFunTy_maybe ty of {
 931           Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
 932                                 where
 933                                    arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
 934                                    (uniq:us2) = us
 935
 936         ; Nothing ->
 937
 938                 -- Given this:
 939                 --      newtype T = MkT ([T] -> Int)
 940                 -- Consider eta-expanding this
 941                 --      eta_expand 1 e T
 942                 -- We want to get
 943                 --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 944                 -- Only try this for recursive newtypes; the non-recursive kind
 945                 -- are transparent anyway
 946
 947         case splitRecNewType_maybe ty of {
 948           Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
 949           Nothing  -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
 950         }}}
 951 \end{code}
 952
 953 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 954 It tells how many things the expression can be applied to before doing
 955 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 956 exprEtaExpandArity will do the hard work, leaving something that's easy
 957 for exprArity to grapple with.  In particular, Simplify uses exprArity to
 958 compute the ArityInfo for the Id.
 959
 960 Originally I thought that it was enough just to look for top-level lambdas, but
 961 it isn't.  I've seen this
 962
 963         foo = PrelBase.timesInt
 964
 965 We want foo to get arity 2 even though the eta-expander will leave it
 966 unchanged, in the expectation that it'll be inlined.  But occasionally it
 967 isn't, because foo is blacklisted (used in a rule).
 968
 969 Similarly, see the ok_note check in exprEtaExpandArity.  So
 970         f = __inline_me (\x -> e)
 971 won't be eta-expanded.
 972
 973 And in any case it seems more robust to have exprArity be a bit more intelligent.
 974 But note that   (\x y z -> f x y z)
 975 should have arity 3, regardless of f's arity.
 976
 977 \begin{code}
 978 exprArity :: CoreExpr -> Arity
 979 exprArity e = go e
 980             where
 981               go (Var v)                   = idArity v
 982               go (Lam x e) | isId x        = go e + 1
 983                            | otherwise     = go e
 984               go (Note n e)                = go e
 985               go (App e (Type t))          = go e
 986               go (App f a) | exprIsCheap a = (go f - 1) `max` 0
 987                 -- NB: exprIsCheap a!
 988                 --      f (fac x) does not have arity 2,
 989                 --      even if f has arity 3!
 990                 -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
 991                 --               unknown, hence arity 0
 992               go _                         = 0
 993 \end{code}
 994
 995 %************************************************************************
 996 %*                                                                      *
 997 \subsection{Equality}
 998 %*                                                                      *
 999 %************************************************************************
1000
1001 @cheapEqExpr@ is a cheap equality test which bales out fast!
1002         True  => definitely equal
1003         False => may or may not be equal
1004
1005 \begin{code}
1006 cheapEqExpr :: Expr b -> Expr b -> Bool
1007
1008 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
1009 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1010 cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
1011
1012 cheapEqExpr (App f1 a1) (App f2 a2)
1013   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1014
1015 cheapEqExpr _ _ = False
1016
1017 exprIsBig :: Expr b -> Bool
1018 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1019 exprIsBig (Lit _)      = False
1020 exprIsBig (Var v)      = False
1021 exprIsBig (Type t)     = False
1022 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1023 exprIsBig other        = True
1024 \end{code}
1025
1026
1027 \begin{code}
1028 tcEqExpr :: CoreExpr -> CoreExpr -> Bool
1029 -- Used in rule matching, so does *not* look through
1030 -- newtypes, predicate types; hence tcEqExpr
1031
1032 tcEqExpr e1 e2 = tcEqExprX rn_env e1 e2
1033   where
1034     rn_env = mkRnEnv2 (mkInScopeSet (exprFreeVars e1 `unionVarSet` exprFreeVars e2))
1035
1036 tcEqExprX :: RnEnv2 -> CoreExpr -> CoreExpr -> Bool
1037 tcEqExprX env (Var v1)     (Var v2)     = rnOccL env v1 == rnOccR env v2
1038 tcEqExprX env (Lit lit1)   (Lit lit2)   = lit1 == lit2
1039 tcEqExprX env (App f1 a1)  (App f2 a2)  = tcEqExprX env f1 f2 && tcEqExprX env a1 a2
1040 tcEqExprX env (Lam v1 e1)  (Lam v2 e2)  = tcEqExprX (rnBndr2 env v1 v2) e1 e2
1041 tcEqExprX env (Let (NonRec v1 r1) e1)
1042               (Let (NonRec v2 r2) e2)   = tcEqExprX env r1 r2
1043                                        && tcEqExprX (rnBndr2 env v1 v2) e1 e2
1044 tcEqExprX env (Let (Rec ps1) e1)
1045               (Let (Rec ps2) e2)        =  equalLength ps1 ps2
1046                                         && and (zipWith eq_rhs ps1 ps2)
1047                                         && tcEqExprX env' e1 e2
1048                                      where
1049                                        env' = foldl2 rn_bndr2 env ps2 ps2
1050                                        rn_bndr2 env (b1,_) (b2,_) = rnBndr2 env b1 b2
1051                                        eq_rhs       (_,r1) (_,r2) = tcEqExprX env' r1 r2
1052 tcEqExprX env (Case e1 v1 t1 a1)
1053               (Case e2 v2 t2 a2)     =  tcEqExprX env e1 e2
1054                                      && tcEqTypeX env t1 t2
1055                                      && equalLength a1 a2
1056                                      && and (zipWith (eq_alt env') a1 a2)
1057                                      where
1058                                        env' = rnBndr2 env v1 v2
1059
1060 tcEqExprX env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && tcEqExprX env e1 e2
1061 tcEqExprX env (Type t1)    (Type t2)    = tcEqTypeX env t1 t2
1062 tcEqExprX env e1                e2      = False
1063
1064 eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 && tcEqExprX (rnBndrs2 env vs1  vs2) r1 r2
1065
1066 eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
1067 eq_note env (Coerce t1 f1) (Coerce t2 f2) = tcEqTypeX env t1 t2 && tcEqTypeX env f1 f2
1068 eq_note env InlineCall     InlineCall     = True
1069 eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
1070 eq_note env other1             other2     = False
1071 \end{code}
1072
1073
1074 %************************************************************************
1075 %*                                                                      *
1076 \subsection{The size of an expression}
1077 %*                                                                      *
1078 %************************************************************************
1079
1080 \begin{code}
1081 coreBindsSize :: [CoreBind] -> Int
1082 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1083
1084 exprSize :: CoreExpr -> Int
1085         -- A measure of the size of the expressions
1086         -- It also forces the expression pretty drastically as a side effect
1087 exprSize (Var v)         = v `seq` 1
1088 exprSize (Lit lit)       = lit `seq` 1
1089 exprSize (App f a)       = exprSize f + exprSize a
1090 exprSize (Lam b e)       = varSize b + exprSize e
1091 exprSize (Let b e)       = bindSize b + exprSize e
1092 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1093 exprSize (Note n e)      = noteSize n + exprSize e
1094 exprSize (Type t)        = seqType t `seq` 1
1095
1096 noteSize (SCC cc)       = cc `seq` 1
1097 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1098 noteSize InlineCall     = 1
1099 noteSize InlineMe       = 1
1100 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1101
1102 varSize :: Var -> Int
1103 varSize b  | isTyVar b = 1
1104            | otherwise = seqType (idType b)             `seq`
1105                          megaSeqIdInfo (idInfo b)       `seq`
1106                          1
1107
1108 varsSize = foldr ((+) . varSize) 0
1109
1110 bindSize (NonRec b e) = varSize b + exprSize e
1111 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1112
1113 pairSize (b,e) = varSize b + exprSize e
1114
1115 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1116 \end{code}
1117
1118
1119 %************************************************************************
1120 %*                                                                      *
1121 \subsection{Hashing}
1122 %*                                                                      *
1123 %************************************************************************
1124
1125 \begin{code}
1126 hashExpr :: CoreExpr -> Int
1127 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
1128            | otherwise = hash
1129            where
1130              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
1131
1132 hash_expr (Note _ e)              = hash_expr e
1133 hash_expr (Let (NonRec b r) e)    = hashId b
1134 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1135 hash_expr (Case _ b _ _)          = hashId b
1136 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
1137 hash_expr (Var v)                 = hashId v
1138 hash_expr (Lit lit)               = hashLiteral lit
1139 hash_expr (Lam b _)               = hashId b
1140 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
1141
1142 fast_hash_expr (Var v)          = hashId v
1143 fast_hash_expr (Lit lit)        = hashLiteral lit
1144 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1145 fast_hash_expr (App f a)        = fast_hash_expr a
1146 fast_hash_expr (Lam b _)        = hashId b
1147 fast_hash_expr other            = 1
1148
1149 hashId :: Id -> Int
1150 hashId id = hashName (idName id)
1151 \end{code}
1152
1153 %************************************************************************
1154 %*                                                                      *
1155 \subsection{Determining non-updatable right-hand-sides}
1156 %*                                                                      *
1157 %************************************************************************
1158
1159 Top-level constructor applications can usually be allocated
1160 statically, but they can't if the constructor, or any of the
1161 arguments, come from another DLL (because we can't refer to static
1162 labels in other DLLs).
1163
1164 If this happens we simply make the RHS into an updatable thunk,
1165 and 'exectute' it rather than allocating it statically.
1166
1167 \begin{code}
1168 rhsIsStatic :: HomeModules -> CoreExpr -> Bool
1169 -- This function is called only on *top-level* right-hand sides
1170 -- Returns True if the RHS can be allocated statically, with
1171 -- no thunks involved at all.
1172 --
1173 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1174 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1175 -- update flag on it.
1176 --
1177 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1178 --      (a) a value lambda
1179 --      (b) a saturated constructor application with static args
1180 --
1181 -- BUT watch out for
1182 --  (i) Any cross-DLL references kill static-ness completely
1183 --      because they must be 'executed' not statically allocated
1184 --      ("DLL" here really only refers to Windows DLLs, on other platforms,
1185 --      this is not necessary)
1186 --
1187 -- (ii) We treat partial applications as redexes, because in fact we
1188 --      make a thunk for them that runs and builds a PAP
1189 --      at run-time.  The only appliations that are treated as
1190 --      static are *saturated* applications of constructors.
1191
1192 -- We used to try to be clever with nested structures like this:
1193 --              ys = (:) w ((:) w [])
1194 -- on the grounds that CorePrep will flatten ANF-ise it later.
1195 -- But supporting this special case made the function much more
1196 -- complicated, because the special case only applies if there are no
1197 -- enclosing type lambdas:
1198 --              ys = /\ a -> Foo (Baz ([] a))
1199 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1200 --
1201 -- But in fact, even without -O, nested structures at top level are
1202 -- flattened by the simplifier, so we don't need to be super-clever here.
1203 --
1204 -- Examples
1205 --
1206 --      f = \x::Int. x+7        TRUE
1207 --      p = (True,False)        TRUE
1208 --
1209 --      d = (fst p, False)      FALSE because there's a redex inside
1210 --                              (this particular one doesn't happen but...)
1211 --
1212 --      h = D# (1.0## /## 2.0##)        FALSE (redex again)
1213 --      n = /\a. Nil a                  TRUE
1214 --
1215 --      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
1216 --
1217 --
1218 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1219 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1220 --
1221 --    b) (C x xs), where C is a contructors is updatable if the application is
1222 --         dynamic
1223 --
1224 --    c) don't look through unfolding of f in (f x).
1225 --
1226 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1227 -- them as making the RHS re-entrant (non-updatable).
1228
1229 rhsIsStatic hmods rhs = is_static False rhs
1230   where
1231   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
1232           -> CoreExpr -> Bool
1233
1234   is_static False (Lam b e) = isRuntimeVar b || is_static False e
1235
1236   is_static in_arg (Note (SCC _) e) = False
1237   is_static in_arg (Note _ e)       = is_static in_arg e
1238
1239   is_static in_arg (Lit lit)
1240     = case lit of
1241         MachLabel _ _ -> False
1242         other         -> True
1243         -- A MachLabel (foreign import "&foo") in an argument
1244         -- prevents a constructor application from being static.  The
1245         -- reason is that it might give rise to unresolvable symbols
1246         -- in the object file: under Linux, references to "weak"
1247         -- symbols from the data segment give rise to "unresolvable
1248         -- relocation" errors at link time This might be due to a bug
1249         -- in the linker, but we'll work around it here anyway.
1250         -- SDM 24/2/2004
1251
1252   is_static in_arg other_expr = go other_expr 0
1253    where
1254     go (Var f) n_val_args
1255 #if mingw32_TARGET_OS
1256         | not (isDllName hmods (idName f))
1257 #endif
1258         =  saturated_data_con f n_val_args
1259         || (in_arg && n_val_args == 0)
1260                 -- A naked un-applied variable is *not* deemed a static RHS
1261                 -- E.g.         f = g
1262                 -- Reason: better to update so that the indirection gets shorted
1263                 --         out, and the true value will be seen
1264                 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1265                 --     are always updatable.  If you do so, make sure that non-updatable
1266                 --     ones have enough space for their static link field!
1267
1268     go (App f a) n_val_args
1269         | isTypeArg a                    = go f n_val_args
1270         | not in_arg && is_static True a = go f (n_val_args + 1)
1271         -- The (not in_arg) checks that we aren't in a constructor argument;
1272         -- if we are, we don't allow (value) applications of any sort
1273         --
1274         -- NB. In case you wonder, args are sometimes not atomic.  eg.
1275         --   x = D# (1.0## /## 2.0##)
1276         -- can't float because /## can fail.
1277
1278     go (Note (SCC _) f) n_val_args = False
1279     go (Note _ f) n_val_args       = go f n_val_args
1280
1281     go other n_val_args = False
1282
1283     saturated_data_con f n_val_args
1284         = case isDataConWorkId_maybe f of
1285             Just dc -> n_val_args == dataConRepArity dc
1286             Nothing -> False
1287 \end{code}