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