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