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