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