compiler/coreSyn/CoreSyn.lhs

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