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