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 -> Expr b -> Expr b
 163 -- In (mkCoerce to_ty from_ty e), we require that from_ty = exprType e
 164 -- But exprType is defined in CoreUtils, so we don't check the assertion
 165
 166 mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
 167   = ASSERT( from_ty == to_ty2 )
 168     mkCoerce to_ty from_ty2 expr
 169
 170 mkCoerce to_ty from_ty expr
 171   | to_ty == from_ty = expr
 172   | otherwise        = 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
 231                 happy to duplicate; simple variables and constants,
 232                 and type applications.
 233
 234 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 235
 236
 237 \begin{code}
 238 exprIsTrivial (Type _)       = True
 239 exprIsTrivial (Lit lit)      = True
 240 exprIsTrivial (Var v)        = True
 241 exprIsTrivial (App e arg)    = isTypeArg arg && exprIsTrivial e
 242 exprIsTrivial (Note _ e)     = exprIsTrivial e
 243 exprIsTrivial (Lam b body)   | isTyVar b = exprIsTrivial body
 244 exprIsTrivial other          = False
 245 \end{code}
 246
 247
 248 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 249                 cost in code size.  This will only happen in different case
 250                 branches, so there's no issue about duplicating work.
 251
 252                 That is, exprIsDupable returns True of (f x) even if
 253                 f is very very expensive to call.
 254
 255                 Its only purpose is to avoid fruitless let-binding
 256                 and then inlining of case join points
 257
 258
 259 \begin{code}
 260 exprIsDupable (Type _)       = True
 261 exprIsDupable (Var v)        = True
 262 exprIsDupable (Lit lit)      = True
 263 exprIsDupable (Note _ e)     = exprIsDupable e
 264 exprIsDupable expr
 265   = go expr 0
 266   where
 267     go (Var v)   n_args = True
 268     go (App f a) n_args =  n_args < dupAppSize
 269                         && exprIsDupable a
 270                         && go f (n_args+1)
 271     go other n_args     = False
 272
 273 dupAppSize :: Int
 274 dupAppSize = 4          -- Size of application we are prepared to duplicate
 275 \end{code}
 276
 277 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 278 it is obviously in weak head normal form, or is cheap to get to WHNF.
 279 [Note that that's not the same as exprIsDupable; an expression might be
 280 big, and hence not dupable, but still cheap.]
 281
 282 By ``cheap'' we mean a computation we're willing to:
 283         push inside a lambda, or
 284         inline at more than one place
 285 That might mean it gets evaluated more than once, instead of being
 286 shared.  The main examples of things which aren't WHNF but are
 287 ``cheap'' are:
 288
 289   *     case e of
 290           pi -> ei
 291
 292         where e, and all the ei are cheap; and
 293
 294   *     let x = e
 295         in b
 296
 297         where e and b are cheap; and
 298
 299   *     op x1 ... xn
 300
 301         where op is a cheap primitive operator
 302
 303   *     error "foo"
 304
 305 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 306 because sharing will make sure it is only evaluated once.
 307
 308 \begin{code}
 309 exprIsCheap :: CoreExpr -> Bool
 310 exprIsCheap (Lit lit)             = True
 311 exprIsCheap (Type _)              = True
 312 exprIsCheap (Var _)               = True
 313 exprIsCheap (Note _ e)            = exprIsCheap e
 314 exprIsCheap (Lam x e)             = if isId x then True else exprIsCheap e
 315 exprIsCheap (Case (Var v) _ alts) = and [exprIsCheap rhs | (_,_,rhs) <- alts]
 316         -- Experimentally, treat (case x of ...) as cheap
 317         -- This improves arities of overloaded functions where
 318         -- there is only dictionary selection (no construction) involved
 319 exprIsCheap other_expr
 320   = go other_expr 0 True
 321   where
 322     go (Var f) n_args args_cheap
 323         = (idAppIsCheap f n_args && args_cheap)
 324                         -- A constructor, cheap primop, or partial application
 325
 326           || idAppIsBottom f n_args
 327                         -- Application of a function which
 328                         -- always gives bottom; we treat this as
 329                         -- a WHNF, because it certainly doesn't
 330                         -- need to be shared!
 331
 332     go (App f a) n_args args_cheap
 333         | isTypeArg a = go f n_args       args_cheap
 334         | otherwise   = go f (n_args + 1) (exprIsCheap a && args_cheap)
 335
 336     go other   n_args args_cheap = False
 337
 338 idAppIsCheap :: Id -> Int -> Bool
 339 idAppIsCheap id n_val_args
 340   | n_val_args == 0 = True      -- Just a type application of
 341                                 -- a variable (f t1 t2 t3)
 342                                 -- counts as WHNF
 343   | otherwise = case idFlavour id of
 344                   DataConId _   -> True
 345                   RecordSelId _ -> True                 -- I'm experimenting with making record selection
 346                                                         -- look cheap, so we will substitute it inside a
 347                                                         -- lambda.  Particularly for dictionary field selection
 348
 349                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 350                                                         -- that return a type variable, since the result
 351                                                         -- might be applied to something, but I'm not going
 352                                                         -- to bother to check the number of args
 353                   other       -> n_val_args < idArity id
 354 \end{code}
 355
 356 exprOkForSpeculation returns True of an expression that it is
 357
 358         * safe to evaluate even if normal order eval might not
 359           evaluate the expression at all, or
 360
 361         * safe *not* to evaluate even if normal order would do so
 362
 363 It returns True iff
 364
 365         the expression guarantees to terminate,
 366         soon,
 367         without raising an exception,
 368         without causing a side effect (e.g. writing a mutable variable)
 369
 370 E.G.
 371         let x = case y# +# 1# of { r# -> I# r# }
 372         in E
 373 ==>
 374         case y# +# 1# of { r# ->
 375         let x = I# r#
 376         in E
 377         }
 378
 379 We can only do this if the (y+1) is ok for speculation: it has no
 380 side effects, and can't diverge or raise an exception.
 381
 382 \begin{code}
 383 exprOkForSpeculation :: CoreExpr -> Bool
 384 exprOkForSpeculation (Lit _)    = True
 385 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 386 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 387 exprOkForSpeculation other_expr
 388   = go other_expr 0 True
 389   where
 390     go (Var f) n_args args_ok
 391       = case idFlavour f of
 392           DataConId _ -> True   -- The strictness of the constructor has already
 393                                 -- been expressed by its "wrapper", so we don't need
 394                                 -- to take the arguments into account
 395
 396           PrimOpId op -> primOpOkForSpeculation op && args_ok
 397                                 -- A bit conservative: we don't really need
 398                                 -- to care about lazy arguments, but this is easy
 399
 400           other -> False
 401
 402     go (App f a) n_args args_ok
 403         | isTypeArg a = go f n_args       args_ok
 404         | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
 405
 406     go other n_args args_ok = False
 407 \end{code}
 408
 409
 410 \begin{code}
 411 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 412 exprIsBottom e = go 0 e
 413                where
 414                 -- n is the number of args
 415                  go n (Note _ e)   = go n e
 416                  go n (Let _ e)    = go n e
 417                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 418                  go n (App e _)    = go (n+1) e
 419                  go n (Var v)      = idAppIsBottom v n
 420                  go n (Lit _)      = False
 421                  go n (Lam _ _)    = False
 422
 423 idAppIsBottom :: Id -> Int -> Bool
 424 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
 425 \end{code}
 426
 427 @exprIsValue@ returns true for expressions that are certainly *already*
 428 evaluated to WHNF.  This is used to decide wether it's ok to change
 429         case x of _ -> e   ===>   e
 430
 431 and to decide whether it's safe to discard a `seq`
 432
 433 So, it does *not* treat variables as evaluated, unless they say they are
 434
 435 \begin{code}
 436 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 437 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 438                                         -- copying them
 439 exprIsValue (Lit l)       = True
 440 exprIsValue (Lam b e)     = isId b || exprIsValue e
 441 exprIsValue (Note _ e)    = exprIsValue e
 442 exprIsValue other_expr
 443   = go other_expr 0
 444   where
 445     go (Var f) n_args = idAppIsValue f n_args
 446
 447     go (App f a) n_args
 448         | isTypeArg a = go f n_args
 449         | otherwise   = go f (n_args + 1)
 450
 451     go (Note _ f) n_args = go f n_args
 452
 453     go other n_args = False
 454
 455 idAppIsValue :: Id -> Int -> Bool
 456 idAppIsValue id n_val_args
 457   = case idFlavour id of
 458         DataConId _ -> True
 459         PrimOpId _  -> n_val_args < idArity id
 460         other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
 461               | otherwise       -> n_val_args < idArity id
 462         -- A worry: what if an Id's unfolding is just itself:
 463         -- then we could get an infinite loop...
 464 \end{code}
 465
 466 \begin{code}
 467 exprArity :: CoreExpr -> Int    -- How many value lambdas are at the top
 468 exprArity (Lam b e)     | isTyVar b     = exprArity e
 469                         | otherwise     = 1 + exprArity e
 470
 471 exprArity (Note note e) | ok_note note  = exprArity e
 472                         where
 473                           ok_note (Coerce _ _) = True
 474                                 -- We *do* look through coerces when getting arities.
 475                                 -- Reason: arities are to do with *representation* and
 476                                 -- work duplication.
 477                           ok_note InlineMe     = True
 478                           ok_note InlineCall   = True
 479                           ok_note other        = False
 480                                 -- SCC and TermUsg might be over-conservative?
 481
 482 exprArity other = 0
 483 \end{code}
 484
 485 \begin{code}
 486 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 487 exprIsConApp_maybe expr
 488   = analyse (collectArgs expr)
 489   where
 490     analyse (Var fun, args)
 491         | maybeToBool maybe_con_app = maybe_con_app
 492         where
 493           maybe_con_app = case isDataConId_maybe fun of
 494                                 Just con | length args >= dataConRepArity con
 495                                         -- Might be > because the arity excludes type args
 496                                          -> Just (con, args)
 497                                 other    -> Nothing
 498
 499     analyse (Var fun, [])
 500         = case maybeUnfoldingTemplate (idUnfolding fun) of
 501                 Nothing  -> Nothing
 502                 Just unf -> exprIsConApp_maybe unf
 503
 504     analyse other = Nothing
 505 \end{code}
 506
 507
 508 %************************************************************************
 509 %*                                                                      *
 510 \subsection{Eta reduction and expansion}
 511 %*                                                                      *
 512 %************************************************************************
 513
 514 @etaReduceExpr@ trys an eta reduction at the top level of a Core Expr.
 515
 516 e.g.    \ x y -> f x y  ===>  f
 517
 518 But we only do this if it gets rid of a whole lambda, not part.
 519 The idea is that lambdas are often quite helpful: they indicate
 520 head normal forms, so we don't want to chuck them away lightly.
 521
 522 \begin{code}
 523 etaReduceExpr :: CoreExpr -> CoreExpr
 524                 -- ToDo: we should really check that we don't turn a non-bottom
 525                 -- lambda into a bottom variable.  Sigh
 526
 527 etaReduceExpr expr@(Lam bndr body)
 528   = check (reverse binders) body
 529   where
 530     (binders, body) = collectBinders expr
 531
 532     check [] body
 533         | not (any (`elemVarSet` body_fvs) binders)
 534         = body                  -- Success!
 535         where
 536           body_fvs = exprFreeVars body
 537
 538     check (b : bs) (App fun arg)
 539         |  (varToCoreExpr b `cheapEqExpr` arg)
 540         = check bs fun
 541
 542     check _ _ = expr    -- Bale out
 543
 544 etaReduceExpr expr = expr               -- The common case
 545 \end{code}
 546
 547
 548 \begin{code}
 549 exprEtaExpandArity :: CoreExpr -> Int   -- The number of args the thing can be applied to
 550                                         -- without doing much work
 551 -- This is used when eta expanding
 552 --      e  ==>  \xy -> e x y
 553 --
 554 -- It returns 1 (or more) to:
 555 --      case x of p -> \s -> ...
 556 -- because for I/O ish things we really want to get that \s to the top.
 557 -- We are prepared to evaluate x each time round the loop in order to get that
 558 -- Hence "generous" arity
 559
 560 exprEtaExpandArity e
 561   = go e
 562   where
 563     go (Var v)                          = idArity v
 564     go (App f (Type _))                 = go f
 565     go (App f a)  | exprIsCheap a       = (go f - 1) `max` 0    -- Never go -ve!
 566     go (Lam x e)  | isId x              = go e + 1
 567                   | otherwise           = go e
 568     go (Note n e) | ok_note n           = go e
 569     go (Case scrut _ alts)
 570       | exprIsCheap scrut               = min_zero [go rhs | (_,_,rhs) <- alts]
 571     go (Let b e)
 572       | all exprIsCheap (rhssOfBind b)  = go e
 573
 574     go other                            = 0
 575
 576     ok_note (Coerce _ _) = True
 577     ok_note InlineCall   = True
 578     ok_note other        = False
 579             -- Notice that we do not look through __inline_me__
 580             -- This one is a bit more surprising, but consider
 581             --  f = _inline_me (\x -> e)
 582             -- We DO NOT want to eta expand this to
 583             --  f = \x -> (_inline_me (\x -> e)) x
 584             -- because the _inline_me gets dropped now it is applied,
 585             -- giving just
 586             --  f = \x -> e
 587             -- A Bad Idea
 588
 589 min_zero :: [Int] -> Int        -- Find the minimum, but zero is the smallest
 590 min_zero (x:xs) = go x xs
 591                 where
 592                   go 0   xs                 = 0         -- Nothing beats zero
 593                   go min []                 = min
 594                   go min (x:xs) | x < min   = go x xs
 595                                 | otherwise = go min xs
 596
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection{Equality}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 @cheapEqExpr@ is a cheap equality test which bales out fast!
 607         True  => definitely equal
 608         False => may or may not be equal
 609
 610 \begin{code}
 611 cheapEqExpr :: Expr b -> Expr b -> Bool
 612
 613 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 614 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 615 cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
 616
 617 cheapEqExpr (App f1 a1) (App f2 a2)
 618   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 619
 620 cheapEqExpr _ _ = False
 621
 622 exprIsBig :: Expr b -> Bool
 623 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 624 exprIsBig (Lit _)      = False
 625 exprIsBig (Var v)      = False
 626 exprIsBig (Type t)     = False
 627 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 628 exprIsBig other        = True
 629 \end{code}
 630
 631
 632 \begin{code}
 633 eqExpr :: CoreExpr -> CoreExpr -> Bool
 634         -- Works ok at more general type, but only needed at CoreExpr
 635 eqExpr e1 e2
 636   = eq emptyVarEnv e1 e2
 637   where
 638   -- The "env" maps variables in e1 to variables in ty2
 639   -- So when comparing lambdas etc,
 640   -- we in effect substitute v2 for v1 in e1 before continuing
 641     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 642                                   Just v1' -> v1' == v2
 643                                   Nothing  -> v1  == v2
 644
 645     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
 646     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 647     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 648     eq env (Let (NonRec v1 r1) e1)
 649            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 650     eq env (Let (Rec ps1) e1)
 651            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 652                                        and (zipWith eq_rhs ps1 ps2) &&
 653                                        eq env' e1 e2
 654                                      where
 655                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 656                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 657     eq env (Case e1 v1 a1)
 658            (Case e2 v2 a2)           = eq env e1 e2 &&
 659                                        length a1 == length a2 &&
 660                                        and (zipWith (eq_alt env') a1 a2)
 661                                      where
 662                                        env' = extendVarEnv env v1 v2
 663
 664     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 665     eq env (Type t1)    (Type t2)    = t1 == t2
 666     eq env e1           e2           = False
 667
 668     eq_list env []       []       = True
 669     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 670     eq_list env es1      es2      = False
 671
 672     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 673                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 674
 675     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 676     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
 677     eq_note env InlineCall     InlineCall     = True
 678     eq_note env other1         other2         = False
 679 \end{code}
 680
 681
 682 %************************************************************************
 683 %*                                                                      *
 684 \subsection{The size of an expression}
 685 %*                                                                      *
 686 %************************************************************************
 687
 688 \begin{code}
 689 coreBindsSize :: [CoreBind] -> Int
 690 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 691
 692 exprSize :: CoreExpr -> Int
 693         -- A measure of the size of the expressions
 694         -- It also forces the expression pretty drastically as a side effect
 695 exprSize (Var v)       = varSize v
 696 exprSize (Lit lit)     = 1
 697 exprSize (App f a)     = exprSize f + exprSize a
 698 exprSize (Lam b e)     = varSize b + exprSize e
 699 exprSize (Let b e)     = bindSize b + exprSize e
 700 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0  as
 701 exprSize (Note n e)    = exprSize e
 702 exprSize (Type t)      = seqType t `seq`
 703                          1
 704
 705 exprsSize = foldr ((+) . exprSize) 0
 706
 707 varSize :: Var -> Int
 708 varSize b | isTyVar b = 1
 709           | otherwise = seqType (idType b)              `seq`
 710                         megaSeqIdInfo (idInfo b)        `seq`
 711                         1
 712
 713 varsSize = foldr ((+) . varSize) 0
 714
 715 bindSize (NonRec b e) = varSize b + exprSize e
 716 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
 717
 718 pairSize (b,e) = varSize b + exprSize e
 719
 720 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 721 \end{code}
 722
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsection{Hashing}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 \begin{code}
 731 hashExpr :: CoreExpr -> Int
 732 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
 733            | otherwise = hash
 734            where
 735              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
 736
 737 hash_expr (Note _ e)              = hash_expr e
 738 hash_expr (Let (NonRec b r) e)    = hashId b
 739 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
 740 hash_expr (Case _ b _)            = hashId b
 741 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
 742 hash_expr (Var v)                 = hashId v
 743 hash_expr (Lit lit)               = hashLiteral lit
 744 hash_expr (Lam b _)               = hashId b
 745 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
 746
 747 fast_hash_expr (Var v)          = hashId v
 748 fast_hash_expr (Lit lit)        = hashLiteral lit
 749 fast_hash_expr (App f (Type _)) = fast_hash_expr f
 750 fast_hash_expr (App f a)        = fast_hash_expr a
 751 fast_hash_expr (Lam b _)        = hashId b
 752 fast_hash_expr other            = 1
 753
 754 hashId :: Id -> Int
 755 hashId id = hashName (idName id)
 756 \end{code}