ghc/compiler/coreSyn/CoreUtils.lhs

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