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