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
   8 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
   9 module CoreSyn (
  10         -- * Main data types
  11         Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
  12         CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
  13         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
  14
  15         -- ** 'Expr' construction
  16         mkLets, mkLams,
  17         mkApps, mkTyApps, mkVarApps,
  18
  19         mkIntLit, mkIntLitInt,
  20         mkWordLit, mkWordLitWord,
  21         mkCharLit, mkStringLit,
  22         mkFloatLit, mkFloatLitFloat,
  23         mkDoubleLit, mkDoubleLitDouble,
  24
  25         mkConApp, mkTyBind,
  26         varToCoreExpr, varsToCoreExprs,
  27
  28         isTyVar, isIdVar, cmpAltCon, cmpAlt, ltAlt,
  29
  30         -- ** Simple 'Expr' access functions and predicates
  31         bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
  32         collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
  33         collectArgs, coreExprCc, flattenBinds,
  34
  35         isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
  36
  37         -- * Unfolding data types
  38         Unfolding(..),  UnfoldingGuidance(..),  -- Both abstract everywhere but in CoreUnfold.lhs
  39
  40         -- ** Constructing 'Unfolding's
  41         noUnfolding, evaldUnfolding, mkOtherCon,
  42
  43         -- ** Predicates and deconstruction on 'Unfolding'
  44         unfoldingTemplate, setUnfoldingTemplate,
  45         maybeUnfoldingTemplate, otherCons,
  46         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
  47         isInlineRule, isClosedUnfolding, hasSomeUnfolding, canUnfold, neverUnfoldGuidance,
  48
  49         -- * Strictness
  50         seqExpr, seqExprs, seqUnfolding,
  51
  52         -- * Annotated expression data types
  53         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
  54
  55         -- ** Operations on annotations
  56         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
  57
  58         -- * Core rule data types
  59         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  60         RuleName,
  61
  62         -- ** Operations on 'CoreRule's
  63         seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
  64         setRuleIdName,
  65         isBuiltinRule, isLocalRule
  66     ) where
  67
  68 #include "HsVersions.h"
  69
  70 import CostCentre
  71 import Var
  72 import Type
  73 import Coercion
  74 import Name
  75 import Literal
  76 import DataCon
  77 import BasicTypes
  78 import FastString
  79 import Outputable
  80 import Util
  81
  82 import Data.Word
  83
  84 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
  85 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{The main data types}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 These data types are the heart of the compiler
  95
  96 \begin{code}
  97 infixl 8 `App`  -- App brackets to the left
  98
  99 -- | This is the data type that represents GHCs core intermediate language. Currently
 100 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 101 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
 102 --
 103 -- We get from Haskell source to this Core language in a number of stages:
 104 --
 105 -- 1. The source code is parsed into an abstract syntax tree, which is represented
 106 --    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
 107 --
 108 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
 109 --    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
 110 --    For example, this program:
 111 --
 112 -- @
 113 --      f x = let f x = x + 1
 114 --            in f (x - 2)
 115 -- @
 116 --
 117 --    Would be renamed by having 'Unique's attached so it looked something like this:
 118 --
 119 -- @
 120 --      f_1 x_2 = let f_3 x_4 = x_4 + 1
 121 --                in f_3 (x_2 - 2)
 122 -- @
 123 --
 124 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
 125 --    type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
 126 --
 127 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
 128 --    this 'Expr' type, which has far fewer constructors and hence is easier to perform
 129 --    optimization, analysis and code generation on.
 130 --
 131 -- The type parameter @b@ is for the type of binders in the expression tree.
 132 data Expr b
 133   = Var   Id                            -- ^ Variables
 134   | Lit   Literal                       -- ^ Primitive literals
 135   | App   (Expr b) (Arg b)              -- ^ Applications: note that the argument may be a 'Type'.
 136                                         --
 137                                         -- See "CoreSyn#let_app_invariant" for another invariant
 138   | Lam   b (Expr b)                    -- ^ Lambda abstraction
 139   | Let   (Bind b) (Expr b)             -- ^ Recursive and non recursive @let@s. Operationally
 140                                         -- this corresponds to allocating a thunk for the things
 141                                         -- bound and then executing the sub-expression.
 142                                         --
 143                                         -- #top_level_invariant#
 144                                         -- #letrec_invariant#
 145                                         --
 146                                         -- The right hand sides of all top-level and recursive @let@s
 147                                         -- /must/ be of lifted type (see "Type#type_classification" for
 148                                         -- the meaning of /lifted/ vs. /unlifted/).
 149                                         --
 150                                         -- #let_app_invariant#
 151                                         -- The right hand side of of a non-recursive 'Let' _and_ the argument of an 'App',
 152                                         -- /may/ be of unlifted type, but only if the expression
 153                                         -- is ok-for-speculation.  This means that the let can be floated around
 154                                         -- without difficulty. For example, this is OK:
 155                                         --
 156                                         -- > y::Int# = x +# 1#
 157                                         --
 158                                         -- But this is not, as it may affect termination if the expression is floated out:
 159                                         --
 160                                         -- > y::Int# = fac 4#
 161                                         --
 162                                         -- In this situation you should use @case@ rather than a @let@. The function
 163                                         -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
 164                                         -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
 165                                         -- which will generate a @case@ if necessary
 166                                         --
 167                                         -- #type_let#
 168                                         -- We allow a /non-recursive/ let to bind a type variable, thus:
 169                                         --
 170                                         -- > Let (NonRec tv (Type ty)) body
 171                                         --
 172                                         -- This can be very convenient for postponing type substitutions until
 173                                         -- the next run of the simplifier.
 174                                         --
 175                                         -- At the moment, the rest of the compiler only deals with type-let
 176                                         -- in a Let expression, rather than at top level.  We may want to revist
 177                                         -- this choice.
 178   | Case  (Expr b) b Type [Alt b]       -- ^ Case split. Operationally this corresponds to evaluating
 179                                         -- the scrutinee (expression examined) to weak head normal form
 180                                         -- and then examining at most one level of resulting constructor (i.e. you
 181                                         -- cannot do nested pattern matching directly with this).
 182                                         --
 183                                         -- The binder gets bound to the value of the scrutinee,
 184                                         -- and the 'Type' must be that of all the case alternatives
 185                                         --
 186                                         -- #case_invariants#
 187                                         -- This is one of the more complicated elements of the Core language, and comes
 188                                         -- with a number of restrictions:
 189                                         --
 190                                         -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all.
 191                                         --
 192                                         -- The remaining cases are in order of increasing
 193                                         --      tag     (for 'DataAlts') or
 194                                         --      lit     (for 'LitAlts').
 195                                         -- This makes finding the relevant constructor easy, and makes comparison easier too.
 196                                         --
 197                                         -- The list of alternatives must be exhaustive. An /exhaustive/ case
 198                                         -- does not necessarily mention all constructors:
 199                                         --
 200                                         -- @
 201                                         --      data Foo = Red | Green | Blue
 202                                         -- ... case x of
 203                                         --      Red   -> True
 204                                         --      other -> f (case x of
 205                                         --                      Green -> ...
 206                                         --                      Blue  -> ... ) ...
 207                                         -- @
 208                                         --
 209                                         -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at
 210                                         -- that program point.
 211   | Cast  (Expr b) Coercion             -- ^ Cast an expression to a particular type. This is used to implement @newtype@s
 212                                         -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs.
 213   | Note  Note (Expr b)                 -- ^ Notes. These allow general information to be
 214                                         -- added to expressions in the syntax tree
 215   | Type  Type                          -- ^ A type: this should only show up at the top
 216                                         -- level of an Arg
 217
 218 -- | Type synonym for expressions that occur in function argument positions.
 219 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
 220 type Arg b = Expr b
 221
 222 -- | A case split alternative. Consists of the constructor leading to the alternative,
 223 -- the variables bound from the constructor, and the expression to be executed given that binding.
 224 -- The default alternative is @(DEFAULT, [], rhs)@
 225 type Alt b = (AltCon, [b], Expr b)
 226
 227 -- | A case alternative constructor (i.e. pattern match)
 228 data AltCon = DataAlt DataCon   -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
 229                                 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
 230             | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
 231             | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
 232          deriving (Eq, Ord)
 233
 234 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
 235 data Bind b = NonRec b (Expr b)
 236             | Rec [(b, (Expr b))]
 237 \end{code}
 238
 239 -------------------------- CoreSyn INVARIANTS ---------------------------
 240
 241 Note [CoreSyn top-level invariant]
 242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 243 See #toplevel_invariant#
 244
 245 Note [CoreSyn letrec invariant]
 246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 247 See #letrec_invariant#
 248
 249 Note [CoreSyn let/app invariant]
 250 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 251 See #let_app_invariant#
 252
 253 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
 254
 255 Note [CoreSyn case invariants]
 256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 257 See #case_invariants#
 258
 259 Note [CoreSyn let goal]
 260 ~~~~~~~~~~~~~~~~~~~~~~~
 261 * The simplifier tries to ensure that if the RHS of a let is a constructor
 262   application, its arguments are trivial, so that the constructor can be
 263   inlined vigorously.
 264
 265
 266 Note [Type let]
 267 ~~~~~~~~~~~~~~~
 268 See #type_let#
 269
 270 \begin{code}
 271
 272 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
 273 data Note
 274   = SCC CostCentre      -- ^ A cost centre annotation for profiling
 275   | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
 276 \end{code}
 277
 278
 279 %************************************************************************
 280 %*                                                                      *
 281 \subsection{Transformation rules}
 282 %*                                                                      *
 283 %************************************************************************
 284
 285 The CoreRule type and its friends are dealt with mainly in CoreRules,
 286 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 287
 288 \begin{code}
 289 -- | A 'CoreRule' is:
 290 --
 291 -- * \"Local\" if the function it is a rule for is defined in the
 292 --   same module as the rule itself.
 293 --
 294 -- * \"Orphan\" if nothing on the LHS is defined in the same module
 295 --   as the rule itself
 296 data CoreRule
 297   = Rule {
 298         ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
 299         ru_act  :: Activation,          -- ^ When the rule is active
 300
 301         -- Rough-matching stuff
 302         -- see comments with InstEnv.Instance( is_cls, is_rough )
 303         ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
 304         ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
 305
 306         -- Proper-matching stuff
 307         -- see comments with InstEnv.Instance( is_tvs, is_tys )
 308         ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
 309         ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
 310
 311         -- And the right-hand side
 312         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
 313
 314         -- Locality
 315         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
 316                                 -- defined in the same module as the rule
 317                                 -- and is not an implicit 'Id' (like a record selector,
 318                                 -- class operation, or data constructor)
 319
 320                 -- NB: ru_local is *not* used to decide orphan-hood
 321                 --      c.g. MkIface.coreRuleToIfaceRule
 322     }
 323
 324   -- | Built-in rules are used for constant folding
 325   -- and suchlike.  They have no free variables.
 326   | BuiltinRule {
 327         ru_name :: RuleName,    -- ^ As above
 328         ru_fn :: Name,          -- ^ As above
 329         ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' expects,
 330                                 -- including type arguments
 331         ru_try  :: [CoreExpr] -> Maybe CoreExpr
 332                 -- ^ This function does the rewrite.  It given too many
 333                 -- arguments, it simply discards them; the returned 'CoreExpr'
 334                 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
 335     }
 336                 -- See Note [Extra args in rule matching] in Rules.lhs
 337
 338 isBuiltinRule :: CoreRule -> Bool
 339 isBuiltinRule (BuiltinRule {}) = True
 340 isBuiltinRule _                = False
 341
 342 -- | The number of arguments the 'ru_fn' must be applied
 343 -- to before the rule can match on it
 344 ruleArity :: CoreRule -> Int
 345 ruleArity (BuiltinRule {ru_nargs = n}) = n
 346 ruleArity (Rule {ru_args = args})      = length args
 347
 348 ruleName :: CoreRule -> RuleName
 349 ruleName = ru_name
 350
 351 ruleActivation_maybe :: CoreRule -> Maybe Activation
 352 ruleActivation_maybe (BuiltinRule { })       = Nothing
 353 ruleActivation_maybe (Rule { ru_act = act }) = Just act
 354
 355 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
 356 ruleIdName :: CoreRule -> Name
 357 ruleIdName = ru_fn
 358
 359 isLocalRule :: CoreRule -> Bool
 360 isLocalRule = ru_local
 361
 362 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
 363 setRuleIdName :: Name -> CoreRule -> CoreRule
 364 setRuleIdName nm ru = ru { ru_fn = nm }
 365 \end{code}
 366
 367
 368 %************************************************************************
 369 %*                                                                      *
 370                 Unfoldings
 371 %*                                                                      *
 372 %************************************************************************
 373
 374 The @Unfolding@ type is declared here to avoid numerous loops
 375
 376 \begin{code}
 377 -- | Records the /unfolding/ of an identifier, which is approximately the form the
 378 -- identifier would have if we substituted its definition in for the identifier.
 379 -- This type should be treated as abstract everywhere except in "CoreUnfold"
 380 data Unfolding
 381   = NoUnfolding                 -- ^ We have no information about the unfolding
 382
 383   | OtherCon [AltCon]           -- ^ It ain't one of these constructors.
 384                                 -- @OtherCon xs@ also indicates that something has been evaluated
 385                                 -- and hence there's no point in re-evaluating it.
 386                                 -- @OtherCon []@ is used even for non-data-type values
 387                                 -- to indicated evaluated-ness.  Notably:
 388                                 --
 389                                 -- > data C = C !(Int -> Int)
 390                                 -- > case x of { C f -> ... }
 391                                 --
 392                                 -- Here, @f@ gets an @OtherCon []@ unfolding.
 393
 394   | CompulsoryUnfolding {       -- There is /no original definition/, so you'd better unfold.
 395         uf_tmpl :: CoreExpr     -- The unfolding is guaranteed to have no free variables
 396     }                           -- so no need to think about it during dependency analysis
 397
 398   | InlineRule {                -- The function has an INLINE pragma, with the specified (original) RHS
 399                                 -- (The inline phase, if any, is in the InlinePragInfo for this Id.)
 400                                 -- Inline when (a) applied to at least this number of args
 401                                 --             (b) if there is something interesting about args or context
 402         uf_tmpl  :: CoreExpr,           -- The *original* RHS; occurrence info is correct
 403                                         -- (The actual RHS of the function may be different by now,
 404                                         -- but what we inline is still the original RHS (kept in the InlineRule).)
 405         uf_is_top :: Bool,
 406
 407         uf_arity    :: Arity,           -- Don't inline unless applied to this number of *value* args
 408         uf_is_value :: Bool,            -- True <=> exprIsHNF is true; save to discard a `seq`
 409         uf_worker   :: Maybe Id         -- Just wrk_id <=> this unfolding is a the wrapper in a worker/wrapper
 410                                         --                 split from the strictness analyser
 411                                         --      Used to abbreviate the uf_tmpl in interface files
 412                                         --        In the Just case, interface files don't actually
 413                                         --        need to contain the RHS; it can be derived from
 414                                         --        the strictness info
 415                                         --      Also used in CoreUnfold to guide inlining decisions
 416     }
 417
 418   | CoreUnfolding {             -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
 419                                 -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
 420         uf_tmpl     :: CoreExpr,        -- Template; binder-info is correct
 421         uf_is_top   :: Bool,            -- True <=> top level binding
 422         uf_is_value :: Bool,            -- exprIsHNF template (cached); it is ok to discard a `seq` on
 423                                         --      this variable
 424         uf_is_cheap :: Bool,            -- True <=> doesn't waste (much) work to expand inside an inlining
 425                                         --      Basically it's exprIsCheap
 426         uf_guidance :: UnfoldingGuidance        -- Tells about the *size* of the template.
 427     }
 428   -- ^ An unfolding with redundant cached information. Parameters:
 429   --
 430   --  uf_tmpl: Template used to perform unfolding; binder-info is correct
 431   --
 432   --  uf_is_top: Is this a top level binding?
 433   --
 434   --  uf_is_valiue: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
 435   --     this variable
 436   --
 437   --  uf_is_cheap:  Does this waste only a little work if we expand it inside an inlining?
 438   --     Basically this is a cached version of 'exprIsCheap'
 439   --
 440   --  uf_guidance:  Tells us about the /size/ of the unfolding template
 441
 442 ------------------------------------------------
 443 -- | 'UnfoldingGuidance' says when unfolding should take place
 444 data UnfoldingGuidance
 445   = UnfoldNever
 446   | UnfoldIfGoodArgs {
 447       ug_arity :: Arity,  -- "n" value args
 448
 449       ug_args ::  [Int],  -- Discount if the argument is evaluated.
 450                           -- (i.e., a simplification will definitely
 451                           -- be possible).  One elt of the list per *value* arg.
 452
 453       ug_size :: Int,     -- The "size" of the unfolding; to be elaborated
 454                           -- later. ToDo
 455
 456       ug_res :: Int       -- Scrutinee discount: the discount to substract if the thing is in
 457     }                     -- a context (case (thing args) of ...),
 458                           -- (where there are the right number of arguments.)
 459
 460 ------------------------------------------------
 461 noUnfolding :: Unfolding
 462 -- ^ There is no known 'Unfolding'
 463 evaldUnfolding :: Unfolding
 464 -- ^ This unfolding marks the associated thing as being evaluated
 465
 466 noUnfolding    = NoUnfolding
 467 evaldUnfolding = OtherCon []
 468
 469 mkOtherCon :: [AltCon] -> Unfolding
 470 mkOtherCon = OtherCon
 471
 472 seqUnfolding :: Unfolding -> ()
 473 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
 474                 uf_is_value = b1, uf_is_cheap = b2, uf_guidance = g})
 475   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
 476 seqUnfolding _ = ()
 477
 478 seqGuidance :: UnfoldingGuidance -> ()
 479 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
 480 seqGuidance _                           = ()
 481 \end{code}
 482
 483 \begin{code}
 484 -- | Retrieves the template of an unfolding: panics if none is known
 485 unfoldingTemplate :: Unfolding -> CoreExpr
 486 unfoldingTemplate = uf_tmpl
 487
 488 setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
 489 setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
 490
 491 -- | Retrieves the template of an unfolding if possible
 492 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 493 maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr })       = Just expr
 494 maybeUnfoldingTemplate (CompulsoryUnfolding { uf_tmpl = expr }) = Just expr
 495 maybeUnfoldingTemplate (InlineRule { uf_tmpl = expr })          = Just expr
 496 maybeUnfoldingTemplate _                                        = Nothing
 497
 498 -- | The constructors that the unfolding could never be:
 499 -- returns @[]@ if no information is available
 500 otherCons :: Unfolding -> [AltCon]
 501 otherCons (OtherCon cons) = cons
 502 otherCons _               = []
 503
 504 -- | Determines if it is certainly the case that the unfolding will
 505 -- yield a value (something in HNF): returns @False@ if unsure
 506 isValueUnfolding :: Unfolding -> Bool
 507         -- Returns False for OtherCon
 508 isValueUnfolding (CoreUnfolding   { uf_is_value = is_evald }) = is_evald
 509 isValueUnfolding (InlineRule { uf_is_value = is_evald })      = is_evald
 510 isValueUnfolding _                                            = False
 511
 512 -- | Determines if it possibly the case that the unfolding will
 513 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 514 -- for 'OtherCon'
 515 isEvaldUnfolding :: Unfolding -> Bool
 516         -- Returns True for OtherCon
 517 isEvaldUnfolding (OtherCon _)                                 = True
 518 isEvaldUnfolding (CoreUnfolding   { uf_is_value = is_evald }) = is_evald
 519 isEvaldUnfolding (InlineRule { uf_is_value = is_evald })      = is_evald
 520 isEvaldUnfolding _                                            = False
 521
 522 -- | Is the thing we will unfold into certainly cheap?
 523 isCheapUnfolding :: Unfolding -> Bool
 524 isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
 525 isCheapUnfolding _                                          = False
 526
 527 isInlineRule :: Unfolding -> Bool
 528 isInlineRule (InlineRule {}) = True
 529 isInlineRule _               = False
 530
 531 -- | Must this unfolding happen for the code to be executable?
 532 isCompulsoryUnfolding :: Unfolding -> Bool
 533 isCompulsoryUnfolding (CompulsoryUnfolding {}) = True
 534 isCompulsoryUnfolding _                       = False
 535
 536 isClosedUnfolding :: Unfolding -> Bool          -- No free variables
 537 isClosedUnfolding (CoreUnfolding {})   = False
 538 isClosedUnfolding (InlineRule {}) = False
 539 isClosedUnfolding _               = True
 540
 541 -- | Only returns False if there is no unfolding information available at all
 542 hasSomeUnfolding :: Unfolding -> Bool
 543 hasSomeUnfolding NoUnfolding = False
 544 hasSomeUnfolding _           = True
 545
 546 neverUnfoldGuidance :: UnfoldingGuidance -> Bool
 547 neverUnfoldGuidance UnfoldNever = True
 548 neverUnfoldGuidance _           = False
 549
 550 canUnfold :: Unfolding -> Bool
 551 canUnfold (InlineRule {})                     = True
 552 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
 553 canUnfold _                                   = False
 554 \end{code}
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection{The main data type}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 \begin{code}
 564 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 565 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 566 -- constructor-applications with LitArg args, then you could get
 567 -- rid of this Ord.
 568
 569 instance Outputable AltCon where
 570   ppr (DataAlt dc) = ppr dc
 571   ppr (LitAlt lit) = ppr lit
 572   ppr DEFAULT      = ptext (sLit "__DEFAULT")
 573
 574 instance Show AltCon where
 575   showsPrec p con = showsPrecSDoc p (ppr con)
 576
 577 cmpAlt :: Alt b -> Alt b -> Ordering
 578 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 579
 580 ltAlt :: Alt b -> Alt b -> Bool
 581 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 582
 583 cmpAltCon :: AltCon -> AltCon -> Ordering
 584 -- ^ Compares 'AltCon's within a single list of alternatives
 585 cmpAltCon DEFAULT      DEFAULT     = EQ
 586 cmpAltCon DEFAULT      _           = LT
 587
 588 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 589 cmpAltCon (DataAlt _)  DEFAULT      = GT
 590 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 591 cmpAltCon (LitAlt _)   DEFAULT      = GT
 592
 593 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 594                                   ppr con1 <+> ppr con2 )
 595                       LT
 596 \end{code}
 597
 598 %************************************************************************
 599 %*                                                                      *
 600 \subsection{Useful synonyms}
 601 %*                                                                      *
 602 %************************************************************************
 603
 604 \begin{code}
 605 -- | The common case for the type of binders and variables when
 606 -- we are manipulating the Core language within GHC
 607 type CoreBndr = Var
 608 -- | Expressions where binders are 'CoreBndr's
 609 type CoreExpr = Expr CoreBndr
 610 -- | Argument expressions where binders are 'CoreBndr's
 611 type CoreArg  = Arg  CoreBndr
 612 -- | Binding groups where binders are 'CoreBndr's
 613 type CoreBind = Bind CoreBndr
 614 -- | Case alternatives where binders are 'CoreBndr's
 615 type CoreAlt  = Alt  CoreBndr
 616 \end{code}
 617
 618 %************************************************************************
 619 %*                                                                      *
 620 \subsection{Tagging}
 621 %*                                                                      *
 622 %************************************************************************
 623
 624 \begin{code}
 625 -- | Binders are /tagged/ with a t
 626 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 627
 628 type TaggedBind t = Bind (TaggedBndr t)
 629 type TaggedExpr t = Expr (TaggedBndr t)
 630 type TaggedArg  t = Arg  (TaggedBndr t)
 631 type TaggedAlt  t = Alt  (TaggedBndr t)
 632
 633 instance Outputable b => Outputable (TaggedBndr b) where
 634   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 635
 636 instance Outputable b => OutputableBndr (TaggedBndr b) where
 637   pprBndr _ b = ppr b   -- Simple
 638 \end{code}
 639
 640
 641 %************************************************************************
 642 %*                                                                      *
 643 \subsection{Core-constructing functions with checking}
 644 %*                                                                      *
 645 %************************************************************************
 646
 647 \begin{code}
 648 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
 649 -- use 'CoreUtils.mkCoreApps' if possible
 650 mkApps    :: Expr b -> [Arg b]  -> Expr b
 651 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 652 mkTyApps  :: Expr b -> [Type]   -> Expr b
 653 -- | Apply a list of type or value variables to a function expression in a nested fashion
 654 mkVarApps :: Expr b -> [Var] -> Expr b
 655 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
 656 -- use 'MkCore.mkCoreConApps' if possible
 657 mkConApp      :: DataCon -> [Arg b] -> Expr b
 658
 659 mkApps    f args = foldl App                       f args
 660 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 661 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 662 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 663
 664
 665 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 666 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 667 mkIntLit      :: Integer -> Expr b
 668 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
 669 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 670 mkIntLitInt   :: Int     -> Expr b
 671
 672 mkIntLit    n = Lit (mkMachInt n)
 673 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 674
 675 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
 676 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 677 mkWordLit     :: Integer -> Expr b
 678 -- | Create a machine word literal expression of type  @Word#@ from a @Word@.
 679 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 680 mkWordLitWord :: Word -> Expr b
 681
 682 mkWordLit     w = Lit (mkMachWord w)
 683 mkWordLitWord w = Lit (mkMachWord (toInteger w))
 684
 685 -- | Create a machine character literal expression of type @Char#@.
 686 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
 687 mkCharLit :: Char -> Expr b
 688 -- | Create a machine string literal expression of type @Addr#@.
 689 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
 690 mkStringLit :: String -> Expr b
 691
 692 mkCharLit   c = Lit (mkMachChar c)
 693 mkStringLit s = Lit (mkMachString s)
 694
 695 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
 696 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 697 mkFloatLit :: Rational -> Expr b
 698 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
 699 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 700 mkFloatLitFloat :: Float -> Expr b
 701
 702 mkFloatLit      f = Lit (mkMachFloat f)
 703 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
 704
 705 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
 706 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 707 mkDoubleLit :: Rational -> Expr b
 708 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
 709 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 710 mkDoubleLitDouble :: Double -> Expr b
 711
 712 mkDoubleLit       d = Lit (mkMachDouble d)
 713 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
 714
 715 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
 716 -- use 'CoreUtils.mkCoreLets' if possible
 717 mkLets        :: [Bind b] -> Expr b -> Expr b
 718 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
 719 -- use 'CoreUtils.mkCoreLams' if possible
 720 mkLams        :: [b] -> Expr b -> Expr b
 721
 722 mkLams binders body = foldr Lam body binders
 723 mkLets binds body   = foldr Let body binds
 724
 725
 726 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
 727 -- this can only be used to bind something in a non-recursive @let@ expression
 728 mkTyBind :: TyVar -> Type -> CoreBind
 729 mkTyBind tv ty      = NonRec tv (Type ty)
 730
 731 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 732 varToCoreExpr :: CoreBndr -> Expr b
 733 varToCoreExpr v | isIdVar v = Var v
 734                 | otherwise = Type (mkTyVarTy v)
 735
 736 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 737 varsToCoreExprs vs = map varToCoreExpr vs
 738 \end{code}
 739
 740
 741 %************************************************************************
 742 %*                                                                      *
 743 \subsection{Simple access functions}
 744 %*                                                                      *
 745 %************************************************************************
 746
 747 \begin{code}
 748 -- | Extract every variable by this group
 749 bindersOf  :: Bind b -> [b]
 750 bindersOf (NonRec binder _) = [binder]
 751 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 752
 753 -- | 'bindersOf' applied to a list of binding groups
 754 bindersOfBinds :: [Bind b] -> [b]
 755 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 756
 757 rhssOfBind :: Bind b -> [Expr b]
 758 rhssOfBind (NonRec _ rhs) = [rhs]
 759 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 760
 761 rhssOfAlts :: [Alt b] -> [Expr b]
 762 rhssOfAlts alts = [e | (_,_,e) <- alts]
 763
 764 -- | Collapse all the bindings in the supplied groups into a single
 765 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
 766 flattenBinds :: [Bind b] -> [(b, Expr b)]
 767 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 768 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 769 flattenBinds []                   = []
 770 \end{code}
 771
 772 \begin{code}
 773 -- | We often want to strip off leading lambdas before getting down to
 774 -- business. This function is your friend.
 775 collectBinders               :: Expr b -> ([b],         Expr b)
 776 -- | Collect as many type bindings as possible from the front of a nested lambda
 777 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 778 -- | Collect as many value bindings as possible from the front of a nested lambda
 779 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 780 -- | Collect type binders from the front of the lambda first,
 781 -- then follow up by collecting as many value bindings as possible
 782 -- from the resulting stripped expression
 783 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 784
 785 collectBinders expr
 786   = go [] expr
 787   where
 788     go bs (Lam b e) = go (b:bs) e
 789     go bs e          = (reverse bs, e)
 790
 791 collectTyAndValBinders expr
 792   = (tvs, ids, body)
 793   where
 794     (tvs, body1) = collectTyBinders expr
 795     (ids, body)  = collectValBinders body1
 796
 797 collectTyBinders expr
 798   = go [] expr
 799   where
 800     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 801     go tvs e                     = (reverse tvs, e)
 802
 803 collectValBinders expr
 804   = go [] expr
 805   where
 806     go ids (Lam b e) | isIdVar b = go (b:ids) e
 807     go ids body                  = (reverse ids, body)
 808 \end{code}
 809
 810 \begin{code}
 811 -- | Takes a nested application expression and returns the the function
 812 -- being applied and the arguments to which it is applied
 813 collectArgs :: Expr b -> (Expr b, [Arg b])
 814 collectArgs expr
 815   = go expr []
 816   where
 817     go (App f a) as = go f (a:as)
 818     go e         as = (e, as)
 819 \end{code}
 820
 821 \begin{code}
 822 -- | Gets the cost centre enclosing an expression, if any.
 823 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
 824 coreExprCc :: Expr b -> CostCentre
 825 coreExprCc (Note (SCC cc) _)   = cc
 826 coreExprCc (Note _ e)          = coreExprCc e
 827 coreExprCc (Lam _ e)           = coreExprCc e
 828 coreExprCc _                   = noCostCentre
 829 \end{code}
 830
 831 %************************************************************************
 832 %*                                                                      *
 833 \subsection{Predicates}
 834 %*                                                                      *
 835 %************************************************************************
 836
 837 At one time we optionally carried type arguments through to runtime.
 838 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 839 i.e. if type applications are actual lambdas because types are kept around
 840 at runtime.  Similarly isRuntimeArg.
 841
 842 \begin{code}
 843 -- | Will this variable exist at runtime?
 844 isRuntimeVar :: Var -> Bool
 845 isRuntimeVar = isIdVar
 846
 847 -- | Will this argument expression exist at runtime?
 848 isRuntimeArg :: CoreExpr -> Bool
 849 isRuntimeArg = isValArg
 850
 851 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
 852 isValArg :: Expr b -> Bool
 853 isValArg (Type _) = False
 854 isValArg _        = True
 855
 856 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
 857 isTypeArg :: Expr b -> Bool
 858 isTypeArg (Type _) = True
 859 isTypeArg _        = False
 860
 861 -- | The number of binders that bind values rather than types
 862 valBndrCount :: [CoreBndr] -> Int
 863 valBndrCount = count isIdVar
 864
 865 -- | The number of argument expressions that are values rather than types at their top level
 866 valArgCount :: [Arg b] -> Int
 867 valArgCount = count isValArg
 868 \end{code}
 869
 870
 871 %************************************************************************
 872 %*                                                                      *
 873 \subsection{Seq stuff}
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 seqExpr :: CoreExpr -> ()
 879 seqExpr (Var v)         = v `seq` ()
 880 seqExpr (Lit lit)       = lit `seq` ()
 881 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 882 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 883 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 884 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 885 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 886 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 887 seqExpr (Type t)        = seqType t
 888
 889 seqExprs :: [CoreExpr] -> ()
 890 seqExprs [] = ()
 891 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 892
 893 seqNote :: Note -> ()
 894 seqNote (CoreNote s)   = s `seq` ()
 895 seqNote _              = ()
 896
 897 seqBndr :: CoreBndr -> ()
 898 seqBndr b = b `seq` ()
 899
 900 seqBndrs :: [CoreBndr] -> ()
 901 seqBndrs [] = ()
 902 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 903
 904 seqBind :: Bind CoreBndr -> ()
 905 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 906 seqBind (Rec prs)    = seqPairs prs
 907
 908 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
 909 seqPairs [] = ()
 910 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 911
 912 seqAlts :: [CoreAlt] -> ()
 913 seqAlts [] = ()
 914 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 915
 916 seqRules :: [CoreRule] -> ()
 917 seqRules [] = ()
 918 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 919   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 920 seqRules (BuiltinRule {} : rules) = seqRules rules
 921 \end{code}
 922
 923 %************************************************************************
 924 %*                                                                      *
 925 \subsection{Annotated core}
 926 %*                                                                      *
 927 %************************************************************************
 928
 929 \begin{code}
 930 -- | Annotated core: allows annotation at every node in the tree
 931 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 932
 933 -- | A clone of the 'Expr' type but allowing annotation at every tree node
 934 data AnnExpr' bndr annot
 935   = AnnVar      Id
 936   | AnnLit      Literal
 937   | AnnLam      bndr (AnnExpr bndr annot)
 938   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 939   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 940   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 941   | AnnCast     (AnnExpr bndr annot) Coercion
 942   | AnnNote     Note (AnnExpr bndr annot)
 943   | AnnType     Type
 944
 945 -- | A clone of the 'Alt' type but allowing annotation at every tree node
 946 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 947
 948 -- | A clone of the 'Bind' type but allowing annotation at every tree node
 949 data AnnBind bndr annot
 950   = AnnNonRec bndr (AnnExpr bndr annot)
 951   | AnnRec    [(bndr, AnnExpr bndr annot)]
 952 \end{code}
 953
 954 \begin{code}
 955 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 956 deAnnotate (_, e) = deAnnotate' e
 957
 958 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
 959 deAnnotate' (AnnType t)           = Type t
 960 deAnnotate' (AnnVar  v)           = Var v
 961 deAnnotate' (AnnLit  lit)         = Lit lit
 962 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 963 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 964 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 965 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 966
 967 deAnnotate' (AnnLet bind body)
 968   = Let (deAnnBind bind) (deAnnotate body)
 969   where
 970     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 971     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 972
 973 deAnnotate' (AnnCase scrut v t alts)
 974   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 975
 976 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 977 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 978 \end{code}
 979
 980 \begin{code}
 981 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
 982 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 983 collectAnnBndrs e
 984   = collect [] e
 985   where
 986     collect bs (_, AnnLam b body) = collect (b:bs) body
 987     collect bs body               = (reverse bs, body)
 988 \end{code}