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, isId, 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, maybeUnfoldingTemplate, otherCons,
  45         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
  46         hasUnfolding, hasSomeUnfolding, neverUnfold,
  47
  48         -- * Strictness
  49         seqExpr, seqExprs, seqUnfolding,
  50
  51         -- * Annotated expression data types
  52         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
  53
  54         -- ** Operations on annotations
  55         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
  56
  57         -- * Core rule data types
  58         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  59         RuleName,
  60
  61         -- ** Operations on 'CoreRule's
  62         seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
  63         setRuleIdName,
  64         isBuiltinRule, isLocalRule
  65     ) where
  66
  67 #include "HsVersions.h"
  68
  69 import CostCentre
  70 import Var
  71 import Id
  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                                         --
 203                                         -- ... case x of
 204                                         --      Red   -> True
 205                                         --      other -> f (case x of
 206                                         --                      Green -> ...
 207                                         --                      Blue  -> ... ) ...
 208                                         -- @
 209                                         --
 210                                         -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at
 211                                         -- that program point.
 212   | Cast  (Expr b) Coercion             -- ^ Cast an expression to a particular type. This is used to implement @newtype@s
 213                                         -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs.
 214   | Note  Note (Expr b)                 -- ^ Notes. These allow general information to be
 215                                         -- added to expressions in the syntax tree
 216   | Type  Type                          -- ^ A type: this should only show up at the top
 217                                         -- level of an Arg
 218
 219 -- | Type synonym for expressions that occur in function argument positions.
 220 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
 221 type Arg b = Expr b
 222
 223 -- | A case split alternative. Consists of the constructor leading to the alternative,
 224 -- the variables bound from the constructor, and the expression to be executed given that binding.
 225 -- The default alternative is @(DEFAULT, [], rhs)@
 226 type Alt b = (AltCon, [b], Expr b)
 227
 228 -- | A case alternative constructor (i.e. pattern match)
 229 data AltCon = DataAlt DataCon   -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
 230                                 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
 231             | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
 232             | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
 233          deriving (Eq, Ord)
 234
 235 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
 236 data Bind b = NonRec b (Expr b)
 237             | Rec [(b, (Expr b))]
 238 \end{code}
 239
 240 -------------------------- CoreSyn INVARIANTS ---------------------------
 241
 242 Note [CoreSyn top-level invariant]
 243 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 244 See #toplevel_invariant#
 245
 246 Note [CoreSyn letrec invariant]
 247 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 248 See #letrec_invariant#
 249
 250 Note [CoreSyn let/app invariant]
 251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 252 See #let_app_invariant#
 253
 254 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
 255
 256 Note [CoreSyn case invariants]
 257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 258 See #case_invariants#
 259
 260 Note [CoreSyn let goal]
 261 ~~~~~~~~~~~~~~~~~~~~~~~
 262 * The simplifier tries to ensure that if the RHS of a let is a constructor
 263   application, its arguments are trivial, so that the constructor can be
 264   inlined vigorously.
 265
 266
 267 Note [Type let]
 268 ~~~~~~~~~~~~~~~
 269 See #type_let#
 270
 271 \begin{code}
 272
 273 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
 274 data Note
 275   = SCC CostCentre      -- ^ A cost centre annotation for profiling
 276
 277   | InlineMe            -- ^ Instructs the core simplifer to treat the enclosed expression
 278                         -- as very small, and inline it at its call sites
 279
 280   | CoreNote String     -- ^ A generic core annotation, propagated but not used by GHC
 281
 282 -- NOTE: we also treat expressions wrapped in InlineMe as
 283 -- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
 284 -- What this means is that we obediently inline even things that don't
 285 -- look like valuse.  This is sometimes important:
 286 --      {-# INLINE f #-}
 287 --      f = g . h
 288 -- Here, f looks like a redex, and we aren't going to inline (.) because it's
 289 -- inside an INLINE, so it'll stay looking like a redex.  Nevertheless, we
 290 -- should inline f even inside lambdas.  In effect, we should trust the programmer.
 291 \end{code}
 292
 293
 294 %************************************************************************
 295 %*                                                                      *
 296 \subsection{Transformation rules}
 297 %*                                                                      *
 298 %************************************************************************
 299
 300 The CoreRule type and its friends are dealt with mainly in CoreRules,
 301 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
 302
 303 \begin{code}
 304 -- | A 'CoreRule' is:
 305 --
 306 -- * \"Local\" if the function it is a rule for is defined in the
 307 --   same module as the rule itself.
 308 --
 309 -- * \"Orphan\" if nothing on the LHS is defined in the same module
 310 --   as the rule itself
 311 data CoreRule
 312   = Rule {
 313         ru_name :: RuleName,            -- ^ Name of the rule, for communication with the user
 314         ru_act  :: Activation,          -- ^ When the rule is active
 315
 316         -- Rough-matching stuff
 317         -- see comments with InstEnv.Instance( is_cls, is_rough )
 318         ru_fn    :: Name,               -- ^ Name of the 'Id.Id' at the head of this rule
 319         ru_rough :: [Maybe Name],       -- ^ Name at the head of each argument to the left hand side
 320
 321         -- Proper-matching stuff
 322         -- see comments with InstEnv.Instance( is_tvs, is_tys )
 323         ru_bndrs :: [CoreBndr],         -- ^ Variables quantified over
 324         ru_args  :: [CoreExpr],         -- ^ Left hand side arguments
 325
 326         -- And the right-hand side
 327         ru_rhs   :: CoreExpr,           -- ^ Right hand side of the rule
 328
 329         -- Locality
 330         ru_local :: Bool        -- ^ @True@ iff the fn at the head of the rule is
 331                                 -- defined in the same module as the rule
 332                                 -- and is not an implicit 'Id' (like a record selector,
 333                                 -- class operation, or data constructor)
 334
 335                 -- NB: ru_local is *not* used to decide orphan-hood
 336                 --      c.g. MkIface.coreRuleToIfaceRule
 337     }
 338
 339   -- | Built-in rules are used for constant folding
 340   -- and suchlike.  They have no free variables.
 341   | BuiltinRule {
 342         ru_name :: RuleName,    -- ^ As above
 343         ru_fn :: Name,          -- ^ As above
 344         ru_nargs :: Int,        -- ^ Number of arguments that 'ru_try' expects,
 345                                 -- including type arguments
 346         ru_try  :: [CoreExpr] -> Maybe CoreExpr
 347                 -- ^ This function does the rewrite.  It given too many
 348                 -- arguments, it simply discards them; the returned 'CoreExpr'
 349                 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
 350     }
 351                 -- See Note [Extra args in rule matching] in Rules.lhs
 352
 353 isBuiltinRule :: CoreRule -> Bool
 354 isBuiltinRule (BuiltinRule {}) = True
 355 isBuiltinRule _                = False
 356
 357 -- | The number of arguments the 'ru_fn' must be applied
 358 -- to before the rule can match on it
 359 ruleArity :: CoreRule -> Int
 360 ruleArity (BuiltinRule {ru_nargs = n}) = n
 361 ruleArity (Rule {ru_args = args})      = length args
 362
 363 ruleName :: CoreRule -> RuleName
 364 ruleName = ru_name
 365
 366 ruleActivation_maybe :: CoreRule -> Maybe Activation
 367 ruleActivation_maybe (BuiltinRule { })       = Nothing
 368 ruleActivation_maybe (Rule { ru_act = act }) = Just act
 369
 370 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
 371 ruleIdName :: CoreRule -> Name
 372 ruleIdName = ru_fn
 373
 374 isLocalRule :: CoreRule -> Bool
 375 isLocalRule = ru_local
 376
 377 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
 378 setRuleIdName :: Name -> CoreRule -> CoreRule
 379 setRuleIdName nm ru = ru { ru_fn = nm }
 380 \end{code}
 381
 382
 383 %************************************************************************
 384 %*                                                                      *
 385                 Unfoldings
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 The @Unfolding@ type is declared here to avoid numerous loops
 390
 391 \begin{code}
 392 -- | Records the /unfolding/ of an identifier, which is approximately the form the
 393 -- identifier would have if we substituted its definition in for the identifier.
 394 -- This type should be treated as abstract everywhere except in "CoreUnfold"
 395 data Unfolding
 396   = NoUnfolding                 -- ^ We have no information about the unfolding
 397
 398   | OtherCon [AltCon]           -- ^ It ain't one of these constructors.
 399                                 -- @OtherCon xs@ also indicates that something has been evaluated
 400                                 -- and hence there's no point in re-evaluating it.
 401                                 -- @OtherCon []@ is used even for non-data-type values
 402                                 -- to indicated evaluated-ness.  Notably:
 403                                 --
 404                                 -- > data C = C !(Int -> Int)
 405                                 -- > case x of { C f -> ... }
 406                                 --
 407                                 -- Here, @f@ gets an @OtherCon []@ unfolding.
 408
 409   | CompulsoryUnfolding CoreExpr        -- ^ There is /no original definition/,
 410                                         -- so you'd better unfold.
 411
 412   | CoreUnfolding
 413                 CoreExpr
 414                 Bool
 415                 Bool
 416                 Bool
 417                 UnfoldingGuidance
 418   -- ^ An unfolding with redundant cached information. Parameters:
 419   --
 420   --  1) Template used to perform unfolding; binder-info is correct
 421   --
 422   --  2) Is this a top level binding?
 423   --
 424   --  3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
 425   --     this variable
 426   --
 427   --  4) Does this waste only a little work if we expand it inside an inlining?
 428   --     Basically this is a cached version of 'exprIsCheap'
 429   --
 430   --  5) Tells us about the /size/ of the unfolding template
 431
 432 -- | When unfolding should take place
 433 data UnfoldingGuidance
 434   = UnfoldNever
 435   | UnfoldIfGoodArgs    Int     -- and "n" value args
 436
 437                         [Int]   -- Discount if the argument is evaluated.
 438                                 -- (i.e., a simplification will definitely
 439                                 -- be possible).  One elt of the list per *value* arg.
 440
 441                         Int     -- The "size" of the unfolding; to be elaborated
 442                                 -- later. ToDo
 443
 444                         Int     -- Scrutinee discount: the discount to substract if the thing is in
 445                                 -- a context (case (thing args) of ...),
 446                                 -- (where there are the right number of arguments.)
 447
 448 noUnfolding :: Unfolding
 449 -- ^ There is no known 'Unfolding'
 450 evaldUnfolding :: Unfolding
 451 -- ^ This unfolding marks the associated thing as being evaluated
 452
 453 noUnfolding    = NoUnfolding
 454 evaldUnfolding = OtherCon []
 455
 456 mkOtherCon :: [AltCon] -> Unfolding
 457 mkOtherCon = OtherCon
 458
 459 seqUnfolding :: Unfolding -> ()
 460 seqUnfolding (CoreUnfolding e top b1 b2 g)
 461   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g
 462 seqUnfolding _ = ()
 463
 464 seqGuidance :: UnfoldingGuidance -> ()
 465 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
 466 seqGuidance _                           = ()
 467 \end{code}
 468
 469 \begin{code}
 470 -- | Retrieves the template of an unfolding: panics if none is known
 471 unfoldingTemplate :: Unfolding -> CoreExpr
 472 unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr
 473 unfoldingTemplate (CompulsoryUnfolding expr)   = expr
 474 unfoldingTemplate _ = panic "getUnfoldingTemplate"
 475
 476 -- | Retrieves the template of an unfolding if possible
 477 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
 478 maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr
 479 maybeUnfoldingTemplate (CompulsoryUnfolding expr)   = Just expr
 480 maybeUnfoldingTemplate _                            = Nothing
 481
 482 -- | The constructors that the unfolding could never be:
 483 -- returns @[]@ if no information is available
 484 otherCons :: Unfolding -> [AltCon]
 485 otherCons (OtherCon cons) = cons
 486 otherCons _               = []
 487
 488 -- | Determines if it is certainly the case that the unfolding will
 489 -- yield a value (something in HNF): returns @False@ if unsure
 490 isValueUnfolding :: Unfolding -> Bool
 491 isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 492 isValueUnfolding _                                = False
 493
 494 -- | Determines if it possibly the case that the unfolding will
 495 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
 496 -- for 'OtherCon'
 497 isEvaldUnfolding :: Unfolding -> Bool
 498 isEvaldUnfolding (OtherCon _)                     = True
 499 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald
 500 isEvaldUnfolding _                                = False
 501
 502 -- | Is the thing we will unfold into certainly cheap?
 503 isCheapUnfolding :: Unfolding -> Bool
 504 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap
 505 isCheapUnfolding _                                = False
 506
 507 -- | Must this unfolding happen for the code to be executable?
 508 isCompulsoryUnfolding :: Unfolding -> Bool
 509 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
 510 isCompulsoryUnfolding _                       = False
 511
 512 -- | Do we have an available or compulsory unfolding?
 513 hasUnfolding :: Unfolding -> Bool
 514 hasUnfolding (CoreUnfolding _ _ _ _ _) = True
 515 hasUnfolding (CompulsoryUnfolding _)   = True
 516 hasUnfolding _                         = False
 517
 518 -- | Only returns False if there is no unfolding information available at all
 519 hasSomeUnfolding :: Unfolding -> Bool
 520 hasSomeUnfolding NoUnfolding = False
 521 hasSomeUnfolding _           = True
 522
 523 -- | Similar to @not . hasUnfolding@, but also returns @True@
 524 -- if it has an unfolding that says it should never occur
 525 neverUnfold :: Unfolding -> Bool
 526 neverUnfold NoUnfolding                         = True
 527 neverUnfold (OtherCon _)                        = True
 528 neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True
 529 neverUnfold _                                   = False
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535 \subsection{The main data type}
 536 %*                                                                      *
 537 %************************************************************************
 538
 539 \begin{code}
 540 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 541 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 542 -- constructor-applications with LitArg args, then you could get
 543 -- rid of this Ord.
 544
 545 instance Outputable AltCon where
 546   ppr (DataAlt dc) = ppr dc
 547   ppr (LitAlt lit) = ppr lit
 548   ppr DEFAULT      = ptext (sLit "__DEFAULT")
 549
 550 instance Show AltCon where
 551   showsPrec p con = showsPrecSDoc p (ppr con)
 552
 553 cmpAlt :: Alt b -> Alt b -> Ordering
 554 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 555
 556 ltAlt :: Alt b -> Alt b -> Bool
 557 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 558
 559 cmpAltCon :: AltCon -> AltCon -> Ordering
 560 -- ^ Compares 'AltCon's within a single list of alternatives
 561 cmpAltCon DEFAULT      DEFAULT     = EQ
 562 cmpAltCon DEFAULT      _           = LT
 563
 564 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 565 cmpAltCon (DataAlt _)  DEFAULT      = GT
 566 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 567 cmpAltCon (LitAlt _)   DEFAULT      = GT
 568
 569 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 570                                   ppr con1 <+> ppr con2 )
 571                       LT
 572 \end{code}
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection{Useful synonyms}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 \begin{code}
 581 -- | The common case for the type of binders and variables when
 582 -- we are manipulating the Core language within GHC
 583 type CoreBndr = Var
 584 -- | Expressions where binders are 'CoreBndr's
 585 type CoreExpr = Expr CoreBndr
 586 -- | Argument expressions where binders are 'CoreBndr's
 587 type CoreArg  = Arg  CoreBndr
 588 -- | Binding groups where binders are 'CoreBndr's
 589 type CoreBind = Bind CoreBndr
 590 -- | Case alternatives where binders are 'CoreBndr's
 591 type CoreAlt  = Alt  CoreBndr
 592 \end{code}
 593
 594 %************************************************************************
 595 %*                                                                      *
 596 \subsection{Tagging}
 597 %*                                                                      *
 598 %************************************************************************
 599
 600 \begin{code}
 601 -- | Binders are /tagged/ with a t
 602 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 603
 604 type TaggedBind t = Bind (TaggedBndr t)
 605 type TaggedExpr t = Expr (TaggedBndr t)
 606 type TaggedArg  t = Arg  (TaggedBndr t)
 607 type TaggedAlt  t = Alt  (TaggedBndr t)
 608
 609 instance Outputable b => Outputable (TaggedBndr b) where
 610   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 611
 612 instance Outputable b => OutputableBndr (TaggedBndr b) where
 613   pprBndr _ b = ppr b   -- Simple
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsection{Core-constructing functions with checking}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
 625 -- use 'CoreUtils.mkCoreApps' if possible
 626 mkApps    :: Expr b -> [Arg b]  -> Expr b
 627 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 628 mkTyApps  :: Expr b -> [Type]   -> Expr b
 629 -- | Apply a list of type or value variables to a function expression in a nested fashion
 630 mkVarApps :: Expr b -> [Var] -> Expr b
 631 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
 632 -- use 'MkCore.mkCoreConApps' if possible
 633 mkConApp      :: DataCon -> [Arg b] -> Expr b
 634
 635 mkApps    f args = foldl App                       f args
 636 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 637 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 638 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 639
 640
 641 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 642 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 643 mkIntLit      :: Integer -> Expr b
 644 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
 645 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 646 mkIntLitInt   :: Int     -> Expr b
 647
 648 mkIntLit    n = Lit (mkMachInt n)
 649 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 650
 651 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
 652 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 653 mkWordLit     :: Integer -> Expr b
 654 -- | Create a machine word literal expression of type  @Word#@ from a @Word@.
 655 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 656 mkWordLitWord :: Word -> Expr b
 657
 658 mkWordLit     w = Lit (mkMachWord w)
 659 mkWordLitWord w = Lit (mkMachWord (toInteger w))
 660
 661 -- | Create a machine character literal expression of type @Char#@.
 662 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
 663 mkCharLit :: Char -> Expr b
 664 -- | Create a machine string literal expression of type @Addr#@.
 665 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
 666 mkStringLit :: String -> Expr b
 667
 668 mkCharLit   c = Lit (mkMachChar c)
 669 mkStringLit s = Lit (mkMachString s)
 670
 671 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
 672 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 673 mkFloatLit :: Rational -> Expr b
 674 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
 675 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 676 mkFloatLitFloat :: Float -> Expr b
 677
 678 mkFloatLit      f = Lit (mkMachFloat f)
 679 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
 680
 681 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
 682 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 683 mkDoubleLit :: Rational -> Expr b
 684 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
 685 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 686 mkDoubleLitDouble :: Double -> Expr b
 687
 688 mkDoubleLit       d = Lit (mkMachDouble d)
 689 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
 690
 691 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
 692 -- use 'CoreUtils.mkCoreLets' if possible
 693 mkLets        :: [Bind b] -> Expr b -> Expr b
 694 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
 695 -- use 'CoreUtils.mkCoreLams' if possible
 696 mkLams        :: [b] -> Expr b -> Expr b
 697
 698 mkLams binders body = foldr Lam body binders
 699 mkLets binds body   = foldr Let body binds
 700
 701
 702 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
 703 -- this can only be used to bind something in a non-recursive @let@ expression
 704 mkTyBind :: TyVar -> Type -> CoreBind
 705 mkTyBind tv ty      = NonRec tv (Type ty)
 706
 707 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 708 varToCoreExpr :: CoreBndr -> Expr b
 709 varToCoreExpr v | isId v    = Var v
 710                 | otherwise = Type (mkTyVarTy v)
 711
 712 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 713 varsToCoreExprs vs = map varToCoreExpr vs
 714 \end{code}
 715
 716
 717 %************************************************************************
 718 %*                                                                      *
 719 \subsection{Simple access functions}
 720 %*                                                                      *
 721 %************************************************************************
 722
 723 \begin{code}
 724 -- | Extract every variable by this group
 725 bindersOf  :: Bind b -> [b]
 726 bindersOf (NonRec binder _) = [binder]
 727 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 728
 729 -- | 'bindersOf' applied to a list of binding groups
 730 bindersOfBinds :: [Bind b] -> [b]
 731 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 732
 733 rhssOfBind :: Bind b -> [Expr b]
 734 rhssOfBind (NonRec _ rhs) = [rhs]
 735 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 736
 737 rhssOfAlts :: [Alt b] -> [Expr b]
 738 rhssOfAlts alts = [e | (_,_,e) <- alts]
 739
 740 -- | Collapse all the bindings in the supplied groups into a single
 741 -- list of lhs/rhs pairs suitable for binding in a 'Rec' binding group
 742 flattenBinds :: [Bind b] -> [(b, Expr b)]
 743 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 744 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 745 flattenBinds []                   = []
 746 \end{code}
 747
 748 \begin{code}
 749 -- | We often want to strip off leading lambdas before getting down to
 750 -- business. This function is your friend.
 751 collectBinders               :: Expr b -> ([b],         Expr b)
 752 -- | Collect as many type bindings as possible from the front of a nested lambda
 753 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 754 -- | Collect as many value bindings as possible from the front of a nested lambda
 755 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 756 -- | Collect type binders from the front of the lambda first,
 757 -- then follow up by collecting as many value bindings as possible
 758 -- from the resulting stripped expression
 759 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 760
 761 collectBinders expr
 762   = go [] expr
 763   where
 764     go bs (Lam b e) = go (b:bs) e
 765     go bs e          = (reverse bs, e)
 766
 767 collectTyAndValBinders expr
 768   = (tvs, ids, body)
 769   where
 770     (tvs, body1) = collectTyBinders expr
 771     (ids, body)  = collectValBinders body1
 772
 773 collectTyBinders expr
 774   = go [] expr
 775   where
 776     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 777     go tvs e                     = (reverse tvs, e)
 778
 779 collectValBinders expr
 780   = go [] expr
 781   where
 782     go ids (Lam b e) | isId b = go (b:ids) e
 783     go ids body               = (reverse ids, body)
 784 \end{code}
 785
 786 \begin{code}
 787 -- | Takes a nested application expression and returns the the function
 788 -- being applied and the arguments to which it is applied
 789 collectArgs :: Expr b -> (Expr b, [Arg b])
 790 collectArgs expr
 791   = go expr []
 792   where
 793     go (App f a) as = go f (a:as)
 794     go e         as = (e, as)
 795 \end{code}
 796
 797 \begin{code}
 798 -- | Gets the cost centre enclosing an expression, if any.
 799 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
 800 coreExprCc :: Expr b -> CostCentre
 801 coreExprCc (Note (SCC cc) _)   = cc
 802 coreExprCc (Note _ e)          = coreExprCc e
 803 coreExprCc (Lam _ e)           = coreExprCc e
 804 coreExprCc _                   = noCostCentre
 805 \end{code}
 806
 807 %************************************************************************
 808 %*                                                                      *
 809 \subsection{Predicates}
 810 %*                                                                      *
 811 %************************************************************************
 812
 813 At one time we optionally carried type arguments through to runtime.
 814 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 815 i.e. if type applications are actual lambdas because types are kept around
 816 at runtime.  Similarly isRuntimeArg.
 817
 818 \begin{code}
 819 -- | Will this variable exist at runtime?
 820 isRuntimeVar :: Var -> Bool
 821 isRuntimeVar = isId
 822
 823 -- | Will this argument expression exist at runtime?
 824 isRuntimeArg :: CoreExpr -> Bool
 825 isRuntimeArg = isValArg
 826
 827 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
 828 isValArg :: Expr b -> Bool
 829 isValArg (Type _) = False
 830 isValArg _        = True
 831
 832 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
 833 isTypeArg :: Expr b -> Bool
 834 isTypeArg (Type _) = True
 835 isTypeArg _        = False
 836
 837 -- | The number of binders that bind values rather than types
 838 valBndrCount :: [CoreBndr] -> Int
 839 valBndrCount = count isId
 840
 841 -- | The number of argument expressions that are values rather than types at their top level
 842 valArgCount :: [Arg b] -> Int
 843 valArgCount = count isValArg
 844 \end{code}
 845
 846
 847 %************************************************************************
 848 %*                                                                      *
 849 \subsection{Seq stuff}
 850 %*                                                                      *
 851 %************************************************************************
 852
 853 \begin{code}
 854 seqExpr :: CoreExpr -> ()
 855 seqExpr (Var v)         = v `seq` ()
 856 seqExpr (Lit lit)       = lit `seq` ()
 857 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 858 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 859 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 860 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 861 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 862 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 863 seqExpr (Type t)        = seqType t
 864
 865 seqExprs :: [CoreExpr] -> ()
 866 seqExprs [] = ()
 867 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 868
 869 seqNote :: Note -> ()
 870 seqNote (CoreNote s)   = s `seq` ()
 871 seqNote _              = ()
 872
 873 seqBndr :: CoreBndr -> ()
 874 seqBndr b = b `seq` ()
 875
 876 seqBndrs :: [CoreBndr] -> ()
 877 seqBndrs [] = ()
 878 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 879
 880 seqBind :: Bind CoreBndr -> ()
 881 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 882 seqBind (Rec prs)    = seqPairs prs
 883
 884 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
 885 seqPairs [] = ()
 886 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 887
 888 seqAlts :: [CoreAlt] -> ()
 889 seqAlts [] = ()
 890 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 891
 892 seqRules :: [CoreRule] -> ()
 893 seqRules [] = ()
 894 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 895   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 896 seqRules (BuiltinRule {} : rules) = seqRules rules
 897 \end{code}
 898
 899 %************************************************************************
 900 %*                                                                      *
 901 \subsection{Annotated core}
 902 %*                                                                      *
 903 %************************************************************************
 904
 905 \begin{code}
 906 -- | Annotated core: allows annotation at every node in the tree
 907 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 908
 909 -- | A clone of the 'Expr' type but allowing annotation at every tree node
 910 data AnnExpr' bndr annot
 911   = AnnVar      Id
 912   | AnnLit      Literal
 913   | AnnLam      bndr (AnnExpr bndr annot)
 914   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 915   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 916   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 917   | AnnCast     (AnnExpr bndr annot) Coercion
 918   | AnnNote     Note (AnnExpr bndr annot)
 919   | AnnType     Type
 920
 921 -- | A clone of the 'Alt' type but allowing annotation at every tree node
 922 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 923
 924 -- | A clone of the 'Bind' type but allowing annotation at every tree node
 925 data AnnBind bndr annot
 926   = AnnNonRec bndr (AnnExpr bndr annot)
 927   | AnnRec    [(bndr, AnnExpr bndr annot)]
 928 \end{code}
 929
 930 \begin{code}
 931 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 932 deAnnotate (_, e) = deAnnotate' e
 933
 934 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
 935 deAnnotate' (AnnType t)           = Type t
 936 deAnnotate' (AnnVar  v)           = Var v
 937 deAnnotate' (AnnLit  lit)         = Lit lit
 938 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 939 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 940 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 941 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 942
 943 deAnnotate' (AnnLet bind body)
 944   = Let (deAnnBind bind) (deAnnotate body)
 945   where
 946     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 947     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 948
 949 deAnnotate' (AnnCase scrut v t alts)
 950   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 951
 952 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 953 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 954 \end{code}
 955
 956 \begin{code}
 957 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
 958 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 959 collectAnnBndrs e
 960   = collect [] e
 961   where
 962     collect bs (_, AnnLam b body) = collect (b:bs) body
 963     collect bs body               = (reverse bs, body)
 964 \end{code}