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