compiler/coreSyn/CoreSyn.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 CoreSyn: A data type for the Haskell compiler midsection
   7
   8 \begin{code}
   9 module CoreSyn (
  10         Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
  11         CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
  12         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
  13
  14         mkLets, mkLams,
  15         mkApps, mkTyApps, mkValApps, mkVarApps,
  16         mkLit, mkIntLitInt, mkIntLit,
  17         mkConApp, mkCast,
  18         varToCoreExpr, varsToCoreExprs,
  19
  20         isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
  21         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
  22         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
  23         collectArgs,
  24         coreExprCc,
  25         flattenBinds,
  26
  27         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
  28
  29         -- Unfoldings
  30         Unfolding(..),  UnfoldingGuidance(..),  -- Both abstract everywhere but in CoreUnfold.lhs
  31         noUnfolding, evaldUnfolding, mkOtherCon,
  32         unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
  33         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
  34         hasUnfolding, hasSomeUnfolding, neverUnfold,
  35
  36         -- Seq stuff
  37         seqExpr, seqExprs, seqUnfolding,
  38
  39         -- Annotated expressions
  40         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
  41         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
  42
  43         -- Core rules
  44         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  45         RuleName, seqRules, ruleArity,
  46         isBuiltinRule, ruleName, isLocalRule, ruleIdName
  47     ) where
  48
  49 #include "HsVersions.h"
  50
  51 import StaticFlags
  52 import CostCentre
  53 import Var
  54 import Type
  55 import Coercion
  56 import Name
  57 import Literal
  58 import DataCon
  59 import BasicTypes
  60 import FastString
  61 import Outputable
  62 import Util
  63
  64 infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps`
  65 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
  66 \end{code}
  67
  68 %************************************************************************
  69 %*                                                                      *
  70 \subsection{The main data types}
  71 %*                                                                      *
  72 %************************************************************************
  73
  74 These data types are the heart of the compiler
  75
  76 \begin{code}
  77 infixl 8 `App`  -- App brackets to the left
  78
  79 data Expr b     -- "b" for the type of binders,
  80   = Var   Id
  81   | Lit   Literal
  82   | App   (Expr b) (Arg b)              -- See Note [CoreSyn let/app invariant]
  83   | Lam   b (Expr b)
  84   | Let   (Bind b) (Expr b)             -- See [CoreSyn let/app invariant],
  85                                         -- and [CoreSyn letrec invariant]
  86   | Case  (Expr b) b Type [Alt b]       -- Binder gets bound to value of scrutinee
  87                                         -- See Note [CoreSyn case invariants]
  88   | Cast  (Expr b) Coercion
  89   | Note  Note (Expr b)
  90   | Type  Type                  -- This should only show up at the top
  91                                 -- level of an Arg
  92
  93 type Arg b = Expr b             -- Can be a Type
  94
  95 type Alt b = (AltCon, [b], Expr b)      -- (DEFAULT, [], rhs) is the default alternative
  96
  97 data AltCon = DataAlt DataCon   -- Invariant: the DataCon is always from
  98                                 -- a *data* type, and never from a *newtype*
  99             | LitAlt  Literal
 100             | DEFAULT
 101          deriving (Eq, Ord)
 102
 103
 104 data Bind b = NonRec b (Expr b)
 105               | Rec [(b, (Expr b))]
 106 \end{code}
 107
 108 -------------------------- CoreSyn INVARIANTS ---------------------------
 109
 110 Note [CoreSyn top-level invariant]
 111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 112 * The RHSs of all top-level lets must be of LIFTED type.
 113
 114 Note [CoreSyn letrec invariant]
 115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 116 * The RHS of a letrec must be of LIFTED type.
 117
 118 Note [CoreSyn let/app invariant]
 119 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 120 * The RHS of a non-recursive let, *and* the argument of an App,
 121   may be of UNLIFTED type, but only if the expression
 122   is ok-for-speculation.  This means that the let can be floated around
 123   without difficulty.  e.g.
 124         y::Int# = x +# 1#       ok
 125         y::Int# = fac 4#        not ok [use case instead]
 126 This is intially enforced by DsUtils.mkDsLet and mkDsApp
 127
 128 Note [CoreSyn case invariants]
 129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 130 Invariant: The DEFAULT case must be *first*, if it occurs at all
 131
 132 Invariant: The remaining cases are in order of increasing
 133                 tag     (for DataAlts)
 134                 lit     (for LitAlts)
 135             This makes finding the relevant constructor easy,
 136             and makes comparison easier too
 137
 138 Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
 139            meaning that it covers all cases that can occur
 140
 141     An "exhaustive" case does not necessarily mention all constructors:
 142         data Foo = Red | Green | Blue
 143
 144         ...case x of
 145                 Red   -> True
 146                 other -> f (case x of
 147                                 Green -> ...
 148                                 Blue  -> ... )
 149     The inner case does not need a Red alternative, because x can't be Red at
 150     that program point.
 151
 152
 153 Note [CoreSyn let goal]
 154 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 155 * The simplifier tries to ensure that if the RHS of a let is a constructor
 156   application, its arguments are trivial, so that the constructor can be
 157   inlined vigorously.
 158
 159
 160 \begin{code}
 161 data Note
 162   = SCC CostCentre
 163
 164   | InlineMe            -- Instructs simplifer to treat the enclosed expression
 165                         -- as very small, and inline it at its call sites
 166
 167   | CoreNote String     -- A generic core annotation, propagated but not used by GHC
 168
 169 -- NOTE: we also treat expressions wrapped in InlineMe as
 170 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
 171 -- What this means is that we obediently inline even things that don't
 172 -- look like valuse.  This is sometimes important:
 173 --      {-# INLINE f #-}
 174 --      f = g . h
 175 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
 176 -- inside an INLINE, so it'll stay looking like a redex.  Nevertheless, we
 177 -- should inline f even inside lambdas.  In effect, we should trust the programmer.
 178 \end{code}
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Transformation rules}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 The CoreRule type and its friends are dealt with mainly in CoreRules,
 188 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 189
 190 A Rule is
 191
 192   "local"  if the function it is a rule for is defined in the
 193            same module as the rule itself.
 194
 195   "orphan" if nothing on the LHS is defined in the same module
 196            as the rule itself
 197
 198 \begin{code}
 199 type RuleName = FastString
 200
 201 data CoreRule
 202   = Rule {
 203         ru_name :: RuleName,
 204         ru_act  :: Activation,  -- When the rule is active
 205
 206         -- Rough-matching stuff
 207         -- see comments with InstEnv.Instance( is_cls, is_rough )
 208         ru_fn    :: Name,       -- Name of the Id at the head of this rule
 209         ru_rough :: [Maybe Name],       -- Name at the head of each argument
 210
 211         -- Proper-matching stuff
 212         -- see comments with InstEnv.Instance( is_tvs, is_tys )
 213         ru_bndrs :: [CoreBndr], -- Forall'd variables
 214         ru_args  :: [CoreExpr], -- LHS args
 215
 216         -- And the right-hand side
 217         ru_rhs   :: CoreExpr,
 218
 219         -- Locality
 220         ru_local :: Bool        -- The fn at the head of the rule is
 221                                 -- defined in the same module as the rule
 222                                 -- and is not an implicit Id (like a record sel
 223                                 -- class op, or data con)
 224                 -- NB: ru_local is *not* used to decide orphan-hood
 225                 --      c.g. MkIface.coreRuleToIfaceRule
 226     }
 227
 228   | BuiltinRule {               -- Built-in rules are used for constant folding
 229         ru_name :: RuleName,    -- and suchlike.  It has no free variables.
 230         ru_fn :: Name,          -- Name of the Id at
 231                                 -- the head of this rule
 232         ru_nargs :: Int,        -- Number of args that ru_try expects,
 233                                 -- including type args
 234         ru_try  :: [CoreExpr] -> Maybe CoreExpr }
 235                 -- This function does the rewrite.  It given too many
 236                 -- arguments, it simply discards them; the returned CoreExpr
 237                 -- is just the rewrite of ru_fn applied to the first ru_nargs args
 238                 -- See Note [Extra args in rule matching] in Rules.lhs
 239
 240 isBuiltinRule :: CoreRule -> Bool
 241 isBuiltinRule (BuiltinRule {}) = True
 242 isBuiltinRule _                = False
 243
 244 ruleArity :: CoreRule -> Int
 245 ruleArity (BuiltinRule {ru_nargs = n}) = n
 246 ruleArity (Rule {ru_args = args})      = length args
 247
 248 ruleName :: CoreRule -> RuleName
 249 ruleName = ru_name
 250
 251 ruleIdName :: CoreRule -> Name
 252 ruleIdName = ru_fn
 253
 254 isLocalRule :: CoreRule -> Bool
 255 isLocalRule = ru_local
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261                 Unfoldings
 262 %*                                                                      *
 263 %************************************************************************
 264
 265 The @Unfolding@ type is declared here to avoid numerous loops, but it
 266 should be abstract everywhere except in CoreUnfold.lhs
 267
 268 \begin{code}
 269 data Unfolding
 270   = NoUnfolding
 271
 272   | OtherCon [AltCon]           -- It ain't one of these
 273                                 -- (OtherCon xs) also indicates that something has been evaluated
 274                                 -- and hence there's no point in re-evaluating it.
 275                                 -- OtherCon [] is used even for non-data-type values
 276                                 -- to indicated evaluated-ness.  Notably:
 277                                 --      data C = C !(Int -> Int)
 278                                 --      case x of { C f -> ... }
 279                                 -- Here, f gets an OtherCon [] unfolding.
 280
 281   | CompulsoryUnfolding CoreExpr        -- There is no "original" definition,
 282                                         -- so you'd better unfold.
 283
 284   | CoreUnfolding                       -- An unfolding with redundant cached information
 285                 CoreExpr                -- Template; binder-info is correct
 286                 Bool                    -- True <=> top level binding
 287                 Bool                    -- exprIsHNF template (cached); it is ok to discard a `seq` on
 288                                         --      this variable
 289                 Bool                    -- True <=> doesn't waste (much) work to expand inside an inlining
 290                                         --      Basically it's exprIsCheap
 291                 UnfoldingGuidance       -- Tells about the *size* of the template.
 292
 293
 294 data UnfoldingGuidance
 295   = UnfoldNever
 296   | UnfoldIfGoodArgs    Int     -- and "n" value args
 297
 298                         [Int]   -- Discount if the argument is evaluated.
 299                                 -- (i.e., a simplification will definitely
 300                                 -- be possible).  One elt of the list per *value* arg.
 301
 302                         Int     -- The "size" of the unfolding; to be elaborated
 303                                 -- later. ToDo
 304
 305                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 306                                 -- a context (case (thing args) of ...),
 307                                 -- (where there are the right number of arguments.)
 308
 309 noUnfolding, evaldUnfolding :: Unfolding
 310 noUnfolding    = NoUnfolding
 311 evaldUnfolding = OtherCon []
 312
 313 mkOtherCon :: [AltCon] -> Unfolding
 314 mkOtherCon = OtherCon
 315
 316 seqUnfolding :: Unfolding -> ()
 317 seqUnfolding (CoreUnfolding e top b1 b2 g)
 318   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
 319 seqUnfolding _ = ()
 320
 321 seqGuidance :: UnfoldingGuidance -> ()
 322 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
 323 seqGuidance _                           = ()
 324 \end{code}
 325
 326 \begin{code}
 327 unfoldingTemplate :: Unfolding -> CoreExpr
 328 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
 329 unfoldingTemplate (CompulsoryUnfolding expr)   = expr
 330 unfoldingTemplate _ = panic "getUnfoldingTemplate"
 331
 332 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 333 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
 334 maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
 335 maybeUnfoldingTemplate _                            = Nothing
 336
 337 otherCons :: Unfolding -> [AltCon]
 338 otherCons (OtherCon cons) = cons
 339 otherCons _               = []
 340
 341 isValueUnfolding :: Unfolding -> Bool
 342         -- Returns False for OtherCon
 343 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 344 isValueUnfolding _                                = False
 345
 346 isEvaldUnfolding :: Unfolding -> Bool
 347         -- Returns True for OtherCon
 348 isEvaldUnfolding (OtherCon _)                     = True
 349 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 350 isEvaldUnfolding _                                = False
 351
 352 isCheapUnfolding :: Unfolding -> Bool
 353 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
 354 isCheapUnfolding _                                = False
 355
 356 isCompulsoryUnfolding :: Unfolding -> Bool
 357 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
 358 isCompulsoryUnfolding _                       = False
 359
 360 hasUnfolding :: Unfolding -> Bool
 361 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
 362 hasUnfolding (CompulsoryUnfolding _)   = True
 363 hasUnfolding _                         = False
 364
 365 hasSomeUnfolding :: Unfolding -> Bool
 366 hasSomeUnfolding NoUnfolding = False
 367 hasSomeUnfolding _           = True
 368
 369 neverUnfold :: Unfolding -> Bool
 370 neverUnfold NoUnfolding                         = True
 371 neverUnfold (OtherCon _)                        = True
 372 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
 373 neverUnfold _                                   = False
 374 \end{code}
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection{The main data type}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 385 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 386 -- constructor-applications with LitArg args, then you could get
 387 -- rid of this Ord.
 388
 389 instance Outputable AltCon where
 390   ppr (DataAlt dc) = ppr dc
 391   ppr (LitAlt lit) = ppr lit
 392   ppr DEFAULT      = ptext SLIT("__DEFAULT")
 393
 394 instance Show AltCon where
 395   showsPrec p con = showsPrecSDoc p (ppr con)
 396
 397 cmpAlt :: Alt b -> Alt b -> Ordering
 398 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 399
 400 ltAlt :: Alt b -> Alt b -> Bool
 401 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 402
 403 cmpAltCon :: AltCon -> AltCon -> Ordering
 404 -- Compares AltCons within a single list of alternatives
 405 cmpAltCon DEFAULT      DEFAULT     = EQ
 406 cmpAltCon DEFAULT      _           = LT
 407
 408 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 409 cmpAltCon (DataAlt _)  DEFAULT      = GT
 410 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 411 cmpAltCon (LitAlt _)   DEFAULT      = GT
 412
 413 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 414                                   ppr con1 <+> ppr con2 )
 415                       LT
 416 \end{code}
 417
 418
 419 %************************************************************************
 420 %*                                                                      *
 421 \subsection{Useful synonyms}
 422 %*                                                                      *
 423 %************************************************************************
 424
 425 The common case
 426
 427 \begin{code}
 428 type CoreBndr = Var
 429 type CoreExpr = Expr CoreBndr
 430 type CoreArg  = Arg  CoreBndr
 431 type CoreBind = Bind CoreBndr
 432 type CoreAlt  = Alt  CoreBndr
 433 \end{code}
 434
 435 Binders are ``tagged'' with a \tr{t}:
 436
 437 \begin{code}
 438 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 439
 440 type TaggedBind t = Bind (TaggedBndr t)
 441 type TaggedExpr t = Expr (TaggedBndr t)
 442 type TaggedArg  t = Arg  (TaggedBndr t)
 443 type TaggedAlt  t = Alt  (TaggedBndr t)
 444
 445 instance Outputable b => Outputable (TaggedBndr b) where
 446   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 447
 448 instance Outputable b => OutputableBndr (TaggedBndr b) where
 449   pprBndr _ b = ppr b   -- Simple
 450 \end{code}
 451
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsection{Core-constructing functions with checking}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{code}
 460 mkApps    :: Expr b -> [Arg b]  -> Expr b
 461 mkTyApps  :: Expr b -> [Type]   -> Expr b
 462 mkValApps :: Expr b -> [Expr b] -> Expr b
 463 mkVarApps :: Expr b -> [Var] -> Expr b
 464
 465 mkApps    f args = foldl App                       f args
 466 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 467 mkValApps f args = foldl (\ e a -> App e a)        f args
 468 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 469
 470 mkLit         :: Literal -> Expr b
 471 mkIntLit      :: Integer -> Expr b
 472 mkIntLitInt   :: Int     -> Expr b
 473 mkConApp      :: DataCon -> [Arg b] -> Expr b
 474 mkLets        :: [Bind b] -> Expr b -> Expr b
 475 mkLams        :: [b] -> Expr b -> Expr b
 476
 477 mkLit lit         = Lit lit
 478 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 479
 480 mkLams binders body = foldr Lam body binders
 481 mkLets binds body   = foldr Let body binds
 482
 483 mkIntLit    n = Lit (mkMachInt n)
 484 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 485
 486 varToCoreExpr :: CoreBndr -> Expr b
 487 varToCoreExpr v | isId v    = Var v
 488                 | otherwise = Type (mkTyVarTy v)
 489
 490 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 491 varsToCoreExprs vs = map varToCoreExpr vs
 492
 493 mkCast   :: Expr b -> Coercion -> Expr b
 494 mkCast e co = Cast e co
 495 \end{code}
 496
 497
 498 %************************************************************************
 499 %*                                                                      *
 500 \subsection{Simple access functions}
 501 %*                                                                      *
 502 %************************************************************************
 503
 504 \begin{code}
 505 bindersOf  :: Bind b -> [b]
 506 bindersOf (NonRec binder _) = [binder]
 507 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 508
 509 bindersOfBinds :: [Bind b] -> [b]
 510 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 511
 512 rhssOfBind :: Bind b -> [Expr b]
 513 rhssOfBind (NonRec _ rhs) = [rhs]
 514 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 515
 516 rhssOfAlts :: [Alt b] -> [Expr b]
 517 rhssOfAlts alts = [e | (_,_,e) <- alts]
 518
 519 flattenBinds :: [Bind b] -> [(b, Expr b)]       -- Get all the lhs/rhs pairs
 520 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 521 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 522 flattenBinds []                   = []
 523 \end{code}
 524
 525 We often want to strip off leading lambdas before getting down to
 526 business.  @collectBinders@ is your friend.
 527
 528 We expect (by convention) type-, and value- lambdas in that
 529 order.
 530
 531 \begin{code}
 532 collectBinders               :: Expr b -> ([b],         Expr b)
 533 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 534 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 535 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 536
 537 collectBinders expr
 538   = go [] expr
 539   where
 540     go bs (Lam b e) = go (b:bs) e
 541     go bs e          = (reverse bs, e)
 542
 543 collectTyAndValBinders expr
 544   = (tvs, ids, body)
 545   where
 546     (tvs, body1) = collectTyBinders expr
 547     (ids, body)  = collectValBinders body1
 548
 549 collectTyBinders expr
 550   = go [] expr
 551   where
 552     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 553     go tvs e                     = (reverse tvs, e)
 554
 555 collectValBinders expr
 556   = go [] expr
 557   where
 558     go ids (Lam b e) | isId b = go (b:ids) e
 559     go ids body               = (reverse ids, body)
 560 \end{code}
 561
 562
 563 @collectArgs@ takes an application expression, returning the function
 564 and the arguments to which it is applied.
 565
 566 \begin{code}
 567 collectArgs :: Expr b -> (Expr b, [Arg b])
 568 collectArgs expr
 569   = go expr []
 570   where
 571     go (App f a) as = go f (a:as)
 572     go e         as = (e, as)
 573 \end{code}
 574
 575 coreExprCc gets the cost centre enclosing an expression, if any.
 576 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 577
 578 \begin{code}
 579 coreExprCc :: Expr b -> CostCentre
 580 coreExprCc (Note (SCC cc) _)   = cc
 581 coreExprCc (Note _ e)          = coreExprCc e
 582 coreExprCc (Lam _ e)           = coreExprCc e
 583 coreExprCc _                   = noCostCentre
 584 \end{code}
 585
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection{Predicates}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 595 i.e. if type applications are actual lambdas because types are kept around
 596 at runtime.
 597
 598 Similarly isRuntimeArg.
 599
 600 \begin{code}
 601 isRuntimeVar :: Var -> Bool
 602 isRuntimeVar | opt_RuntimeTypes = \_ -> True
 603              | otherwise        = \v -> isId v
 604
 605 isRuntimeArg :: CoreExpr -> Bool
 606 isRuntimeArg | opt_RuntimeTypes = \_ -> True
 607              | otherwise        = \e -> isValArg e
 608 \end{code}
 609
 610 \begin{code}
 611 isValArg :: Expr b -> Bool
 612 isValArg (Type _) = False
 613 isValArg _        = True
 614
 615 isTypeArg :: Expr b -> Bool
 616 isTypeArg (Type _) = True
 617 isTypeArg _        = False
 618
 619 valBndrCount :: [CoreBndr] -> Int
 620 valBndrCount = count isId
 621
 622 valArgCount :: [Arg b] -> Int
 623 valArgCount = count isValArg
 624 \end{code}
 625
 626
 627 %************************************************************************
 628 %*                                                                      *
 629 \subsection{Seq stuff}
 630 %*                                                                      *
 631 %************************************************************************
 632
 633 \begin{code}
 634 seqExpr :: CoreExpr -> ()
 635 seqExpr (Var v)         = v `seq` ()
 636 seqExpr (Lit lit)       = lit `seq` ()
 637 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 638 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 639 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 640 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 641 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 642 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 643 seqExpr (Type t)        = seqType t
 644
 645 seqExprs :: [CoreExpr] -> ()
 646 seqExprs [] = ()
 647 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 648
 649 seqNote :: Note -> ()
 650 seqNote (CoreNote s)   = s `seq` ()
 651 seqNote _              = ()
 652
 653 seqBndr :: CoreBndr -> ()
 654 seqBndr b = b `seq` ()
 655
 656 seqBndrs :: [CoreBndr] -> ()
 657 seqBndrs [] = ()
 658 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 659
 660 seqBind :: Bind CoreBndr -> ()
 661 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 662 seqBind (Rec prs)    = seqPairs prs
 663
 664 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
 665 seqPairs [] = ()
 666 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 667
 668 seqAlts :: [CoreAlt] -> ()
 669 seqAlts [] = ()
 670 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 671
 672 seqRules :: [CoreRule] -> ()
 673 seqRules [] = ()
 674 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 675   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 676 seqRules (BuiltinRule {} : rules) = seqRules rules
 677 \end{code}
 678
 679
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection{Annotated core; annotation at every node in the tree}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 689
 690 data AnnExpr' bndr annot
 691   = AnnVar      Id
 692   | AnnLit      Literal
 693   | AnnLam      bndr (AnnExpr bndr annot)
 694   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 695   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 696   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 697   | AnnCast     (AnnExpr bndr annot) Coercion
 698   | AnnNote     Note (AnnExpr bndr annot)
 699   | AnnType     Type
 700
 701 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 702
 703 data AnnBind bndr annot
 704   = AnnNonRec bndr (AnnExpr bndr annot)
 705   | AnnRec    [(bndr, AnnExpr bndr annot)]
 706 \end{code}
 707
 708 \begin{code}
 709 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 710 deAnnotate (_, e) = deAnnotate' e
 711
 712 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
 713 deAnnotate' (AnnType t)           = Type t
 714 deAnnotate' (AnnVar  v)           = Var v
 715 deAnnotate' (AnnLit  lit)         = Lit lit
 716 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 717 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 718 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 719 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 720
 721 deAnnotate' (AnnLet bind body)
 722   = Let (deAnnBind bind) (deAnnotate body)
 723   where
 724     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 725     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 726
 727 deAnnotate' (AnnCase scrut v t alts)
 728   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 729
 730 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 731 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 732 \end{code}
 733
 734 \begin{code}
 735 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 736 collectAnnBndrs e
 737   = collect [] e
 738   where
 739     collect bs (_, AnnLam b body) = collect (b:bs) body
 740     collect bs body               = (reverse bs, body)
 741 \end{code}