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