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