ghc/compiler/coreSyn/CoreUtils.lhs

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