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         mkNote, mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
  10         bindNonRec, needsCaseBinding,
  11         mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
  12
  13         -- Taking expressions apart
  14         findDefault, findAlt, hasDefault,
  15
  16         -- Properties of expressions
  17         exprType, coreAltsType,
  18         exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
  19         exprIsValue,exprOkForSpeculation, exprIsBig,
  20         exprIsConApp_maybe, exprIsAtom,
  21         idAppIsBottom, idAppIsCheap, rhsIsNonUpd,
  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, eqExpr, applyTypeToArgs, applyTypeToArg,
  35
  36         -- Cross-DLL references
  37         isCrossDllConApp,
  38     ) where
  39
  40 #include "HsVersions.h"
  41
  42
  43 import GLAEXTS          -- For `xori`
  44
  45 import CoreSyn
  46 import PprCore          ( pprCoreExpr )
  47 import Var              ( Var, isId, isTyVar )
  48 import VarEnv
  49 import Name             ( hashName, isDllName )
  50 import Literal          ( hashLiteral, literalType, litIsDupable,
  51                           litIsTrivial, isZeroLit, isLitLitLit )
  52 import DataCon          ( DataCon, dataConRepArity, dataConArgTys,
  53                           isExistentialDataCon, dataConTyCon, dataConName )
  54 import PrimOp           ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
  55 import Id               ( Id, idType, globalIdDetails, idNewStrictness,
  56                           mkWildId, idArity, idName, idUnfolding, idInfo,
  57                           isOneShotLambda, 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,
  64                           applyTys, isUnLiftedType, seqType, mkTyVarTy,
  65                           splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
  66                           splitTyConApp_maybe, eqType, funResultTy, applyTy,
  67                           funResultTy, applyTy
  68                         )
  69 import TyCon            ( tyConArity )
  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 )
  77 import TysPrim          ( statePrimTyCon )
  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 _ _ alts)        = coreAltsType alts
  94 exprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
  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 coreAltsType :: [CoreAlt] -> Type
 104 coreAltsType ((_,_,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)
 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 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
 166 -- Slide InlineCall in around the function
 167 --      No longer necessary I think (SLPJ Apr 99)
 168 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 169 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 170 -- mkNote InlineCall expr      = expr
 171 \end{code}
 172
 173 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 174 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 175 not be *applied* to anything.
 176
 177 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
 178 bindings like
 179         fw = ...
 180         f  = inline_me (coerce t fw)
 181 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
 182 We want the split, so that the coerces can cancel at the call site.
 183
 184 However, we can get left with tiresome type applications.  Notably, consider
 185         f = /\ a -> let t = e in (t, w)
 186 Then lifting the let out of the big lambda gives
 187         t' = /\a -> e
 188         f = /\ a -> let t = inline_me (t' a) in (t, w)
 189 The inline_me is to stop the simplifier inlining t' right back
 190 into t's RHS.  In the next phase we'll substitute for t (since
 191 its rhs is trivial) and *then* we could get rid of the inline_me.
 192 But it hardly seems worth it, so I don't bother.
 193
 194 \begin{code}
 195 mkInlineMe (Var v) = Var v
 196 mkInlineMe e       = Note InlineMe e
 197 \end{code}
 198
 199
 200
 201 \begin{code}
 202 mkCoerce :: Type -> CoreExpr -> CoreExpr
 203 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
 204
 205 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
 206 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 207   = ASSERT( from_ty `eqType` to_ty2 )
 208     mkCoerce2 to_ty from_ty2 expr
 209
 210 mkCoerce2 to_ty from_ty expr
 211   | to_ty `eqType` from_ty = expr
 212   | otherwise              = ASSERT( from_ty `eqType` exprType expr )
 213                              Note (Coerce to_ty from_ty) expr
 214 \end{code}
 215
 216 \begin{code}
 217 mkSCC :: CostCentre -> Expr b -> Expr b
 218         -- Note: Nested SCC's *are* preserved for the benefit of
 219         --       cost centre stack profiling
 220 mkSCC cc (Lit lit)          = Lit lit
 221 mkSCC cc (Lam x e)          = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
 222 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
 223 mkSCC cc (Note n e)         = Note n (mkSCC cc e) -- Move _scc_ inside notes
 224 mkSCC cc expr               = Note (SCC cc) expr
 225 \end{code}
 226
 227
 228 %************************************************************************
 229 %*                                                                      *
 230 \subsection{Other expression construction}
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 \begin{code}
 235 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 236 -- (bindNonRec x r b) produces either
 237 --      let x = r in b
 238 -- or
 239 --      case r of x { _DEFAULT_ -> b }
 240 --
 241 -- depending on whether x is unlifted or not
 242 -- It's used by the desugarer to avoid building bindings
 243 -- that give Core Lint a heart attack.  Actually the simplifier
 244 -- deals with them perfectly well.
 245 bindNonRec bndr rhs body
 246   | needsCaseBinding (idType bndr) rhs = Case rhs bndr [(DEFAULT,[],body)]
 247   | otherwise                          = Let (NonRec bndr rhs) body
 248
 249 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 250         -- Make a case expression instead of a let
 251         -- These can arise either from the desugarer,
 252         -- or from beta reductions: (\x.e) (x +# y)
 253 \end{code}
 254
 255 \begin{code}
 256 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 257         -- This guy constructs the value that the scrutinee must have
 258         -- when you are in one particular branch of a case
 259 mkAltExpr (DataAlt con) args inst_tys
 260   = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
 261 mkAltExpr (LitAlt lit) [] []
 262   = Lit lit
 263
 264 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 265 mkIfThenElse guard then_expr else_expr
 266   = Case guard (mkWildId boolTy)
 267          [ (DataAlt trueDataCon,  [], then_expr),
 268            (DataAlt falseDataCon, [], else_expr) ]
 269 \end{code}
 270
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsection{Taking expressions apart}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 The default alternative must be first, if it exists at all.
 279 This makes it easy to find, though it makes matching marginally harder.
 280
 281 \begin{code}
 282 hasDefault :: [CoreAlt] -> Bool
 283 hasDefault ((DEFAULT,_,_) : alts) = True
 284 hasDefault _                      = False
 285
 286 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 287 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 288 findDefault alts                        =                     (alts, Nothing)
 289
 290 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 291 findAlt con alts
 292   = case alts of
 293         (deflt@(DEFAULT,_,_):alts) -> go alts deflt
 294         other                      -> go alts panic_deflt
 295
 296   where
 297     panic_deflt = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 298
 299     go []                      deflt               = deflt
 300     go (alt@(con1,_,_) : alts) deflt | con == con1 = alt
 301                                      | otherwise   = ASSERT( not (con1 == DEFAULT) )
 302                                                      go alts deflt
 303 \end{code}
 304
 305
 306 %************************************************************************
 307 %*                                                                      *
 308 \subsection{Figuring out things about expressions}
 309 %*                                                                      *
 310 %************************************************************************
 311
 312 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 313                 duplicate; simple variables and constants, and type
 314                 applications.  Note that primop Ids aren't considered
 315                 trivial unless
 316
 317 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 318
 319
 320 There used to be a gruesome test for (hasNoBinding v) in the
 321 Var case:
 322         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 323 The idea here is that a constructor worker, like $wJust, is
 324 really short for (\x -> $wJust x), becuase $wJust has no binding.
 325 So it should be treated like a lambda.  Ditto unsaturated primops.
 326 But now constructor workers are not "have-no-binding" Ids.  And
 327 completely un-applied primops and foreign-call Ids are sufficiently
 328 rare that I plan to allow them to be duplicated and put up with
 329 saturating them.
 330
 331 \begin{code}
 332 exprIsTrivial (Var v)      = True       -- See notes above
 333 exprIsTrivial (Type _)     = True
 334 exprIsTrivial (Lit lit)    = litIsTrivial lit
 335 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 336 exprIsTrivial (Note _ e)   = exprIsTrivial e
 337 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 338 exprIsTrivial other        = False
 339
 340 exprIsAtom :: CoreExpr -> Bool
 341 -- Used to decide whether to let-binding an STG argument
 342 -- when compiling to ILX => type applications are not allowed
 343 exprIsAtom (Var v)    = True    -- primOpIsDupable?
 344 exprIsAtom (Lit lit)  = True
 345 exprIsAtom (Type ty)  = True
 346 exprIsAtom (Note (SCC _) e) = False
 347 exprIsAtom (Note _ e) = exprIsAtom e
 348 exprIsAtom 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 = case globalIdDetails id of
 454                   DataConWorkId _ -> True
 455                   RecordSelId _   -> True       -- I'm experimenting with making record selection
 456                   ClassOpId _     -> True       -- look cheap, so we will substitute it inside a
 457                                                 -- lambda.  Particularly for dictionary field selection
 458
 459                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 460                                                         -- that return a type variable, since the result
 461                                                         -- might be applied to something, but I'm not going
 462                                                         -- to bother to check the number of args
 463                   other       -> n_val_args < idArity id
 464 \end{code}
 465
 466 exprOkForSpeculation returns True of an expression that it is
 467
 468         * safe to evaluate even if normal order eval might not
 469           evaluate the expression at all, or
 470
 471         * safe *not* to evaluate even if normal order would do so
 472
 473 It returns True iff
 474
 475         the expression guarantees to terminate,
 476         soon,
 477         without raising an exception,
 478         without causing a side effect (e.g. writing a mutable variable)
 479
 480 E.G.
 481         let x = case y# +# 1# of { r# -> I# r# }
 482         in E
 483 ==>
 484         case y# +# 1# of { r# ->
 485         let x = I# r#
 486         in E
 487         }
 488
 489 We can only do this if the (y+1) is ok for speculation: it has no
 490 side effects, and can't diverge or raise an exception.
 491
 492 \begin{code}
 493 exprOkForSpeculation :: CoreExpr -> Bool
 494 exprOkForSpeculation (Lit _)    = True
 495 exprOkForSpeculation (Type _)   = True
 496 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 497 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 498 exprOkForSpeculation other_expr
 499   = case collectArgs other_expr of
 500         (Var f, args) -> spec_ok (globalIdDetails f) args
 501         other         -> False
 502
 503   where
 504     spec_ok (DataConWorkId _) args
 505       = True    -- The strictness of the constructor has already
 506                 -- been expressed by its "wrapper", so we don't need
 507                 -- to take the arguments into account
 508
 509     spec_ok (PrimOpId op) args
 510       | isDivOp op,             -- Special case for dividing operations that fail
 511         [arg1, Lit lit] <- args -- only if the divisor is zero
 512       = not (isZeroLit lit) && exprOkForSpeculation arg1
 513                 -- Often there is a literal divisor, and this
 514                 -- can get rid of a thunk in an inner looop
 515
 516       | otherwise
 517       = primOpOkForSpeculation op &&
 518         all exprOkForSpeculation args
 519                                 -- A bit conservative: we don't really need
 520                                 -- to care about lazy arguments, but this is easy
 521
 522     spec_ok other args = False
 523
 524 isDivOp :: PrimOp -> Bool
 525 -- True of dyadic operators that can fail
 526 -- only if the second arg is zero
 527 -- This function probably belongs in PrimOp, or even in
 528 -- an automagically generated file.. but it's such a
 529 -- special case I thought I'd leave it here for now.
 530 isDivOp IntQuotOp        = True
 531 isDivOp IntRemOp         = True
 532 isDivOp WordQuotOp       = True
 533 isDivOp WordRemOp        = True
 534 isDivOp IntegerQuotRemOp = True
 535 isDivOp IntegerDivModOp  = True
 536 isDivOp FloatDivOp       = True
 537 isDivOp DoubleDivOp      = True
 538 isDivOp other            = False
 539 \end{code}
 540
 541
 542 \begin{code}
 543 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 544 exprIsBottom e = go 0 e
 545                where
 546                 -- n is the number of args
 547                  go n (Note _ e)   = go n e
 548                  go n (Let _ e)    = go n e
 549                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 550                  go n (App e _)    = go (n+1) e
 551                  go n (Var v)      = idAppIsBottom v n
 552                  go n (Lit _)      = False
 553                  go n (Lam _ _)    = False
 554
 555 idAppIsBottom :: Id -> Int -> Bool
 556 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 557 \end{code}
 558
 559 @exprIsValue@ returns true for expressions that are certainly *already*
 560 evaluated to *head* normal form.  This is used to decide whether it's ok
 561 to change
 562
 563         case x of _ -> e   ===>   e
 564
 565 and to decide whether it's safe to discard a `seq`
 566
 567 So, it does *not* treat variables as evaluated, unless they say they are.
 568
 569 But it *does* treat partial applications and constructor applications
 570 as values, even if their arguments are non-trivial, provided the argument
 571 type is lifted;
 572         e.g.  (:) (f x) (map f xs)      is a value
 573               map (...redex...)         is a value
 574 Because `seq` on such things completes immediately
 575
 576 For unlifted argument types, we have to be careful:
 577                 C (f x :: Int#)
 578 Suppose (f x) diverges; then C (f x) is not a value.  True, but
 579 this form is illegal (see the invariants in CoreSyn).  Args of unboxed
 580 type must be ok-for-speculation (or trivial).
 581
 582 \begin{code}
 583 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 584 exprIsValue (Var v)     -- NB: There are no value args at this point
 585   =  isDataConWorkId v  -- Catches nullary constructors,
 586                         --      so that [] and () are values, for example
 587   || idArity v > 0      -- Catches (e.g.) primops that don't have unfoldings
 588   || isEvaldUnfolding (idUnfolding v)
 589         -- Check the thing's unfolding; it might be bound to a value
 590         -- A worry: what if an Id's unfolding is just itself:
 591         -- then we could get an infinite loop...
 592
 593 exprIsValue (Lit l)          = True
 594 exprIsValue (Type ty)        = True     -- Types are honorary Values;
 595                                         -- we don't mind copying them
 596 exprIsValue (Lam b e)        = isRuntimeVar b || exprIsValue e
 597 exprIsValue (Note _ e)       = exprIsValue e
 598 exprIsValue (App e (Type _)) = exprIsValue e
 599 exprIsValue (App e a)        = app_is_value e [a]
 600 exprIsValue other            = False
 601
 602 -- There is at least one value argument
 603 app_is_value (Var fun) args
 604   |  isDataConWorkId fun                        -- Constructor apps are values
 605   || idArity fun > valArgCount args     -- Under-applied function
 606   = check_args (idType fun) args
 607 app_is_value (App f a) as = app_is_value f (a:as)
 608 app_is_value other     as = False
 609
 610         -- 'check_args' checks that unlifted-type args
 611         -- are in fact guaranteed non-divergent
 612 check_args fun_ty []              = True
 613 check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of
 614                                       Just (_, ty) -> check_args ty args
 615 check_args fun_ty (arg : args)
 616   | isUnLiftedType arg_ty = exprOkForSpeculation arg
 617   | otherwise             = check_args res_ty args
 618   where
 619     (arg_ty, res_ty) = splitFunTy fun_ty
 620 \end{code}
 621
 622 \begin{code}
 623 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 624 exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
 625   =     -- Maybe this is over the top, but here we try to turn
 626         --      coerce (S,T) ( x, y )
 627         -- effectively into
 628         --      ( coerce S x, coerce T y )
 629         -- This happens in anger in PrelArrExts which has a coerce
 630         --      case coerce memcpy a b of
 631         --        (# r, s #) -> ...
 632         -- where the memcpy is in the IO monad, but the call is in
 633         -- the (ST s) monad
 634     case exprIsConApp_maybe expr of {
 635         Nothing           -> Nothing ;
 636         Just (dc, args)   ->
 637
 638     case splitTyConApp_maybe to_ty of {
 639         Nothing -> Nothing ;
 640         Just (tc, tc_arg_tys) | tc /= dataConTyCon dc   -> Nothing
 641                               | isExistentialDataCon dc -> Nothing
 642                               | otherwise               ->
 643                 -- Type constructor must match
 644                 -- We knock out existentials to keep matters simple(r)
 645     let
 646         arity            = tyConArity tc
 647         val_args         = drop arity args
 648         to_arg_tys       = dataConArgTys dc tc_arg_tys
 649         mk_coerce ty arg = mkCoerce ty arg
 650         new_val_args     = zipWith mk_coerce to_arg_tys val_args
 651     in
 652     ASSERT( all isTypeArg (take arity args) )
 653     ASSERT( equalLength val_args to_arg_tys )
 654     Just (dc, map Type tc_arg_tys ++ new_val_args)
 655     }}
 656
 657 exprIsConApp_maybe (Note _ expr)
 658   = exprIsConApp_maybe expr
 659     -- We ignore InlineMe notes in case we have
 660     --  x = __inline_me__ (a,b)
 661     -- All part of making sure that INLINE pragmas never hurt
 662     -- Marcin tripped on this one when making dictionaries more inlinable
 663     --
 664     -- In fact, we ignore all notes.  For example,
 665     --          case _scc_ "foo" (C a b) of
 666     --                  C a b -> e
 667     -- should be optimised away, but it will be only if we look
 668     -- through the SCC note.
 669
 670 exprIsConApp_maybe expr = analyse (collectArgs expr)
 671   where
 672     analyse (Var fun, args)
 673         | Just con <- isDataConWorkId_maybe fun,
 674           args `lengthAtLeast` dataConRepArity con
 675                 -- Might be > because the arity excludes type args
 676         = Just (con,args)
 677
 678         -- Look through unfoldings, but only cheap ones, because
 679         -- we are effectively duplicating the unfolding
 680     analyse (Var fun, [])
 681         | let unf = idUnfolding fun,
 682           isCheapUnfolding unf
 683         = exprIsConApp_maybe (unfoldingTemplate unf)
 684
 685     analyse other = Nothing
 686 \end{code}
 687
 688
 689
 690 %************************************************************************
 691 %*                                                                      *
 692 \subsection{Eta reduction and expansion}
 693 %*                                                                      *
 694 %************************************************************************
 695
 696 \begin{code}
 697 exprEtaExpandArity :: CoreExpr -> Arity
 698 {- The Arity returned is the number of value args the
 699    thing can be applied to without doing much work
 700
 701 exprEtaExpandArity is used when eta expanding
 702         e  ==>  \xy -> e x y
 703
 704 It returns 1 (or more) to:
 705         case x of p -> \s -> ...
 706 because for I/O ish things we really want to get that \s to the top.
 707 We are prepared to evaluate x each time round the loop in order to get that
 708
 709 It's all a bit more subtle than it looks:
 710
 711 1.  One-shot lambdas
 712
 713 Consider one-shot lambdas
 714                 let x = expensive in \y z -> E
 715 We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
 716 Hence the ArityType returned by arityType
 717
 718 2.  The state-transformer hack
 719
 720 The one-shot lambda special cause is particularly important/useful for
 721 IO state transformers, where we often get
 722         let x = E in \ s -> ...
 723
 724 and the \s is a real-world state token abstraction.  Such abstractions
 725 are almost invariably 1-shot, so we want to pull the \s out, past the
 726 let x=E, even if E is expensive.  So we treat state-token lambdas as
 727 one-shot even if they aren't really.  The hack is in Id.isOneShotLambda.
 728
 729 3.  Dealing with bottom
 730
 731 Consider also
 732         f = \x -> error "foo"
 733 Here, arity 1 is fine.  But if it is
 734         f = \x -> case x of
 735                         True  -> error "foo"
 736                         False -> \y -> x+y
 737 then we want to get arity 2.  Tecnically, this isn't quite right, because
 738         (f True) `seq` 1
 739 should diverge, but it'll converge if we eta-expand f.  Nevertheless, we
 740 do so; it improves some programs significantly, and increasing convergence
 741 isn't a bad thing.  Hence the ABot/ATop in ArityType.
 742
 743 Actually, the situation is worse.  Consider
 744         f = \x -> case x of
 745                         True  -> \y -> x+y
 746                         False -> \y -> x-y
 747 Can we eta-expand here?  At first the answer looks like "yes of course", but
 748 consider
 749         (f bot) `seq` 1
 750 This should diverge!  But if we eta-expand, it won't.   Again, we ignore this
 751 "problem", because being scrupulous would lose an important transformation for
 752 many programs.
 753 -}
 754
 755
 756 exprEtaExpandArity e = arityDepth (arityType e)
 757
 758 -- A limited sort of function type
 759 data ArityType = AFun Bool ArityType    -- True <=> one-shot
 760                | ATop                   -- Know nothing
 761                | ABot                   -- Diverges
 762
 763 arityDepth :: ArityType -> Arity
 764 arityDepth (AFun _ ty) = 1 + arityDepth ty
 765 arityDepth ty          = 0
 766
 767 andArityType ABot           at2           = at2
 768 andArityType ATop           at2           = ATop
 769 andArityType (AFun t1 at1)  (AFun t2 at2) = AFun (t1 && t2) (andArityType at1 at2)
 770 andArityType at1            at2           = andArityType at2 at1
 771
 772 arityType :: CoreExpr -> ArityType
 773         -- (go1 e) = [b1,..,bn]
 774         -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
 775         -- where bi is True <=> the lambda is one-shot
 776
 777 arityType (Note n e) = arityType e
 778 --      Not needed any more: etaExpand is cleverer
 779 --  | ok_note n = arityType e
 780 --  | otherwise = ATop
 781
 782 arityType (Var v)
 783   = mk (idArity v)
 784   where
 785     mk :: Arity -> ArityType
 786     mk 0 | isBottomingId v  = ABot
 787          | otherwise        = ATop
 788     mk n                    = AFun False (mk (n-1))
 789
 790                         -- When the type of the Id encodes one-shot-ness,
 791                         -- use the idinfo here
 792
 793         -- Lambdas; increase arity
 794 arityType (Lam x e) | isId x    = AFun (isOneShotLambda x || isStateHack x) (arityType e)
 795                     | otherwise = arityType e
 796
 797         -- Applications; decrease arity
 798 arityType (App f (Type _)) = arityType f
 799 arityType (App f a)        = case arityType f of
 800                                 AFun one_shot xs | exprIsCheap a -> xs
 801                                 other                            -> ATop
 802
 803         -- Case/Let; keep arity if either the expression is cheap
 804         -- or it's a 1-shot lambda
 805 arityType (Case scrut _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
 806                                   xs@(AFun one_shot _) | one_shot -> xs
 807                                   xs | exprIsCheap scrut          -> xs
 808                                      | otherwise                  -> ATop
 809
 810 arityType (Let b e) = case arityType e of
 811                         xs@(AFun one_shot _) | one_shot                       -> xs
 812                         xs                   | all exprIsCheap (rhssOfBind b) -> xs
 813                                              | otherwise                      -> ATop
 814
 815 arityType other = ATop
 816
 817 isStateHack id = case splitTyConApp_maybe (idType id) of
 818                      Just (tycon,_) | tycon == statePrimTyCon -> True
 819                      other                                    -> False
 820
 821         -- The last clause is a gross hack.  It claims that
 822         -- every function over realWorldStatePrimTy is a one-shot
 823         -- function.  This is pretty true in practice, and makes a big
 824         -- difference.  For example, consider
 825         --      a `thenST` \ r -> ...E...
 826         -- The early full laziness pass, if it doesn't know that r is one-shot
 827         -- will pull out E (let's say it doesn't mention r) to give
 828         --      let lvl = E in a `thenST` \ r -> ...lvl...
 829         -- When `thenST` gets inlined, we end up with
 830         --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...
 831         -- and we don't re-inline E.
 832         --
 833         -- It would be better to spot that r was one-shot to start with, but
 834         -- I don't want to rely on that.
 835         --
 836         -- Another good example is in fill_in in PrelPack.lhs.  We should be able to
 837         -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.
 838
 839 {- NOT NEEDED ANY MORE: etaExpand is cleverer
 840 ok_note InlineMe = False
 841 ok_note other    = True
 842     -- Notice that we do not look through __inline_me__
 843     -- This may seem surprising, but consider
 844     --          f = _inline_me (\x -> e)
 845     -- We DO NOT want to eta expand this to
 846     --          f = \x -> (_inline_me (\x -> e)) x
 847     -- because the _inline_me gets dropped now it is applied,
 848     -- giving just
 849     --          f = \x -> e
 850     -- A Bad Idea
 851 -}
 852 \end{code}
 853
 854
 855 \begin{code}
 856 etaExpand :: Arity              -- Result should have this number of value args
 857           -> [Unique]
 858           -> CoreExpr -> Type   -- Expression and its type
 859           -> CoreExpr
 860 -- (etaExpand n us e ty) returns an expression with
 861 -- the same meaning as 'e', but with arity 'n'.
 862 --
 863 -- Given e' = etaExpand n us e ty
 864 -- We should have
 865 --      ty = exprType e = exprType e'
 866 --
 867 -- Note that SCCs are not treated specially.  If we have
 868 --      etaExpand 2 (\x -> scc "foo" e)
 869 --      = (\xy -> (scc "foo" e) y)
 870 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 871
 872 etaExpand n us expr ty
 873   | manifestArity expr >= n = expr              -- The no-op case
 874   | otherwise               = eta_expand n us expr ty
 875   where
 876
 877 -- manifestArity sees how many leading value lambdas there are
 878 manifestArity :: CoreExpr -> Arity
 879 manifestArity (Lam v e) | isId v    = 1 + manifestArity e
 880                         | otherwise = manifestArity e
 881 manifestArity (Note _ e)            = manifestArity e
 882 manifestArity e                     = 0
 883
 884 -- etaExpand deals with for-alls. For example:
 885 --              etaExpand 1 E
 886 -- where  E :: forall a. a -> a
 887 -- would return
 888 --      (/\b. \y::a -> E b y)
 889 --
 890 -- It deals with coerces too, though they are now rare
 891 -- so perhaps the extra code isn't worth it
 892
 893 eta_expand n us expr ty
 894   | n == 0 &&
 895     -- The ILX code generator requires eta expansion for type arguments
 896     -- too, but alas the 'n' doesn't tell us how many of them there
 897     -- may be.  So we eagerly eta expand any big lambdas, and just
 898     -- cross our fingers about possible loss of sharing in the ILX case.
 899     -- The Right Thing is probably to make 'arity' include
 900     -- type variables throughout the compiler.  (ToDo.)
 901     not (isForAllTy ty)
 902     -- Saturated, so nothing to do
 903   = expr
 904
 905         -- Short cut for the case where there already
 906         -- is a lambda; no point in gratuitously adding more
 907 eta_expand n us (Lam v body) ty
 908   | isTyVar v
 909   = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
 910
 911   | otherwise
 912   = Lam v (eta_expand (n-1) us body (funResultTy ty))
 913
 914 -- We used to have a special case that stepped inside Coerces here,
 915 -- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _
 916 --              = Note note (eta_expand n us e ty)
 917 -- BUT this led to an infinite loop
 918 -- Example:     newtype T = MkT (Int -> Int)
 919 --      eta_expand 1 (coerce (Int->Int) e)
 920 --      --> coerce (Int->Int) (eta_expand 1 T e)
 921 --              by the bogus eqn
 922 --      --> coerce (Int->Int) (coerce T
 923 --              (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
 924 --              by the splitNewType_maybe case below
 925 --      and round we go
 926
 927 eta_expand n us expr ty
 928   = case splitForAllTy_maybe ty of {
 929           Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
 930
 931         ; Nothing ->
 932
 933         case splitFunTy_maybe ty of {
 934           Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
 935                                 where
 936                                    arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
 937                                    (uniq:us2) = us
 938
 939         ; Nothing ->
 940
 941                 -- Given this:
 942                 --      newtype T = MkT (Int -> Int)
 943                 -- Consider eta-expanding this
 944                 --      eta_expand 1 e T
 945                 -- We want to get
 946                 --      coerce T (\x::Int -> (coerce (Int->Int) e) x)
 947
 948         case splitNewType_maybe ty of {
 949           Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
 950           Nothing  -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
 951         }}}
 952 \end{code}
 953
 954 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 955 It tells how many things the expression can be applied to before doing
 956 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 957 exprEtaExpandArity will do the hard work, leaving something that's easy
 958 for exprArity to grapple with.  In particular, Simplify uses exprArity to
 959 compute the ArityInfo for the Id.
 960
 961 Originally I thought that it was enough just to look for top-level lambdas, but
 962 it isn't.  I've seen this
 963
 964         foo = PrelBase.timesInt
 965
 966 We want foo to get arity 2 even though the eta-expander will leave it
 967 unchanged, in the expectation that it'll be inlined.  But occasionally it
 968 isn't, because foo is blacklisted (used in a rule).
 969
 970 Similarly, see the ok_note check in exprEtaExpandArity.  So
 971         f = __inline_me (\x -> e)
 972 won't be eta-expanded.
 973
 974 And in any case it seems more robust to have exprArity be a bit more intelligent.
 975 But note that   (\x y z -> f x y z)
 976 should have arity 3, regardless of f's arity.
 977
 978 \begin{code}
 979 exprArity :: CoreExpr -> Arity
 980 exprArity e = go e
 981             where
 982               go (Var v)                   = idArity v
 983               go (Lam x e) | isId x        = go e + 1
 984                            | otherwise     = go e
 985               go (Note n e)                = go e
 986               go (App e (Type t))          = go e
 987               go (App f a) | exprIsCheap a = (go f - 1) `max` 0
 988                 -- NB: exprIsCheap a!
 989                 --      f (fac x) does not have arity 2,
 990                 --      even if f has arity 3!
 991                 -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
 992                 --               unknown, hence arity 0
 993               go _                         = 0
 994 \end{code}
 995
 996 %************************************************************************
 997 %*                                                                      *
 998 \subsection{Equality}
 999 %*                                                                      *
1000 %************************************************************************
1001
1002 @cheapEqExpr@ is a cheap equality test which bales out fast!
1003         True  => definitely equal
1004         False => may or may not be equal
1005
1006 \begin{code}
1007 cheapEqExpr :: Expr b -> Expr b -> Bool
1008
1009 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
1010 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1011 cheapEqExpr (Type t1)  (Type t2)  = t1 `eqType` t2
1012
1013 cheapEqExpr (App f1 a1) (App f2 a2)
1014   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1015
1016 cheapEqExpr _ _ = False
1017
1018 exprIsBig :: Expr b -> Bool
1019 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1020 exprIsBig (Lit _)      = False
1021 exprIsBig (Var v)      = False
1022 exprIsBig (Type t)     = False
1023 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1024 exprIsBig other        = True
1025 \end{code}
1026
1027
1028 \begin{code}
1029 eqExpr :: CoreExpr -> CoreExpr -> Bool
1030         -- Works ok at more general type, but only needed at CoreExpr
1031         -- Used in rule matching, so when we find a type we use
1032         -- eqTcType, which doesn't look through newtypes
1033         -- [And it doesn't risk falling into a black hole either.]
1034 eqExpr e1 e2
1035   = eq emptyVarEnv e1 e2
1036   where
1037   -- The "env" maps variables in e1 to variables in ty2
1038   -- So when comparing lambdas etc,
1039   -- we in effect substitute v2 for v1 in e1 before continuing
1040     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1041                                   Just v1' -> v1' == v2
1042                                   Nothing  -> v1  == v2
1043
1044     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
1045     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
1046     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
1047     eq env (Let (NonRec v1 r1) e1)
1048            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1049     eq env (Let (Rec ps1) e1)
1050            (Let (Rec ps2) e2)        = equalLength ps1 ps2 &&
1051                                        and (zipWith eq_rhs ps1 ps2) &&
1052                                        eq env' e1 e2
1053                                      where
1054                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1055                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1056     eq env (Case e1 v1 a1)
1057            (Case e2 v2 a2)           = eq env e1 e2 &&
1058                                        equalLength a1 a2 &&
1059                                        and (zipWith (eq_alt env') a1 a2)
1060                                      where
1061                                        env' = extendVarEnv env v1 v2
1062
1063     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1064     eq env (Type t1)    (Type t2)    = t1 `eqType` t2
1065     eq env e1           e2           = False
1066
1067     eq_list env []       []       = True
1068     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1069     eq_list env es1      es2      = False
1070
1071     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1072                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1073
1074     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
1075     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1076     eq_note env InlineCall     InlineCall     = True
1077     eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
1078     eq_note env other1         other2         = False
1079 \end{code}
1080
1081
1082 %************************************************************************
1083 %*                                                                      *
1084 \subsection{The size of an expression}
1085 %*                                                                      *
1086 %************************************************************************
1087
1088 \begin{code}
1089 coreBindsSize :: [CoreBind] -> Int
1090 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1091
1092 exprSize :: CoreExpr -> Int
1093         -- A measure of the size of the expressions
1094         -- It also forces the expression pretty drastically as a side effect
1095 exprSize (Var v)       = v `seq` 1
1096 exprSize (Lit lit)     = lit `seq` 1
1097 exprSize (App f a)     = exprSize f + exprSize a
1098 exprSize (Lam b e)     = varSize b + exprSize e
1099 exprSize (Let b e)     = bindSize b + exprSize e
1100 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
1101 exprSize (Note n e)    = noteSize n + exprSize e
1102 exprSize (Type t)      = seqType t `seq` 1
1103
1104 noteSize (SCC cc)       = cc `seq` 1
1105 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1106 noteSize InlineCall     = 1
1107 noteSize InlineMe       = 1
1108 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1109
1110 varSize :: Var -> Int
1111 varSize b  | isTyVar b = 1
1112            | otherwise = seqType (idType b)             `seq`
1113                          megaSeqIdInfo (idInfo b)       `seq`
1114                          1
1115
1116 varsSize = foldr ((+) . varSize) 0
1117
1118 bindSize (NonRec b e) = varSize b + exprSize e
1119 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1120
1121 pairSize (b,e) = varSize b + exprSize e
1122
1123 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1124 \end{code}
1125
1126
1127 %************************************************************************
1128 %*                                                                      *
1129 \subsection{Hashing}
1130 %*                                                                      *
1131 %************************************************************************
1132
1133 \begin{code}
1134 hashExpr :: CoreExpr -> Int
1135 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
1136            | otherwise = hash
1137            where
1138              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
1139
1140 hash_expr (Note _ e)              = hash_expr e
1141 hash_expr (Let (NonRec b r) e)    = hashId b
1142 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1143 hash_expr (Case _ b _)            = hashId b
1144 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
1145 hash_expr (Var v)                 = hashId v
1146 hash_expr (Lit lit)               = hashLiteral lit
1147 hash_expr (Lam b _)               = hashId b
1148 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
1149
1150 fast_hash_expr (Var v)          = hashId v
1151 fast_hash_expr (Lit lit)        = hashLiteral lit
1152 fast_hash_expr (App f (Type _)) = fast_hash_expr f
1153 fast_hash_expr (App f a)        = fast_hash_expr a
1154 fast_hash_expr (Lam b _)        = hashId b
1155 fast_hash_expr other            = 1
1156
1157 hashId :: Id -> Int
1158 hashId id = hashName (idName id)
1159 \end{code}
1160
1161 %************************************************************************
1162 %*                                                                      *
1163 \subsection{Cross-DLL references}
1164 %*                                                                      *
1165 %************************************************************************
1166
1167 Top-level constructor applications can usually be allocated
1168 statically, but they can't if
1169    a) the constructor, or any of the arguments, come from another DLL
1170    b) any of the arguments are LitLits
1171 (because we can't refer to static labels in other DLLs).
1172
1173 If this happens we simply make the RHS into an updatable thunk,
1174 and 'exectute' it rather than allocating it statically.
1175
1176 We also catch lit-lit arguments here, because those cannot be used in
1177 static constructors either.  (litlits are deprecated, so I'm not going
1178 to bother cleaning up this infelicity --SDM).
1179
1180 \begin{code}
1181 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
1182 isCrossDllConApp con args =
1183   isDllName (dataConName con) || any isCrossDllArg args
1184
1185 isCrossDllArg :: CoreExpr -> Bool
1186 -- True if somewhere in the expression there's a cross-DLL reference
1187 isCrossDllArg (Type _)    = False
1188 isCrossDllArg (Var v)     = isDllName (idName v)
1189 isCrossDllArg (Note _ e)  = isCrossDllArg e
1190 isCrossDllArg (Lit lit)   = isLitLitLit lit
1191 isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2
1192                                 -- must be a type app
1193 isCrossDllArg (Lam v e)   = isCrossDllArg e
1194                                 -- must be a type lam
1195 \end{code}
1196
1197 %************************************************************************
1198 %*                                                                      *
1199 \subsection{Determining non-updatable right-hand-sides}
1200 %*                                                                      *
1201 %************************************************************************
1202
1203 \begin{code}
1204 rhsIsNonUpd :: CoreExpr -> Bool
1205 -- True => Value-lambda, saturated constructor
1206 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1207 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1208 --
1209 --    b) (C x xs), where C is a contructors is updatable if the application is
1210 --         dynamic
1211 --
1212 --    c) don't look through unfolding of f in (f x).
1213 --
1214 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1215 -- them as making the RHS re-entrant (non-updatable).
1216 --
1217 rhsIsNonUpd (Lam b e)          = isRuntimeVar b || rhsIsNonUpd e
1218 rhsIsNonUpd (Note (SCC _) e)   = False
1219 rhsIsNonUpd (Note _ e)         = rhsIsNonUpd e
1220 rhsIsNonUpd other_expr
1221   = go other_expr 0 []
1222   where
1223     go (Var f) n_args args = idAppIsNonUpd f n_args args
1224
1225     go (App f a) n_args args
1226         | isTypeArg a = go f n_args args
1227         | otherwise   = go f (n_args + 1) (a:args)
1228
1229     go (Note (SCC _) f) n_args args = False
1230     go (Note _ f) n_args args       = go f n_args args
1231
1232     go other n_args args = False
1233
1234 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
1235 idAppIsNonUpd id n_val_args args
1236   -- saturated constructors are not updatable
1237   | Just con <- isDataConWorkId_maybe id,
1238     n_val_args == dataConRepArity con,
1239     not (isCrossDllConApp con args),
1240     all exprIsAtom args
1241     = True
1242    -- NB. args sometimes not atomic.  eg.
1243    --   x = D# (1.0## /## 2.0##)
1244    -- can't float because /## can fail.
1245
1246   | otherwise = False
1247     -- Historical note: we used to make partial applications
1248     -- non-updatable, so they behaved just like PAPs, but this
1249     -- doesn't work too well with eval/apply so it is disabled
1250     -- now.
1251 \end{code}