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