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