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