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