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