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 \begin{code}
   7 {-# LANGUAGE DeriveDataTypeable #-}
   8
   9 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
  10 module CoreSyn (
  11         -- * Main data types
  12         Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
  13         CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
  14         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
  15
  16         -- ** 'Expr' construction
  17         mkLets, mkLams,
  18         mkApps, mkTyApps, mkVarApps,
  19
  20         mkIntLit, mkIntLitInt,
  21         mkWordLit, mkWordLitWord,
  22         mkCharLit, mkStringLit,
  23         mkFloatLit, mkFloatLitFloat,
  24         mkDoubleLit, mkDoubleLitDouble,
  25
  26         mkConApp, mkTyBind,
  27         varToCoreExpr, varsToCoreExprs,
  28
  29         isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
  30
  31         -- ** Simple 'Expr' access functions and predicates
  32         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
  33         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
  34         collectArgs, coreExprCc, flattenBinds,
  35
  36         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
  37
  38         -- * Unfolding data types
  39         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
  40                 -- Abstract everywhere but in CoreUnfold.lhs
  41
  42         -- ** Constructing 'Unfolding's
  43         noUnfolding, evaldUnfolding, mkOtherCon,
  44         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
  45
  46         -- ** Predicates and deconstruction on 'Unfolding'
  47         unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,
  48         maybeUnfoldingTemplate, otherCons, unfoldingArity,
  49         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
  50         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
  51         isStableUnfolding, isStableUnfolding_maybe,
  52         isClosedUnfolding, hasSomeUnfolding,
  53         canUnfold, neverUnfoldGuidance, isStableSource,
  54
  55         -- * Strictness
  56         seqExpr, seqExprs, seqUnfolding,
  57
  58         -- * Annotated expression data types
  59         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
  60
  61         -- ** Operations on annotations
  62         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
  63
  64         -- * Core rule data types
  65         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  66         RuleName, IdUnfoldingFun,
  67
  68         -- ** Operations on 'CoreRule's
  69         seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
  70         setRuleIdName,
  71         isBuiltinRule, isLocalRule
  72     ) where
  73
  74 #include "HsVersions.h"
  75
  76 import CostCentre
  77 import Var
  78 import Type
  79 import Coercion
  80 import Name
  81 import Literal
  82 import DataCon
  83 import BasicTypes
  84 import FastString
  85 import Outputable
  86 import Util
  87
  88 import Data.Data
  89 import Data.Word
  90
  91 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
  92 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
  93 \end{code}
  94
  95 %************************************************************************
  96 %*                                                                      *
  97 \subsection{The main data types}
  98 %*                                                                      *
  99 %************************************************************************
 100
 101 These data types are the heart of the compiler
 102
 103 \begin{code}
 104 -- | This is the data type that represents GHCs core intermediate language. Currently
 105 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 106 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
 107 --
 108 -- We get from Haskell source to this Core language in a number of stages:
 109 --
 110 -- 1. The source code is parsed into an abstract syntax tree, which is represented
 111 --    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
 112 --
 113 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
 114 --    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
 115 --    For example, this program:
 116 --
 117 -- @
 118 --      f x = let f x = x + 1
 119 --            in f (x - 2)
 120 -- @
 121 --
 122 --    Would be renamed by having 'Unique's attached so it looked something like this:
 123 --
 124 -- @
 125 --      f_1 x_2 = let f_3 x_4 = x_4 + 1
 126 --                in f_3 (x_2 - 2)
 127 -- @
 128 --
 129 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
 130 --    type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
 131 --
 132 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
 133 --    this 'Expr' type, which has far fewer constructors and hence is easier to perform
 134 --    optimization, analysis and code generation on.
 135 --
 136 -- The type parameter @b@ is for the type of binders in the expression tree.
 137 data Expr b
 138   = Var   Id                            -- ^ Variables
 139
 140   | Lit   Literal                       -- ^ Primitive literals
 141
 142   | App   (Expr b) (Arg b)              -- ^ Applications: note that the argument may be a 'Type'.
 143                                         --
 144                                         -- See "CoreSyn#let_app_invariant" for another invariant
 145
 146   | Lam   b (Expr b)                    -- ^ Lambda abstraction
 147
 148   | Let   (Bind b) (Expr b)             -- ^ Recursive and non recursive @let@s. Operationally
 149                                         -- this corresponds to allocating a thunk for the things
 150                                         -- bound and then executing the sub-expression.
 151                                         --
 152                                         -- #top_level_invariant#
 153                                         -- #letrec_invariant#
 154                                         --
 155                                         -- The right hand sides of all top-level and recursive @let@s
 156                                         -- /must/ be of lifted type (see "Type#type_classification" for
 157                                         -- the meaning of /lifted/ vs. /unlifted/).
 158                                         --
 159                                         -- #let_app_invariant#
 160                                         -- The right hand side of of a non-recursive 'Let'
 161                                         -- _and_ the argument of an 'App',
 162                                         -- /may/ be of unlifted type, but only if the expression
 163                                         -- is ok-for-speculation.  This means that the let can be floated
 164                                         -- around without difficulty. For example, this is OK:
 165                                         --
 166                                         -- > y::Int# = x +# 1#
 167                                         --
 168                                         -- But this is not, as it may affect termination if the
 169                                         -- expression is floated out:
 170                                         --
 171                                         -- > y::Int# = fac 4#
 172                                         --
 173                                         -- In this situation you should use @case@ rather than a @let@. The function
 174                                         -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
 175                                         -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
 176                                         -- which will generate a @case@ if necessary
 177                                         --
 178                                         -- #type_let#
 179                                         -- We allow a /non-recursive/ let to bind a type variable, thus:
 180                                         --
 181                                         -- > Let (NonRec tv (Type ty)) body
 182                                         --
 183                                         -- This can be very convenient for postponing type substitutions until
 184                                         -- the next run of the simplifier.
 185                                         --
 186                                         -- At the moment, the rest of the compiler only deals with type-let
 187                                         -- in a Let expression, rather than at top level.  We may want to revist
 188                                         -- this choice.
 189
 190   | Case  (Expr b) b Type [Alt b]       -- ^ Case split. Operationally this corresponds to evaluating
 191                                         -- the scrutinee (expression examined) to weak head normal form
 192                                         -- and then examining at most one level of resulting constructor (i.e. you
 193                                         -- cannot do nested pattern matching directly with this).
 194                                         --
 195                                         -- The binder gets bound to the value of the scrutinee,
 196                                         -- and the 'Type' must be that of all the case alternatives
 197                                         --
 198                                         -- #case_invariants#
 199                                         -- This is one of the more complicated elements of the Core language,
 200                                         -- and comes with a number of restrictions:
 201                                         --
 202                                         -- The 'DEFAULT' case alternative must be first in the list,
 203                                         -- if it occurs at all.
 204                                         --
 205                                         -- The remaining cases are in order of increasing
 206                                         --      tag     (for 'DataAlts') or
 207                                         --      lit     (for 'LitAlts').
 208                                         -- This makes finding the relevant constructor easy,
 209                                         -- and makes comparison easier too.
 210                                         --
 211                                         -- The list of alternatives must be exhaustive. An /exhaustive/ case
 212                                         -- does not necessarily mention all constructors:
 213                                         --
 214                                         -- @
 215                                         --      data Foo = Red | Green | Blue
 216                                         -- ... case x of
 217                                         --      Red   -> True
 218                                         --      other -> f (case x of
 219                                         --                      Green -> ...
 220                                         --                      Blue  -> ... ) ...
 221                                         -- @
 222                                         --
 223                                         -- The inner case does not need a @Red@ alternative, because @x@
 224                                         -- can't be @Red@ at that program point.
 225
 226   | Cast  (Expr b) Coercion             -- ^ Cast an expression to a particular type.
 227                                         -- This is used to implement @newtype@s (a @newtype@ constructor or
 228                                         -- destructor just becomes a 'Cast' in Core) and GADTs.
 229
 230   | Note  Note (Expr b)                 -- ^ Notes. These allow general information to be
 231                                         -- added to expressions in the syntax tree
 232
 233   | Type  Type                          -- ^ A type: this should only show up at the top
 234                                         -- level of an Arg
 235   deriving (Data, Typeable)
 236
 237 -- | Type synonym for expressions that occur in function argument positions.
 238 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
 239 type Arg b = Expr b
 240
 241 -- | A case split alternative. Consists of the constructor leading to the alternative,
 242 -- the variables bound from the constructor, and the expression to be executed given that binding.
 243 -- The default alternative is @(DEFAULT, [], rhs)@
 244 type Alt b = (AltCon, [b], Expr b)
 245
 246 -- | A case alternative constructor (i.e. pattern match)
 247 data AltCon = DataAlt DataCon   -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
 248                                 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
 249             | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
 250             | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
 251          deriving (Eq, Ord, Data, Typeable)
 252
 253 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
 254 data Bind b = NonRec b (Expr b)
 255             | Rec [(b, (Expr b))]
 256   deriving (Data, Typeable)
 257 \end{code}
 258
 259 -------------------------- CoreSyn INVARIANTS ---------------------------
 260
 261 Note [CoreSyn top-level invariant]
 262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 263 See #toplevel_invariant#
 264
 265 Note [CoreSyn letrec invariant]
 266 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 267 See #letrec_invariant#
 268
 269 Note [CoreSyn let/app invariant]
 270 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 271 See #let_app_invariant#
 272
 273 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
 274
 275 Note [CoreSyn case invariants]
 276 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 277 See #case_invariants#
 278
 279 Note [CoreSyn let goal]
 280 ~~~~~~~~~~~~~~~~~~~~~~~
 281 * The simplifier tries to ensure that if the RHS of a let is a constructor
 282   application, its arguments are trivial, so that the constructor can be
 283   inlined vigorously.
 284
 285
 286 Note [Type let]
 287 ~~~~~~~~~~~~~~~
 288 See #type_let#
 289
 290 \begin{code}
 291
 292 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
 293 data Note
 294   = SCC CostCentre      -- ^ A cost centre annotation for profiling
 295   | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
 296   deriving (Data, Typeable)
 297 \end{code}
 298
 299
 300 %************************************************************************
 301 %*                                                                      *
 302 \subsection{Transformation rules}
 303 %*                                                                      *
 304 %************************************************************************
 305
 306 The CoreRule type and its friends are dealt with mainly in CoreRules,
 307 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 308
 309 \begin{code}
 310 -- | A 'CoreRule' is:
 311 --
 312 -- * \"Local\" if the function it is a rule for is defined in the
 313 --   same module as the rule itself.
 314 --
 315 -- * \"Orphan\" if nothing on the LHS is defined in the same module
 316 --   as the rule itself
 317 data CoreRule
 318   = Rule {
 319         ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
 320         ru_act  :: Activation,          -- ^ When the rule is active
 321
 322         -- Rough-matching stuff
 323         -- see comments with InstEnv.Instance( is_cls, is_rough )
 324         ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
 325         ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
 326
 327         -- Proper-matching stuff
 328         -- see comments with InstEnv.Instance( is_tvs, is_tys )
 329         ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
 330         ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
 331
 332         -- And the right-hand side
 333         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
 334                                         -- Occurrence info is guaranteed correct
 335                                         -- See Note [OccInfo in unfoldings and rules]
 336
 337         -- Locality
 338         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
 339                                 -- defined in the same module as the rule
 340                                 -- and is not an implicit 'Id' (like a record selector,
 341                                 -- class operation, or data constructor)
 342
 343                 -- NB: ru_local is *not* used to decide orphan-hood
 344                 --      c.g. MkIface.coreRuleToIfaceRule
 345     }
 346
 347   -- | Built-in rules are used for constant folding
 348   -- and suchlike.  They have no free variables.
 349   | BuiltinRule {
 350         ru_name  :: RuleName,   -- ^ As above
 351         ru_fn    :: Name,       -- ^ As above
 352         ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' consumes,
 353                                 -- if it fires, including type arguments
 354         ru_try  :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 355                 -- ^ This function does the rewrite.  It given too many
 356                 -- arguments, it simply discards them; the returned 'CoreExpr'
 357                 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
 358     }
 359                 -- See Note [Extra args in rule matching] in Rules.lhs
 360
 361 type IdUnfoldingFun = Id -> Unfolding
 362 -- A function that embodies how to unfold an Id if you need
 363 -- to do that in the Rule.  The reason we need to pass this info in
 364 -- is that whether an Id is unfoldable depends on the simplifier phase
 365
 366 isBuiltinRule :: CoreRule -> Bool
 367 isBuiltinRule (BuiltinRule {}) = True
 368 isBuiltinRule _                = False
 369
 370 -- | The number of arguments the 'ru_fn' must be applied
 371 -- to before the rule can match on it
 372 ruleArity :: CoreRule -> Int
 373 ruleArity (BuiltinRule {ru_nargs = n}) = n
 374 ruleArity (Rule {ru_args = args})      = length args
 375
 376 ruleName :: CoreRule -> RuleName
 377 ruleName = ru_name
 378
 379 ruleActivation_maybe :: CoreRule -> Maybe Activation
 380 ruleActivation_maybe (BuiltinRule { })       = Nothing
 381 ruleActivation_maybe (Rule { ru_act = act }) = Just act
 382
 383 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
 384 ruleIdName :: CoreRule -> Name
 385 ruleIdName = ru_fn
 386
 387 isLocalRule :: CoreRule -> Bool
 388 isLocalRule = ru_local
 389
 390 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
 391 setRuleIdName :: Name -> CoreRule -> CoreRule
 392 setRuleIdName nm ru = ru { ru_fn = nm }
 393 \end{code}
 394
 395
 396 %************************************************************************
 397 %*                                                                      *
 398                 Unfoldings
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 The @Unfolding@ type is declared here to avoid numerous loops
 403
 404 \begin{code}
 405 -- | Records the /unfolding/ of an identifier, which is approximately the form the
 406 -- identifier would have if we substituted its definition in for the identifier.
 407 -- This type should be treated as abstract everywhere except in "CoreUnfold"
 408 data Unfolding
 409   = NoUnfolding        -- ^ We have no information about the unfolding
 410
 411   | OtherCon [AltCon]  -- ^ It ain't one of these constructors.
 412                        -- @OtherCon xs@ also indicates that something has been evaluated
 413                        -- and hence there's no point in re-evaluating it.
 414                        -- @OtherCon []@ is used even for non-data-type values
 415                        -- to indicated evaluated-ness.  Notably:
 416                        --
 417                        -- > data C = C !(Int -> Int)
 418                        -- > case x of { C f -> ... }
 419                        --
 420                        -- Here, @f@ gets an @OtherCon []@ unfolding.
 421
 422   | DFunUnfolding       -- The Unfolding of a DFunId
 423                         -- See Note [DFun unfoldings]
 424                         --     df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
 425                         --                                 (op2 a1..am d1..dn)
 426
 427         Arity           -- Arity = m+n, the *total* number of args
 428                         --   (unusually, both type and value) to the dfun
 429
 430         DataCon         -- The dictionary data constructor (possibly a newtype datacon)
 431
 432         [CoreExpr]      -- The [CoreExpr] are the superclasses and methods [op1,op2],
 433                         -- in positional order.
 434                         -- They are usually variables, but can be trivial expressions
 435                         -- instead (e.g. a type application).
 436
 437   | CoreUnfolding {             -- An unfolding for an Id with no pragma,
 438                                 -- or perhaps a NOINLINE pragma
 439                                 -- (For NOINLINE, the phase, if any, is in the
 440                                 -- InlinePragInfo for this Id.)
 441         uf_tmpl       :: CoreExpr,        -- Template; occurrence info is correct
 442         uf_src        :: UnfoldingSource, -- Where the unfolding came from
 443         uf_is_top     :: Bool,          -- True <=> top level binding
 444         uf_arity      :: Arity,         -- Number of value arguments expected
 445         uf_is_value   :: Bool,          -- exprIsHNF template (cached); it is ok to discard
 446                                         --      a `seq` on this variable
 447         uf_is_conlike :: Bool,          -- True <=> applicn of constructor or CONLIKE function
 448                                         --      Cached version of exprIsConLike
 449         uf_is_cheap   :: Bool,          -- True <=> doesn't waste (much) work to expand
 450                                         --          inside an inlining
 451                                         --      Cached version of exprIsCheap
 452         uf_expandable :: Bool,          -- True <=> can expand in RULE matching
 453                                         --      Cached version of exprIsExpandable
 454         uf_guidance   :: UnfoldingGuidance      -- Tells about the *size* of the template.
 455     }
 456   -- ^ An unfolding with redundant cached information. Parameters:
 457   --
 458   --  uf_tmpl: Template used to perform unfolding;
 459   --           NB: Occurrence info is guaranteed correct:
 460   --               see Note [OccInfo in unfoldings and rules]
 461   --
 462   --  uf_is_top: Is this a top level binding?
 463   --
 464   --  uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
 465   --     this variable
 466   --
 467   --  uf_is_cheap:  Does this waste only a little work if we expand it inside an inlining?
 468   --     Basically this is a cached version of 'exprIsCheap'
 469   --
 470   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 471
 472 ------------------------------------------------
 473 data UnfoldingSource
 474   = InlineRhs          -- The current rhs of the function
 475                        -- Replace uf_tmpl each time around
 476
 477   | InlineStable       -- From an INLINE or INLINABLE pragma
 478                        -- Do not replace uf_tmpl; instead, keep it unchanged
 479                        -- See Note [InlineRules]
 480
 481   | InlineCompulsory   -- Something that *has* no binding, so you *must* inline it
 482                        -- Only a few primop-like things have this property
 483                        -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
 484                        -- Inline absolutely always, however boring the context.
 485
 486   | InlineWrapper Id   -- This unfolding is a the wrapper in a
 487                        --     worker/wrapper split from the strictness analyser
 488                        -- The Id is the worker-id
 489                        -- Used to abbreviate the uf_tmpl in interface files
 490                        --       which don't need to contain the RHS;
 491                        --       it can be derived from the strictness info
 492
 493
 494
 495 -- | 'UnfoldingGuidance' says when unfolding should take place
 496 data UnfoldingGuidance
 497   = UnfWhen {   -- Inline without thinking about the *size* of the uf_tmpl
 498                 -- Used (a) for small *and* cheap unfoldings
 499                 --      (b) for INLINE functions
 500                 -- See Note [INLINE for small functions] in CoreUnfold
 501       ug_unsat_ok  :: Bool,     -- True <=> ok to inline even if unsaturated
 502       ug_boring_ok :: Bool      -- True <=> ok to inline even if the context is boring
 503                 -- So True,True means "always"
 504     }
 505
 506   | UnfIfGoodArgs {     -- Arose from a normal Id; the info here is the
 507                         -- result of a simple analysis of the RHS
 508
 509       ug_args ::  [Int],  -- Discount if the argument is evaluated.
 510                           -- (i.e., a simplification will definitely
 511                           -- be possible).  One elt of the list per *value* arg.
 512
 513       ug_size :: Int,     -- The "size" of the unfolding.
 514
 515       ug_res :: Int       -- Scrutinee discount: the discount to substract if the thing is in
 516     }                     -- a context (case (thing args) of ...),
 517                           -- (where there are the right number of arguments.)
 518
 519   | UnfNever        -- The RHS is big, so don't inline it
 520 \end{code}
 521
 522
 523 Note [DFun unfoldings]
 524 ~~~~~~~~~~~~~~~~~~~~~~
 525 The Arity in a DFunUnfolding is total number of args (type and value)
 526 that the DFun needs to produce a dictionary.  That's not necessarily
 527 related to the ordinary arity of the dfun Id, esp if the class has
 528 one method, so the dictionary is represented by a newtype.  Example
 529
 530      class C a where { op :: a -> Int }
 531      instance C a -> C [a] where op xs = op (head xs)
 532
 533 The instance translates to
 534
 535      $dfCList :: forall a. C a => C [a]  -- Arity 2!
 536      $dfCList = /\a.\d. $copList {a} d |> co
 537
 538      $copList :: forall a. C a => [a] -> Int  -- Arity 2!
 539      $copList = /\a.\d.\xs. op {a} d (head xs)
 540
 541 Now we might encounter (op (dfCList {ty} d) a1 a2)
 542 and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
 543 has all its arguments, even though its (value) arity is 2.  That's
 544 why we record the number of expected arguments in the DFunUnfolding.
 545
 546 Note that although it's an Arity, it's most convenient for it to give
 547 the *total* number of arguments, both type and value.  See the use
 548 site in exprIsConApp_maybe.
 549
 550 \begin{code}
 551 -- Constants for the UnfWhen constructor
 552 needSaturated, unSaturatedOk :: Bool
 553 needSaturated = False
 554 unSaturatedOk = True
 555
 556 boringCxtNotOk, boringCxtOk :: Bool
 557 boringCxtOk    = True
 558 boringCxtNotOk = False
 559
 560 ------------------------------------------------
 561 noUnfolding :: Unfolding
 562 -- ^ There is no known 'Unfolding'
 563 evaldUnfolding :: Unfolding
 564 -- ^ This unfolding marks the associated thing as being evaluated
 565
 566 noUnfolding    = NoUnfolding
 567 evaldUnfolding = OtherCon []
 568
 569 mkOtherCon :: [AltCon] -> Unfolding
 570 mkOtherCon = OtherCon
 571
 572 seqUnfolding :: Unfolding -> ()
 573 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
 574                 uf_is_value = b1, uf_is_cheap = b2,
 575                 uf_expandable = b3, uf_is_conlike = b4,
 576                 uf_arity = a, uf_guidance = g})
 577   = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
 578
 579 seqUnfolding _ = ()
 580
 581 seqGuidance :: UnfoldingGuidance -> ()
 582 seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
 583 seqGuidance _                      = ()
 584 \end{code}
 585
 586 \begin{code}
 587 isStableSource :: UnfoldingSource -> Bool
 588 -- Keep the unfolding template
 589 isStableSource InlineCompulsory   = True
 590 isStableSource InlineStable       = True
 591 isStableSource (InlineWrapper {}) = True
 592 isStableSource InlineRhs          = False
 593
 594 -- | Retrieves the template of an unfolding: panics if none is known
 595 unfoldingTemplate :: Unfolding -> CoreExpr
 596 unfoldingTemplate = uf_tmpl
 597
 598 setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
 599 setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
 600
 601 -- | Retrieves the template of an unfolding if possible
 602 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 603 maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })       = Just expr
 604 maybeUnfoldingTemplate _                                        = Nothing
 605
 606 -- | The constructors that the unfolding could never be:
 607 -- returns @[]@ if no information is available
 608 otherCons :: Unfolding -> [AltCon]
 609 otherCons (OtherCon cons) = cons
 610 otherCons _               = []
 611
 612 -- | Determines if it is certainly the case that the unfolding will
 613 -- yield a value (something in HNF): returns @False@ if unsure
 614 isValueUnfolding :: Unfolding -> Bool
 615         -- Returns False for OtherCon
 616 isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 617 isValueUnfolding _                                          = False
 618
 619 -- | Determines if it possibly the case that the unfolding will
 620 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 621 -- for 'OtherCon'
 622 isEvaldUnfolding :: Unfolding -> Bool
 623         -- Returns True for OtherCon
 624 isEvaldUnfolding (OtherCon _)                               = True
 625 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
 626 isEvaldUnfolding _                                          = False
 627
 628 -- | @True@ if the unfolding is a constructor application, the application
 629 -- of a CONLIKE function or 'OtherCon'
 630 isConLikeUnfolding :: Unfolding -> Bool
 631 isConLikeUnfolding (OtherCon _)                             = True
 632 isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con
 633 isConLikeUnfolding _                                        = False
 634
 635 -- | Is the thing we will unfold into certainly cheap?
 636 isCheapUnfolding :: Unfolding -> Bool
 637 isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
 638 isCheapUnfolding _                                          = False
 639
 640 isExpandableUnfolding :: Unfolding -> Bool
 641 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
 642 isExpandableUnfolding _                                              = False
 643
 644 expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
 645 -- Expand an expandable unfolding; this is used in rule matching
 646 --   See Note [Expanding variables] in Rules.lhs
 647 -- The key point here is that CONLIKE things can be expanded
 648 expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
 649 expandUnfolding_maybe _                                                       = Nothing
 650
 651 isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
 652 isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
 653    | isStableSource src
 654    = Just (src, unsat_ok)
 655    where
 656      unsat_ok = case guide of
 657                   UnfWhen unsat_ok _ -> unsat_ok
 658                   _                  -> needSaturated
 659 isStableUnfolding_maybe _ = Nothing
 660
 661 isCompulsoryUnfolding :: Unfolding -> Bool
 662 isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
 663 isCompulsoryUnfolding _                                             = False
 664
 665 isStableUnfolding :: Unfolding -> Bool
 666 -- True of unfoldings that should not be overwritten
 667 -- by a CoreUnfolding for the RHS of a let-binding
 668 isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
 669 isStableUnfolding (DFunUnfolding {})               = True
 670 isStableUnfolding _                                = False
 671
 672 unfoldingArity :: Unfolding -> Arity
 673 unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
 674 unfoldingArity _                                    = panic "unfoldingArity"
 675
 676 isClosedUnfolding :: Unfolding -> Bool          -- No free variables
 677 isClosedUnfolding (CoreUnfolding {}) = False
 678 isClosedUnfolding (DFunUnfolding {}) = False
 679 isClosedUnfolding _                  = True
 680
 681 -- | Only returns False if there is no unfolding information available at all
 682 hasSomeUnfolding :: Unfolding -> Bool
 683 hasSomeUnfolding NoUnfolding = False
 684 hasSomeUnfolding _           = True
 685
 686 neverUnfoldGuidance :: UnfoldingGuidance -> Bool
 687 neverUnfoldGuidance UnfNever = True
 688 neverUnfoldGuidance _        = False
 689
 690 canUnfold :: Unfolding -> Bool
 691 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
 692 canUnfold _                                   = False
 693 \end{code}
 694
 695 Note [InlineRules]
 696 ~~~~~~~~~~~~~~~~~
 697 When you say
 698       {-# INLINE f #-}
 699       f x = <rhs>
 700 you intend that calls (f e) are replaced by <rhs>[e/x] So we
 701 should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
 702 with it.  Meanwhile, we can optimise <rhs> to our heart's content,
 703 leaving the original unfolding intact in Unfolding of 'f'. For example
 704         all xs = foldr (&&) True xs
 705         any p = all . map p  {-# INLINE any #-}
 706 We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
 707 which deforests well at the call site.
 708
 709 So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
 710
 711 Moreover, it's only used when 'f' is applied to the
 712 specified number of arguments; that is, the number of argument on
 713 the LHS of the '=' sign in the original source definition.
 714 For example, (.) is now defined in the libraries like this
 715    {-# INLINE (.) #-}
 716    (.) f g = \x -> f (g x)
 717 so that it'll inline when applied to two arguments. If 'x' appeared
 718 on the left, thus
 719    (.) f g x = f (g x)
 720 it'd only inline when applied to three arguments.  This slightly-experimental
 721 change was requested by Roman, but it seems to make sense.
 722
 723 See also Note [Inlining an InlineRule] in CoreUnfold.
 724
 725
 726 Note [OccInfo in unfoldings and rules]
 727 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 728 In unfoldings and rules, we guarantee that the template is occ-analysed,
 729 so that the occurence info on the binders is correct.  This is important,
 730 because the Simplifier does not re-analyse the template when using it. If
 731 the occurrence info is wrong
 732   - We may get more simpifier iterations than necessary, because
 733     once-occ info isn't there
 734   - More seriously, we may get an infinite loop if there's a Rec
 735     without a loop breaker marked
 736
 737
 738 %************************************************************************
 739 %*                                                                      *
 740 \subsection{The main data type}
 741 %*                                                                      *
 742 %************************************************************************
 743
 744 \begin{code}
 745 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 746 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 747 -- constructor-applications with LitArg args, then you could get
 748 -- rid of this Ord.
 749
 750 instance Outputable AltCon where
 751   ppr (DataAlt dc) = ppr dc
 752   ppr (LitAlt lit) = ppr lit
 753   ppr DEFAULT      = ptext (sLit "__DEFAULT")
 754
 755 instance Show AltCon where
 756   showsPrec p con = showsPrecSDoc p (ppr con)
 757
 758 cmpAlt :: Alt b -> Alt b -> Ordering
 759 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 760
 761 ltAlt :: Alt b -> Alt b -> Bool
 762 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 763
 764 cmpAltCon :: AltCon -> AltCon -> Ordering
 765 -- ^ Compares 'AltCon's within a single list of alternatives
 766 cmpAltCon DEFAULT      DEFAULT     = EQ
 767 cmpAltCon DEFAULT      _           = LT
 768
 769 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 770 cmpAltCon (DataAlt _)  DEFAULT      = GT
 771 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 772 cmpAltCon (LitAlt _)   DEFAULT      = GT
 773
 774 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 775                                   ppr con1 <+> ppr con2 )
 776                       LT
 777 \end{code}
 778
 779 %************************************************************************
 780 %*                                                                      *
 781 \subsection{Useful synonyms}
 782 %*                                                                      *
 783 %************************************************************************
 784
 785 \begin{code}
 786 -- | The common case for the type of binders and variables when
 787 -- we are manipulating the Core language within GHC
 788 type CoreBndr = Var
 789 -- | Expressions where binders are 'CoreBndr's
 790 type CoreExpr = Expr CoreBndr
 791 -- | Argument expressions where binders are 'CoreBndr's
 792 type CoreArg  = Arg  CoreBndr
 793 -- | Binding groups where binders are 'CoreBndr's
 794 type CoreBind = Bind CoreBndr
 795 -- | Case alternatives where binders are 'CoreBndr's
 796 type CoreAlt  = Alt  CoreBndr
 797 \end{code}
 798
 799 %************************************************************************
 800 %*                                                                      *
 801 \subsection{Tagging}
 802 %*                                                                      *
 803 %************************************************************************
 804
 805 \begin{code}
 806 -- | Binders are /tagged/ with a t
 807 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 808
 809 type TaggedBind t = Bind (TaggedBndr t)
 810 type TaggedExpr t = Expr (TaggedBndr t)
 811 type TaggedArg  t = Arg  (TaggedBndr t)
 812 type TaggedAlt  t = Alt  (TaggedBndr t)
 813
 814 instance Outputable b => Outputable (TaggedBndr b) where
 815   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 816
 817 instance Outputable b => OutputableBndr (TaggedBndr b) where
 818   pprBndr _ b = ppr b   -- Simple
 819 \end{code}
 820
 821
 822 %************************************************************************
 823 %*                                                                      *
 824 \subsection{Core-constructing functions with checking}
 825 %*                                                                      *
 826 %************************************************************************
 827
 828 \begin{code}
 829 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
 830 -- use 'CoreUtils.mkCoreApps' if possible
 831 mkApps    :: Expr b -> [Arg b]  -> Expr b
 832 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 833 mkTyApps  :: Expr b -> [Type]   -> Expr b
 834 -- | Apply a list of type or value variables to a function expression in a nested fashion
 835 mkVarApps :: Expr b -> [Var] -> Expr b
 836 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
 837 -- use 'MkCore.mkCoreConApps' if possible
 838 mkConApp      :: DataCon -> [Arg b] -> Expr b
 839
 840 mkApps    f args = foldl App                       f args
 841 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 842 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 843 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 844
 845
 846 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 847 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 848 mkIntLit      :: Integer -> Expr b
 849 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
 850 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 851 mkIntLitInt   :: Int     -> Expr b
 852
 853 mkIntLit    n = Lit (mkMachInt n)
 854 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 855
 856 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
 857 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 858 mkWordLit     :: Integer -> Expr b
 859 -- | Create a machine word literal expression of type  @Word#@ from a @Word@.
 860 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 861 mkWordLitWord :: Word -> Expr b
 862
 863 mkWordLit     w = Lit (mkMachWord w)
 864 mkWordLitWord w = Lit (mkMachWord (toInteger w))
 865
 866 -- | Create a machine character literal expression of type @Char#@.
 867 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
 868 mkCharLit :: Char -> Expr b
 869 -- | Create a machine string literal expression of type @Addr#@.
 870 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
 871 mkStringLit :: String -> Expr b
 872
 873 mkCharLit   c = Lit (mkMachChar c)
 874 mkStringLit s = Lit (mkMachString s)
 875
 876 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
 877 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 878 mkFloatLit :: Rational -> Expr b
 879 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
 880 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 881 mkFloatLitFloat :: Float -> Expr b
 882
 883 mkFloatLit      f = Lit (mkMachFloat f)
 884 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
 885
 886 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
 887 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 888 mkDoubleLit :: Rational -> Expr b
 889 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
 890 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 891 mkDoubleLitDouble :: Double -> Expr b
 892
 893 mkDoubleLit       d = Lit (mkMachDouble d)
 894 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
 895
 896 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
 897 -- use 'CoreUtils.mkCoreLets' if possible
 898 mkLets        :: [Bind b] -> Expr b -> Expr b
 899 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
 900 -- use 'CoreUtils.mkCoreLams' if possible
 901 mkLams        :: [b] -> Expr b -> Expr b
 902
 903 mkLams binders body = foldr Lam body binders
 904 mkLets binds body   = foldr Let body binds
 905
 906
 907 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
 908 -- this can only be used to bind something in a non-recursive @let@ expression
 909 mkTyBind :: TyVar -> Type -> CoreBind
 910 mkTyBind tv ty      = NonRec tv (Type ty)
 911
 912 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 913 varToCoreExpr :: CoreBndr -> Expr b
 914 varToCoreExpr v | isId v = Var v
 915                 | otherwise = Type (mkTyVarTy v)
 916
 917 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 918 varsToCoreExprs vs = map varToCoreExpr vs
 919 \end{code}
 920
 921
 922 %************************************************************************
 923 %*                                                                      *
 924 \subsection{Simple access functions}
 925 %*                                                                      *
 926 %************************************************************************
 927
 928 \begin{code}
 929 -- | Extract every variable by this group
 930 bindersOf  :: Bind b -> [b]
 931 bindersOf (NonRec binder _) = [binder]
 932 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 933
 934 -- | 'bindersOf' applied to a list of binding groups
 935 bindersOfBinds :: [Bind b] -> [b]
 936 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 937
 938 rhssOfBind :: Bind b -> [Expr b]
 939 rhssOfBind (NonRec _ rhs) = [rhs]
 940 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 941
 942 rhssOfAlts :: [Alt b] -> [Expr b]
 943 rhssOfAlts alts = [e | (_,_,e) <- alts]
 944
 945 -- | Collapse all the bindings in the supplied groups into a single
 946 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
 947 flattenBinds :: [Bind b] -> [(b, Expr b)]
 948 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 949 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 950 flattenBinds []                   = []
 951 \end{code}
 952
 953 \begin{code}
 954 -- | We often want to strip off leading lambdas before getting down to
 955 -- business. This function is your friend.
 956 collectBinders               :: Expr b -> ([b],         Expr b)
 957 -- | Collect as many type bindings as possible from the front of a nested lambda
 958 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 959 -- | Collect as many value bindings as possible from the front of a nested lambda
 960 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 961 -- | Collect type binders from the front of the lambda first,
 962 -- then follow up by collecting as many value bindings as possible
 963 -- from the resulting stripped expression
 964 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 965
 966 collectBinders expr
 967   = go [] expr
 968   where
 969     go bs (Lam b e) = go (b:bs) e
 970     go bs e          = (reverse bs, e)
 971
 972 collectTyAndValBinders expr
 973   = (tvs, ids, body)
 974   where
 975     (tvs, body1) = collectTyBinders expr
 976     (ids, body)  = collectValBinders body1
 977
 978 collectTyBinders expr
 979   = go [] expr
 980   where
 981     go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
 982     go tvs e                     = (reverse tvs, e)
 983
 984 collectValBinders expr
 985   = go [] expr
 986   where
 987     go ids (Lam b e) | isId b = go (b:ids) e
 988     go ids body               = (reverse ids, body)
 989 \end{code}
 990
 991 \begin{code}
 992 -- | Takes a nested application expression and returns the the function
 993 -- being applied and the arguments to which it is applied
 994 collectArgs :: Expr b -> (Expr b, [Arg b])
 995 collectArgs expr
 996   = go expr []
 997   where
 998     go (App f a) as = go f (a:as)
 999     go e         as = (e, as)
1000 \end{code}
1001
1002 \begin{code}
1003 -- | Gets the cost centre enclosing an expression, if any.
1004 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
1005 coreExprCc :: Expr b -> CostCentre
1006 coreExprCc (Note (SCC cc) _)   = cc
1007 coreExprCc (Note _ e)          = coreExprCc e
1008 coreExprCc (Lam _ e)           = coreExprCc e
1009 coreExprCc _                   = noCostCentre
1010 \end{code}
1011
1012 %************************************************************************
1013 %*                                                                      *
1014 \subsection{Predicates}
1015 %*                                                                      *
1016 %************************************************************************
1017
1018 At one time we optionally carried type arguments through to runtime.
1019 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
1020 i.e. if type applications are actual lambdas because types are kept around
1021 at runtime.  Similarly isRuntimeArg.
1022
1023 \begin{code}
1024 -- | Will this variable exist at runtime?
1025 isRuntimeVar :: Var -> Bool
1026 isRuntimeVar = isId
1027
1028 -- | Will this argument expression exist at runtime?
1029 isRuntimeArg :: CoreExpr -> Bool
1030 isRuntimeArg = isValArg
1031
1032 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
1033 isValArg :: Expr b -> Bool
1034 isValArg (Type _) = False
1035 isValArg _        = True
1036
1037 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
1038 isTypeArg :: Expr b -> Bool
1039 isTypeArg (Type _) = True
1040 isTypeArg _        = False
1041
1042 -- | The number of binders that bind values rather than types
1043 valBndrCount :: [CoreBndr] -> Int
1044 valBndrCount = count isId
1045
1046 -- | The number of argument expressions that are values rather than types at their top level
1047 valArgCount :: [Arg b] -> Int
1048 valArgCount = count isValArg
1049 \end{code}
1050
1051
1052 %************************************************************************
1053 %*                                                                      *
1054 \subsection{Seq stuff}
1055 %*                                                                      *
1056 %************************************************************************
1057
1058 \begin{code}
1059 seqExpr :: CoreExpr -> ()
1060 seqExpr (Var v)         = v `seq` ()
1061 seqExpr (Lit lit)       = lit `seq` ()
1062 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
1063 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
1064 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
1065 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
1066 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
1067 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
1068 seqExpr (Type t)        = seqType t
1069
1070 seqExprs :: [CoreExpr] -> ()
1071 seqExprs [] = ()
1072 seqExprs (e:es) = seqExpr e `seq` seqExprs es
1073
1074 seqNote :: Note -> ()
1075 seqNote (CoreNote s)   = s `seq` ()
1076 seqNote _              = ()
1077
1078 seqBndr :: CoreBndr -> ()
1079 seqBndr b = b `seq` ()
1080
1081 seqBndrs :: [CoreBndr] -> ()
1082 seqBndrs [] = ()
1083 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
1084
1085 seqBind :: Bind CoreBndr -> ()
1086 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
1087 seqBind (Rec prs)    = seqPairs prs
1088
1089 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
1090 seqPairs [] = ()
1091 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
1092
1093 seqAlts :: [CoreAlt] -> ()
1094 seqAlts [] = ()
1095 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
1096
1097 seqRules :: [CoreRule] -> ()
1098 seqRules [] = ()
1099 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
1100   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
1101 seqRules (BuiltinRule {} : rules) = seqRules rules
1102 \end{code}
1103
1104 %************************************************************************
1105 %*                                                                      *
1106 \subsection{Annotated core}
1107 %*                                                                      *
1108 %************************************************************************
1109
1110 \begin{code}
1111 -- | Annotated core: allows annotation at every node in the tree
1112 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
1113
1114 -- | A clone of the 'Expr' type but allowing annotation at every tree node
1115 data AnnExpr' bndr annot
1116   = AnnVar      Id
1117   | AnnLit      Literal
1118   | AnnLam      bndr (AnnExpr bndr annot)
1119   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
1120   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
1121   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
1122   | AnnCast     (AnnExpr bndr annot) Coercion
1123   | AnnNote     Note (AnnExpr bndr annot)
1124   | AnnType     Type
1125
1126 -- | A clone of the 'Alt' type but allowing annotation at every tree node
1127 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
1128
1129 -- | A clone of the 'Bind' type but allowing annotation at every tree node
1130 data AnnBind bndr annot
1131   = AnnNonRec bndr (AnnExpr bndr annot)
1132   | AnnRec    [(bndr, AnnExpr bndr annot)]
1133 \end{code}
1134
1135 \begin{code}
1136 deAnnotate :: AnnExpr bndr annot -> Expr bndr
1137 deAnnotate (_, e) = deAnnotate' e
1138
1139 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
1140 deAnnotate' (AnnType t)           = Type t
1141 deAnnotate' (AnnVar  v)           = Var v
1142 deAnnotate' (AnnLit  lit)         = Lit lit
1143 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
1144 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
1145 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
1146 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
1147
1148 deAnnotate' (AnnLet bind body)
1149   = Let (deAnnBind bind) (deAnnotate body)
1150   where
1151     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
1152     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
1153
1154 deAnnotate' (AnnCase scrut v t alts)
1155   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
1156
1157 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
1158 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
1159 \end{code}
1160
1161 \begin{code}
1162 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
1163 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
1164 collectAnnBndrs e
1165   = collect [] e
1166   where
1167     collect bs (_, AnnLam b body) = collect (b:bs) body
1168     collect bs body               = (reverse bs, body)
1169 \end{code}