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