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, litSize, 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
  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   | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
 262   | otherwise                          = True
 263 exprIsTrivial (Type _)                 = True
 264 exprIsTrivial (Lit lit)                = True
 265 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 266 exprIsTrivial (Note _ e)               = exprIsTrivial e
 267 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 268 exprIsTrivial other                    = False
 269
 270 exprIsAtom :: CoreExpr -> Bool
 271 -- Used to decide whether to let-binding an STG argument
 272 -- when compiling to ILX => type applications are not allowed
 273 exprIsAtom (Var v)    = True    -- primOpIsDupable?
 274 exprIsAtom (Lit lit)  = True
 275 exprIsAtom (Type ty)  = True
 276 exprIsAtom (Note _ e) = exprIsAtom e
 277 exprIsAtom other      = False
 278 \end{code}
 279
 280
 281 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 282                 cost in code size.  This will only happen in different case
 283                 branches, so there's no issue about duplicating work.
 284
 285                 That is, exprIsDupable returns True of (f x) even if
 286                 f is very very expensive to call.
 287
 288                 Its only purpose is to avoid fruitless let-binding
 289                 and then inlining of case join points
 290
 291
 292 \begin{code}
 293 exprIsDupable (Type _)       = True
 294 exprIsDupable (Var v)        = True
 295 exprIsDupable (Lit lit)      = litIsDupable lit
 296 exprIsDupable (Note _ e)     = exprIsDupable e
 297 exprIsDupable expr
 298   = go expr 0
 299   where
 300     go (Var v)   n_args = True
 301     go (App f a) n_args =  n_args < dupAppSize
 302                         && exprIsDupable a
 303                         && go f (n_args+1)
 304     go other n_args     = False
 305
 306 dupAppSize :: Int
 307 dupAppSize = 4          -- Size of application we are prepared to duplicate
 308 \end{code}
 309
 310 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 311 it is obviously in weak head normal form, or is cheap to get to WHNF.
 312 [Note that that's not the same as exprIsDupable; an expression might be
 313 big, and hence not dupable, but still cheap.]
 314
 315 By ``cheap'' we mean a computation we're willing to:
 316         push inside a lambda, or
 317         inline at more than one place
 318 That might mean it gets evaluated more than once, instead of being
 319 shared.  The main examples of things which aren't WHNF but are
 320 ``cheap'' are:
 321
 322   *     case e of
 323           pi -> ei
 324         (where e, and all the ei are cheap)
 325
 326   *     let x = e in b
 327         (where e and b are cheap)
 328
 329   *     op x1 ... xn
 330         (where op is a cheap primitive operator)
 331
 332   *     error "foo"
 333         (because we are happy to substitute it inside a lambda)
 334
 335 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 336 because sharing will make sure it is only evaluated once.
 337
 338 \begin{code}
 339 exprIsCheap :: CoreExpr -> Bool
 340 exprIsCheap (Lit lit)             = True
 341 exprIsCheap (Type _)              = True
 342 exprIsCheap (Var _)               = True
 343 exprIsCheap (Note _ e)            = exprIsCheap e
 344 exprIsCheap (Lam x e)             = if isId x then True else exprIsCheap e
 345 exprIsCheap (Case e _ alts)       = exprIsCheap e &&
 346                                     and [exprIsCheap rhs | (_,_,rhs) <- alts]
 347         -- Experimentally, treat (case x of ...) as cheap
 348         -- (and case __coerce x etc.)
 349         -- This improves arities of overloaded functions where
 350         -- there is only dictionary selection (no construction) involved
 351 exprIsCheap (Let (NonRec x _) e)
 352       | isUnLiftedType (idType x) = exprIsCheap e
 353       | otherwise                 = False
 354         -- strict lets always have cheap right hand sides, and
 355         -- do no allocation.
 356
 357 exprIsCheap other_expr
 358   = go other_expr 0 True
 359   where
 360     go (Var f) n_args args_cheap
 361         = (idAppIsCheap f n_args && args_cheap)
 362                         -- A constructor, cheap primop, or partial application
 363
 364           || idAppIsBottom f n_args
 365                         -- Application of a function which
 366                         -- always gives bottom; we treat this as cheap
 367                         -- because it certainly doesn't need to be shared!
 368
 369     go (App f a) n_args args_cheap
 370         | isTypeArg a = go f n_args       args_cheap
 371         | otherwise   = go f (n_args + 1) (exprIsCheap a && args_cheap)
 372
 373     go other   n_args args_cheap = False
 374
 375 idAppIsCheap :: Id -> Int -> Bool
 376 idAppIsCheap id n_val_args
 377   | n_val_args == 0 = True      -- Just a type application of
 378                                 -- a variable (f t1 t2 t3)
 379                                 -- counts as WHNF
 380   | otherwise = case idFlavour id of
 381                   DataConId _   -> True
 382                   RecordSelId _ -> True                 -- I'm experimenting with making record selection
 383                                                         -- look cheap, so we will substitute it inside a
 384                                                         -- lambda.  Particularly for dictionary field selection
 385
 386                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 387                                                         -- that return a type variable, since the result
 388                                                         -- might be applied to something, but I'm not going
 389                                                         -- to bother to check the number of args
 390                   other       -> n_val_args < idArity id
 391 \end{code}
 392
 393 exprOkForSpeculation returns True of an expression that it is
 394
 395         * safe to evaluate even if normal order eval might not
 396           evaluate the expression at all, or
 397
 398         * safe *not* to evaluate even if normal order would do so
 399
 400 It returns True iff
 401
 402         the expression guarantees to terminate,
 403         soon,
 404         without raising an exception,
 405         without causing a side effect (e.g. writing a mutable variable)
 406
 407 E.G.
 408         let x = case y# +# 1# of { r# -> I# r# }
 409         in E
 410 ==>
 411         case y# +# 1# of { r# ->
 412         let x = I# r#
 413         in E
 414         }
 415
 416 We can only do this if the (y+1) is ok for speculation: it has no
 417 side effects, and can't diverge or raise an exception.
 418
 419 \begin{code}
 420 exprOkForSpeculation :: CoreExpr -> Bool
 421 exprOkForSpeculation (Lit _)    = True
 422 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 423 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 424 exprOkForSpeculation other_expr
 425   = go other_expr 0 True
 426   where
 427     go (Var f) n_args args_ok
 428       = case idFlavour f of
 429           DataConId _ -> True   -- The strictness of the constructor has already
 430                                 -- been expressed by its "wrapper", so we don't need
 431                                 -- to take the arguments into account
 432
 433           PrimOpId op -> primOpOkForSpeculation op && args_ok
 434                                 -- A bit conservative: we don't really need
 435                                 -- to care about lazy arguments, but this is easy
 436
 437           other -> False
 438
 439     go (App f a) n_args args_ok
 440         | isTypeArg a = go f n_args       args_ok
 441         | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
 442
 443     go other n_args args_ok = False
 444 \end{code}
 445
 446
 447 \begin{code}
 448 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 449 exprIsBottom e = go 0 e
 450                where
 451                 -- n is the number of args
 452                  go n (Note _ e)   = go n e
 453                  go n (Let _ e)    = go n e
 454                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 455                  go n (App e _)    = go (n+1) e
 456                  go n (Var v)      = idAppIsBottom v n
 457                  go n (Lit _)      = False
 458                  go n (Lam _ _)    = False
 459
 460 idAppIsBottom :: Id -> Int -> Bool
 461 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
 462 \end{code}
 463
 464 @exprIsValue@ returns true for expressions that are certainly *already*
 465 evaluated to WHNF.  This is used to decide wether it's ok to change
 466         case x of _ -> e   ===>   e
 467
 468 and to decide whether it's safe to discard a `seq`
 469
 470 So, it does *not* treat variables as evaluated, unless they say they are
 471
 472 \begin{code}
 473 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 474 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 475                                         -- copying them
 476 exprIsValue (Lit l)       = True
 477 exprIsValue (Lam b e)     = isId b || exprIsValue e
 478 exprIsValue (Note _ e)    = exprIsValue e
 479 exprIsValue other_expr
 480   = go other_expr 0
 481   where
 482     go (Var f) n_args = idAppIsValue f n_args
 483
 484     go (App f a) n_args
 485         | isTypeArg a = go f n_args
 486         | otherwise   = go f (n_args + 1)
 487
 488     go (Note _ f) n_args = go f n_args
 489
 490     go other n_args = False
 491
 492 idAppIsValue :: Id -> Int -> Bool
 493 idAppIsValue id n_val_args
 494   = case idFlavour id of
 495         DataConId _ -> True
 496         PrimOpId _  -> n_val_args < idArity id
 497         other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
 498               | otherwise       -> n_val_args < idArity id
 499         -- A worry: what if an Id's unfolding is just itself:
 500         -- then we could get an infinite loop...
 501 \end{code}
 502
 503 \begin{code}
 504 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 505 exprIsConApp_maybe expr
 506   = analyse (collectArgs expr)
 507   where
 508     analyse (Var fun, args)
 509         | maybeToBool maybe_con_app = maybe_con_app
 510         where
 511           maybe_con_app = case isDataConId_maybe fun of
 512                                 Just con | length args >= dataConRepArity con
 513                                         -- Might be > because the arity excludes type args
 514                                          -> Just (con, args)
 515                                 other    -> Nothing
 516
 517     analyse (Var fun, [])
 518         = case maybeUnfoldingTemplate (idUnfolding fun) of
 519                 Nothing  -> Nothing
 520                 Just unf -> exprIsConApp_maybe unf
 521
 522     analyse other = Nothing
 523 \end{code}
 524
 525 The arity of an expression (in the code-generator sense, i.e. the
 526 number of lambdas at the beginning).
 527
 528 \begin{code}
 529 exprArity :: CoreExpr -> Int
 530 exprArity (Lam x e)
 531   | isTyVar x = exprArity e
 532   | otherwise = 1 + exprArity e
 533 exprArity (Note _ e)
 534   -- Ignore coercions.   Top level sccs are removed by the final
 535   -- profiling pass, so we ignore those too.
 536   = exprArity e
 537 exprArity _ = 0
 538 \end{code}
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsection{Eta reduction and expansion}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
 548
 549 e.g.    \ x y -> f x y  ===>  f
 550
 551 But we only do this if it gets rid of a whole lambda, not part.
 552 The idea is that lambdas are often quite helpful: they indicate
 553 head normal forms, so we don't want to chuck them away lightly.
 554
 555 \begin{code}
 556 etaReduce :: CoreExpr -> CoreExpr
 557                 -- ToDo: we should really check that we don't turn a non-bottom
 558                 -- lambda into a bottom variable.  Sigh
 559
 560 etaReduce expr@(Lam bndr body)
 561   = check (reverse binders) body
 562   where
 563     (binders, body) = collectBinders expr
 564
 565     check [] body
 566         | not (any (`elemVarSet` body_fvs) binders)
 567         = body                  -- Success!
 568         where
 569           body_fvs = exprFreeVars body
 570
 571     check (b : bs) (App fun arg)
 572         |  (varToCoreExpr b `cheapEqExpr` arg)
 573         = check bs fun
 574
 575     check _ _ = expr    -- Bale out
 576
 577 etaReduce expr = expr           -- The common case
 578 \end{code}
 579
 580
 581 \begin{code}
 582 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
 583 -- The Int is number of value args the thing can be
 584 --      applied to without doing much work
 585 -- The Bool is True iff there are enough explicit value lambdas
 586 --      at the top to make this arity apparent
 587 --      (but ignore it when arity==0)
 588
 589 -- This is used when eta expanding
 590 --      e  ==>  \xy -> e x y
 591 --
 592 -- It returns 1 (or more) to:
 593 --      case x of p -> \s -> ...
 594 -- because for I/O ish things we really want to get that \s to the top.
 595 -- We are prepared to evaluate x each time round the loop in order to get that
 596 -- Hence "generous" arity
 597
 598 exprEtaExpandArity e
 599   = go 0 e
 600   where
 601     go ar (Lam x e)  | isId x           = go (ar+1) e
 602                      | otherwise        = go ar e
 603     go ar (Note n e) | ok_note n        = go ar e
 604     go ar other                         = (ar + ar', ar' == 0)
 605                                         where
 606                                           ar' = go1 other `max` 0
 607
 608     go1 (Var v)                         = idArity v
 609     go1 (Lam x e)  | isId x             = go1 e + 1
 610                    | otherwise          = go1 e
 611     go1 (Note n e) | ok_note n          = go1 e
 612     go1 (App f (Type _))                        = go1 f
 613     go1 (App f a)  | exprIsCheap a      = go1 f - 1
 614     go1 (Case scrut _ alts)
 615       | exprIsCheap scrut               = min_zero [go1 rhs | (_,_,rhs) <- alts]
 616     go1 (Let b e)
 617       | all exprIsCheap (rhssOfBind b)  = go1 e
 618
 619     go1 other                           = 0
 620
 621     ok_note (Coerce _ _) = True
 622     ok_note InlineCall   = True
 623     ok_note other        = False
 624             -- Notice that we do not look through __inline_me__
 625             -- This one is a bit more surprising, but consider
 626             --  f = _inline_me (\x -> e)
 627             -- We DO NOT want to eta expand this to
 628             --  f = \x -> (_inline_me (\x -> e)) x
 629             -- because the _inline_me gets dropped now it is applied,
 630             -- giving just
 631             --  f = \x -> e
 632             -- A Bad Idea
 633
 634 min_zero :: [Int] -> Int        -- Find the minimum, but zero is the smallest
 635 min_zero (x:xs) = go x xs
 636                 where
 637                   go 0   xs                 = 0         -- Nothing beats zero
 638                   go min []                 = min
 639                   go min (x:xs) | x < min   = go x xs
 640                                 | otherwise = go min xs
 641
 642 \end{code}
 643
 644
 645 \begin{code}
 646 etaExpand :: Int                -- Add this number of value args
 647           -> UniqSupply
 648           -> CoreExpr -> Type   -- Expression and its type
 649           -> CoreExpr
 650 -- (etaExpand n us e ty) returns an expression with
 651 -- the same meaning as 'e', but with arity 'n'.
 652
 653 -- Given e' = etaExpand n us e ty
 654 -- We should have
 655 --      ty = exprType e = exprType e'
 656 --
 657 -- etaExpand deals with for-alls and coerces. For example:
 658 --              etaExpand 1 E
 659 -- where  E :: forall a. T
 660 --        newtype T = MkT (A -> B)
 661 --
 662 -- would return
 663 --      (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
 664
 665 -- (case x of { I# x -> /\ a -> coerce T E)
 666
 667 etaExpand n us expr ty
 668   | n == 0      -- Saturated, so nothing to do
 669   = expr
 670
 671   | otherwise   -- An unsaturated constructor or primop; eta expand it
 672   = case splitForAllTy_maybe ty of {
 673           Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
 674
 675         ; Nothing ->
 676
 677         case splitFunTy_maybe ty of {
 678           Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
 679                                 where
 680                                    arg1       = mkSysLocal SLIT("eta") uniq arg_ty
 681                                    (us1, us2) = splitUniqSupply us
 682                                    uniq       = uniqFromSupply us1
 683
 684         ; Nothing ->
 685
 686         case splitNewType_maybe ty of {
 687           Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
 688
 689           Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
 690         }}}
 691 \end{code}
 692
 693
 694 %************************************************************************
 695 %*                                                                      *
 696 \subsection{Equality}
 697 %*                                                                      *
 698 %************************************************************************
 699
 700 @cheapEqExpr@ is a cheap equality test which bales out fast!
 701         True  => definitely equal
 702         False => may or may not be equal
 703
 704 \begin{code}
 705 cheapEqExpr :: Expr b -> Expr b -> Bool
 706
 707 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 708 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 709 cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
 710
 711 cheapEqExpr (App f1 a1) (App f2 a2)
 712   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 713
 714 cheapEqExpr _ _ = False
 715
 716 exprIsBig :: Expr b -> Bool
 717 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 718 exprIsBig (Lit _)      = False
 719 exprIsBig (Var v)      = False
 720 exprIsBig (Type t)     = False
 721 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 722 exprIsBig other        = True
 723 \end{code}
 724
 725
 726 \begin{code}
 727 eqExpr :: CoreExpr -> CoreExpr -> Bool
 728         -- Works ok at more general type, but only needed at CoreExpr
 729 eqExpr e1 e2
 730   = eq emptyVarEnv e1 e2
 731   where
 732   -- The "env" maps variables in e1 to variables in ty2
 733   -- So when comparing lambdas etc,
 734   -- we in effect substitute v2 for v1 in e1 before continuing
 735     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 736                                   Just v1' -> v1' == v2
 737                                   Nothing  -> v1  == v2
 738
 739     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
 740     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 741     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 742     eq env (Let (NonRec v1 r1) e1)
 743            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 744     eq env (Let (Rec ps1) e1)
 745            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 746                                        and (zipWith eq_rhs ps1 ps2) &&
 747                                        eq env' e1 e2
 748                                      where
 749                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 750                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 751     eq env (Case e1 v1 a1)
 752            (Case e2 v2 a2)           = eq env e1 e2 &&
 753                                        length a1 == length a2 &&
 754                                        and (zipWith (eq_alt env') a1 a2)
 755                                      where
 756                                        env' = extendVarEnv env v1 v2
 757
 758     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 759     eq env (Type t1)    (Type t2)    = t1 == t2
 760     eq env e1           e2           = False
 761
 762     eq_list env []       []       = True
 763     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 764     eq_list env es1      es2      = False
 765
 766     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 767                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 768
 769     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 770     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
 771     eq_note env InlineCall     InlineCall     = True
 772     eq_note env other1         other2         = False
 773 \end{code}
 774
 775
 776 %************************************************************************
 777 %*                                                                      *
 778 \subsection{The size of an expression}
 779 %*                                                                      *
 780 %************************************************************************
 781
 782 \begin{code}
 783 coreBindsSize :: [CoreBind] -> Int
 784 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 785
 786 exprSize :: CoreExpr -> Int
 787         -- A measure of the size of the expressions
 788         -- It also forces the expression pretty drastically as a side effect
 789 exprSize (Var v)       = varSize v
 790 exprSize (Lit lit)     = lit `seq` 1
 791 exprSize (App f a)     = exprSize f + exprSize a
 792 exprSize (Lam b e)     = varSize b + exprSize e
 793 exprSize (Let b e)     = bindSize b + exprSize e
 794 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
 795 exprSize (Note n e)    = noteSize n + exprSize e
 796 exprSize (Type t)      = seqType t `seq` 1
 797
 798 noteSize (SCC cc)       = cc `seq` 1
 799 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
 800 noteSize InlineCall     = 1
 801 noteSize InlineMe       = 1
 802
 803 varSize :: Var -> Int
 804 varSize b  | isTyVar b = 1
 805            | otherwise = seqType (idType b)             `seq`
 806                          megaSeqIdInfo (idInfo b)       `seq`
 807                          1
 808
 809 varsSize = foldr ((+) . varSize) 0
 810
 811 bindSize (NonRec b e) = varSize b + exprSize e
 812 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
 813
 814 pairSize (b,e) = varSize b + exprSize e
 815
 816 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 817 \end{code}
 818
 819
 820 %************************************************************************
 821 %*                                                                      *
 822 \subsection{Hashing}
 823 %*                                                                      *
 824 %************************************************************************
 825
 826 \begin{code}
 827 hashExpr :: CoreExpr -> Int
 828 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
 829            | otherwise = hash
 830            where
 831              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
 832
 833 hash_expr (Note _ e)              = hash_expr e
 834 hash_expr (Let (NonRec b r) e)    = hashId b
 835 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
 836 hash_expr (Case _ b _)            = hashId b
 837 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
 838 hash_expr (Var v)                 = hashId v
 839 hash_expr (Lit lit)               = hashLiteral lit
 840 hash_expr (Lam b _)               = hashId b
 841 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
 842
 843 fast_hash_expr (Var v)          = hashId v
 844 fast_hash_expr (Lit lit)        = hashLiteral lit
 845 fast_hash_expr (App f (Type _)) = fast_hash_expr f
 846 fast_hash_expr (App f a)        = fast_hash_expr a
 847 fast_hash_expr (Lam b _)        = hashId b
 848 fast_hash_expr other            = 1
 849
 850 hashId :: Id -> Int
 851 hashId id = hashName (idName id)
 852 \end{code}