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