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