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