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