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