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