ghc/compiler/coreSyn/CoreUtils.lhs

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