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