ghc/compiler/coreSyn/CoreUtils.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CoreUtils]{Utility functions on @Core@ syntax}
   5
   6 \begin{code}
   7 module CoreUtils (
   8         -- Construction
   9         mkNote, mkInlineMe, mkSCC, mkCoerce,
  10         bindNonRec, mkIfThenElse, mkAltExpr,
  11
  12         -- Properties of expressions
  13         exprType, coreAltsType, exprArity,
  14         exprIsBottom, exprIsDupable, exprIsTrivial, exprIsCheap,
  15         exprIsValue,exprOkForSpeculation, exprIsBig,
  16         exprIsConApp_maybe,
  17         idAppIsBottom, idAppIsCheap,
  18
  19         -- Expr transformation
  20         etaReduceExpr, exprEtaExpandArity,
  21
  22         -- Size
  23         coreBindsSize,
  24
  25         -- Hashing
  26         hashExpr,
  27
  28         -- Equality
  29         cheapEqExpr, eqExpr, applyTypeToArgs
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34
  35 import GlaExts          -- For `xori`
  36
  37 import CoreSyn
  38 import CoreFVs          ( exprFreeVars )
  39 import PprCore          ( pprCoreExpr )
  40 import Var              ( Var, isId, isTyVar )
  41 import VarSet
  42 import VarEnv
  43 import Name             ( isLocallyDefined, hashName )
  44 import Literal          ( Literal, hashLiteral, literalType )
  45 import DataCon          ( DataCon, dataConRepArity )
  46 import PrimOp           ( primOpOkForSpeculation, primOpIsCheap,
  47                           primOpIsDupable )
  48 import Id               ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
  49                           mkWildId, idArity, idName, idUnfolding, idInfo,
  50                           isDataConId_maybe, isPrimOpId_maybe
  51                         )
  52 import IdInfo           ( arityLowerBound, InlinePragInfo(..),
  53                           LBVarInfo(..),
  54                           IdFlavour(..),
  55                           megaSeqIdInfo )
  56 import Demand           ( appIsBottom )
  57 import Type             ( Type, mkFunTy, mkForAllTy,
  58                           splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
  59                           isNotUsgTy, mkUsgTy, unUsgTy, UsageAnn(..),
  60                           applyTys, isUnLiftedType, seqType
  61                         )
  62 import TysWiredIn       ( boolTy, stringTy, trueDataCon, falseDataCon )
  63 import CostCentre       ( CostCentre )
  64 import Unique           ( buildIdKey, augmentIdKey )
  65 import Util             ( zipWithEqual, mapAccumL )
  66 import Maybes           ( maybeToBool )
  67 import Outputable
  68 import TysPrim          ( alphaTy )     -- Debugging only
  69 \end{code}
  70
  71
  72 %************************************************************************
  73 %*                                                                      *
  74 \subsection{Find the type of a Core atom/expression}
  75 %*                                                                      *
  76 %************************************************************************
  77
  78 \begin{code}
  79 exprType :: CoreExpr -> Type
  80
  81 exprType (Var var)              = idType var
  82 exprType (Lit lit)              = literalType lit
  83 exprType (Let _ body)           = exprType body
  84 exprType (Case _ _ alts)        = coreAltsType alts
  85 exprType (Note (Coerce ty _) e) = ty  -- **! should take usage from e
  86 exprType (Note (TermUsg u) e)   = mkUsgTy u (unUsgTy (exprType e))
  87 exprType (Note other_note e)    = exprType e
  88 exprType (Lam binder expr)
  89   | isId binder    = (case idLBVarInfo binder of
  90                        IsOneShotLambda -> mkUsgTy UsOnce
  91                        otherwise       -> id) $
  92                      idType binder `mkFunTy` exprType expr
  93   | isTyVar binder = mkForAllTy binder (exprType expr)
  94
  95 exprType e@(App _ _)
  96   = case collectArgs e of
  97         (fun, args) -> applyTypeToArgs e (exprType fun) args
  98
  99 exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy
 100
 101 coreAltsType :: [CoreAlt] -> Type
 102 coreAltsType ((_,_,rhs) : _) = exprType rhs
 103 \end{code}
 104
 105 \begin{code}
 106 -- The first argument is just for debugging
 107 applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
 108 applyTypeToArgs e op_ty [] = op_ty
 109
 110 applyTypeToArgs e op_ty (Type ty : args)
 111   =     -- Accumulate type arguments so we can instantiate all at once
 112     ASSERT2( all isNotUsgTy tys,
 113              ppr e <+> text "of" <+> ppr op_ty <+> text "to" <+>
 114              ppr (Type ty : args) <+> text "i.e." <+> ppr tys )
 115     applyTypeToArgs e (applyTys op_ty tys) rest_args
 116   where
 117     (tys, rest_args)        = go [ty] args
 118     go tys (Type ty : args) = go (ty:tys) args
 119     go tys rest_args        = (reverse tys, rest_args)
 120
 121 applyTypeToArgs e op_ty (other_arg : args)
 122   = case (splitFunTy_maybe op_ty) of
 123         Just (_, res_ty) -> applyTypeToArgs e res_ty args
 124         Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e)
 125 \end{code}
 126
 127
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection{Attaching notes}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 mkNote removes redundant coercions, and SCCs where possible
 136
 137 \begin{code}
 138 mkNote :: Note -> CoreExpr -> CoreExpr
 139 mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
 140 mkNote (SCC cc) expr               = mkSCC cc expr
 141 mkNote InlineMe expr               = mkInlineMe expr
 142 mkNote note     expr               = Note note expr
 143
 144 -- Slide InlineCall in around the function
 145 --      No longer necessary I think (SLPJ Apr 99)
 146 -- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
 147 -- mkNote InlineCall (Var v)   = Note InlineCall (Var v)
 148 -- mkNote InlineCall expr      = expr
 149 \end{code}
 150
 151 Drop trivial InlineMe's.  This is somewhat important, because if we have an unfolding
 152 that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
 153 not be *applied* to anything.
 154
 155 \begin{code}
 156 mkInlineMe e | exprIsTrivial e = e
 157              | otherwise       = Note InlineMe e
 158 \end{code}
 159
 160
 161
 162 \begin{code}
 163 mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
 164
 165 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 166   = ASSERT( from_ty == to_ty2 )
 167     mkCoerce to_ty from_ty2 expr
 168
 169 mkCoerce to_ty from_ty expr
 170   | to_ty == from_ty = expr
 171   | otherwise        = ASSERT( from_ty == exprType expr )
 172                        Note (Coerce to_ty from_ty) expr
 173 \end{code}
 174
 175 \begin{code}
 176 mkSCC :: CostCentre -> Expr b -> Expr b
 177         -- Note: Nested SCC's *are* preserved for the benefit of
 178         --       cost centre stack profiling (Durham)
 179
 180 mkSCC cc (Lit lit) = Lit lit
 181 mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
 182 mkSCC cc expr      = Note (SCC cc) expr
 183 \end{code}
 184
 185
 186 %************************************************************************
 187 %*                                                                      *
 188 \subsection{Other expression construction}
 189 %*                                                                      *
 190 %************************************************************************
 191
 192 \begin{code}
 193 bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 194 -- (bindNonRec x r b) produces either
 195 --      let x = r in b
 196 -- or
 197 --      case r of x { _DEFAULT_ -> b }
 198 --
 199 -- depending on whether x is unlifted or not
 200 -- It's used by the desugarer to avoid building bindings
 201 -- that give Core Lint a heart attack.  Actually the simplifier
 202 -- deals with them perfectly well.
 203 bindNonRec bndr rhs body
 204   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 205   | otherwise                    = Let (NonRec bndr rhs) body
 206 \end{code}
 207
 208 \begin{code}
 209 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 210         -- This guy constructs the value that the scrutinee must have
 211         -- when you are in one particular branch of a case
 212 mkAltExpr (DataAlt con) args inst_tys
 213   = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
 214 mkAltExpr (LitAlt lit) [] []
 215   = Lit lit
 216
 217 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 218 mkIfThenElse guard then_expr else_expr
 219   = Case guard (mkWildId boolTy)
 220          [ (DataAlt trueDataCon,  [], then_expr),
 221            (DataAlt falseDataCon, [], else_expr) ]
 222 \end{code}
 223
 224 %************************************************************************
 225 %*                                                                      *
 226 \subsection{Figuring out things about expressions}
 227 %*                                                                      *
 228 %************************************************************************
 229
 230 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 231                 duplicate; simple variables and constants, and type
 232                 applications.  Note that primop Ids aren't considered
 233                 trivial unless
 234
 235 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 236
 237
 238 \begin{code}
 239 exprIsTrivial (Var v)
 240   | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
 241   | otherwise                          = True
 242 exprIsTrivial (Type _)                 = True
 243 exprIsTrivial (Lit lit)                = True
 244 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 245 exprIsTrivial (Note _ e)               = exprIsTrivial e
 246 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 247 exprIsTrivial other                    = False
 248 \end{code}
 249
 250
 251 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 252                 cost in code size.  This will only happen in different case
 253                 branches, so there's no issue about duplicating work.
 254
 255                 That is, exprIsDupable returns True of (f x) even if
 256                 f is very very expensive to call.
 257
 258                 Its only purpose is to avoid fruitless let-binding
 259                 and then inlining of case join points
 260
 261
 262 \begin{code}
 263 exprIsDupable (Type _)       = True
 264 exprIsDupable (Var v)        = True
 265 exprIsDupable (Lit lit)      = True
 266 exprIsDupable (Note _ e)     = exprIsDupable e
 267 exprIsDupable expr
 268   = go expr 0
 269   where
 270     go (Var v)   n_args = True
 271     go (App f a) n_args =  n_args < dupAppSize
 272                         && exprIsDupable a
 273                         && go f (n_args+1)
 274     go other n_args     = False
 275
 276 dupAppSize :: Int
 277 dupAppSize = 4          -- Size of application we are prepared to duplicate
 278 \end{code}
 279
 280 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 281 it is obviously in weak head normal form, or is cheap to get to WHNF.
 282 [Note that that's not the same as exprIsDupable; an expression might be
 283 big, and hence not dupable, but still cheap.]
 284
 285 By ``cheap'' we mean a computation we're willing to:
 286         push inside a lambda, or
 287         inline at more than one place
 288 That might mean it gets evaluated more than once, instead of being
 289 shared.  The main examples of things which aren't WHNF but are
 290 ``cheap'' are:
 291
 292   *     case e of
 293           pi -> ei
 294
 295         where e, and all the ei are cheap; and
 296
 297   *     let x = e
 298         in b
 299
 300         where e and b are cheap; and
 301
 302   *     op x1 ... xn
 303
 304         where op is a cheap primitive operator
 305
 306   *     error "foo"
 307
 308 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 309 because sharing will make sure it is only evaluated once.
 310
 311 \begin{code}
 312 exprIsCheap :: CoreExpr -> Bool
 313 exprIsCheap (Lit lit)             = True
 314 exprIsCheap (Type _)              = True
 315 exprIsCheap (Var _)               = True
 316 exprIsCheap (Note _ e)            = exprIsCheap e
 317 exprIsCheap (Lam x e)             = if isId x then True else exprIsCheap e
 318 exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
 319         -- Experimentally, treat (case x of ...) as cheap
 320         -- This improves arities of overloaded functions where
 321         -- there is only dictionary selection (no construction) involved
 322 exprIsCheap other_expr
 323   = go other_expr 0 True
 324   where
 325     go (Var f) n_args args_cheap
 326         = (idAppIsCheap f n_args && args_cheap)
 327                         -- A constructor, cheap primop, or partial application
 328
 329           || idAppIsBottom f n_args
 330                         -- Application of a function which
 331                         -- always gives bottom; we treat this as
 332                         -- a WHNF, because it certainly doesn't
 333                         -- need to be shared!
 334
 335     go (App f a) n_args args_cheap
 336         | isTypeArg a = go f n_args       args_cheap
 337         | otherwise   = go f (n_args + 1) (exprIsCheap a && args_cheap)
 338
 339     go other   n_args args_cheap = False
 340
 341 idAppIsCheap :: Id -> Int -> Bool
 342 idAppIsCheap id n_val_args
 343   | n_val_args == 0 = True      -- Just a type application of
 344                                 -- a variable (f t1 t2 t3)
 345                                 -- counts as WHNF
 346   | otherwise = case idFlavour id of
 347                   DataConId _   -> True
 348                   RecordSelId _ -> True                 -- I'm experimenting with making record selection
 349                                                         -- look cheap, so we will substitute it inside a
 350                                                         -- lambda.  Particularly for dictionary field selection
 351
 352                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 353                                                         -- that return a type variable, since the result
 354                                                         -- might be applied to something, but I'm not going
 355                                                         -- to bother to check the number of args
 356                   other       -> n_val_args < idArity id
 357 \end{code}
 358
 359 exprOkForSpeculation returns True of an expression that it is
 360
 361         * safe to evaluate even if normal order eval might not
 362           evaluate the expression at all, or
 363
 364         * safe *not* to evaluate even if normal order would do so
 365
 366 It returns True iff
 367
 368         the expression guarantees to terminate,
 369         soon,
 370         without raising an exception,
 371         without causing a side effect (e.g. writing a mutable variable)
 372
 373 E.G.
 374         let x = case y# +# 1# of { r# -> I# r# }
 375         in E
 376 ==>
 377         case y# +# 1# of { r# ->
 378         let x = I# r#
 379         in E
 380         }
 381
 382 We can only do this if the (y+1) is ok for speculation: it has no
 383 side effects, and can't diverge or raise an exception.
 384
 385 \begin{code}
 386 exprOkForSpeculation :: CoreExpr -> Bool
 387 exprOkForSpeculation (Lit _)    = True
 388 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 389 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 390 exprOkForSpeculation other_expr
 391   = go other_expr 0 True
 392   where
 393     go (Var f) n_args args_ok
 394       = case idFlavour f of
 395           DataConId _ -> True   -- The strictness of the constructor has already
 396                                 -- been expressed by its "wrapper", so we don't need
 397                                 -- to take the arguments into account
 398
 399           PrimOpId op -> primOpOkForSpeculation op && args_ok
 400                                 -- A bit conservative: we don't really need
 401                                 -- to care about lazy arguments, but this is easy
 402
 403           other -> False
 404
 405     go (App f a) n_args args_ok
 406         | isTypeArg a = go f n_args       args_ok
 407         | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
 408
 409     go other n_args args_ok = False
 410 \end{code}
 411
 412
 413 \begin{code}
 414 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 415 exprIsBottom e = go 0 e
 416                where
 417                 -- n is the number of args
 418                  go n (Note _ e)   = go n e
 419                  go n (Let _ e)    = go n e
 420                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 421                  go n (App e _)    = go (n+1) e
 422                  go n (Var v)      = idAppIsBottom v n
 423                  go n (Lit _)      = False
 424                  go n (Lam _ _)    = False
 425
 426 idAppIsBottom :: Id -> Int -> Bool
 427 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
 428 \end{code}
 429
 430 @exprIsValue@ returns true for expressions that are certainly *already*
 431 evaluated to WHNF.  This is used to decide wether it's ok to change
 432         case x of _ -> e   ===>   e
 433
 434 and to decide whether it's safe to discard a `seq`
 435
 436 So, it does *not* treat variables as evaluated, unless they say they are
 437
 438 \begin{code}
 439 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 440 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 441                                         -- copying them
 442 exprIsValue (Lit l)       = True
 443 exprIsValue (Lam b e)     = isId b || exprIsValue e
 444 exprIsValue (Note _ e)    = exprIsValue e
 445 exprIsValue other_expr
 446   = go other_expr 0
 447   where
 448     go (Var f) n_args = idAppIsValue f n_args
 449
 450     go (App f a) n_args
 451         | isTypeArg a = go f n_args
 452         | otherwise   = go f (n_args + 1)
 453
 454     go (Note _ f) n_args = go f n_args
 455
 456     go other n_args = False
 457
 458 idAppIsValue :: Id -> Int -> Bool
 459 idAppIsValue id n_val_args
 460   = case idFlavour id of
 461         DataConId _ -> True
 462         PrimOpId _  -> n_val_args < idArity id
 463         other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
 464               | otherwise       -> n_val_args < idArity id
 465         -- A worry: what if an Id's unfolding is just itself:
 466         -- then we could get an infinite loop...
 467 \end{code}
 468
 469 \begin{code}
 470 exprArity :: CoreExpr -> Int    -- How many value lambdas are at the top
 471 exprArity (Lam b e)     | isTyVar b     = exprArity e
 472                         | otherwise     = 1 + exprArity e
 473
 474 exprArity (Note note e) | ok_note note  = exprArity e
 475                         where
 476                           ok_note (Coerce _ _) = True
 477                                 -- We *do* look through coerces when getting arities.
 478                                 -- Reason: arities are to do with *representation* and
 479                                 -- work duplication.
 480                           ok_note InlineMe     = True
 481                           ok_note InlineCall   = True
 482                           ok_note other        = False
 483                                 -- SCC and TermUsg might be over-conservative?
 484
 485 exprArity other = 0
 486 \end{code}
 487
 488 \begin{code}
 489 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 490 exprIsConApp_maybe expr
 491   = analyse (collectArgs expr)
 492   where
 493     analyse (Var fun, args)
 494         | maybeToBool maybe_con_app = maybe_con_app
 495         where
 496           maybe_con_app = case isDataConId_maybe fun of
 497                                 Just con | length args >= dataConRepArity con
 498                                         -- Might be > because the arity excludes type args
 499                                          -> Just (con, args)
 500                                 other    -> Nothing
 501
 502     analyse (Var fun, [])
 503         = case maybeUnfoldingTemplate (idUnfolding fun) of
 504                 Nothing  -> Nothing
 505                 Just unf -> exprIsConApp_maybe unf
 506
 507     analyse other = Nothing
 508 \end{code}
 509
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsection{Eta reduction and expansion}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 @etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
 518
 519 e.g.    \ x y -> f x y  ===>  f
 520
 521 But we only do this if it gets rid of a whole lambda, not part.
 522 The idea is that lambdas are often quite helpful: they indicate
 523 head normal forms, so we don't want to chuck them away lightly.
 524
 525 \begin{code}
 526 etaReduceExpr :: CoreExpr -> CoreExpr
 527                 -- ToDo: we should really check that we don't turn a non-bottom
 528                 -- lambda into a bottom variable.  Sigh
 529
 530 etaReduceExpr expr@(Lam bndr body)
 531   = check (reverse binders) body
 532   where
 533     (binders, body) = collectBinders expr
 534
 535     check [] body
 536         | not (any (`elemVarSet` body_fvs) binders)
 537         = body                  -- Success!
 538         where
 539           body_fvs = exprFreeVars body
 540
 541     check (b : bs) (App fun arg)
 542         |  (varToCoreExpr b `cheapEqExpr` arg)
 543         = check bs fun
 544
 545     check _ _ = expr    -- Bale out
 546
 547 etaReduceExpr expr = expr               -- The common case
 548 \end{code}
 549
 550
 551 \begin{code}
 552 exprEtaExpandArity :: CoreExpr -> Int   -- The number of args the thing can be applied to
 553                                         -- without doing much work
 554 -- This is used when eta expanding
 555 --      e  ==>  \xy -> e x y
 556 --
 557 -- It returns 1 (or more) to:
 558 --      case x of p -> \s -> ...
 559 -- because for I/O ish things we really want to get that \s to the top.
 560 -- We are prepared to evaluate x each time round the loop in order to get that
 561 -- Hence "generous" arity
 562
 563 exprEtaExpandArity e
 564   = go e
 565   where
 566     go (Var v)                          = idArity v
 567     go (App f (Type _))                 = go f
 568     go (App f a)  | exprIsCheap a       = (go f - 1) `max` 0    -- Never go -ve!
 569     go (Lam x e)  | isId x              = go e + 1
 570                   | otherwise           = go e
 571     go (Note n e) | ok_note n           = go e
 572     go (Case scrut _ alts)
 573       | exprIsCheap scrut               = min_zero [go rhs | (_,_,rhs) <- alts]
 574     go (Let b e)
 575       | all exprIsCheap (rhssOfBind b)  = go e
 576
 577     go other                            = 0
 578
 579     ok_note (Coerce _ _) = True
 580     ok_note InlineCall   = True
 581     ok_note other        = False
 582             -- Notice that we do not look through __inline_me__
 583             -- This one is a bit more surprising, but consider
 584             --  f = _inline_me (\x -> e)
 585             -- We DO NOT want to eta expand this to
 586             --  f = \x -> (_inline_me (\x -> e)) x
 587             -- because the _inline_me gets dropped now it is applied,
 588             -- giving just
 589             --  f = \x -> e
 590             -- A Bad Idea
 591
 592 min_zero :: [Int] -> Int        -- Find the minimum, but zero is the smallest
 593 min_zero (x:xs) = go x xs
 594                 where
 595                   go 0   xs                 = 0         -- Nothing beats zero
 596                   go min []                 = min
 597                   go min (x:xs) | x < min   = go x xs
 598                                 | otherwise = go min xs
 599
 600 \end{code}
 601
 602
 603 %************************************************************************
 604 %*                                                                      *
 605 \subsection{Equality}
 606 %*                                                                      *
 607 %************************************************************************
 608
 609 @cheapEqExpr@ is a cheap equality test which bales out fast!
 610         True  => definitely equal
 611         False => may or may not be equal
 612
 613 \begin{code}
 614 cheapEqExpr :: Expr b -> Expr b -> Bool
 615
 616 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 617 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 618 cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
 619
 620 cheapEqExpr (App f1 a1) (App f2 a2)
 621   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 622
 623 cheapEqExpr _ _ = False
 624
 625 exprIsBig :: Expr b -> Bool
 626 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 627 exprIsBig (Lit _)      = False
 628 exprIsBig (Var v)      = False
 629 exprIsBig (Type t)     = False
 630 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 631 exprIsBig other        = True
 632 \end{code}
 633
 634
 635 \begin{code}
 636 eqExpr :: CoreExpr -> CoreExpr -> Bool
 637         -- Works ok at more general type, but only needed at CoreExpr
 638 eqExpr e1 e2
 639   = eq emptyVarEnv e1 e2
 640   where
 641   -- The "env" maps variables in e1 to variables in ty2
 642   -- So when comparing lambdas etc,
 643   -- we in effect substitute v2 for v1 in e1 before continuing
 644     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 645                                   Just v1' -> v1' == v2
 646                                   Nothing  -> v1  == v2
 647
 648     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
 649     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 650     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 651     eq env (Let (NonRec v1 r1) e1)
 652            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 653     eq env (Let (Rec ps1) e1)
 654            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 655                                        and (zipWith eq_rhs ps1 ps2) &&
 656                                        eq env' e1 e2
 657                                      where
 658                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 659                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 660     eq env (Case e1 v1 a1)
 661            (Case e2 v2 a2)           = eq env e1 e2 &&
 662                                        length a1 == length a2 &&
 663                                        and (zipWith (eq_alt env') a1 a2)
 664                                      where
 665                                        env' = extendVarEnv env v1 v2
 666
 667     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 668     eq env (Type t1)    (Type t2)    = t1 == t2
 669     eq env e1           e2           = False
 670
 671     eq_list env []       []       = True
 672     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 673     eq_list env es1      es2      = False
 674
 675     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 676                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 677
 678     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 679     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
 680     eq_note env InlineCall     InlineCall     = True
 681     eq_note env other1         other2         = False
 682 \end{code}
 683
 684
 685 %************************************************************************
 686 %*                                                                      *
 687 \subsection{The size of an expression}
 688 %*                                                                      *
 689 %************************************************************************
 690
 691 \begin{code}
 692 coreBindsSize :: [CoreBind] -> Int
 693 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 694
 695 exprSize :: CoreExpr -> Int
 696         -- A measure of the size of the expressions
 697         -- It also forces the expression pretty drastically as a side effect
 698 exprSize (Var v)       = varSize v
 699 exprSize (Lit lit)     = lit `seq` 1
 700 exprSize (App f a)     = exprSize f + exprSize a
 701 exprSize (Lam b e)     = varSize b + exprSize e
 702 exprSize (Let b e)     = bindSize b + exprSize e
 703 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
 704 exprSize (Note n e)    = noteSize n + exprSize e
 705 exprSize (Type t)      = seqType t `seq` 1
 706
 707 noteSize (SCC cc)       = cc `seq` 1
 708 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
 709 noteSize InlineCall     = 1
 710 noteSize InlineMe       = 1
 711 noteSize (TermUsg usg)  = usg `seq` 1
 712
 713 exprsSize = foldr ((+) . exprSize) 0
 714
 715 varSize :: Var -> Int
 716 varSize b  | isTyVar b = 1
 717            | otherwise = seqType (idType b)             `seq`
 718                          megaSeqIdInfo (idInfo b)       `seq`
 719                          1
 720
 721 varsSize = foldr ((+) . varSize) 0
 722
 723 bindSize (NonRec b e) = varSize b + exprSize e
 724 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
 725
 726 pairSize (b,e) = varSize b + exprSize e
 727
 728 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 729 \end{code}
 730
 731
 732 %************************************************************************
 733 %*                                                                      *
 734 \subsection{Hashing}
 735 %*                                                                      *
 736 %************************************************************************
 737
 738 \begin{code}
 739 hashExpr :: CoreExpr -> Int
 740 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
 741            | otherwise = hash
 742            where
 743              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
 744
 745 hash_expr (Note _ e)              = hash_expr e
 746 hash_expr (Let (NonRec b r) e)    = hashId b
 747 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
 748 hash_expr (Case _ b _)            = hashId b
 749 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
 750 hash_expr (Var v)                 = hashId v
 751 hash_expr (Lit lit)               = hashLiteral lit
 752 hash_expr (Lam b _)               = hashId b
 753 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
 754
 755 fast_hash_expr (Var v)          = hashId v
 756 fast_hash_expr (Lit lit)        = hashLiteral lit
 757 fast_hash_expr (App f (Type _)) = fast_hash_expr f
 758 fast_hash_expr (App f a)        = fast_hash_expr a
 759 fast_hash_expr (Lam b _)        = hashId b
 760 fast_hash_expr other            = 1
 761
 762 hashId :: Id -> Int
 763 hashId id = hashName (idName id)
 764 \end{code}