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