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