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