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