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, mkIfThenElse, mkAltExpr,
  11         mkPiType,
  12
  13         -- Taking expressions apart
  14         findDefault, findAlt,
  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 )
  52 import PrimOp           ( primOpOkForSpeculation, primOpIsCheap )
  53 import Id               ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
  54                           mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
  55                           isDataConId_maybe, mkSysLocal, hasNoBinding
  56                         )
  57 import IdInfo           ( LBVarInfo(..),
  58                           GlobalIdDetails(..),
  59                           megaSeqIdInfo )
  60 import Demand           ( appIsBottom )
  61 import Type             ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
  62                           applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy,
  63                           splitForAllTy_maybe, splitNewType_maybe
  64                         )
  65 import TysWiredIn       ( boolTy, trueDataCon, falseDataCon )
  66 import CostCentre       ( CostCentre )
  67 import UniqSupply       ( UniqSupply, splitUniqSupply, uniqFromSupply )
  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 == to_ty2 )
 189     mkCoerce to_ty from_ty2 expr
 190
 191 mkCoerce to_ty from_ty expr
 192   | to_ty == from_ty = expr
 193   | otherwise        = ASSERT( from_ty == 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   | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
 228   | otherwise                    = Let (NonRec bndr rhs) body
 229 \end{code}
 230
 231 \begin{code}
 232 mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
 233         -- This guy constructs the value that the scrutinee must have
 234         -- when you are in one particular branch of a case
 235 mkAltExpr (DataAlt con) args inst_tys
 236   = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
 237 mkAltExpr (LitAlt lit) [] []
 238   = Lit lit
 239
 240 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 241 mkIfThenElse guard then_expr else_expr
 242   = Case guard (mkWildId boolTy)
 243          [ (DataAlt trueDataCon,  [], then_expr),
 244            (DataAlt falseDataCon, [], else_expr) ]
 245 \end{code}
 246
 247
 248 %************************************************************************
 249 %*                                                                      *
 250 \subsection{Taking expressions apart}
 251 %*                                                                      *
 252 %************************************************************************
 253
 254
 255 \begin{code}
 256 findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
 257 findDefault []                          = ([], Nothing)
 258 findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
 259                                           ([], Just rhs)
 260 findDefault (alt : alts)                = case findDefault alts of
 261                                             (alts', deflt) -> (alt : alts', deflt)
 262
 263 findAlt :: AltCon -> [CoreAlt] -> CoreAlt
 264 findAlt con alts
 265   = go alts
 266   where
 267     go []           = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
 268     go (alt : alts) | matches alt = alt
 269                     | otherwise   = go alts
 270
 271     matches (DEFAULT, _, _) = True
 272     matches (con1, _, _)    = con == con1
 273 \end{code}
 274
 275
 276 %************************************************************************
 277 %*                                                                      *
 278 \subsection{Figuring out things about expressions}
 279 %*                                                                      *
 280 %************************************************************************
 281
 282 @exprIsTrivial@ is true of expressions we are unconditionally happy to
 283                 duplicate; simple variables and constants, and type
 284                 applications.  Note that primop Ids aren't considered
 285                 trivial unless
 286
 287 @exprIsBottom@  is true of expressions that are guaranteed to diverge
 288
 289
 290 \begin{code}
 291 exprIsTrivial (Var v)
 292   | hasNoBinding v                     = idArity v == 0
 293         -- WAS: | Just op <- isPrimOpId_maybe v      = primOpIsDupable op
 294         -- The idea here is that a constructor worker, like $wJust, is
 295         -- really short for (\x -> $wJust x), becuase $wJust has no binding.
 296         -- So it should be treated like a lambda.
 297         -- Ditto unsaturated primops.
 298         -- This came up when dealing with eta expansion/reduction for
 299         --      x = $wJust
 300         -- Here we want to eta-expand.  This looks like an optimisation,
 301         -- but it's important (albeit tiresome) that CoreSat doesn't increase
 302         -- anything's arity
 303   | otherwise                          = True
 304 exprIsTrivial (Type _)                 = True
 305 exprIsTrivial (Lit lit)                = True
 306 exprIsTrivial (App e arg)              = isTypeArg arg && exprIsTrivial e
 307 exprIsTrivial (Note _ e)               = exprIsTrivial e
 308 exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body
 309 exprIsTrivial other                    = False
 310
 311 exprIsAtom :: CoreExpr -> Bool
 312 -- Used to decide whether to let-binding an STG argument
 313 -- when compiling to ILX => type applications are not allowed
 314 exprIsAtom (Var v)    = True    -- primOpIsDupable?
 315 exprIsAtom (Lit lit)  = True
 316 exprIsAtom (Type ty)  = True
 317 exprIsAtom (Note (SCC _) e) = False
 318 exprIsAtom (Note _ e) = exprIsAtom e
 319 exprIsAtom other      = False
 320 \end{code}
 321
 322
 323 @exprIsDupable@ is true of expressions that can be duplicated at a modest
 324                 cost in code size.  This will only happen in different case
 325                 branches, so there's no issue about duplicating work.
 326
 327                 That is, exprIsDupable returns True of (f x) even if
 328                 f is very very expensive to call.
 329
 330                 Its only purpose is to avoid fruitless let-binding
 331                 and then inlining of case join points
 332
 333
 334 \begin{code}
 335 exprIsDupable (Type _)          = True
 336 exprIsDupable (Var v)           = True
 337 exprIsDupable (Lit lit)         = litIsDupable lit
 338 exprIsDupable (Note InlineMe e) = True
 339 exprIsDupable (Note _ e)        = exprIsDupable e
 340 exprIsDupable expr
 341   = go expr 0
 342   where
 343     go (Var v)   n_args = True
 344     go (App f a) n_args =  n_args < dupAppSize
 345                         && exprIsDupable a
 346                         && go f (n_args+1)
 347     go other n_args     = False
 348
 349 dupAppSize :: Int
 350 dupAppSize = 4          -- Size of application we are prepared to duplicate
 351 \end{code}
 352
 353 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 354 it is obviously in weak head normal form, or is cheap to get to WHNF.
 355 [Note that that's not the same as exprIsDupable; an expression might be
 356 big, and hence not dupable, but still cheap.]
 357
 358 By ``cheap'' we mean a computation we're willing to:
 359         push inside a lambda, or
 360         inline at more than one place
 361 That might mean it gets evaluated more than once, instead of being
 362 shared.  The main examples of things which aren't WHNF but are
 363 ``cheap'' are:
 364
 365   *     case e of
 366           pi -> ei
 367         (where e, and all the ei are cheap)
 368
 369   *     let x = e in b
 370         (where e and b are cheap)
 371
 372   *     op x1 ... xn
 373         (where op is a cheap primitive operator)
 374
 375   *     error "foo"
 376         (because we are happy to substitute it inside a lambda)
 377
 378 Notice that a variable is considered 'cheap': we can push it inside a lambda,
 379 because sharing will make sure it is only evaluated once.
 380
 381 \begin{code}
 382 exprIsCheap :: CoreExpr -> Bool
 383 exprIsCheap (Lit lit)             = True
 384 exprIsCheap (Type _)              = True
 385 exprIsCheap (Var _)               = True
 386 exprIsCheap (Note InlineMe e)     = True
 387 exprIsCheap (Note _ e)            = exprIsCheap e
 388 exprIsCheap (Lam x e)             = if isId x then True else exprIsCheap e
 389 exprIsCheap (Case e _ alts)       = exprIsCheap e &&
 390                                     and [exprIsCheap rhs | (_,_,rhs) <- alts]
 391         -- Experimentally, treat (case x of ...) as cheap
 392         -- (and case __coerce x etc.)
 393         -- This improves arities of overloaded functions where
 394         -- there is only dictionary selection (no construction) involved
 395 exprIsCheap (Let (NonRec x _) e)
 396       | isUnLiftedType (idType x) = exprIsCheap e
 397       | otherwise                 = False
 398         -- strict lets always have cheap right hand sides, and
 399         -- do no allocation.
 400
 401 exprIsCheap other_expr
 402   = go other_expr 0 True
 403   where
 404     go (Var f) n_args args_cheap
 405         = (idAppIsCheap f n_args && args_cheap)
 406                         -- A constructor, cheap primop, or partial application
 407
 408           || idAppIsBottom f n_args
 409                         -- Application of a function which
 410                         -- always gives bottom; we treat this as cheap
 411                         -- because it certainly doesn't need to be shared!
 412
 413     go (App f a) n_args args_cheap
 414         | isTypeArg a = go f n_args       args_cheap
 415         | otherwise   = go f (n_args + 1) (exprIsCheap a && args_cheap)
 416
 417     go other   n_args args_cheap = False
 418
 419 idAppIsCheap :: Id -> Int -> Bool
 420 idAppIsCheap id n_val_args
 421   | n_val_args == 0 = True      -- Just a type application of
 422                                 -- a variable (f t1 t2 t3)
 423                                 -- counts as WHNF
 424   | otherwise = case globalIdDetails id of
 425                   DataConId _   -> True
 426                   RecordSelId _ -> True                 -- I'm experimenting with making record selection
 427                                                         -- look cheap, so we will substitute it inside a
 428                                                         -- lambda.  Particularly for dictionary field selection
 429
 430                   PrimOpId op   -> primOpIsCheap op     -- In principle we should worry about primops
 431                                                         -- that return a type variable, since the result
 432                                                         -- might be applied to something, but I'm not going
 433                                                         -- to bother to check the number of args
 434                   other       -> n_val_args < idArity id
 435 \end{code}
 436
 437 exprOkForSpeculation returns True of an expression that it is
 438
 439         * safe to evaluate even if normal order eval might not
 440           evaluate the expression at all, or
 441
 442         * safe *not* to evaluate even if normal order would do so
 443
 444 It returns True iff
 445
 446         the expression guarantees to terminate,
 447         soon,
 448         without raising an exception,
 449         without causing a side effect (e.g. writing a mutable variable)
 450
 451 E.G.
 452         let x = case y# +# 1# of { r# -> I# r# }
 453         in E
 454 ==>
 455         case y# +# 1# of { r# ->
 456         let x = I# r#
 457         in E
 458         }
 459
 460 We can only do this if the (y+1) is ok for speculation: it has no
 461 side effects, and can't diverge or raise an exception.
 462
 463 \begin{code}
 464 exprOkForSpeculation :: CoreExpr -> Bool
 465 exprOkForSpeculation (Lit _)    = True
 466 exprOkForSpeculation (Var v)    = isUnLiftedType (idType v)
 467 exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
 468 exprOkForSpeculation other_expr
 469   = go other_expr 0 True
 470   where
 471     go (Var f) n_args args_ok
 472       = case globalIdDetails f of
 473           DataConId _ -> True   -- The strictness of the constructor has already
 474                                 -- been expressed by its "wrapper", so we don't need
 475                                 -- to take the arguments into account
 476
 477           PrimOpId op -> primOpOkForSpeculation op && args_ok
 478                                 -- A bit conservative: we don't really need
 479                                 -- to care about lazy arguments, but this is easy
 480
 481           other -> False
 482
 483     go (App f a) n_args args_ok
 484         | isTypeArg a = go f n_args       args_ok
 485         | otherwise   = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
 486
 487     go other n_args args_ok = False
 488 \end{code}
 489
 490
 491 \begin{code}
 492 exprIsBottom :: CoreExpr -> Bool        -- True => definitely bottom
 493 exprIsBottom e = go 0 e
 494                where
 495                 -- n is the number of args
 496                  go n (Note _ e)   = go n e
 497                  go n (Let _ e)    = go n e
 498                  go n (Case e _ _) = go 0 e     -- Just check the scrut
 499                  go n (App e _)    = go (n+1) e
 500                  go n (Var v)      = idAppIsBottom v n
 501                  go n (Lit _)      = False
 502                  go n (Lam _ _)    = False
 503
 504 idAppIsBottom :: Id -> Int -> Bool
 505 idAppIsBottom id n_val_args = appIsBottom (idStrictness id) n_val_args
 506 \end{code}
 507
 508 @exprIsValue@ returns true for expressions that are certainly *already*
 509 evaluated to WHNF.  This is used to decide wether it's ok to change
 510         case x of _ -> e   ===>   e
 511
 512 and to decide whether it's safe to discard a `seq`
 513
 514 So, it does *not* treat variables as evaluated, unless they say they are.
 515
 516 But it *does* treat partial applications and constructor applications
 517 as values, even if their arguments are non-trivial;
 518         e.g.  (:) (f x) (map f xs)      is a value
 519               map (...redex...)         is a value
 520 Because `seq` on such things completes immediately
 521
 522 A possible worry: constructors with unboxed args:
 523                 C (f x :: Int#)
 524 Suppose (f x) diverges; then C (f x) is not a value.  True, but
 525 this form is illegal (see the invariants in CoreSyn).  Args of unboxed
 526 type must be ok-for-speculation (or trivial).
 527
 528 \begin{code}
 529 exprIsValue :: CoreExpr -> Bool         -- True => Value-lambda, constructor, PAP
 530 exprIsValue (Type ty)     = True        -- Types are honorary Values; we don't mind
 531                                         -- copying them
 532 exprIsValue (Lit l)       = True
 533 exprIsValue (Lam b e)     = isId b || exprIsValue e
 534 exprIsValue (Note _ e)    = exprIsValue e
 535 exprIsValue other_expr
 536   = go other_expr 0
 537   where
 538     go (Var f) n_args = idAppIsValue f n_args
 539
 540     go (App f a) n_args
 541         | isTypeArg a = go f n_args
 542         | otherwise   = go f (n_args + 1)
 543
 544     go (Note _ f) n_args = go f n_args
 545
 546     go other n_args = False
 547
 548 idAppIsValue :: Id -> Int -> Bool
 549 idAppIsValue id n_val_args
 550   = case globalIdDetails id of
 551         DataConId _ -> True
 552         PrimOpId _  -> n_val_args < idArity id
 553         other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
 554               | otherwise       -> n_val_args < idArity id
 555         -- A worry: what if an Id's unfolding is just itself:
 556         -- then we could get an infinite loop...
 557 \end{code}
 558
 559 \begin{code}
 560 exprIsConApp_maybe :: CoreExpr -> Maybe (DataCon, [CoreExpr])
 561 exprIsConApp_maybe (Note InlineMe expr) = exprIsConApp_maybe expr
 562     -- We ignore InlineMe notes in case we have
 563     --  x = __inline_me__ (a,b)
 564     -- All part of making sure that INLINE pragmas never hurt
 565     -- Marcin tripped on this one when making dictionaries more inlinable
 566
 567 exprIsConApp_maybe expr = analyse (collectArgs expr)
 568   where
 569     analyse (Var fun, args)
 570         | Just con <- isDataConId_maybe fun,
 571           length args >= dataConRepArity con
 572                 -- Might be > because the arity excludes type args
 573         = Just (con,args)
 574
 575         -- Look through unfoldings, but only cheap ones, because
 576         -- we are effectively duplicating the unfolding
 577     analyse (Var fun, [])
 578         | let unf = idUnfolding fun,
 579           isCheapUnfolding unf
 580         = exprIsConApp_maybe (unfoldingTemplate unf)
 581
 582     analyse other = Nothing
 583 \end{code}
 584
 585
 586
 587 %************************************************************************
 588 %*                                                                      *
 589 \subsection{Eta reduction and expansion}
 590 %*                                                                      *
 591 %************************************************************************
 592
 593 @etaReduce@ trys an eta reduction at the top level of a Core Expr.
 594
 595 e.g.    \ x y -> f x y  ===>  f
 596
 597 But we only do this if it gets rid of a whole lambda, not part.
 598 The idea is that lambdas are often quite helpful: they indicate
 599 head normal forms, so we don't want to chuck them away lightly.
 600
 601 \begin{code}
 602 etaReduce :: CoreExpr -> CoreExpr
 603                 -- ToDo: we should really check that we don't turn a non-bottom
 604                 -- lambda into a bottom variable.  Sigh
 605
 606 etaReduce expr@(Lam bndr body)
 607   = check (reverse binders) body
 608   where
 609     (binders, body) = collectBinders expr
 610
 611     check [] body
 612         | not (any (`elemVarSet` body_fvs) binders)
 613         = body                  -- Success!
 614         where
 615           body_fvs = exprFreeVars body
 616
 617     check (b : bs) (App fun arg)
 618         |  (varToCoreExpr b `cheapEqExpr` arg)
 619         = check bs fun
 620
 621     check _ _ = expr    -- Bale out
 622
 623 etaReduce expr = expr           -- The common case
 624 \end{code}
 625
 626
 627 \begin{code}
 628 exprEtaExpandArity :: CoreExpr -> (Int, Bool)
 629 -- The Int is number of value args the thing can be
 630 --      applied to without doing much work
 631 -- The Bool is True iff there are enough explicit value lambdas
 632 --      at the top to make this arity apparent
 633 --      (but ignore it when arity==0)
 634
 635 -- This is used when eta expanding
 636 --      e  ==>  \xy -> e x y
 637 --
 638 -- It returns 1 (or more) to:
 639 --      case x of p -> \s -> ...
 640 -- because for I/O ish things we really want to get that \s to the top.
 641 -- We are prepared to evaluate x each time round the loop in order to get that
 642 --
 643 -- Consider     let x = expensive in \y z -> E
 644 -- We want this to have arity 2 if the \y-abstraction is a 1-shot lambda
 645 --
 646 -- Hence the list of Bools returned by go1
 647 --      NB: this is particularly important/useful for IO state
 648 --      transformers, where we often get
 649 --              let x = E in \ s -> ...
 650 --      and the \s is a real-world state token abstraction.  Such
 651 --      abstractions are almost invariably 1-shot, so we want to
 652 --      pull the \s out, past the let x=E.
 653 --      The hack is in Id.isOneShotLambda
 654
 655 exprEtaExpandArity e
 656   = go 0 e
 657   where
 658     go :: Int -> CoreExpr -> (Int,Bool)
 659     go ar (Lam x e)  | isId x           = go (ar+1) e
 660                      | otherwise        = go ar e
 661     go ar (Note n e) | ok_note n        = go ar e
 662     go ar other                         = (ar + ar', ar' == 0)
 663                                         where
 664                                           ar' = length (go1 other)
 665
 666     go1 :: CoreExpr -> [Bool]
 667         -- (go1 e) = [b1,..,bn]
 668         -- means expression can be rewritten \x_b1 -> ... \x_bn -> body
 669         -- where bi is True <=> the lambda is one-shot
 670
 671     go1 (Note n e) | ok_note n  = go1 e
 672     go1 (Var v)                 = replicate (idArity v) False   -- When the type of the Id
 673                                                                 -- encodes one-shot-ness, use
 674                                                                 -- the idinfo here
 675
 676         -- Lambdas; increase arity
 677     go1 (Lam x e)  | isId x     = isOneShotLambda x : go1 e
 678                    | otherwise  = go1 e
 679
 680         -- Applications; decrease arity
 681     go1 (App f (Type _))        = go1 f
 682     go1 (App f a)               = case go1 f of
 683                                     (one_shot : xs) | one_shot || exprIsCheap a -> xs
 684                                     other                                       -> []
 685
 686         -- Case/Let; keep arity if either the expression is cheap
 687         -- or it's a 1-shot lambda
 688     go1 (Case scrut _ alts) = case foldr1 (zipWith (&&)) [go1 rhs | (_,_,rhs) <- alts] of
 689                                 xs@(one_shot : _) | one_shot || exprIsCheap scrut -> xs
 690                                 other                                             -> []
 691     go1 (Let b e) = case go1 e of
 692                       xs@(one_shot : _) | one_shot || all exprIsCheap (rhssOfBind b) -> xs
 693                       other                                                          -> []
 694
 695     go1 other = []
 696
 697     ok_note (Coerce _ _) = True
 698     ok_note InlineCall   = True
 699     ok_note other        = False
 700             -- Notice that we do not look through __inline_me__
 701             -- This may seem surprising, but consider
 702             --  f = _inline_me (\x -> e)
 703             -- We DO NOT want to eta expand this to
 704             --  f = \x -> (_inline_me (\x -> e)) x
 705             -- because the _inline_me gets dropped now it is applied,
 706             -- giving just
 707             --  f = \x -> e
 708             -- A Bad Idea
 709
 710 min_zero :: [Int] -> Int        -- Find the minimum, but zero is the smallest
 711 min_zero (x:xs) = go x xs
 712                 where
 713                   go 0   xs                 = 0         -- Nothing beats zero
 714                   go min []                 = min
 715                   go min (x:xs) | x < min   = go x xs
 716                                 | otherwise = go min xs
 717
 718 \end{code}
 719
 720
 721 \begin{code}
 722 etaExpand :: Int                -- Add this number of value args
 723           -> UniqSupply
 724           -> CoreExpr -> Type   -- Expression and its type
 725           -> CoreExpr
 726 -- (etaExpand n us e ty) returns an expression with
 727 -- the same meaning as 'e', but with arity 'n'.
 728
 729 -- Given e' = etaExpand n us e ty
 730 -- We should have
 731 --      ty = exprType e = exprType e'
 732 --
 733 -- etaExpand deals with for-alls and coerces. For example:
 734 --              etaExpand 1 E
 735 -- where  E :: forall a. T
 736 --        newtype T = MkT (A -> B)
 737 --
 738 -- would return
 739 --      (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y)
 740
 741 etaExpand n us expr ty
 742   | n == 0      -- Saturated, so nothing to do
 743   = expr
 744
 745   | otherwise   -- An unsaturated constructor or primop; eta expand it
 746   = case splitForAllTy_maybe ty of {
 747           Just (tv,ty') -> Lam tv (etaExpand n us (App expr (Type (mkTyVarTy tv))) ty')
 748
 749         ; Nothing ->
 750
 751         case splitFunTy_maybe ty of {
 752           Just (arg_ty, res_ty) -> Lam arg1 (etaExpand (n-1) us2 (App expr (Var arg1)) res_ty)
 753                                 where
 754                                    arg1       = mkSysLocal SLIT("eta") uniq arg_ty
 755                                    (us1, us2) = splitUniqSupply us
 756                                    uniq       = uniqFromSupply us1
 757
 758         ; Nothing ->
 759
 760         case splitNewType_maybe ty of {
 761           Just ty' -> mkCoerce ty ty' (etaExpand n us (mkCoerce ty' ty expr) ty') ;
 762
 763           Nothing -> pprTrace "Bad eta expand" (ppr expr $$ ppr ty) expr
 764         }}}
 765 \end{code}
 766
 767
 768 exprArity is a cheap-and-cheerful version of exprEtaExpandArity.
 769 It tells how many things the expression can be applied to before doing
 770 any work.  It doesn't look inside cases, lets, etc.  The idea is that
 771 exprEtaExpandArity will do the hard work, leaving something that's easy
 772 for exprArity to grapple with.  In particular, Simplify uses exprArity to
 773 compute the ArityInfo for the Id.
 774
 775 Originally I thought that it was enough just to look for top-level lambdas, but
 776 it isn't.  I've seen this
 777
 778         foo = PrelBase.timesInt
 779
 780 We want foo to get arity 2 even though the eta-expander will leave it
 781 unchanged, in the expectation that it'll be inlined.  But occasionally it
 782 isn't, because foo is blacklisted (used in a rule).
 783
 784 Similarly, see the ok_note check in exprEtaExpandArity.  So
 785         f = __inline_me (\x -> e)
 786 won't be eta-expanded.
 787
 788 And in any case it seems more robust to have exprArity be a bit more intelligent.
 789
 790 \begin{code}
 791 exprArity :: CoreExpr -> Int
 792 exprArity e = go e `max` 0
 793             where
 794               go (Lam x e) | isId x    = go e + 1
 795                            | otherwise = go e
 796               go (Note _ e)            = go e
 797               go (App e (Type t))      = go e
 798               go (App f a)             = go f - 1
 799               go (Var v)               = idArity v
 800               go _                     = 0
 801 \end{code}
 802
 803
 804 %************************************************************************
 805 %*                                                                      *
 806 \subsection{Equality}
 807 %*                                                                      *
 808 %************************************************************************
 809
 810 @cheapEqExpr@ is a cheap equality test which bales out fast!
 811         True  => definitely equal
 812         False => may or may not be equal
 813
 814 \begin{code}
 815 cheapEqExpr :: Expr b -> Expr b -> Bool
 816
 817 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 818 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
 819 cheapEqExpr (Type t1)  (Type t2)  = t1 == t2
 820
 821 cheapEqExpr (App f1 a1) (App f2 a2)
 822   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
 823
 824 cheapEqExpr _ _ = False
 825
 826 exprIsBig :: Expr b -> Bool
 827 -- Returns True of expressions that are too big to be compared by cheapEqExpr
 828 exprIsBig (Lit _)      = False
 829 exprIsBig (Var v)      = False
 830 exprIsBig (Type t)     = False
 831 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 832 exprIsBig other        = True
 833 \end{code}
 834
 835
 836 \begin{code}
 837 eqExpr :: CoreExpr -> CoreExpr -> Bool
 838         -- Works ok at more general type, but only needed at CoreExpr
 839 eqExpr e1 e2
 840   = eq emptyVarEnv e1 e2
 841   where
 842   -- The "env" maps variables in e1 to variables in ty2
 843   -- So when comparing lambdas etc,
 844   -- we in effect substitute v2 for v1 in e1 before continuing
 845     eq env (Var v1) (Var v2) = case lookupVarEnv env v1 of
 846                                   Just v1' -> v1' == v2
 847                                   Nothing  -> v1  == v2
 848
 849     eq env (Lit lit1)   (Lit lit2)   = lit1 == lit2
 850     eq env (App f1 a1)  (App f2 a2)  = eq env f1 f2 && eq env a1 a2
 851     eq env (Lam v1 e1)  (Lam v2 e2)  = eq (extendVarEnv env v1 v2) e1 e2
 852     eq env (Let (NonRec v1 r1) e1)
 853            (Let (NonRec v2 r2) e2)   = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
 854     eq env (Let (Rec ps1) e1)
 855            (Let (Rec ps2) e2)        = length ps1 == length ps2 &&
 856                                        and (zipWith eq_rhs ps1 ps2) &&
 857                                        eq env' e1 e2
 858                                      where
 859                                        env' = extendVarEnvList env [(v1,v2) | ((v1,_),(v2,_)) <- zip ps1 ps2]
 860                                        eq_rhs (_,r1) (_,r2) = eq env' r1 r2
 861     eq env (Case e1 v1 a1)
 862            (Case e2 v2 a2)           = eq env e1 e2 &&
 863                                        length a1 == length a2 &&
 864                                        and (zipWith (eq_alt env') a1 a2)
 865                                      where
 866                                        env' = extendVarEnv env v1 v2
 867
 868     eq env (Note n1 e1) (Note n2 e2) = eq_note env n1 n2 && eq env e1 e2
 869     eq env (Type t1)    (Type t2)    = t1 == t2
 870     eq env e1           e2           = False
 871
 872     eq_list env []       []       = True
 873     eq_list env (e1:es1) (e2:es2) = eq env e1 e2 && eq_list env es1 es2
 874     eq_list env es1      es2      = False
 875
 876     eq_alt env (c1,vs1,r1) (c2,vs2,r2) = c1==c2 &&
 877                                          eq (extendVarEnvList env (vs1 `zip` vs2)) r1 r2
 878
 879     eq_note env (SCC cc1)      (SCC cc2)      = cc1 == cc2
 880     eq_note env (Coerce t1 f1) (Coerce t2 f2) = t1==t2 && f1==f2
 881     eq_note env InlineCall     InlineCall     = True
 882     eq_note env other1         other2         = False
 883 \end{code}
 884
 885
 886 %************************************************************************
 887 %*                                                                      *
 888 \subsection{The size of an expression}
 889 %*                                                                      *
 890 %************************************************************************
 891
 892 \begin{code}
 893 coreBindsSize :: [CoreBind] -> Int
 894 coreBindsSize bs = foldr ((+) . bindSize) 0 bs
 895
 896 exprSize :: CoreExpr -> Int
 897         -- A measure of the size of the expressions
 898         -- It also forces the expression pretty drastically as a side effect
 899 exprSize (Var v)       = varSize v
 900 exprSize (Lit lit)     = lit `seq` 1
 901 exprSize (App f a)     = exprSize f + exprSize a
 902 exprSize (Lam b e)     = varSize b + exprSize e
 903 exprSize (Let b e)     = bindSize b + exprSize e
 904 exprSize (Case e b as) = exprSize e + varSize b + foldr ((+) . altSize) 0 as
 905 exprSize (Note n e)    = noteSize n + exprSize e
 906 exprSize (Type t)      = seqType t `seq` 1
 907
 908 noteSize (SCC cc)       = cc `seq` 1
 909 noteSize (Coerce t1 t2) = seqType t1 `seq` seqType t2 `seq` 1
 910 noteSize InlineCall     = 1
 911 noteSize InlineMe       = 1
 912
 913 varSize :: Var -> Int
 914 varSize b  | isTyVar b = 1
 915            | otherwise = seqType (idType b)             `seq`
 916                          megaSeqIdInfo (idInfo b)       `seq`
 917                          1
 918
 919 varsSize = foldr ((+) . varSize) 0
 920
 921 bindSize (NonRec b e) = varSize b + exprSize e
 922 bindSize (Rec prs)    = foldr ((+) . pairSize) 0 prs
 923
 924 pairSize (b,e) = varSize b + exprSize e
 925
 926 altSize (c,bs,e) = c `seq` varsSize bs + exprSize e
 927 \end{code}
 928
 929
 930 %************************************************************************
 931 %*                                                                      *
 932 \subsection{Hashing}
 933 %*                                                                      *
 934 %************************************************************************
 935
 936 \begin{code}
 937 hashExpr :: CoreExpr -> Int
 938 hashExpr e | hash < 0  = 77     -- Just in case we hit -maxInt
 939            | otherwise = hash
 940            where
 941              hash = abs (hash_expr e)   -- Negative numbers kill UniqFM
 942
 943 hash_expr (Note _ e)              = hash_expr e
 944 hash_expr (Let (NonRec b r) e)    = hashId b
 945 hash_expr (Let (Rec ((b,r):_)) e) = hashId b
 946 hash_expr (Case _ b _)            = hashId b
 947 hash_expr (App f e)               = hash_expr f * fast_hash_expr e
 948 hash_expr (Var v)                 = hashId v
 949 hash_expr (Lit lit)               = hashLiteral lit
 950 hash_expr (Lam b _)               = hashId b
 951 hash_expr (Type t)                = trace "hash_expr: type" 1           -- Shouldn't happen
 952
 953 fast_hash_expr (Var v)          = hashId v
 954 fast_hash_expr (Lit lit)        = hashLiteral lit
 955 fast_hash_expr (App f (Type _)) = fast_hash_expr f
 956 fast_hash_expr (App f a)        = fast_hash_expr a
 957 fast_hash_expr (Lam b _)        = hashId b
 958 fast_hash_expr other            = 1
 959
 960 hashId :: Id -> Int
 961 hashId id = hashName (idName id)
 962 \end{code}