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