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