compiler/coreSyn/CoreSyn.lhs

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