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