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