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