ghc/compiler/coreSyn/CoreSyn.lhs

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