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