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