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