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