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