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