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