compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Utility functions on @Core@ syntax
   7
   8 \begin{code}
   9 {-# OPTIONS -fno-warn-incomplete-patterns #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 -- | Commonly useful utilites for manipulating the Core language
  17 module CoreUtils (
  18         -- * Constructing expressions
  19         mkInlineMe, mkSCC, mkCoerce, mkCoerceI,
  20         bindNonRec, needsCaseBinding,
  21         mkAltExpr, mkPiType, mkPiTypes,
  22
  23         -- * Taking expressions apart
  24         findDefault, findAlt, isDefaultAlt, mergeAlts, trimConArgs,
  25
  26         -- * Properties of expressions
  27         exprType, coreAltType, coreAltsType,
  28         exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
  29         exprIsHNF,exprOkForSpeculation, exprIsBig,
  30         exprIsConApp_maybe, exprIsBottom,
  31         rhsIsStatic,
  32
  33         -- * Expression and bindings size
  34         coreBindsSize, exprSize,
  35
  36         -- * Hashing
  37         hashExpr,
  38
  39         -- * Equality
  40         cheapEqExpr,
  41
  42         -- * Manipulating data constructors and types
  43         applyTypeToArgs, applyTypeToArg,
  44         dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
  45     ) where
  46
  47 #include "HsVersions.h"
  48
  49 import CoreSyn
  50 import PprCore
  51 import Var
  52 import SrcLoc
  53 import VarEnv
  54 import VarSet
  55 import Name
  56 import Module
  57 #if mingw32_TARGET_OS
  58 import Packages
  59 #endif
  60 import Literal
  61 import DataCon
  62 import PrimOp
  63 import Id
  64 import IdInfo
  65 import NewDemand
  66 import Type
  67 import Coercion
  68 import TyCon
  69 import CostCentre
  70 import Unique
  71 import Outputable
  72 import TysPrim
  73 import FastString
  74 import Maybes
  75 import Util
  76 import Data.Word
  77 import Data.Bits
  78 \end{code}
  79
  80
  81 %************************************************************************
  82 %*                                                                      *
  83 \subsection{Find the type of a Core atom/expression}
  84 %*                                                                      *
  85 %************************************************************************
  86
  87 \begin{code}
  88 exprType :: CoreExpr -> Type
  89 -- ^ Recover the type of a well-typed Core expression. Fails when
  90 -- applied to the actual 'CoreSyn.Type' expression as it cannot
  91 -- really be said to have a type
  92 exprType (Var var)           = idType var
  93 exprType (Lit lit)           = literalType lit
  94 exprType (Let _ body)        = exprType body
  95 exprType (Case _ _ ty _)     = ty
  96 exprType (Cast _ co)         = snd (coercionKind co)
  97 exprType (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 -- ^ Returns the type of the alternatives right hand side
 107 coreAltType (_,bs,rhs)
 108   | any bad_binder bs = expandTypeSynonyms ty
 109   | otherwise         = ty    -- Note [Existential variables and silly type synonyms]
 110   where
 111     ty           = exprType rhs
 112     free_tvs     = tyVarsOfType ty
 113     bad_binder b = isTyVar b && b `elemVarSet` free_tvs
 114
 115 coreAltsType :: [CoreAlt] -> Type
 116 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
 117 coreAltsType (alt:_) = coreAltType alt
 118 coreAltsType []      = panic "corAltsType"
 119 \end{code}
 120
 121 Note [Existential variables and silly type synonyms]
 122 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 123 Consider
 124         data T = forall a. T (Funny a)
 125         type Funny a = Bool
 126         f :: T -> Bool
 127         f (T x) = x
 128
 129 Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.
 130 That means that 'exprType' and 'coreAltsType' may give a result that *appears*
 131 to mention an out-of-scope type variable.  See Trac #3409 for a more real-world
 132 example.
 133
 134 Various possibilities suggest themselves:
 135
 136  - Ignore the problem, and make Lint not complain about such variables
 137
 138  - Expand all type synonyms (or at least all those that discard arguments)
 139       This is tricky, because at least for top-level things we want to
 140       retain the type the user originally specified.
 141
 142  - Expand synonyms on the fly, when the problem arises. That is what
 143    we are doing here.  It's not too expensive, I think.
 144
 145 \begin{code}
 146 mkPiType  :: Var   -> Type -> Type
 147 -- ^ Makes a @(->)@ type or a forall type, depending
 148 -- on whether it is given a type variable or a term variable.
 149 mkPiTypes :: [Var] -> Type -> Type
 150 -- ^ 'mkPiType' for multiple type or value arguments
 151
 152 mkPiType v ty
 153    | isId v    = mkFunTy (idType v) ty
 154    | otherwise = mkForAllTy v ty
 155
 156 mkPiTypes vs ty = foldr mkPiType ty vs
 157 \end{code}
 158
 159 \begin{code}
 160 applyTypeToArg :: Type -> CoreExpr -> Type
 161 -- ^ Determines the type resulting from applying an expression to a function with the given type
 162 applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
 163 applyTypeToArg fun_ty _             = funResultTy fun_ty
 164
 165 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 166 -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
 167 -- The first argument is just for debugging, and gives some context
 168 applyTypeToArgs _ op_ty [] = op_ty
 169
 170 applyTypeToArgs e op_ty (Type ty : args)
 171   =     -- Accumulate type arguments so we can instantiate all at once
 172     go [ty] args
 173   where
 174     go rev_tys (Type ty : args) = go (ty:rev_tys) args
 175     go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
 176                                 where
 177                                   op_ty' = applyTysD msg op_ty (reverse rev_tys)
 178                                   msg = ptext (sLit "applyTypeToArgs") <+>
 179                                         panic_msg e op_ty
 180
 181 applyTypeToArgs e op_ty (_ : args)
 182   = case (splitFunTy_maybe op_ty) of
 183         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 184         Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
 185
 186 panic_msg :: CoreExpr -> Type -> SDoc
 187 panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 188 \end{code}
 189
 190 %************************************************************************
 191 %*                                                                      *
 192 \subsection{Attaching notes}
 193 %*                                                                      *
 194 %************************************************************************
 195
 196 mkNote removes redundant coercions, and SCCs where possible
 197
 198 \begin{code}
 199 #ifdef UNUSED
 200 mkNote :: Note -> CoreExpr -> CoreExpr
 201 mkNote (SCC cc) expr               = mkSCC cc expr
 202 mkNote InlineMe expr               = mkInlineMe expr
 203 mkNote note     expr               = Note note expr
 204 #endif
 205 \end{code}
 206
 207 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 208 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 209 not be *applied* to anything.
 210
 211 We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
 212 bindings like
 213         fw = ...
 214         f  = inline_me (coerce t fw)
 215 As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
 216 We want the split, so that the coerces can cancel at the call site.
 217
 218 However, we can get left with tiresome type applications.  Notably, consider
 219         f = /\ a -> let t = e in (t, w)
 220 Then lifting the let out of the big lambda gives
 221         t' = /\a -> e
 222         f = /\ a -> let t = inline_me (t' a) in (t, w)
 223 The inline_me is to stop the simplifier inlining t' right back
 224 into t's RHS.  In the next phase we'll substitute for t (since
 225 its rhs is trivial) and *then* we could get rid of the inline_me.
 226 But it hardly seems worth it, so I don't bother.
 227
 228 \begin{code}
 229 -- | Wraps the given expression in an inlining hint unless the expression
 230 -- is trivial in some sense, so that doing so would usually hurt us
 231 mkInlineMe :: CoreExpr -> CoreExpr
 232 mkInlineMe e@(Var _)           = e
 233 mkInlineMe e@(Note InlineMe _) = e
 234 mkInlineMe e                   = Note InlineMe e
 235 \end{code}
 236
 237 \begin{code}
 238 -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
 239 mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
 240 mkCoerceI IdCo e = e
 241 mkCoerceI (ACo co) e = mkCoerce co e
 242
 243 -- | Wrap the given expression in the coercion safely, coalescing nested coercions
 244 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
 245 mkCoerce co (Cast expr co2)
 246   = ASSERT(let { (from_ty, _to_ty) = coercionKind co;
 247                  (_from_ty2, to_ty2) = coercionKind co2} in
 248            from_ty `coreEqType` to_ty2 )
 249     mkCoerce (mkTransCoercion co2 co) expr
 250
 251 mkCoerce co expr
 252   = let (from_ty, _to_ty) = coercionKind co in
 253 --    if to_ty `coreEqType` from_ty
 254 --    then expr
 255 --    else
 256         ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
 257          (Cast expr co)
 258 \end{code}
 259
 260 \begin{code}
 261 -- | Wraps the given expression in the cost centre unless
 262 -- in a way that maximises their utility to the user
 263 mkSCC :: CostCentre -> Expr b -> Expr b
 264         -- Note: Nested SCC's *are* preserved for the benefit of
 265         --       cost centre stack profiling
 266 mkSCC _  (Lit lit)          = Lit lit
 267 mkSCC cc (Lam x e)          = Lam x (mkSCC cc e)  -- Move _scc_ inside lambda
 268 mkSCC cc (Note (SCC cc') e) = Note (SCC cc) (Note (SCC cc') e)
 269 mkSCC cc (Note n e)         = Note n (mkSCC cc e) -- Move _scc_ inside notes
 270 mkSCC cc (Cast e co)        = Cast (mkSCC cc e) co -- Move _scc_ inside cast
 271 mkSCC cc expr               = Note (SCC cc) expr
 272 \end{code}
 273
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection{Other expression construction}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 \begin{code}
 282 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 283 -- ^ @bindNonRec x r b@ produces either:
 284 --
 285 -- > let x = r in b
 286 --
 287 -- or:
 288 --
 289 -- > case r of x { _DEFAULT_ -> b }
 290 --
 291 -- depending on whether we have to use a @case@ or @let@
 292 -- binding for the expression (see 'needsCaseBinding').
 293 -- It's used by the desugarer to avoid building bindings
 294 -- that give Core Lint a heart attack, although actually
 295 -- the simplifier deals with them perfectly well. See
 296 -- also 'MkCore.mkCoreLet'
 297 bindNonRec bndr rhs body
 298   | needsCaseBinding (idType bndr) rhs = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
 299   | otherwise                          = Let (NonRec bndr rhs) body
 300
 301 -- | Tests whether we have to use a @case@ rather than @let@ binding for this expression
 302 -- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant"
 303 needsCaseBinding :: Type -> CoreExpr -> Bool
 304 needsCaseBinding ty rhs = isUnLiftedType ty && not (exprOkForSpeculation rhs)
 305         -- Make a case expression instead of a let
 306         -- These can arise either from the desugarer,
 307         -- or from beta reductions: (\x.e) (x +# y)
 308 \end{code}
 309
 310 \begin{code}
 311 mkAltExpr :: AltCon     -- ^ Case alternative constructor
 312           -> [CoreBndr] -- ^ Things bound by the pattern match
 313           -> [Type]     -- ^ The type arguments to the case alternative
 314           -> CoreExpr
 315 -- ^ This guy constructs the value that the scrutinee must have
 316 -- given that you are in one particular branch of a case
 317 mkAltExpr (DataAlt con) args inst_tys
 318   = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)
 319 mkAltExpr (LitAlt lit) [] []
 320   = Lit lit
 321 mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
 322 mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
 323 \end{code}
 324
 325
 326 %************************************************************************
 327 %*                                                                      *
 328 \subsection{Taking expressions apart}
 329 %*                                                                      *
 330 %************************************************************************
 331
 332 The default alternative must be first, if it exists at all.
 333 This makes it easy to find, though it makes matching marginally harder.
 334
 335 \begin{code}
 336 -- | Extract the default case alternative
 337 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 338 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)
 339 findDefault alts                        =                     (alts, Nothing)
 340
 341 isDefaultAlt :: CoreAlt -> Bool
 342 isDefaultAlt (DEFAULT, _, _) = True
 343 isDefaultAlt _               = False
 344
 345
 346 -- | Find the case alternative corresponding to a particular
 347 -- constructor: panics if no such constructor exists
 348 findAlt :: AltCon -> [CoreAlt] -> Maybe CoreAlt
 349     -- A "Nothing" result *is* legitmiate
 350     -- See Note [Unreachable code]
 351 findAlt con alts
 352   = case alts of
 353         (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)
 354         _                          -> go alts Nothing
 355   where
 356     go []                     deflt = deflt
 357     go (alt@(con1,_,_) : alts) deflt
 358       = case con `cmpAltCon` con1 of
 359           LT -> deflt   -- Missed it already; the alts are in increasing order
 360           EQ -> Just alt
 361           GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt
 362
 363 ---------------------------------
 364 mergeAlts :: [CoreAlt] -> [CoreAlt] -> [CoreAlt]
 365 -- ^ Merge alternatives preserving order; alternatives in
 366 -- the first argument shadow ones in the second
 367 mergeAlts [] as2 = as2
 368 mergeAlts as1 [] = as1
 369 mergeAlts (a1:as1) (a2:as2)
 370   = case a1 `cmpAlt` a2 of
 371         LT -> a1 : mergeAlts as1      (a2:as2)
 372         EQ -> a1 : mergeAlts as1      as2       -- Discard a2
 373         GT -> a2 : mergeAlts (a1:as1) as2
 374
 375
 376 ---------------------------------
 377 trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]
 378 -- ^ Given:
 379 --
 380 -- > case (C a b x y) of
 381 -- >        C b x y -> ...
 382 --
 383 -- We want to drop the leading type argument of the scrutinee
 384 -- leaving the arguments to match agains the pattern
 385
 386 trimConArgs DEFAULT      args = ASSERT( null args ) []
 387 trimConArgs (LitAlt _)   args = ASSERT( null args ) []
 388 trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
 389 \end{code}
 390
 391 Note [Unreachable code]
 392 ~~~~~~~~~~~~~~~~~~~~~~~
 393 It is possible (although unusual) for GHC to find a case expression
 394 that cannot match.  For example:
 395
 396      data Col = Red | Green | Blue
 397      x = Red
 398      f v = case x of
 399               Red -> ...
 400               _ -> ...(case x of { Green -> e1; Blue -> e2 })...
 401
 402 Suppose that for some silly reason, x isn't substituted in the case
 403 expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff
 404 gets in the way; cf Trac #3118.)  Then the full-lazines pass might produce
 405 this
 406
 407      x = Red
 408      lvl = case x of { Green -> e1; Blue -> e2 })
 409      f v = case x of
 410              Red -> ...
 411              _ -> ...lvl...
 412
 413 Now if x gets inlined, we won't be able to find a matching alternative
 414 for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing
 415 we generate (error "Inaccessible alternative").
 416
 417 Similar things can happen (augmented by GADTs) when the Simplifier
 418 filters down the matching alternatives in Simplify.rebuildCase.
 419
 420
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection{Figuring out things about expressions}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 429                 duplicate; simple variables and constants, and type
 430                 applications.  Note that primop Ids aren't considered
 431                 trivial unless
 432
 433 There used to be a gruesome test for (hasNoBinding v) in the
 434 Var case:
 435         exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0
 436 The idea here is that a constructor worker, like \$wJust, is
 437 really short for (\x -> \$wJust x), becuase \$wJust has no binding.
 438 So it should be treated like a lambda.  Ditto unsaturated primops.
 439 But now constructor workers are not "have-no-binding" Ids.  And
 440 completely un-applied primops and foreign-call Ids are sufficiently
 441 rare that I plan to allow them to be duplicated and put up with
 442 saturating them.
 443
 444 SCC notes.  We do not treat (_scc_ "foo" x) as trivial, because
 445   a) it really generates code, (and a heap object when it's
 446      a function arg) to capture the cost centre
 447   b) see the note [SCC-and-exprIsTrivial] in Simplify.simplLazyBind
 448
 449 \begin{code}
 450 exprIsTrivial :: CoreExpr -> Bool
 451 exprIsTrivial (Var _)          = True        -- See notes above
 452 exprIsTrivial (Type _)         = True
 453 exprIsTrivial (Lit lit)        = litIsTrivial lit
 454 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
 455 exprIsTrivial (Note (SCC _) _) = False       -- See notes above
 456 exprIsTrivial (Note _       e) = exprIsTrivial e
 457 exprIsTrivial (Cast e _)       = exprIsTrivial e
 458 exprIsTrivial (Lam b body)     = not (isRuntimeVar b) && exprIsTrivial body
 459 exprIsTrivial _                = False
 460 \end{code}
 461
 462
 463 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 464                 cost in code size.  This will only happen in different case
 465                 branches, so there's no issue about duplicating work.
 466
 467                 That is, exprIsDupable returns True of (f x) even if
 468                 f is very very expensive to call.
 469
 470                 Its only purpose is to avoid fruitless let-binding
 471                 and then inlining of case join points
 472
 473
 474 \begin{code}
 475 exprIsDupable :: CoreExpr -> Bool
 476 exprIsDupable (Type _)          = True
 477 exprIsDupable (Var _)           = True
 478 exprIsDupable (Lit lit)         = litIsDupable lit
 479 exprIsDupable (Note InlineMe _) = True
 480 exprIsDupable (Note _ e)        = exprIsDupable e
 481 exprIsDupable (Cast e _)        = exprIsDupable e
 482 exprIsDupable expr
 483   = go expr 0
 484   where
 485     go (Var _)   _      = True
 486     go (App f a) n_args =  n_args < dupAppSize
 487                         && exprIsDupable a
 488                         && go f (n_args+1)
 489     go _         _      = False
 490
 491 dupAppSize :: Int
 492 dupAppSize = 4          -- Size of application we are prepared to duplicate
 493 \end{code}
 494
 495 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 496 it is obviously in weak head normal form, or is cheap to get to WHNF.
 497 [Note that that's not the same as exprIsDupable; an expression might be
 498 big, and hence not dupable, but still cheap.]
 499
 500 By ``cheap'' we mean a computation we're willing to:
 501         push inside a lambda, or
 502         inline at more than one place
 503 That might mean it gets evaluated more than once, instead of being
 504 shared.  The main examples of things which aren't WHNF but are
 505 ``cheap'' are:
 506
 507   *     case e of
 508           pi -> ei
 509         (where e, and all the ei are cheap)
 510
 511   *     let x = e in b
 512         (where e and b are cheap)
 513
 514   *     op x1 ... xn
 515         (where op is a cheap primitive operator)
 516
 517   *     error "foo"
 518         (because we are happy to substitute it inside a lambda)
 519
 520 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 521 because sharing will make sure it is only evaluated once.
 522
 523 \begin{code}
 524 exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
 525 exprIsCheap' _          (Lit _)           = True
 526 exprIsCheap' _          (Type _)          = True
 527 exprIsCheap' _          (Var _)           = True
 528 exprIsCheap' _          (Note InlineMe _) = True
 529 exprIsCheap' is_conlike (Note _ e)        = exprIsCheap' is_conlike e
 530 exprIsCheap' is_conlike (Cast e _)        = exprIsCheap' is_conlike e
 531 exprIsCheap' is_conlike (Lam x e)         = isRuntimeVar x
 532                                             || exprIsCheap' is_conlike e
 533 exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e &&
 534                                 and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
 535         -- Experimentally, treat (case x of ...) as cheap
 536         -- (and case __coerce x etc.)
 537         -- This improves arities of overloaded functions where
 538         -- there is only dictionary selection (no construction) involved
 539 exprIsCheap' is_conlike (Let (NonRec x _) e)
 540       | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
 541       | otherwise                 = False
 542         -- strict lets always have cheap right hand sides,
 543         -- and do no allocation.
 544
 545 exprIsCheap' is_conlike other_expr      -- Applications and variables
 546   = go other_expr []
 547   where
 548         -- Accumulate value arguments, then decide
 549     go (App f a) val_args | isRuntimeArg a = go f (a:val_args)
 550                           | otherwise      = go f val_args
 551
 552     go (Var _) [] = True        -- Just a type application of a variable
 553                                 -- (f t1 t2 t3) counts as WHNF
 554     go (Var f) args
 555         = case idDetails f of
 556                 RecSelId {}  -> go_sel args
 557                 ClassOpId _  -> go_sel args
 558                 PrimOpId op  -> go_primop op args
 559
 560                 _ | is_conlike f -> go_pap args
 561                   | length args < idArity f -> go_pap args
 562
 563                 _ -> isBottomingId f
 564                         -- Application of a function which
 565                         -- always gives bottom; we treat this as cheap
 566                         -- because it certainly doesn't need to be shared!
 567
 568     go _ _ = False
 569
 570     --------------
 571     go_pap args = all exprIsTrivial args
 572         -- For constructor applications and primops, check that all
 573         -- the args are trivial.  We don't want to treat as cheap, say,
 574         --      (1:2:3:4:5:[])
 575         -- We'll put up with one constructor application, but not dozens
 576
 577     --------------
 578     go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
 579         -- In principle we should worry about primops
 580         -- that return a type variable, since the result
 581         -- might be applied to something, but I'm not going
 582         -- to bother to check the number of args
 583
 584     --------------
 585     go_sel [arg] = exprIsCheap' is_conlike arg  -- I'm experimenting with making record selection
 586     go_sel _     = False                -- look cheap, so we will substitute it inside a
 587                                         -- lambda.  Particularly for dictionary field selection.
 588                 -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
 589                 --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 590
 591 exprIsCheap :: CoreExpr -> Bool
 592 exprIsCheap = exprIsCheap' isDataConWorkId
 593
 594 exprIsExpandable :: CoreExpr -> Bool
 595 exprIsExpandable = exprIsCheap' isConLikeId
 596 \end{code}
 597
 598 \begin{code}
 599 -- | 'exprOkForSpeculation' returns True of an expression that is:
 600 --
 601 --  * Safe to evaluate even if normal order eval might not
 602 --    evaluate the expression at all, or
 603 --
 604 --  * Safe /not/ to evaluate even if normal order would do so
 605 --
 606 -- Precisely, it returns @True@ iff:
 607 --
 608 --  * The expression guarantees to terminate,
 609 --
 610 --  * soon,
 611 --
 612 --  * without raising an exception,
 613 --
 614 --  * without causing a side effect (e.g. writing a mutable variable)
 615 --
 616 -- Note that if @exprIsHNF e@, then @exprOkForSpecuation e@.
 617 -- As an example of the considerations in this test, consider:
 618 --
 619 -- > let x = case y# +# 1# of { r# -> I# r# }
 620 -- > in E
 621 --
 622 -- being translated to:
 623 --
 624 -- > case y# +# 1# of { r# ->
 625 -- >    let x = I# r#
 626 -- >    in E
 627 -- > }
 628 --
 629 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 630 -- side effects, and can't diverge or raise an exception.
 631 exprOkForSpeculation :: CoreExpr -> Bool
 632 exprOkForSpeculation (Lit _)     = True
 633 exprOkForSpeculation (Type _)    = True
 634     -- Tick boxes are *not* suitable for speculation
 635 exprOkForSpeculation (Var v)     = isUnLiftedType (idType v)
 636                                  && not (isTickBoxOp v)
 637 exprOkForSpeculation (Note _ e)  = exprOkForSpeculation e
 638 exprOkForSpeculation (Cast e _)  = exprOkForSpeculation e
 639 exprOkForSpeculation other_expr
 640   = case collectArgs other_expr of
 641         (Var f, args) -> spec_ok (idDetails f) args
 642         _             -> False
 643
 644   where
 645     spec_ok (DataConWorkId _) _
 646       = True    -- The strictness of the constructor has already
 647                 -- been expressed by its "wrapper", so we don't need
 648                 -- to take the arguments into account
 649
 650     spec_ok (PrimOpId op) args
 651       | isDivOp op,             -- Special case for dividing operations that fail
 652         [arg1, Lit lit] <- args -- only if the divisor is zero
 653       = not (isZeroLit lit) && exprOkForSpeculation arg1
 654                 -- Often there is a literal divisor, and this
 655                 -- can get rid of a thunk in an inner looop
 656
 657       | otherwise
 658       = primOpOkForSpeculation op &&
 659         all exprOkForSpeculation args
 660                                 -- A bit conservative: we don't really need
 661                                 -- to care about lazy arguments, but this is easy
 662
 663     spec_ok _ _ = False
 664
 665 -- | True of dyadic operators that can fail only if the second arg is zero!
 666 isDivOp :: PrimOp -> Bool
 667 -- This function probably belongs in PrimOp, or even in
 668 -- an automagically generated file.. but it's such a
 669 -- special case I thought I'd leave it here for now.
 670 isDivOp IntQuotOp        = True
 671 isDivOp IntRemOp         = True
 672 isDivOp WordQuotOp       = True
 673 isDivOp WordRemOp        = True
 674 isDivOp FloatDivOp       = True
 675 isDivOp DoubleDivOp      = True
 676 isDivOp _                = False
 677 \end{code}
 678
 679 \begin{code}
 680 -- | True of expressions that are guaranteed to diverge upon execution
 681 exprIsBottom :: CoreExpr -> Bool
 682 exprIsBottom e = go 0 e
 683                where
 684                 -- n is the number of args
 685                  go n (Note _ e)     = go n e
 686                  go n (Cast e _)     = go n e
 687                  go n (Let _ e)      = go n e
 688                  go _ (Case e _ _ _) = go 0 e   -- Just check the scrut
 689                  go n (App e _)      = go (n+1) e
 690                  go n (Var v)        = idAppIsBottom v n
 691                  go _ (Lit _)        = False
 692                  go _ (Lam _ _)      = False
 693                  go _ (Type _)       = False
 694
 695 idAppIsBottom :: Id -> Int -> Bool
 696 idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 697 \end{code}
 698
 699 \begin{code}
 700
 701 -- | This returns true for expressions that are certainly /already/
 702 -- evaluated to /head/ normal form.  This is used to decide whether it's ok
 703 -- to change:
 704 --
 705 -- > case x of _ -> e
 706 --
 707 -- into:
 708 --
 709 -- > e
 710 --
 711 -- and to decide whether it's safe to discard a 'seq'.
 712 -- So, it does /not/ treat variables as evaluated, unless they say they are.
 713 -- However, it /does/ treat partial applications and constructor applications
 714 -- as values, even if their arguments are non-trivial, provided the argument
 715 -- type is lifted. For example, both of these are values:
 716 --
 717 -- > (:) (f x) (map f xs)
 718 -- > map (...redex...)
 719 --
 720 -- Because 'seq' on such things completes immediately.
 721 --
 722 -- For unlifted argument types, we have to be careful:
 723 --
 724 -- > C (f x :: Int#)
 725 --
 726 -- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't
 727 -- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
 728 -- unboxed type must be ok-for-speculation (or trivial).
 729 exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP
 730 exprIsHNF (Var v)       -- NB: There are no value args at this point
 731   =  isDataConWorkId v  -- Catches nullary constructors,
 732                         --      so that [] and () are values, for example
 733   || idArity v > 0      -- Catches (e.g.) primops that don't have unfoldings
 734   || isEvaldUnfolding (idUnfolding v)
 735         -- Check the thing's unfolding; it might be bound to a value
 736         -- A worry: what if an Id's unfolding is just itself:
 737         -- then we could get an infinite loop...
 738
 739 exprIsHNF (Lit _)          = True
 740 exprIsHNF (Type _)         = True       -- Types are honorary Values;
 741                                         -- we don't mind copying them
 742 exprIsHNF (Lam b e)        = isRuntimeVar b || exprIsHNF e
 743 exprIsHNF (Note _ e)       = exprIsHNF e
 744 exprIsHNF (Cast e _)       = exprIsHNF e
 745 exprIsHNF (App e (Type _)) = exprIsHNF e
 746 exprIsHNF (App e a)        = app_is_value e [a]
 747 exprIsHNF _                = False
 748
 749 -- There is at least one value argument
 750 app_is_value :: CoreExpr -> [CoreArg] -> Bool
 751 app_is_value (Var fun) args
 752   = idArity fun > valArgCount args      -- Under-applied function
 753     ||  isDataConWorkId fun             --  or data constructor
 754 app_is_value (Note _ f) as = app_is_value f as
 755 app_is_value (Cast f _) as = app_is_value f as
 756 app_is_value (App f a)  as = app_is_value f (a:as)
 757 app_is_value _          _  = False
 758 \end{code}
 759
 760 These InstPat functions go here to avoid circularity between DataCon and Id
 761
 762 \begin{code}
 763 dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
 764 dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
 765
 766 dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
 767 dataConRepFSInstPat = dataConInstPat dataConRepArgTys
 768 dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat ((fsLit "ipv")))
 769   where
 770     dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
 771         -- Remember to include the existential dictionaries
 772
 773 dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 774                   -> [FastString]          -- A long enough list of FSs to use for names
 775                   -> [Unique]              -- An equally long list of uniques, at least one for each binder
 776                   -> DataCon
 777                   -> [Type]                -- Types to instantiate the universally quantified tyvars
 778                -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
 779 -- dataConInstPat arg_fun fss us con inst_tys returns a triple
 780 -- (ex_tvs, co_tvs, arg_ids),
 781 --
 782 --   ex_tvs are intended to be used as binders for existential type args
 783 --
 784 --   co_tvs are intended to be used as binders for coercion args and the kinds
 785 --     of these vars have been instantiated by the inst_tys and the ex_tys
 786 --     The co_tvs include both GADT equalities (dcEqSpec) and
 787 --     programmer-specified equalities (dcEqTheta)
 788 --
 789 --   arg_ids are indended to be used as binders for value arguments,
 790 --     and their types have been instantiated with inst_tys and ex_tys
 791 --     The arg_ids include both dicts (dcDictTheta) and
 792 --     programmer-specified arguments (after rep-ing) (deRepArgTys)
 793 --
 794 -- Example.
 795 --  The following constructor T1
 796 --
 797 --  data T a where
 798 --    T1 :: forall b. Int -> b -> T(a,b)
 799 --    ...
 800 --
 801 --  has representation type
 802 --   forall a. forall a1. forall b. (a ~ (a1,b)) =>
 803 --     Int -> b -> T a
 804 --
 805 --  dataConInstPat fss us T1 (a1',b') will return
 806 --
 807 --  ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
 808 --
 809 --  where the double-primed variables are created with the FastStrings and
 810 --  Uniques given as fss and us
 811 dataConInstPat arg_fun fss uniqs con inst_tys
 812   = (ex_bndrs, co_bndrs, arg_ids)
 813   where
 814     univ_tvs = dataConUnivTyVars con
 815     ex_tvs   = dataConExTyVars con
 816     arg_tys  = arg_fun con
 817     eq_spec  = dataConEqSpec con
 818     eq_theta = dataConEqTheta con
 819     eq_preds = eqSpecPreds eq_spec ++ eq_theta
 820
 821     n_ex = length ex_tvs
 822     n_co = length eq_preds
 823
 824       -- split the Uniques and FastStrings
 825     (ex_uniqs, uniqs')   = splitAt n_ex uniqs
 826     (co_uniqs, id_uniqs) = splitAt n_co uniqs'
 827
 828     (ex_fss, fss')     = splitAt n_ex fss
 829     (co_fss, id_fss)   = splitAt n_co fss'
 830
 831       -- Make existential type variables
 832     ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
 833     mk_ex_var uniq fs var = mkTyVar new_name kind
 834       where
 835         new_name = mkSysTvName uniq fs
 836         kind     = tyVarKind var
 837
 838       -- Make the instantiating substitution
 839     subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 840
 841       -- Make new coercion vars, instantiating kind
 842     co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
 843     mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
 844        where
 845          new_name = mkSysTvName uniq fs
 846          co_kind  = substTy subst (mkPredTy eq_pred)
 847
 848       -- make value vars, instantiating types
 849     mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
 850     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
 851
 852 -- | Returns @Just (dc, [x1..xn])@ if the argument expression is
 853 -- a constructor application of the form @dc x1 .. xn@
 854 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 855 exprIsConApp_maybe (Cast expr co)
 856   =     -- Here we do the KPush reduction rule as described in the FC paper
 857     case exprIsConApp_maybe expr of {
 858         Nothing            -> Nothing ;
 859         Just (dc, dc_args) ->
 860
 861         -- The transformation applies iff we have
 862         --      (C e1 ... en) `cast` co
 863         -- where co :: (T t1 .. tn) ~ (T s1 ..sn)
 864         -- That is, with a T at the top of both sides
 865         -- The left-hand one must be a T, because exprIsConApp returned True
 866         -- but the right-hand one might not be.  (Though it usually will.)
 867
 868     let (from_ty, to_ty)           = coercionKind co
 869         (from_tc, from_tc_arg_tys) = splitTyConApp from_ty
 870                 -- The inner one must be a TyConApp
 871     in
 872     case splitTyConApp_maybe to_ty of {
 873         Nothing -> Nothing ;
 874         Just (to_tc, to_tc_arg_tys)
 875                 | from_tc /= to_tc -> Nothing
 876                 -- These two Nothing cases are possible; we might see
 877                 --      (C x y) `cast` (g :: T a ~ S [a]),
 878                 -- where S is a type function.  In fact, exprIsConApp
 879                 -- will probably not be called in such circumstances,
 880                 -- but there't nothing wrong with it
 881
 882                 | otherwise  ->
 883     let
 884         tc_arity = tyConArity from_tc
 885
 886         (univ_args, rest1)        = splitAt tc_arity dc_args
 887         (ex_args, rest2)          = splitAt n_ex_tvs rest1
 888         (co_args_spec, rest3)     = splitAt n_cos_spec rest2
 889         (co_args_theta, val_args) = splitAt n_cos_theta rest3
 890
 891         arg_tys             = dataConRepArgTys dc
 892         dc_univ_tyvars      = dataConUnivTyVars dc
 893         dc_ex_tyvars        = dataConExTyVars dc
 894         dc_eq_spec          = dataConEqSpec dc
 895         dc_eq_theta         = dataConEqTheta dc
 896         dc_tyvars           = dc_univ_tyvars ++ dc_ex_tyvars
 897         n_ex_tvs            = length dc_ex_tyvars
 898         n_cos_spec          = length dc_eq_spec
 899         n_cos_theta         = length dc_eq_theta
 900
 901         -- Make the "theta" from Fig 3 of the paper
 902         gammas              = decomposeCo tc_arity co
 903         new_tys             = gammas ++ map (\ (Type t) -> t) ex_args
 904         theta               = zipOpenTvSubst dc_tyvars new_tys
 905
 906           -- First we cast the existential coercion arguments
 907         cast_co_spec (tv, ty) co
 908           = cast_co_theta (mkEqPred (mkTyVarTy tv, ty)) co
 909         cast_co_theta eqPred (Type co)
 910           | (ty1, ty2) <- getEqPredTys eqPred
 911           = Type $ mkSymCoercion (substTy theta ty1)
 912                    `mkTransCoercion` co
 913                    `mkTransCoercion` (substTy theta ty2)
 914         new_co_args = zipWith cast_co_spec  dc_eq_spec  co_args_spec ++
 915                       zipWith cast_co_theta dc_eq_theta co_args_theta
 916
 917           -- ...and now value arguments
 918         new_val_args = zipWith cast_arg arg_tys val_args
 919         cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
 920
 921     in
 922     ASSERT( length univ_args == tc_arity )
 923     ASSERT( from_tc == dataConTyCon dc )
 924     ASSERT( and (zipWith coreEqType [t | Type t <- univ_args] from_tc_arg_tys) )
 925     ASSERT( all isTypeArg (univ_args ++ ex_args) )
 926     ASSERT2( equalLength val_args arg_tys, ppr dc $$ ppr dc_tyvars $$ ppr dc_ex_tyvars $$ ppr arg_tys $$ ppr dc_args $$ ppr univ_args $$ ppr ex_args $$ ppr val_args $$ ppr arg_tys  )
 927
 928     Just (dc, map Type to_tc_arg_tys ++ ex_args ++ new_co_args ++ new_val_args)
 929     }}
 930
 931 {-
 932 -- We do not want to tell the world that we have a
 933 -- Cons, to *stop* Case of Known Cons, which removes
 934 -- the TickBox.
 935 exprIsConApp_maybe (Note (TickBox {}) expr)
 936   = Nothing
 937 exprIsConApp_maybe (Note (BinaryTickBox {}) expr)
 938   = Nothing
 939 -}
 940
 941 exprIsConApp_maybe (Note _ expr)
 942   = exprIsConApp_maybe expr
 943     -- We ignore InlineMe notes in case we have
 944     --  x = __inline_me__ (a,b)
 945     -- All part of making sure that INLINE pragmas never hurt
 946     -- Marcin tripped on this one when making dictionaries more inlinable
 947     --
 948     -- In fact, we ignore all notes.  For example,
 949     --          case _scc_ "foo" (C a b) of
 950     --                  C a b -> e
 951     -- should be optimised away, but it will be only if we look
 952     -- through the SCC note.
 953
 954 exprIsConApp_maybe expr = analyse (collectArgs expr)
 955   where
 956     analyse (Var fun, args)
 957         | Just con <- isDataConWorkId_maybe fun,
 958           args `lengthAtLeast` dataConRepArity con
 959                 -- Might be > because the arity excludes type args
 960         = Just (con,args)
 961
 962         -- Look through unfoldings, but only cheap ones, because
 963         -- we are effectively duplicating the unfolding
 964     analyse (Var fun, [])
 965         | let unf = idUnfolding fun,
 966           isExpandableUnfolding unf
 967         = exprIsConApp_maybe (unfoldingTemplate unf)
 968
 969     analyse _ = Nothing
 970 \end{code}
 971
 972
 973
 974 %************************************************************************
 975 %*                                                                      *
 976 \subsection{Equality}
 977 %*                                                                      *
 978 %************************************************************************
 979
 980 \begin{code}
 981 -- | A cheap equality test which bales out fast!
 982 --      If it returns @True@ the arguments are definitely equal,
 983 --      otherwise, they may or may not be equal.
 984 --
 985 -- See also 'exprIsBig'
 986 cheapEqExpr :: Expr b -> Expr b -> Bool
 987
 988 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 989 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 990 cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
 991
 992 cheapEqExpr (App f1 a1) (App f2 a2)
 993   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 994
 995 cheapEqExpr (Cast e1 t1) (Cast e2 t2)
 996   = e1 `cheapEqExpr` e2 && t1 `coreEqCoercion` t2
 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 _)      = False
1004 exprIsBig (Type _)     = False
1005 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
1006 exprIsBig (Cast e _)   = exprIsBig e    -- Hopefully coercions are not too big!
1007 exprIsBig _            = True
1008 \end{code}
1009
1010
1011
1012 %************************************************************************
1013 %*                                                                      *
1014 \subsection{The size of an expression}
1015 %*                                                                      *
1016 %************************************************************************
1017
1018 \begin{code}
1019 coreBindsSize :: [CoreBind] -> Int
1020 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
1021
1022 exprSize :: CoreExpr -> Int
1023 -- ^ A measure of the size of the expressions, strictly greater than 0
1024 -- It also forces the expression pretty drastically as a side effect
1025 exprSize (Var v)         = v `seq` 1
1026 exprSize (Lit lit)       = lit `seq` 1
1027 exprSize (App f a)       = exprSize f + exprSize a
1028 exprSize (Lam b e)       = varSize b + exprSize e
1029 exprSize (Let b e)       = bindSize b + exprSize e
1030 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
1031 exprSize (Cast e co)     = (seqType co `seq` 1) + exprSize e
1032 exprSize (Note n e)      = noteSize n + exprSize e
1033 exprSize (Type t)        = seqType t `seq` 1
1034
1035 noteSize :: Note -> Int
1036 noteSize (SCC cc)       = cc `seq` 1
1037 noteSize InlineMe       = 1
1038 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
1039
1040 varSize :: Var -> Int
1041 varSize b  | isTyVar b = 1
1042            | otherwise = seqType (idType b)             `seq`
1043                          megaSeqIdInfo (idInfo b)       `seq`
1044                          1
1045
1046 varsSize :: [Var] -> Int
1047 varsSize = sum . map varSize
1048
1049 bindSize :: CoreBind -> Int
1050 bindSize (NonRec b e) = varSize b + exprSize e
1051 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
1052
1053 pairSize :: (Var, CoreExpr) -> Int
1054 pairSize (b,e) = varSize b + exprSize e
1055
1056 altSize :: CoreAlt -> Int
1057 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
1058 \end{code}
1059
1060
1061 %************************************************************************
1062 %*                                                                      *
1063 \subsection{Hashing}
1064 %*                                                                      *
1065 %************************************************************************
1066
1067 \begin{code}
1068 hashExpr :: CoreExpr -> Int
1069 -- ^ Two expressions that hash to the same @Int@ may be equal (but may not be)
1070 -- Two expressions that hash to the different Ints are definitely unequal.
1071 --
1072 -- The emphasis is on a crude, fast hash, rather than on high precision.
1073 --
1074 -- But unequal here means \"not identical\"; two alpha-equivalent
1075 -- expressions may hash to the different Ints.
1076 --
1077 -- We must be careful that @\\x.x@ and @\\y.y@ map to the same hash code,
1078 -- (at least if we want the above invariant to be true).
1079
1080 hashExpr e = fromIntegral (hash_expr (1,emptyVarEnv) e .&. 0x7fffffff)
1081              -- UniqFM doesn't like negative Ints
1082
1083 type HashEnv = (Int, VarEnv Int)  -- Hash code for bound variables
1084
1085 hash_expr :: HashEnv -> CoreExpr -> Word32
1086 -- Word32, because we're expecting overflows here, and overflowing
1087 -- signed types just isn't cool.  In C it's even undefined.
1088 hash_expr env (Note _ e)              = hash_expr env e
1089 hash_expr env (Cast e _)              = hash_expr env e
1090 hash_expr env (Var v)                 = hashVar env v
1091 hash_expr _   (Lit lit)               = fromIntegral (hashLiteral lit)
1092 hash_expr env (App f e)               = hash_expr env f * fast_hash_expr env e
1093 hash_expr env (Let (NonRec b r) e)    = hash_expr (extend_env env b) e * fast_hash_expr env r
1094 hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
1095 hash_expr env (Case e _ _ _)          = hash_expr env e
1096 hash_expr env (Lam b e)               = hash_expr (extend_env env b) e
1097 hash_expr _   (Type _)                = WARN(True, text "hash_expr: type") 1
1098 -- Shouldn't happen.  Better to use WARN than trace, because trace
1099 -- prevents the CPR optimisation kicking in for hash_expr.
1100
1101 fast_hash_expr :: HashEnv -> CoreExpr -> Word32
1102 fast_hash_expr env (Var v)      = hashVar env v
1103 fast_hash_expr env (Type t)     = fast_hash_type env t
1104 fast_hash_expr _   (Lit lit)    = fromIntegral (hashLiteral lit)
1105 fast_hash_expr env (Cast e _)   = fast_hash_expr env e
1106 fast_hash_expr env (Note _ e)   = fast_hash_expr env e
1107 fast_hash_expr env (App _ a)    = fast_hash_expr env a  -- A bit idiosyncratic ('a' not 'f')!
1108 fast_hash_expr _   _            = 1
1109
1110 fast_hash_type :: HashEnv -> Type -> Word32
1111 fast_hash_type env ty
1112   | Just tv <- getTyVar_maybe ty            = hashVar env tv
1113   | Just (tc,tys) <- splitTyConApp_maybe ty = let hash_tc = fromIntegral (hashName (tyConName tc))
1114                                               in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
1115   | otherwise                               = 1
1116
1117 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
1118 extend_env (n,env) b = (n+1, extendVarEnv env b n)
1119
1120 hashVar :: HashEnv -> Var -> Word32
1121 hashVar (_,env) v
1122  = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
1123 \end{code}
1124
1125 %************************************************************************
1126 %*                                                                      *
1127 \subsection{Determining non-updatable right-hand-sides}
1128 %*                                                                      *
1129 %************************************************************************
1130
1131 Top-level constructor applications can usually be allocated
1132 statically, but they can't if the constructor, or any of the
1133 arguments, come from another DLL (because we can't refer to static
1134 labels in other DLLs).
1135
1136 If this happens we simply make the RHS into an updatable thunk,
1137 and 'execute' it rather than allocating it statically.
1138
1139 \begin{code}
1140 -- | This function is called only on *top-level* right-hand sides.
1141 -- Returns @True@ if the RHS can be allocated statically in the output,
1142 -- with no thunks involved at all.
1143 rhsIsStatic :: PackageId -> CoreExpr -> Bool
1144 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
1145 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
1146 -- update flag on it and (iii) in DsExpr to decide how to expand
1147 -- list literals
1148 --
1149 -- The basic idea is that rhsIsStatic returns True only if the RHS is
1150 --      (a) a value lambda
1151 --      (b) a saturated constructor application with static args
1152 --
1153 -- BUT watch out for
1154 --  (i) Any cross-DLL references kill static-ness completely
1155 --      because they must be 'executed' not statically allocated
1156 --      ("DLL" here really only refers to Windows DLLs, on other platforms,
1157 --      this is not necessary)
1158 --
1159 -- (ii) We treat partial applications as redexes, because in fact we
1160 --      make a thunk for them that runs and builds a PAP
1161 --      at run-time.  The only appliations that are treated as
1162 --      static are *saturated* applications of constructors.
1163
1164 -- We used to try to be clever with nested structures like this:
1165 --              ys = (:) w ((:) w [])
1166 -- on the grounds that CorePrep will flatten ANF-ise it later.
1167 -- But supporting this special case made the function much more
1168 -- complicated, because the special case only applies if there are no
1169 -- enclosing type lambdas:
1170 --              ys = /\ a -> Foo (Baz ([] a))
1171 -- Here the nested (Baz []) won't float out to top level in CorePrep.
1172 --
1173 -- But in fact, even without -O, nested structures at top level are
1174 -- flattened by the simplifier, so we don't need to be super-clever here.
1175 --
1176 -- Examples
1177 --
1178 --      f = \x::Int. x+7        TRUE
1179 --      p = (True,False)        TRUE
1180 --
1181 --      d = (fst p, False)      FALSE because there's a redex inside
1182 --                              (this particular one doesn't happen but...)
1183 --
1184 --      h = D# (1.0## /## 2.0##)        FALSE (redex again)
1185 --      n = /\a. Nil a                  TRUE
1186 --
1187 --      t = /\a. (:) (case w a of ...) (Nil a)  FALSE (redex)
1188 --
1189 --
1190 -- This is a bit like CoreUtils.exprIsHNF, with the following differences:
1191 --    a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
1192 --
1193 --    b) (C x xs), where C is a contructors is updatable if the application is
1194 --         dynamic
1195 --
1196 --    c) don't look through unfolding of f in (f x).
1197
1198 rhsIsStatic _this_pkg rhs = is_static False rhs
1199   where
1200   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
1201           -> CoreExpr -> Bool
1202
1203   is_static False (Lam b e) = isRuntimeVar b || is_static False e
1204
1205   is_static _      (Note (SCC _) _) = False
1206   is_static in_arg (Note _ e)       = is_static in_arg e
1207   is_static in_arg (Cast e _)       = is_static in_arg e
1208
1209   is_static _      (Lit lit)
1210     = case lit of
1211         MachLabel _ _ _ -> False
1212         _             -> True
1213         -- A MachLabel (foreign import "&foo") in an argument
1214         -- prevents a constructor application from being static.  The
1215         -- reason is that it might give rise to unresolvable symbols
1216         -- in the object file: under Linux, references to "weak"
1217         -- symbols from the data segment give rise to "unresolvable
1218         -- relocation" errors at link time This might be due to a bug
1219         -- in the linker, but we'll work around it here anyway.
1220         -- SDM 24/2/2004
1221
1222   is_static in_arg other_expr = go other_expr 0
1223    where
1224     go (Var f) n_val_args
1225 #if mingw32_TARGET_OS
1226         | not (isDllName _this_pkg (idName f))
1227 #endif
1228         =  saturated_data_con f n_val_args
1229         || (in_arg && n_val_args == 0)
1230                 -- A naked un-applied variable is *not* deemed a static RHS
1231                 -- E.g.         f = g
1232                 -- Reason: better to update so that the indirection gets shorted
1233                 --         out, and the true value will be seen
1234                 -- NB: if you change this, you'll break the invariant that THUNK_STATICs
1235                 --     are always updatable.  If you do so, make sure that non-updatable
1236                 --     ones have enough space for their static link field!
1237
1238     go (App f a) n_val_args
1239         | isTypeArg a                    = go f n_val_args
1240         | not in_arg && is_static True a = go f (n_val_args + 1)
1241         -- The (not in_arg) checks that we aren't in a constructor argument;
1242         -- if we are, we don't allow (value) applications of any sort
1243         --
1244         -- NB. In case you wonder, args are sometimes not atomic.  eg.
1245         --   x = D# (1.0## /## 2.0##)
1246         -- can't float because /## can fail.
1247
1248     go (Note (SCC _) _) _          = False
1249     go (Note _ f)       n_val_args = go f n_val_args
1250     go (Cast e _)       n_val_args = go e n_val_args
1251
1252     go _                _          = False
1253
1254     saturated_data_con f n_val_args
1255         = case isDataConWorkId_maybe f of
1256             Just dc -> n_val_args == dataConRepArity dc
1257             Nothing -> False
1258 \end{code}