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