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