ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         -- Construction
   9         mkInlineMe, mkSCC, mkCoerce, mkCoerce2,
  10         bindNonRec, needsCaseBinding,
  11         mkIfThenElse, mkAltExpr, mkPiType, mkPiTypes,
  12
  13         -- Taking expressions apart
  14         findDefault, findAlt,
  15
  16         -- Properties of expressions
  17         exprType, coreAltType,
  18         exprIsDupable, exprIsTrivial, exprIsCheap,
  19         exprIsValue,exprOkForSpeculation, exprIsBig,
  20         exprIsConApp_maybe, exprIsBottom,
  21         rhsIsStatic,
  22
  23         -- Arity and eta expansion
  24         manifestArity, exprArity,
  25         exprEtaExpandArity, etaExpand,
  26
  27         -- Size
  28         coreBindsSize,
  29
  30         -- Hashing
  31         hashExpr,
  32
  33         -- Equality
  34         cheapEqExpr, 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 )
  47 import Packages         ( isDllName )
  48 import CmdLineOpts      ( DynFlags )
  49 import Literal          ( hashLiteral, literalType, litIsDupable,
  50                           litIsTrivial, isZeroLit, Literal( MachLabel ) )
  51 import DataCon          ( DataCon, dataConRepArity, dataConArgTys,
  52                           isVanillaDataCon, dataConTyCon )
  53 import PrimOp           ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
  54 import Id               ( Id, idType, globalIdDetails, idNewStrictness,
  55                           mkWildId, idArity, idName, idUnfolding, idInfo,
  56                           isOneShotBndr, isStateHackType, isDataConWorkId_maybe, mkSysLocal,
  57                           isDataConWorkId, isBottomingId
  58                         )
  59 import IdInfo           ( GlobalIdDetails(..), megaSeqIdInfo )
  60 import NewDemand        ( appIsBottom )
  61 import Type             ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
  62                           splitFunTy,
  63                           applyTys, isUnLiftedType, seqType, mkTyVarTy,
  64                           splitForAllTy_maybe, isForAllTy, splitRecNewType_maybe,
  65                           splitTyConApp_maybe, eqType, funResultTy, applyTy,
  66                           funResultTy, applyTy
  67                         )
  68 import TyCon            ( tyConArity )
  69 -- gaw 2004
  70 import TysWiredIn       ( boolTy, trueDataCon, falseDataCon )
  71 import CostCentre       ( CostCentre )
  72 import BasicTypes       ( Arity )
  73 import Unique           ( Unique )
  74 import Outputable
  75 import TysPrim          ( alphaTy )     -- Debugging only
  76 import Util             ( equalLength, lengthAtLeast )
  77 \end{code}
  78
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{Find the type of a Core atom/expression}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 exprType :: CoreExpr -> Type
  88
  89 exprType (Var var)              = idType var
  90 exprType (Lit lit)              = literalType lit
  91 exprType (Let _ body)           = exprType body
  92 -- gaw 2004
  93 exprType (Case _ _ ty alts)     = ty
  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 coreAltType :: CoreAlt -> Type
 104 coreAltType (_,_,rhs) = exprType rhs
 105 \end{code}
 106
 107 @mkPiType@ makes a (->) type or a forall type, depending on whether
 108 it is given a type variable or a term variable.  We cleverly use the
 109 lbvarinfo field to figure out the right annotation for the arrove in
 110 case of a term variable.
 111
 112 \begin{code}
 113 mkPiType  :: Var   -> Type -> Type      -- The more polymorphic version
 114 mkPiTypes :: [Var] -> Type -> Type      --    doesn't work...
 115
 116 mkPiTypes vs ty = foldr mkPiType ty vs
 117
 118 mkPiType v ty
 119    | isId v    = mkFunTy (idType v) ty
 120    | otherwise = mkForAllTy v ty
 121 \end{code}
 122
 123 \begin{code}
 124 applyTypeToArg :: Type -> CoreExpr -> Type
 125 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
 126 applyTypeToArg fun_ty other_arg     = funResultTy fun_ty
 127
 128 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 129 -- A more efficient version of applyTypeToArg
 130 -- when we have several args
 131 -- The first argument is just for debugging
 132 applyTypeToArgs e op_ty [] = op_ty
 133
 134 applyTypeToArgs e op_ty (Type ty : args)
 135   =     -- Accumulate type arguments so we can instantiate all at once
 136     go [ty] args
 137   where
 138     go rev_tys (Type ty : args) = go (ty:rev_tys) args
 139     go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
 140                                 where
 141                                   op_ty' = applyTys op_ty (reverse rev_tys)
 142
 143 applyTypeToArgs e op_ty (other_arg : args)
 144   = case (splitFunTy_maybe op_ty) of
 145         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 146         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
 147 \end{code}
 148
 149
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection{Attaching notes}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 mkNote removes redundant coercions, and SCCs where possible
 158
 159 \begin{code}
 160 #ifdef UNUSED
 161 mkNote :: Note -> CoreExpr -> CoreExpr
 162 mkNote (Coerce to_ty from_ty) expr = mkCoerce2 to_ty from_ty expr
 163 mkNote (SCC cc) expr               = mkSCC cc expr
 164 mkNote InlineMe expr               = mkInlineMe expr
 165 mkNote note     expr               = Note note expr
 166 #endif
 167
 168 -- Slide InlineCall in around the function
 169 --      No longer necessary I think (SLPJ Apr 99)
 170 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 171 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 172 -- mkNote InlineCall expr      = expr
 173 \end{code}
 174
 175 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 176 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 177 not be *applied* to anything.
 178
 179 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
 180 bindings like
 181         fw = ...
 182         f  = inline_me (coerce t fw)
 183 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
 184 We want the split, so that the coerces can cancel at the call site.
 185
 186 However, we can get left with tiresome type applications.  Notably, consider
 187         f = /\ a -> let t = e in (t, w)
 188 Then lifting the let out of the big lambda gives
 189         t' = /\a -> e
 190         f = /\ a -> let t = inline_me (t' a) in (t, w)
 191 The inline_me is to stop the simplifier inlining t' right back
 192 into t's RHS.  In the next phase we'll substitute for t (since
 193 its rhs is trivial) and *then* we could get rid of the inline_me.
 194 But it hardly seems worth it, so I don't bother.
 195
 196 \begin{code}
 197 mkInlineMe (Var v) = Var v
 198 mkInlineMe e       = Note InlineMe e
 199 \end{code}
 200
 201
 202
 203 \begin{code}
 204 mkCoerce :: Type -> CoreExpr -> CoreExpr
 205 mkCoerce to_ty expr = mkCoerce2 to_ty (exprType expr) expr
 206
 207 mkCoerce2 :: Type -> Type -> CoreExpr -> CoreExpr
 208 mkCoerce2 to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 209   = ASSERT( from_ty `eqType` to_ty2 )
 210     mkCoerce2 to_ty from_ty2 expr
 211
 212 mkCoerce2 to_ty from_ty expr
 213   | to_ty `eqType` from_ty = expr
 214   | otherwise              = ASSERT( from_ty `eqType` exprType expr )
 215                              Note (Coerce to_ty from_ty) expr
 216 \end{code}
 217
 218 \begin{code}
 219 mkSCC :: CostCentre -> Expr b -> Expr b
 220         -- Note: Nested SCC's *are* preserved for the benefit of
 221         --       cost centre stack profiling
 222 mkSCC cc (Lit lit)          = Lit lit
 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
 248 bindNonRec bndr rhs body
 249 -- gaw 2004
 250   | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT,[],body)]
 251   | otherwise                          = Let (NonRec bndr rhs) body
 252
 253 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 254         -- Make a case expression instead of a let
 255         -- These can arise either from the desugarer,
 256         -- or from beta reductions: (\x.e) (x +# y)
 257 \end{code}
 258
 259 \begin{code}
 260 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 261         -- This guy constructs the value that the scrutinee must have
 262         -- when you are in one particular branch of a case
 263 mkAltExpr (DataAlt con) args inst_tys
 264   = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
 265 mkAltExpr (LitAlt lit) [] []
 266   = Lit lit
 267
 268 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 269 mkIfThenElse guard then_expr else_expr
 270 -- gaw 2004
 271 -- Not going to be refining, so okay to take the type of the "then" clause
 272   = Case guard (mkWildId boolTy) (exprType then_expr)
 273          [ (DataAlt trueDataCon,  [], then_expr),
 274            (DataAlt falseDataCon, [], else_expr) ]
 275 \end{code}
 276
 277
 278 %************************************************************************
 279 %*                                                                      *
 280 \subsection{Taking expressions apart}
 281 %*                                                                      *
 282 %************************************************************************
 283
 284 The default alternative must be first, if it exists at all.
 285 This makes it easy to find, though it makes matching marginally harder.
 286
 287 \begin{code}
 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 SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because
 334   a) it really generates code, (and a heap object when it's
 335      a function arg) to capture the cost centre
 336   b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
 337
 338 \begin{code}
 339 exprIsTrivial (Var v)      = True       -- See notes above
 340 exprIsTrivial (Type _)     = True
 341 exprIsTrivial (Lit lit)    = litIsTrivial lit
 342 exprIsTrivial (App e arg)  = not (isRuntimeArg arg) && exprIsTrivial e
 343 exprIsTrivial (Note (SCC _) e) = False          -- See notes above
 344 exprIsTrivial (Note _       e) = exprIsTrivial e
 345 exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body
 346 exprIsTrivial other        = False
 347 \end{code}
 348
 349
 350 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 351                 cost in code size.  This will only happen in different case
 352                 branches, so there's no issue about duplicating work.
 353
 354                 That is, exprIsDupable returns True of (f x) even if
 355                 f is very very expensive to call.
 356
 357                 Its only purpose is to avoid fruitless let-binding
 358                 and then inlining of case join points
 359
 360
 361 \begin{code}
 362 exprIsDupable (Type _)          = True
 363 exprIsDupable (Var v)           = True
 364 exprIsDupable (Lit lit)         = litIsDupable lit
 365 exprIsDupable (Note InlineMe e) = True
 366 exprIsDupable (Note _ e)        = exprIsDupable e
 367 exprIsDupable expr
 368   = go expr 0
 369   where
 370     go (Var v)   n_args = True
 371     go (App f a) n_args =  n_args < dupAppSize
 372                         && exprIsDupable a
 373                         && go f (n_args+1)
 374     go other n_args     = False
 375
 376 dupAppSize :: Int
 377 dupAppSize = 4          -- Size of application we are prepared to duplicate
 378 \end{code}
 379
 380 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 381 it is obviously in weak head normal form, or is cheap to get to WHNF.
 382 [Note that that's not the same as exprIsDupable; an expression might be
 383 big, and hence not dupable, but still cheap.]
 384
 385 By ``cheap'' we mean a computation we're willing to:
 386         push inside a lambda, or
 387         inline at more than one place
 388 That might mean it gets evaluated more than once, instead of being
 389 shared.  The main examples of things which aren't WHNF but are
 390 ``cheap'' are:
 391
 392   *     case e of
 393           pi -> ei
 394         (where e, and all the ei are cheap)
 395
 396   *     let x = e in b
 397         (where e and b are cheap)
 398
 399   *     op x1 ... xn
 400         (where op is a cheap primitive operator)
 401
 402   *     error "foo"
 403         (because we are happy to substitute it inside a lambda)
 404
 405 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 406 because sharing will make sure it is only evaluated once.
 407
 408 \begin{code}
 409 exprIsCheap :: CoreExpr -> Bool
 410 exprIsCheap (Lit lit)               = True
 411 exprIsCheap (Type _)                = True
 412 exprIsCheap (Var _)                 = True
 413 exprIsCheap (Note InlineMe e)       = True
 414 exprIsCheap (Note _ e)              = exprIsCheap e
 415 exprIsCheap (Lam x e)               = isRuntimeVar x || exprIsCheap e
 416 -- gaw 2004
 417 exprIsCheap (Case e _ _ alts)       = exprIsCheap e &&
 418                                     and [exprIsCheap rhs | (_,_,rhs) <- alts]
 419         -- Experimentally, treat (case x of ...) as cheap
 420         -- (and case __coerce x etc.)
 421         -- This improves arities of overloaded functions where
 422         -- there is only dictionary selection (no construction) involved
 423 exprIsCheap (Let (NonRec x _) e)
 424       | isUnLiftedType (idType x) = exprIsCheap e
 425       | otherwise                 = False
 426         -- strict lets always have cheap right hand sides, and
 427         -- do no allocation.
 428
 429 exprIsCheap other_expr
 430   = go other_expr 0 True
 431   where
 432     go (Var f) n_args args_cheap
 433         = (idAppIsCheap f n_args && args_cheap)
 434                         -- A constructor, cheap primop, or partial application
 435
 436           || idAppIsBottom f n_args
 437                         -- Application of a function which
 438                         -- always gives bottom; we treat this as cheap
 439                         -- because it certainly doesn't need to be shared!
 440
 441     go (App f a) n_args args_cheap
 442         | not (isRuntimeArg a) = go f n_args      args_cheap
 443         | otherwise            = go f (n_args + 1) (exprIsCheap a && args_cheap)
 444
 445     go other   n_args args_cheap = False
 446
 447 idAppIsCheap :: Id -> Int -> Bool
 448 idAppIsCheap id n_val_args
 449   | n_val_args == 0 = True      -- Just a type application of
 450                                 -- a variable (f t1 t2 t3)
 451                                 -- counts as WHNF
 452   | otherwise = case globalIdDetails id of
 453                   DataConWorkId _ -> True
 454                   RecordSelId _ _ -> True       -- I'm experimenting with making record selection
 455                   ClassOpId _     -> True       -- look cheap, so we will substitute it inside a
 456                                                 -- lambda.  Particularly for dictionary field selection
 457
 458                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 459                                                         -- that return a type variable, since the result
 460                                                         -- might be applied to something, but I'm not going
 461                                                         -- to bother to check the number of args
 462                   other       -> n_val_args < idArity id
 463 \end{code}
 464
 465 exprOkForSpeculation returns True of an expression that it is
 466
 467         * safe to evaluate even if normal order eval might not
 468           evaluate the expression at all, or
 469
 470         * safe *not* to evaluate even if normal order would do so
 471
 472 It returns True iff
 473
 474         the expression guarantees to terminate,
 475         soon,
 476         without raising an exception,
 477         without causing a side effect (e.g. writing a mutable variable)
 478
 479 E.G.
 480         let x = case y# +# 1# of { r# -> I# r# }
 481         in E
 482 ==>
 483         case y# +# 1# of { r# ->
 484         let x = I# r#
 485         in E
 486         }
 487
 488 We can only do this if the (y+1) is ok for speculation: it has no
 489 side effects, and can't diverge or raise an exception.
 490
 491 \begin{code}
 492 exprOkForSpeculation :: CoreExpr -> Bool
 493 exprOkForSpeculation (Lit _)    = True
 494 exprOkForSpeculation (Type _)   = True
 495 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 496 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 497 exprOkForSpeculation other_expr
 498   = case collectArgs other_expr of
 499         (Var f, args) -> spec_ok (globalIdDetails f) args
 500         other         -> False
 501
 502   where
 503     spec_ok (DataConWorkId _) args
 504       = True    -- The strictness of the constructor has already
 505                 -- been expressed by its "wrapper", so we don't need
 506                 -- to take the arguments into account
 507
 508     spec_ok (PrimOpId op) args
 509       | isDivOp op,             -- Special case for dividing operations that fail
 510         [arg1, Lit lit] <- args -- only if the divisor is zero
 511       = not (isZeroLit lit) && exprOkForSpeculation arg1
 512                 -- Often there is a literal divisor, and this
 513                 -- can get rid of a thunk in an inner looop
 514
 515       | otherwise
 516       = primOpOkForSpeculation op &&
 517         all exprOkForSpeculation args
 518                                 -- A bit conservative: we don't really need
 519                                 -- to care about lazy arguments, but this is easy
 520
 521     spec_ok other args = False
 522
 523 isDivOp :: PrimOp -> Bool
 524 -- True of dyadic operators that can fail
 525 -- only if the second arg is zero
 526 -- This function probably belongs in PrimOp, or even in
 527 -- an automagically generated file.. but it's such a
 528 -- special case I thought I'd leave it here for now.
 529 isDivOp IntQuotOp        = True
 530 isDivOp IntRemOp         = True
 531 isDivOp WordQuotOp       = True
 532 isDivOp WordRemOp        = True
 533 isDivOp IntegerQuotRemOp = True
 534 isDivOp IntegerDivModOp  = True
 535 isDivOp FloatDivOp       = True
 536 isDivOp DoubleDivOp      = True
 537 isDivOp other            = False
 538 \end{code}
 539
 540
 541 \begin{code}
 542 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 543 exprIsBottom e = go 0 e
 544                where
 545                 -- n is the number of args
 546                  go n (Note _ e)     = go n e
 547                  go n (Let _ e)      = go n e
 548 -- gaw 2004
 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                               | not (isVanillaDataCon 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.isOneShotBndr.
 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) (arg_tys (idType v))
 784   where
 785     mk :: Arity -> [Type] -> ArityType
 786         -- The argument types are only to steer the "state hack"
 787         -- Consider case x of
 788         --              True  -> foo
 789         --              False -> \(s:RealWorld) -> e
 790         -- where foo has arity 1.  Then we want the state hack to
 791         -- apply to foo too, so we can eta expand the case.
 792     mk 0 tys | isBottomingId v  = ABot
 793              | otherwise        = ATop
 794     mk n (ty:tys) = AFun (isStateHackType ty) (mk (n-1) tys)
 795     mk n []       = AFun False                (mk (n-1) [])
 796
 797     arg_tys :: Type -> [Type]   -- Ignore for-alls
 798     arg_tys ty
 799         | Just (_, ty')  <- splitForAllTy_maybe ty = arg_tys ty'
 800         | Just (arg,res) <- splitFunTy_maybe ty    = arg : arg_tys res
 801         | otherwise                                = []
 802
 803         -- Lambdas; increase arity
 804 arityType (Lam x e) | isId x    = AFun (isOneShotBndr x) (arityType e)
 805                     | otherwise = arityType e
 806
 807         -- Applications; decrease arity
 808 arityType (App f (Type _)) = arityType f
 809 arityType (App f a)        = case arityType f of
 810                                 AFun one_shot xs | exprIsCheap a -> xs
 811                                 other                            -> ATop
 812
 813         -- Case/Let; keep arity if either the expression is cheap
 814         -- or it's a 1-shot lambda
 815         -- The former is not really right for Haskell
 816         --      f x = case x of { (a,b) -> \y. e }
 817         --  ===>
 818         --      f x y = case x of { (a,b) -> e }
 819         -- The difference is observable using 'seq'
 820 -- gaw 2004
 821 arityType (Case scrut _ _ alts) = case foldr1 andArityType [arityType rhs | (_,_,rhs) <- alts] of
 822                                   xs@(AFun one_shot _) | one_shot -> xs
 823                                   xs | exprIsCheap scrut          -> xs
 824                                      | otherwise                  -> ATop
 825
 826 arityType (Let b e) = case arityType e of
 827                         xs@(AFun one_shot _) | one_shot                       -> xs
 828                         xs                   | all exprIsCheap (rhssOfBind b) -> xs
 829                                              | otherwise                      -> ATop
 830
 831 arityType other = ATop
 832
 833 {- NOT NEEDED ANY MORE: etaExpand is cleverer
 834 ok_note InlineMe = False
 835 ok_note other    = True
 836     -- Notice that we do not look through __inline_me__
 837     -- This may seem surprising, but consider
 838     --          f = _inline_me (\x -> e)
 839     -- We DO NOT want to eta expand this to
 840     --          f = \x -> (_inline_me (\x -> e)) x
 841     -- because the _inline_me gets dropped now it is applied,
 842     -- giving just
 843     --          f = \x -> e
 844     -- A Bad Idea
 845 -}
 846 \end{code}
 847
 848
 849 \begin{code}
 850 etaExpand :: Arity              -- Result should have this number of value args
 851           -> [Unique]
 852           -> CoreExpr -> Type   -- Expression and its type
 853           -> CoreExpr
 854 -- (etaExpand n us e ty) returns an expression with
 855 -- the same meaning as 'e', but with arity 'n'.
 856 --
 857 -- Given e' = etaExpand n us e ty
 858 -- We should have
 859 --      ty = exprType e = exprType e'
 860 --
 861 -- Note that SCCs are not treated specially.  If we have
 862 --      etaExpand 2 (\x -> scc "foo" e)
 863 --      = (\xy -> (scc "foo" e) y)
 864 -- So the costs of evaluating 'e' (not 'e y') are attributed to "foo"
 865
 866 etaExpand n us expr ty
 867   | manifestArity expr >= n = expr              -- The no-op case
 868   | otherwise               = eta_expand n us expr ty
 869   where
 870
 871 -- manifestArity sees how many leading value lambdas there are
 872 manifestArity :: CoreExpr -> Arity
 873 manifestArity (Lam v e) | isId v    = 1 + manifestArity e
 874                         | otherwise = manifestArity e
 875 manifestArity (Note _ e)            = manifestArity e
 876 manifestArity e                     = 0
 877
 878 -- etaExpand deals with for-alls. For example:
 879 --              etaExpand 1 E
 880 -- where  E :: forall a. a -> a
 881 -- would return
 882 --      (/\b. \y::a -> E b y)
 883 --
 884 -- It deals with coerces too, though they are now rare
 885 -- so perhaps the extra code isn't worth it
 886
 887 eta_expand n us expr ty
 888   | n == 0 &&
 889     -- The ILX code generator requires eta expansion for type arguments
 890     -- too, but alas the 'n' doesn't tell us how many of them there
 891     -- may be.  So we eagerly eta expand any big lambdas, and just
 892     -- cross our fingers about possible loss of sharing in the ILX case.
 893     -- The Right Thing is probably to make 'arity' include
 894     -- type variables throughout the compiler.  (ToDo.)
 895     not (isForAllTy ty)
 896     -- Saturated, so nothing to do
 897   = expr
 898
 899         -- Short cut for the case where there already
 900         -- is a lambda; no point in gratuitously adding more
 901 eta_expand n us (Lam v body) ty
 902   | isTyVar v
 903   = Lam v (eta_expand n us body (applyTy ty (mkTyVarTy v)))
 904
 905   | otherwise
 906   = Lam v (eta_expand (n-1) us body (funResultTy ty))
 907
 908 -- We used to have a special case that stepped inside Coerces here,
 909 -- thus:  eta_expand n us (Note note@(Coerce _ ty) e) _
 910 --              = Note note (eta_expand n us e ty)
 911 -- BUT this led to an infinite loop
 912 -- Example:     newtype T = MkT (Int -> Int)
 913 --      eta_expand 1 (coerce (Int->Int) e)
 914 --      --> coerce (Int->Int) (eta_expand 1 T e)
 915 --              by the bogus eqn
 916 --      --> coerce (Int->Int) (coerce T
 917 --              (\x::Int -> eta_expand 1 (coerce (Int->Int) e)))
 918 --              by the splitNewType_maybe case below
 919 --      and round we go
 920
 921 eta_expand n us expr ty
 922   = case splitForAllTy_maybe ty of {
 923           Just (tv,ty') -> Lam tv (eta_expand n us (App expr (Type (mkTyVarTy tv))) ty')
 924
 925         ; Nothing ->
 926
 927         case splitFunTy_maybe ty of {
 928           Just (arg_ty, res_ty) -> Lam arg1 (eta_expand (n-1) us2 (App expr (Var arg1)) res_ty)
 929                                 where
 930                                    arg1       = mkSysLocal FSLIT("eta") uniq arg_ty
 931                                    (uniq:us2) = us
 932
 933         ; Nothing ->
 934
 935                 -- Given this:
 936                 --      newtype T = MkT ([T] -> Int)
 937                 -- Consider eta-expanding this
 938                 --      eta_expand 1 e T
 939                 -- We want to get
 940                 --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
 941                 -- Only try this for recursive newtypes; the non-recursive kind
 942                 -- are transparent anyway
 943
 944         case splitRecNewType_maybe ty of {
 945           Just ty' -> mkCoerce2 ty ty' (eta_expand n us (mkCoerce2 ty' ty expr) ty') ;
 946           Nothing  -> pprTrace "Bad eta expand" (ppr n $$ ppr expr $$ ppr ty) expr
 947         }}}
 948 \end{code}
 949
 950 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 951 It tells how many things the expression can be applied to before doing
 952 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 953 exprEtaExpandArity will do the hard work, leaving something that's easy
 954 for exprArity to grapple with.  In particular, Simplify uses exprArity to
 955 compute the ArityInfo for the Id.
 956
 957 Originally I thought that it was enough just to look for top-level lambdas, but
 958 it isn't.  I've seen this
 959
 960         foo = PrelBase.timesInt
 961
 962 We want foo to get arity 2 even though the eta-expander will leave it
 963 unchanged, in the expectation that it'll be inlined.  But occasionally it
 964 isn't, because foo is blacklisted (used in a rule).
 965
 966 Similarly, see the ok_note check in exprEtaExpandArity.  So
 967         f = __inline_me (\x -> e)
 968 won't be eta-expanded.
 969
 970 And in any case it seems more robust to have exprArity be a bit more intelligent.
 971 But note that   (\x y z -> f x y z)
 972 should have arity 3, regardless of f's arity.
 973
 974 \begin{code}
 975 exprArity :: CoreExpr -> Arity
 976 exprArity e = go e
 977             where
 978               go (Var v)                   = idArity v
 979               go (Lam x e) | isId x        = go e + 1
 980                            | otherwise     = go e
 981               go (Note n e)                = go e
 982               go (App e (Type t))          = go e
 983               go (App f a) | exprIsCheap a = (go f - 1) `max` 0
 984                 -- NB: exprIsCheap a!
 985                 --      f (fac x) does not have arity 2,
 986                 --      even if f has arity 3!
 987                 -- NB: `max 0`!  (\x y -> f x) has arity 2, even if f is
 988                 --               unknown, hence arity 0
 989               go _                         = 0
 990 \end{code}
 991
 992 %************************************************************************
 993 %*                                                                      *
 994 \subsection{Equality}
 995 %*                                                                      *
 996 %************************************************************************
 997
 998 @cheapEqExpr@ is a cheap equality test which bales out fast!
 999         True  => definitely equal
1000         False => may or may not be equal
1001
1002 \begin{code}
1003 cheapEqExpr :: Expr b -> Expr b -> Bool
1004
1005 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
1006 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
1007 cheapEqExpr (Type t1)  (Type t2)  = t1 `eqType` t2
1008
1009 cheapEqExpr (App f1 a1) (App f2 a2)
1010   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
1011
1012 cheapEqExpr _ _ = False
1013
1014 exprIsBig :: Expr b -> Bool
1015 -- Returns True of expressions that are too big to be compared by cheapEqExpr
1016 exprIsBig (Lit _)      = False
1017 exprIsBig (Var v)      = False
1018 exprIsBig (Type t)     = False
1019 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1020 exprIsBig other        = True
1021 \end{code}
1022
1023
1024 \begin{code}
1025 eqExpr :: CoreExpr -> CoreExpr -> Bool
1026         -- Works ok at more general type, but only needed at CoreExpr
1027         -- Used in rule matching, so when we find a type we use
1028         -- eqTcType, which doesn't look through newtypes
1029         -- [And it doesn't risk falling into a black hole either.]
1030 eqExpr e1 e2
1031   = eq emptyVarEnv e1 e2
1032   where
1033   -- The "env" maps variables in e1 to variables in ty2
1034   -- So when comparing lambdas etc,
1035   -- we in effect substitute v2 for v1 in e1 before continuing
1036     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
1037                                   Just v1' -> v1' == v2
1038                                   Nothing  -> v1  == v2
1039
1040     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
1041     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
1042     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
1043     eq env (Let (NonRec v1 r1) e1)
1044            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
1045     eq env (Let (Rec ps1) e1)
1046            (Let (Rec ps2) e2)        = equalLength ps1 ps2 &&
1047                                        and (zipWith eq_rhs ps1 ps2) &&
1048                                        eq env' e1 e2
1049                                      where
1050                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
1051                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
1052 -- gaw 2004
1053     eq env (Case e1 v1 t1 a1)
1054            (Case e2 v2 t2 a2)        = eq env e1 e2 &&
1055                                        t1 `eqType` t2 &&
1056                                        equalLength a1 a2 &&
1057                                        and (zipWith (eq_alt env') a1 a2)
1058                                      where
1059                                        env' = extendVarEnv env v1 v2
1060
1061     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
1062     eq env (Type t1)    (Type t2)    = t1 `eqType` t2
1063     eq env e1           e2           = False
1064
1065     eq_list env []       []       = True
1066     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
1067     eq_list env es1      es2      = False
1068
1069     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
1070                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
1071
1072     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
1073     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1 `eqType` t2 && f1 `eqType` f2
1074     eq_note env InlineCall     InlineCall     = True
1075     eq_note env (CoreNote s1)  (CoreNote s2)  = s1 == s2
1076     eq_note env other1         other2         = False
1077 \end{code}
1078
1079
1080 %************************************************************************
1081 %*                                                                      *
1082 \subsection{The size of an expression}
1083 %*                                                                      *
1084 %************************************************************************
1085
1086 \begin{code}
1087 coreBindsSize :: [CoreBind] -> Int
1088 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1089
1090 exprSize :: CoreExpr -> Int
1091         -- A measure of the size of the expressions
1092         -- It also forces the expression pretty drastically as a side effect
1093 exprSize (Var v)         = v `seq` 1
1094 exprSize (Lit lit)       = lit `seq` 1
1095 exprSize (App f a)       = exprSize f + exprSize a
1096 exprSize (Lam b e)       = varSize b + exprSize e
1097 exprSize (Let b e)       = bindSize b + exprSize e
1098 -- gaw 2004
1099 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1100 exprSize (Note n e)      = noteSize n + exprSize e
1101 exprSize (Type t)        = seqType t `seq` 1
1102
1103 noteSize (SCC cc)       = cc `seq` 1
1104 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
1105 noteSize InlineCall     = 1
1106 noteSize InlineMe       = 1
1107 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1108
1109 varSize :: Var -> Int
1110 varSize b  | isTyVar b = 1
1111            | otherwise = seqType (idType b)             `seq`
1112                          megaSeqIdInfo (idInfo b)       `seq`
1113                          1
1114
1115 varsSize = foldr ((+) . varSize) 0
1116
1117 bindSize (NonRec b e) = varSize b + exprSize e
1118 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1119
1120 pairSize (b,e) = varSize b + exprSize e
1121
1122 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1123 \end{code}
1124
1125
1126 %************************************************************************
1127 %*                                                                      *
1128 \subsection{Hashing}
1129 %*                                                                      *
1130 %************************************************************************
1131
1132 \begin{code}
1133 hashExpr :: CoreExpr -> Int
1134 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
1135            | otherwise = hash
1136            where
1137              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
1138
1139 hash_expr (Note _ e)              = hash_expr e
1140 hash_expr (Let (NonRec b r) e)    = hashId b
1141 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
1142 -- gaw 2004
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{Determining non-updatable right-hand-sides}
1164 %*                                                                      *
1165 %************************************************************************
1166
1167 Top-level constructor applications can usually be allocated
1168 statically, but they can't if the constructor, or any of the
1169 arguments, come from another DLL (because we can't refer to static
1170 labels in other DLLs).
1171
1172 If this happens we simply make the RHS into an updatable thunk,
1173 and 'exectute' it rather than allocating it statically.
1174
1175 \begin{code}
1176 rhsIsStatic :: DynFlags -> CoreExpr -> Bool
1177 -- This function is called only on *top-level* right-hand sides
1178 -- Returns True if the RHS can be allocated statically, with
1179 -- no thunks involved at all.
1180 --
1181 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1182 -- refers to, CAFs; and (ii) in CoreToStg to decide whether to put an
1183 -- update flag on it.
1184 --
1185 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1186 --      (a) a value lambda
1187 --      (b) a saturated constructor application with static args
1188 --
1189 -- BUT watch out for
1190 --  (i) Any cross-DLL references kill static-ness completely
1191 --      because they must be 'executed' not statically allocated
1192 --
1193 -- (ii) We treat partial applications as redexes, because in fact we
1194 --      make a thunk for them that runs and builds a PAP
1195 --      at run-time.  The only appliations that are treated as
1196 --      static are *saturated* applications of constructors.
1197
1198 -- We used to try to be clever with nested structures like this:
1199 --              ys = (:) w ((:) w [])
1200 -- on the grounds that CorePrep will flatten ANF-ise it later.
1201 -- But supporting this special case made the function much more
1202 -- complicated, because the special case only applies if there are no
1203 -- enclosing type lambdas:
1204 --              ys = /\ a -> Foo (Baz ([] a))
1205 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1206 --
1207 -- But in fact, even without -O, nested structures at top level are
1208 -- flattened by the simplifier, so we don't need to be super-clever here.
1209 --
1210 -- Examples
1211 --
1212 --      f = \x::Int. x+7        TRUE
1213 --      p = (True,False)        TRUE
1214 --
1215 --      d = (fst p, False)      FALSE because there's a redex inside
1216 --                              (this particular one doesn't happen but...)
1217 --
1218 --      h = D# (1.0## /## 2.0##)        FALSE (redex again)
1219 --      n = /\a. Nil a                  TRUE
1220 --
1221 --      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
1222 --
1223 --
1224 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
1225 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1226 --
1227 --    b) (C x xs), where C is a contructors is updatable if the application is
1228 --         dynamic
1229 --
1230 --    c) don't look through unfolding of f in (f x).
1231 --
1232 -- When opt_RuntimeTypes is on, we keep type lambdas and treat
1233 -- them as making the RHS re-entrant (non-updatable).
1234
1235 rhsIsStatic dflags rhs = is_static False rhs
1236   where
1237   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
1238           -> CoreExpr -> Bool
1239
1240   is_static False (Lam b e) = isRuntimeVar b || is_static False e
1241
1242   is_static in_arg (Note (SCC _) e) = False
1243   is_static in_arg (Note _ e)       = is_static in_arg e
1244
1245   is_static in_arg (Lit lit)
1246     = case lit of
1247         MachLabel _ _ -> False
1248         other         -> True
1249         -- A MachLabel (foreign import "&foo") in an argument
1250         -- prevents a constructor application from being static.  The
1251         -- reason is that it might give rise to unresolvable symbols
1252         -- in the object file: under Linux, references to "weak"
1253         -- symbols from the data segment give rise to "unresolvable
1254         -- relocation" errors at link time This might be due to a bug
1255         -- in the linker, but we'll work around it here anyway.
1256         -- SDM 24/2/2004
1257
1258   is_static in_arg other_expr = go other_expr 0
1259    where
1260     go (Var f) n_val_args
1261         | not (isDllName dflags (idName f))
1262         =  saturated_data_con f n_val_args
1263         || (in_arg && n_val_args == 0)
1264                 -- A naked un-applied variable is *not* deemed a static RHS
1265                 -- E.g.         f = g
1266                 -- Reason: better to update so that the indirection gets shorted
1267                 --         out, and the true value will be seen
1268                 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1269                 --     are always updatable.  If you do so, make sure that non-updatable
1270                 --     ones have enough space for their static link field!
1271
1272     go (App f a) n_val_args
1273         | isTypeArg a                    = go f n_val_args
1274         | not in_arg && is_static True a = go f (n_val_args + 1)
1275         -- The (not in_arg) checks that we aren't in a constructor argument;
1276         -- if we are, we don't allow (value) applications of any sort
1277         --
1278         -- NB. In case you wonder, args are sometimes not atomic.  eg.
1279         --   x = D# (1.0## /## 2.0##)
1280         -- can't float because /## can fail.
1281
1282     go (Note (SCC _) f) n_val_args = False
1283     go (Note _ f) n_val_args       = go f n_val_args
1284
1285     go other n_val_args = False
1286
1287     saturated_data_con f n_val_args
1288         = case isDataConWorkId_maybe f of
1289             Just dc -> n_val_args == dataConRepArity dc
1290             Nothing -> False
1291 \end{code}