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