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
  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 "exhausive" 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         ru_try  :: [CoreExpr] -> Maybe CoreExpr }
 233
 234 isBuiltinRule (BuiltinRule {}) = True
 235 isBuiltinRule _                = False
 236
 237 ruleArity :: CoreRule -> Int
 238 ruleArity (BuiltinRule {ru_nargs = n}) = n
 239 ruleArity (Rule {ru_args = args})      = length args
 240
 241 ruleName :: CoreRule -> RuleName
 242 ruleName = ru_name
 243
 244 ruleIdName :: CoreRule -> Name
 245 ruleIdName = ru_fn
 246
 247 isLocalRule :: CoreRule -> Bool
 248 isLocalRule = ru_local
 249 \end{code}
 250
 251
 252 %************************************************************************
 253 %*                                                                      *
 254                 Unfoldings
 255 %*                                                                      *
 256 %************************************************************************
 257
 258 The @Unfolding@ type is declared here to avoid numerous loops, but it
 259 should be abstract everywhere except in CoreUnfold.lhs
 260
 261 \begin{code}
 262 data Unfolding
 263   = NoUnfolding
 264
 265   | OtherCon [AltCon]           -- It ain't one of these
 266                                 -- (OtherCon xs) also indicates that something has been evaluated
 267                                 -- and hence there's no point in re-evaluating it.
 268                                 -- OtherCon [] is used even for non-data-type values
 269                                 -- to indicated evaluated-ness.  Notably:
 270                                 --      data C = C !(Int -> Int)
 271                                 --      case x of { C f -> ... }
 272                                 -- Here, f gets an OtherCon [] unfolding.
 273
 274   | CompulsoryUnfolding CoreExpr        -- There is no "original" definition,
 275                                         -- so you'd better unfold.
 276
 277   | CoreUnfolding                       -- An unfolding with redundant cached information
 278                 CoreExpr                -- Template; binder-info is correct
 279                 Bool                    -- True <=> top level binding
 280                 Bool                    -- exprIsHNF template (cached); it is ok to discard a `seq` on
 281                                         --      this variable
 282                 Bool                    -- True <=> doesn't waste (much) work to expand inside an inlining
 283                                         --      Basically it's exprIsCheap
 284                 UnfoldingGuidance       -- Tells about the *size* of the template.
 285
 286
 287 data UnfoldingGuidance
 288   = UnfoldNever
 289   | UnfoldIfGoodArgs    Int     -- and "n" value args
 290
 291                         [Int]   -- Discount if the argument is evaluated.
 292                                 -- (i.e., a simplification will definitely
 293                                 -- be possible).  One elt of the list per *value* arg.
 294
 295                         Int     -- The "size" of the unfolding; to be elaborated
 296                                 -- later. ToDo
 297
 298                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 299                                 -- a context (case (thing args) of ...),
 300                                 -- (where there are the right number of arguments.)
 301
 302 noUnfolding    = NoUnfolding
 303 evaldUnfolding = OtherCon []
 304
 305 mkOtherCon = OtherCon
 306
 307 seqUnfolding :: Unfolding -> ()
 308 seqUnfolding (CoreUnfolding e top b1 b2 g)
 309   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
 310 seqUnfolding other = ()
 311
 312 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
 313 seqGuidance other                       = ()
 314 \end{code}
 315
 316 \begin{code}
 317 unfoldingTemplate :: Unfolding -> CoreExpr
 318 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
 319 unfoldingTemplate (CompulsoryUnfolding expr)   = expr
 320 unfoldingTemplate other = panic "getUnfoldingTemplate"
 321
 322 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 323 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
 324 maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
 325 maybeUnfoldingTemplate other                        = Nothing
 326
 327 otherCons :: Unfolding -> [AltCon]
 328 otherCons (OtherCon cons) = cons
 329 otherCons other           = []
 330
 331 isValueUnfolding :: Unfolding -> Bool
 332         -- Returns False for OtherCon
 333 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 334 isValueUnfolding other                            = False
 335
 336 isEvaldUnfolding :: Unfolding -> Bool
 337         -- Returns True for OtherCon
 338 isEvaldUnfolding (OtherCon _)                     = True
 339 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 340 isEvaldUnfolding other                            = False
 341
 342 isCheapUnfolding :: Unfolding -> Bool
 343 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
 344 isCheapUnfolding other                            = False
 345
 346 isCompulsoryUnfolding :: Unfolding -> Bool
 347 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
 348 isCompulsoryUnfolding other                   = False
 349
 350 hasUnfolding :: Unfolding -> Bool
 351 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
 352 hasUnfolding (CompulsoryUnfolding _)   = True
 353 hasUnfolding other                     = False
 354
 355 hasSomeUnfolding :: Unfolding -> Bool
 356 hasSomeUnfolding NoUnfolding = False
 357 hasSomeUnfolding other       = True
 358
 359 neverUnfold :: Unfolding -> Bool
 360 neverUnfold NoUnfolding                         = True
 361 neverUnfold (OtherCon _)                        = True
 362 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
 363 neverUnfold other                               = False
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{The main data type}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 375 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 376 -- constructor-applications with LitArg args, then you could get
 377 -- rid of this Ord.
 378
 379 instance Outputable AltCon where
 380   ppr (DataAlt dc) = ppr dc
 381   ppr (LitAlt lit) = ppr lit
 382   ppr DEFAULT      = ptext SLIT("__DEFAULT")
 383
 384 instance Show AltCon where
 385   showsPrec p con = showsPrecSDoc p (ppr con)
 386
 387 cmpAlt :: Alt b -> Alt b -> Ordering
 388 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 389
 390 ltAlt :: Alt b -> Alt b -> Bool
 391 ltAlt a1 a2 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
 392
 393 cmpAltCon :: AltCon -> AltCon -> Ordering
 394 -- Compares AltCons within a single list of alternatives
 395 cmpAltCon DEFAULT      DEFAULT     = EQ
 396 cmpAltCon DEFAULT      con         = LT
 397
 398 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 399 cmpAltCon (DataAlt _)  DEFAULT      = GT
 400 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 401 cmpAltCon (LitAlt _)   DEFAULT      = GT
 402
 403 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 404                                   ppr con1 <+> ppr con2 )
 405                       LT
 406 \end{code}
 407
 408
 409 %************************************************************************
 410 %*                                                                      *
 411 \subsection{Useful synonyms}
 412 %*                                                                      *
 413 %************************************************************************
 414
 415 The common case
 416
 417 \begin{code}
 418 type CoreBndr = Var
 419 type CoreExpr = Expr CoreBndr
 420 type CoreArg  = Arg  CoreBndr
 421 type CoreBind = Bind CoreBndr
 422 type CoreAlt  = Alt  CoreBndr
 423 \end{code}
 424
 425 Binders are ``tagged'' with a \tr{t}:
 426
 427 \begin{code}
 428 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 429
 430 type TaggedBind t = Bind (TaggedBndr t)
 431 type TaggedExpr t = Expr (TaggedBndr t)
 432 type TaggedArg  t = Arg  (TaggedBndr t)
 433 type TaggedAlt  t = Alt  (TaggedBndr t)
 434
 435 instance Outputable b => Outputable (TaggedBndr b) where
 436   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 437
 438 instance Outputable b => OutputableBndr (TaggedBndr b) where
 439   pprBndr _ b = ppr b   -- Simple
 440 \end{code}
 441
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection{Core-constructing functions with checking}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 \begin{code}
 450 mkApps    :: Expr b -> [Arg b]  -> Expr b
 451 mkTyApps  :: Expr b -> [Type]   -> Expr b
 452 mkValApps :: Expr b -> [Expr b] -> Expr b
 453 mkVarApps :: Expr b -> [Var] -> Expr b
 454
 455 mkApps    f args = foldl App                       f args
 456 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 457 mkValApps f args = foldl (\ e a -> App e a)        f args
 458 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 459
 460 mkLit         :: Literal -> Expr b
 461 mkIntLit      :: Integer -> Expr b
 462 mkIntLitInt   :: Int     -> Expr b
 463 mkConApp      :: DataCon -> [Arg b] -> Expr b
 464 mkLets        :: [Bind b] -> Expr b -> Expr b
 465 mkLams        :: [b] -> Expr b -> Expr b
 466
 467 mkLit lit         = Lit lit
 468 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 469
 470 mkLams binders body = foldr Lam body binders
 471 mkLets binds body   = foldr Let body binds
 472
 473 mkIntLit    n = Lit (mkMachInt n)
 474 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 475
 476 varToCoreExpr :: CoreBndr -> Expr b
 477 varToCoreExpr v | isId v    = Var v
 478                 | otherwise = Type (mkTyVarTy v)
 479
 480 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 481 varsToCoreExprs vs = map varToCoreExpr vs
 482
 483 mkCast   :: Expr b -> Coercion -> Expr b
 484 mkCast e co = Cast e co
 485 \end{code}
 486
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection{Simple access functions}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 \begin{code}
 495 bindersOf  :: Bind b -> [b]
 496 bindersOf (NonRec binder _) = [binder]
 497 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 498
 499 bindersOfBinds :: [Bind b] -> [b]
 500 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 501
 502 rhssOfBind :: Bind b -> [Expr b]
 503 rhssOfBind (NonRec _ rhs) = [rhs]
 504 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 505
 506 rhssOfAlts :: [Alt b] -> [Expr b]
 507 rhssOfAlts alts = [e | (_,_,e) <- alts]
 508
 509 flattenBinds :: [Bind b] -> [(b, Expr b)]       -- Get all the lhs/rhs pairs
 510 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 511 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 512 flattenBinds []                   = []
 513 \end{code}
 514
 515 We often want to strip off leading lambdas before getting down to
 516 business.  @collectBinders@ is your friend.
 517
 518 We expect (by convention) type-, and value- lambdas in that
 519 order.
 520
 521 \begin{code}
 522 collectBinders               :: Expr b -> ([b],         Expr b)
 523 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 524 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 525 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 526
 527 collectBinders expr
 528   = go [] expr
 529   where
 530     go bs (Lam b e) = go (b:bs) e
 531     go bs e          = (reverse bs, e)
 532
 533 collectTyAndValBinders expr
 534   = (tvs, ids, body)
 535   where
 536     (tvs, body1) = collectTyBinders expr
 537     (ids, body)  = collectValBinders body1
 538
 539 collectTyBinders expr
 540   = go [] expr
 541   where
 542     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 543     go tvs e                     = (reverse tvs, e)
 544
 545 collectValBinders expr
 546   = go [] expr
 547   where
 548     go ids (Lam b e) | isId b = go (b:ids) e
 549     go ids body               = (reverse ids, body)
 550 \end{code}
 551
 552
 553 @collectArgs@ takes an application expression, returning the function
 554 and the arguments to which it is applied.
 555
 556 \begin{code}
 557 collectArgs :: Expr b -> (Expr b, [Arg b])
 558 collectArgs expr
 559   = go expr []
 560   where
 561     go (App f a) as = go f (a:as)
 562     go e         as = (e, as)
 563 \end{code}
 564
 565 coreExprCc gets the cost centre enclosing an expression, if any.
 566 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 567
 568 \begin{code}
 569 coreExprCc :: Expr b -> CostCentre
 570 coreExprCc (Note (SCC cc) e)   = cc
 571 coreExprCc (Note other_note e) = coreExprCc e
 572 coreExprCc (Lam _ e)           = coreExprCc e
 573 coreExprCc other               = noCostCentre
 574 \end{code}
 575
 576
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection{Predicates}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 585 i.e. if type applications are actual lambdas because types are kept around
 586 at runtime.
 587
 588 Similarly isRuntimeArg.
 589
 590 \begin{code}
 591 isRuntimeVar :: Var -> Bool
 592 isRuntimeVar | opt_RuntimeTypes = \v -> True
 593              | otherwise        = \v -> isId v
 594
 595 isRuntimeArg :: CoreExpr -> Bool
 596 isRuntimeArg | opt_RuntimeTypes = \e -> True
 597              | otherwise        = \e -> isValArg e
 598 \end{code}
 599
 600 \begin{code}
 601 isValArg (Type _) = False
 602 isValArg other    = True
 603
 604 isTypeArg (Type _) = True
 605 isTypeArg other    = False
 606
 607 valBndrCount :: [CoreBndr] -> Int
 608 valBndrCount []                   = 0
 609 valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
 610                       | otherwise = valBndrCount bs
 611
 612 valArgCount :: [Arg b] -> Int
 613 valArgCount []              = 0
 614 valArgCount (Type _ : args) = valArgCount args
 615 valArgCount (other  : args) = 1 + valArgCount args
 616 \end{code}
 617
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{Seq stuff}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626 seqExpr :: CoreExpr -> ()
 627 seqExpr (Var v)         = v `seq` ()
 628 seqExpr (Lit lit)       = lit `seq` ()
 629 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 630 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 631 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 632 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 633 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 634 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 635 seqExpr (Type t)        = seqType t
 636
 637 seqExprs [] = ()
 638 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 639
 640 seqNote (CoreNote s)   = s `seq` ()
 641 seqNote other          = ()
 642
 643 seqBndr b = b `seq` ()
 644
 645 seqBndrs [] = ()
 646 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 647
 648 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 649 seqBind (Rec prs)    = seqPairs prs
 650
 651 seqPairs [] = ()
 652 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 653
 654 seqAlts [] = ()
 655 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 656
 657 seqRules [] = ()
 658 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 659   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 660 seqRules (BuiltinRule {} : rules) = seqRules rules
 661 \end{code}
 662
 663
 664
 665 %************************************************************************
 666 %*                                                                      *
 667 \subsection{Annotated core; annotation at every node in the tree}
 668 %*                                                                      *
 669 %************************************************************************
 670
 671 \begin{code}
 672 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 673
 674 data AnnExpr' bndr annot
 675   = AnnVar      Id
 676   | AnnLit      Literal
 677   | AnnLam      bndr (AnnExpr bndr annot)
 678   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 679   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 680   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 681   | AnnCast     (AnnExpr bndr annot) Coercion
 682   | AnnNote     Note (AnnExpr bndr annot)
 683   | AnnType     Type
 684
 685 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 686
 687 data AnnBind bndr annot
 688   = AnnNonRec bndr (AnnExpr bndr annot)
 689   | AnnRec    [(bndr, AnnExpr bndr annot)]
 690 \end{code}
 691
 692 \begin{code}
 693 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 694 deAnnotate (_, e) = deAnnotate' e
 695
 696 deAnnotate' (AnnType t)           = Type t
 697 deAnnotate' (AnnVar  v)           = Var v
 698 deAnnotate' (AnnLit  lit)         = Lit lit
 699 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 700 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 701 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 702 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 703
 704 deAnnotate' (AnnLet bind body)
 705   = Let (deAnnBind bind) (deAnnotate body)
 706   where
 707     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 708     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 709
 710 deAnnotate' (AnnCase scrut v t alts)
 711   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 712
 713 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 714 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 715 \end{code}
 716
 717 \begin{code}
 718 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 719 collectAnnBndrs e
 720   = collect [] e
 721   where
 722     collect bs (_, AnnLam b body) = collect (b:bs) body
 723     collect bs body               = (reverse bs, body)
 724 \end{code}