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