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