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