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