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