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