ghc/compiler/coreSyn/CoreUtils.lhs

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