compiler/coreSyn/CoreSyn.lhs

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