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 TyCon            ( isNewTyCon )
  54 import Coercion         ( Coercion )
  55 import Name             ( Name )
  56 import OccName          ( OccName )
  57 import Literal          ( Literal, mkMachInt )
  58 import DataCon          ( DataCon, dataConWorkId, dataConTag, dataConTyCon,
  59                           dataConWrapId )
  60 import BasicTypes       ( Activation )
  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 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                    -- exprIsHNF 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
 457 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 458 varsToCoreExprs vs = map varToCoreExpr vs
 459
 460 mkCast   :: Expr b -> Coercion -> Expr b
 461 mkCast e co = Cast e co
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Simple access functions}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 \begin{code}
 472 bindersOf  :: Bind b -> [b]
 473 bindersOf (NonRec binder _) = [binder]
 474 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 475
 476 bindersOfBinds :: [Bind b] -> [b]
 477 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 478
 479 rhssOfBind :: Bind b -> [Expr b]
 480 rhssOfBind (NonRec _ rhs) = [rhs]
 481 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 482
 483 rhssOfAlts :: [Alt b] -> [Expr b]
 484 rhssOfAlts alts = [e | (_,_,e) <- alts]
 485
 486 flattenBinds :: [Bind b] -> [(b, Expr b)]       -- Get all the lhs/rhs pairs
 487 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 488 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 489 flattenBinds []                   = []
 490 \end{code}
 491
 492 We often want to strip off leading lambdas before getting down to
 493 business.  @collectBinders@ is your friend.
 494
 495 We expect (by convention) type-, and value- lambdas in that
 496 order.
 497
 498 \begin{code}
 499 collectBinders               :: Expr b -> ([b],         Expr b)
 500 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 501 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 502 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 503
 504 collectBinders expr
 505   = go [] expr
 506   where
 507     go bs (Lam b e) = go (b:bs) e
 508     go bs e          = (reverse bs, e)
 509
 510 collectTyAndValBinders expr
 511   = (tvs, ids, body)
 512   where
 513     (tvs, body1) = collectTyBinders expr
 514     (ids, body)  = collectValBinders body1
 515
 516 collectTyBinders expr
 517   = go [] expr
 518   where
 519     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 520     go tvs e                     = (reverse tvs, e)
 521
 522 collectValBinders expr
 523   = go [] expr
 524   where
 525     go ids (Lam b e) | isId b = go (b:ids) e
 526     go ids body               = (reverse ids, body)
 527 \end{code}
 528
 529
 530 @collectArgs@ takes an application expression, returning the function
 531 and the arguments to which it is applied.
 532
 533 \begin{code}
 534 collectArgs :: Expr b -> (Expr b, [Arg b])
 535 collectArgs expr
 536   = go expr []
 537   where
 538     go (App f a) as = go f (a:as)
 539     go e         as = (e, as)
 540 \end{code}
 541
 542 coreExprCc gets the cost centre enclosing an expression, if any.
 543 It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e
 544
 545 \begin{code}
 546 coreExprCc :: Expr b -> CostCentre
 547 coreExprCc (Note (SCC cc) e)   = cc
 548 coreExprCc (Note other_note e) = coreExprCc e
 549 coreExprCc (Lam _ e)           = coreExprCc e
 550 coreExprCc other               = noCostCentre
 551 \end{code}
 552
 553
 554
 555 %************************************************************************
 556 %*                                                                      *
 557 \subsection{Predicates}
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 562 i.e. if type applications are actual lambdas because types are kept around
 563 at runtime.
 564
 565 Similarly isRuntimeArg.
 566
 567 \begin{code}
 568 isRuntimeVar :: Var -> Bool
 569 isRuntimeVar | opt_RuntimeTypes = \v -> True
 570              | otherwise        = \v -> isId v
 571
 572 isRuntimeArg :: CoreExpr -> Bool
 573 isRuntimeArg | opt_RuntimeTypes = \e -> True
 574              | otherwise        = \e -> isValArg e
 575 \end{code}
 576
 577 \begin{code}
 578 isValArg (Type _) = False
 579 isValArg other    = True
 580
 581 isTypeArg (Type _) = True
 582 isTypeArg other    = False
 583
 584 valBndrCount :: [CoreBndr] -> Int
 585 valBndrCount []                   = 0
 586 valBndrCount (b : bs) | isId b    = 1 + valBndrCount bs
 587                       | otherwise = valBndrCount bs
 588
 589 valArgCount :: [Arg b] -> Int
 590 valArgCount []              = 0
 591 valArgCount (Type _ : args) = valArgCount args
 592 valArgCount (other  : args) = 1 + valArgCount args
 593 \end{code}
 594
 595
 596 %************************************************************************
 597 %*                                                                      *
 598 \subsection{Seq stuff}
 599 %*                                                                      *
 600 %************************************************************************
 601
 602 \begin{code}
 603 seqExpr :: CoreExpr -> ()
 604 seqExpr (Var v)         = v `seq` ()
 605 seqExpr (Lit lit)       = lit `seq` ()
 606 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 607 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 608 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 609 -- gaw 2004
 610 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 611 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 612 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 613 seqExpr (Type t)        = seqType t
 614
 615 seqExprs [] = ()
 616 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 617
 618 seqNote (CoreNote s)   = s `seq` ()
 619 seqNote other          = ()
 620
 621 seqBndr b = b `seq` ()
 622
 623 seqBndrs [] = ()
 624 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 625
 626 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 627 seqBind (Rec prs)    = seqPairs prs
 628
 629 seqPairs [] = ()
 630 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 631
 632 seqAlts [] = ()
 633 seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 634
 635 seqRules [] = ()
 636 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 637   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 638 seqRules (BuiltinRule {} : rules) = seqRules rules
 639 \end{code}
 640
 641
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsection{Annotated core; annotation at every node in the tree}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 \begin{code}
 650 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 651
 652 data AnnExpr' bndr annot
 653   = AnnVar      Id
 654   | AnnLit      Literal
 655   | AnnLam      bndr (AnnExpr bndr annot)
 656   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 657 -- gaw 2004
 658   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 659   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 660   | AnnCast     (AnnExpr bndr annot) Coercion
 661   | AnnNote     Note (AnnExpr bndr annot)
 662   | AnnType     Type
 663
 664 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 665
 666 data AnnBind bndr annot
 667   = AnnNonRec bndr (AnnExpr bndr annot)
 668   | AnnRec    [(bndr, AnnExpr bndr annot)]
 669 \end{code}
 670
 671 \begin{code}
 672 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 673 deAnnotate (_, e) = deAnnotate' e
 674
 675 deAnnotate' (AnnType t)           = Type t
 676 deAnnotate' (AnnVar  v)           = Var v
 677 deAnnotate' (AnnLit  lit)         = Lit lit
 678 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 679 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 680 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 681 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 682
 683 deAnnotate' (AnnLet bind body)
 684   = Let (deAnnBind bind) (deAnnotate body)
 685   where
 686     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 687     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 688
 689 -- gaw 2004
 690 deAnnotate' (AnnCase scrut v t alts)
 691   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 692
 693 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 694 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 695 \end{code}
 696
 697 \begin{code}
 698 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 699 collectAnnBndrs e
 700   = collect [] e
 701   where
 702     collect bs (_, AnnLam b body) = collect (b:bs) body
 703     collect bs body               = (reverse bs, body)
 704 \end{code}