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