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