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