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