ghc/compiler/coreSyn/CoreUtils.lhs

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