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,
  46         isExpandableUnfolding, isCompulsoryUnfolding,
  47         hasUnfolding, hasSomeUnfolding, neverUnfold,
  48
  49         -- * Strictness
  50         seqExpr, seqExprs, seqUnfolding,
  51
  52         -- * Annotated expression data types
  53         AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
  54
  55         -- ** Operations on annotations
  56         deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
  57
  58         -- * Core rule data types
  59         CoreRule(..),   -- CoreSubst, CoreTidy, CoreFVs, PprCore only
  60         RuleName,
  61
  62         -- ** Operations on 'CoreRule's
  63         seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
  64         setRuleIdName,
  65         isBuiltinRule, isLocalRule
  66     ) where
  67
  68 #include "HsVersions.h"
  69
  70 import CostCentre
  71 import Var
  72 import Type
  73 import Coercion
  74 import Name
  75 import Literal
  76 import DataCon
  77 import BasicTypes
  78 import FastString
  79 import Outputable
  80 import Util
  81
  82 import Data.Word
  83
  84 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
  85 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{The main data types}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 These data types are the heart of the compiler
  95
  96 \begin{code}
  97 infixl 8 `App`  -- App brackets to the left
  98
  99 -- | This is the data type that represents GHCs core intermediate language. Currently
 100 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 101 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
 102 --
 103 -- We get from Haskell source to this Core language in a number of stages:
 104 --
 105 -- 1. The source code is parsed into an abstract syntax tree, which is represented
 106 --    by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
 107 --
 108 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
 109 --    (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
 110 --    For example, this program:
 111 --
 112 -- @
 113 --      f x = let f x = x + 1
 114 --            in f (x - 2)
 115 -- @
 116 --
 117 --    Would be renamed by having 'Unique's attached so it looked something like this:
 118 --
 119 -- @
 120 --      f_1 x_2 = let f_3 x_4 = x_4 + 1
 121 --                in f_3 (x_2 - 2)
 122 -- @
 123 --
 124 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
 125 --    type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
 126 --
 127 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
 128 --    this 'Expr' type, which has far fewer constructors and hence is easier to perform
 129 --    optimization, analysis and code generation on.
 130 --
 131 -- The type parameter @b@ is for the type of binders in the expression tree.
 132 data Expr b
 133   = Var   Id                            -- ^ Variables
 134   | Lit   Literal                       -- ^ Primitive literals
 135   | App   (Expr b) (Arg b)              -- ^ Applications: note that the argument may be a 'Type'.
 136                                         --
 137                                         -- See "CoreSyn#let_app_invariant" for another invariant
 138   | Lam   b (Expr b)                    -- ^ Lambda abstraction
 139   | Let   (Bind b) (Expr b)             -- ^ Recursive and non recursive @let@s. Operationally
 140                                         -- this corresponds to allocating a thunk for the things
 141                                         -- bound and then executing the sub-expression.
 142                                         --
 143                                         -- #top_level_invariant#
 144                                         -- #letrec_invariant#
 145                                         --
 146                                         -- The right hand sides of all top-level and recursive @let@s
 147                                         -- /must/ be of lifted type (see "Type#type_classification" for
 148                                         -- the meaning of /lifted/ vs. /unlifted/).
 149                                         --
 150                                         -- #let_app_invariant#
 151                                         -- The right hand side of of a non-recursive 'Let' _and_ the argument of an 'App',
 152                                         -- /may/ be of unlifted type, but only if the expression
 153                                         -- is ok-for-speculation.  This means that the let can be floated around
 154                                         -- without difficulty. For example, this is OK:
 155                                         --
 156                                         -- > y::Int# = x +# 1#
 157                                         --
 158                                         -- But this is not, as it may affect termination if the expression is floated out:
 159                                         --
 160                                         -- > y::Int# = fac 4#
 161                                         --
 162                                         -- In this situation you should use @case@ rather than a @let@. The function
 163                                         -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
 164                                         -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
 165                                         -- which will generate a @case@ if necessary
 166                                         --
 167                                         -- #type_let#
 168                                         -- We allow a /non-recursive/ let to bind a type variable, thus:
 169                                         --
 170                                         -- > Let (NonRec tv (Type ty)) body
 171                                         --
 172                                         -- This can be very convenient for postponing type substitutions until
 173                                         -- the next run of the simplifier.
 174                                         --
 175                                         -- At the moment, the rest of the compiler only deals with type-let
 176                                         -- in a Let expression, rather than at top level.  We may want to revist
 177                                         -- this choice.
 178   | Case  (Expr b) b Type [Alt b]       -- ^ Case split. Operationally this corresponds to evaluating
 179                                         -- the scrutinee (expression examined) to weak head normal form
 180                                         -- and then examining at most one level of resulting constructor (i.e. you
 181                                         -- cannot do nested pattern matching directly with this).
 182                                         --
 183                                         -- The binder gets bound to the value of the scrutinee,
 184                                         -- and the 'Type' must be that of all the case alternatives
 185                                         --
 186                                         -- #case_invariants#
 187                                         -- This is one of the more complicated elements of the Core language, and comes
 188                                         -- with a number of restrictions:
 189                                         --
 190                                         -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all.
 191                                         --
 192                                         -- The remaining cases are in order of increasing
 193                                         --      tag     (for 'DataAlts') or
 194                                         --      lit     (for 'LitAlts').
 195                                         -- This makes finding the relevant constructor easy, and makes comparison easier too.
 196                                         --
 197                                         -- The list of alternatives must be exhaustive. An /exhaustive/ case
 198                                         -- does not necessarily mention all constructors:
 199                                         --
 200                                         -- @
 201                                         --      data Foo = Red | Green | Blue
 202                                         -- ... case x of
 203                                         --      Red   -> True
 204                                         --      other -> f (case x of
 205                                         --                      Green -> ...
 206                                         --                      Blue  -> ... ) ...
 207                                         -- @
 208                                         --
 209                                         -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at
 210                                         -- that program point.
 211   | Cast  (Expr b) Coercion             -- ^ Cast an expression to a particular type. This is used to implement @newtype@s
 212                                         -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs.
 213   | Note  Note (Expr b)                 -- ^ Notes. These allow general information to be
 214                                         -- added to expressions in the syntax tree
 215   | Type  Type                          -- ^ A type: this should only show up at the top
 216                                         -- level of an Arg
 217
 218 -- | Type synonym for expressions that occur in function argument positions.
 219 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
 220 type Arg b = Expr b
 221
 222 -- | A case split alternative. Consists of the constructor leading to the alternative,
 223 -- the variables bound from the constructor, and the expression to be executed given that binding.
 224 -- The default alternative is @(DEFAULT, [], rhs)@
 225 type Alt b = (AltCon, [b], Expr b)
 226
 227 -- | A case alternative constructor (i.e. pattern match)
 228 data AltCon = DataAlt DataCon   -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
 229                                 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
 230             | LitAlt  Literal   -- ^ A literal: @case e of { 1 -> ... }@
 231             | DEFAULT           -- ^ Trivial alternative: @case e of { _ -> ... }@
 232          deriving (Eq, Ord)
 233
 234 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
 235 data Bind b = NonRec b (Expr b)
 236             | Rec [(b, (Expr b))]
 237 \end{code}
 238
 239 -------------------------- CoreSyn INVARIANTS ---------------------------
 240
 241 Note [CoreSyn top-level invariant]
 242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 243 See #toplevel_invariant#
 244
 245 Note [CoreSyn letrec invariant]
 246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 247 See #letrec_invariant#
 248
 249 Note [CoreSyn let/app invariant]
 250 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 251 See #let_app_invariant#
 252
 253 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
 254
 255 Note [CoreSyn case invariants]
 256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 257 See #case_invariants#
 258
 259 Note [CoreSyn let goal]
 260 ~~~~~~~~~~~~~~~~~~~~~~~
 261 * The simplifier tries to ensure that if the RHS of a let is a constructor
 262   application, its arguments are trivial, so that the constructor can be
 263   inlined vigorously.
 264
 265
 266 Note [Type let]
 267 ~~~~~~~~~~~~~~~
 268 See #type_let#
 269
 270 \begin{code}
 271
 272 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
 273 data Note
 274   = SCC CostCentre      -- ^ A cost centre annotation for profiling
 275
 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                 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 b3 g)
 461   = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `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 isExpandableUnfolding :: Unfolding -> Bool
 508 isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
 509 isExpandableUnfolding _                                    = False
 510
 511 -- | Must this unfolding happen for the code to be executable?
 512 isCompulsoryUnfolding :: Unfolding -> Bool
 513 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
 514 isCompulsoryUnfolding _                       = False
 515
 516 -- | Do we have an available or compulsory unfolding?
 517 hasUnfolding :: Unfolding -> Bool
 518 hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
 519 hasUnfolding (CompulsoryUnfolding _)     = True
 520 hasUnfolding _                           = False
 521
 522 -- | Only returns False if there is no unfolding information available at all
 523 hasSomeUnfolding :: Unfolding -> Bool
 524 hasSomeUnfolding NoUnfolding = False
 525 hasSomeUnfolding _           = True
 526
 527 -- | Similar to @not . hasUnfolding@, but also returns @True@
 528 -- if it has an unfolding that says it should never occur
 529 neverUnfold :: Unfolding -> Bool
 530 neverUnfold NoUnfolding                           = True
 531 neverUnfold (OtherCon _)                          = True
 532 neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
 533 neverUnfold _                                     = False
 534 \end{code}
 535
 536
 537 %************************************************************************
 538 %*                                                                      *
 539 \subsection{The main data type}
 540 %*                                                                      *
 541 %************************************************************************
 542
 543 \begin{code}
 544 -- The Ord is needed for the FiniteMap used in the lookForConstructor
 545 -- in SimplEnv.  If you declared that lookForConstructor *ignores*
 546 -- constructor-applications with LitArg args, then you could get
 547 -- rid of this Ord.
 548
 549 instance Outputable AltCon where
 550   ppr (DataAlt dc) = ppr dc
 551   ppr (LitAlt lit) = ppr lit
 552   ppr DEFAULT      = ptext (sLit "__DEFAULT")
 553
 554 instance Show AltCon where
 555   showsPrec p con = showsPrecSDoc p (ppr con)
 556
 557 cmpAlt :: Alt b -> Alt b -> Ordering
 558 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
 559
 560 ltAlt :: Alt b -> Alt b -> Bool
 561 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
 562
 563 cmpAltCon :: AltCon -> AltCon -> Ordering
 564 -- ^ Compares 'AltCon's within a single list of alternatives
 565 cmpAltCon DEFAULT      DEFAULT     = EQ
 566 cmpAltCon DEFAULT      _           = LT
 567
 568 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
 569 cmpAltCon (DataAlt _)  DEFAULT      = GT
 570 cmpAltCon (LitAlt  l1) (LitAlt  l2) = l1 `compare` l2
 571 cmpAltCon (LitAlt _)   DEFAULT      = GT
 572
 573 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
 574                                   ppr con1 <+> ppr con2 )
 575                       LT
 576 \end{code}
 577
 578 %************************************************************************
 579 %*                                                                      *
 580 \subsection{Useful synonyms}
 581 %*                                                                      *
 582 %************************************************************************
 583
 584 \begin{code}
 585 -- | The common case for the type of binders and variables when
 586 -- we are manipulating the Core language within GHC
 587 type CoreBndr = Var
 588 -- | Expressions where binders are 'CoreBndr's
 589 type CoreExpr = Expr CoreBndr
 590 -- | Argument expressions where binders are 'CoreBndr's
 591 type CoreArg  = Arg  CoreBndr
 592 -- | Binding groups where binders are 'CoreBndr's
 593 type CoreBind = Bind CoreBndr
 594 -- | Case alternatives where binders are 'CoreBndr's
 595 type CoreAlt  = Alt  CoreBndr
 596 \end{code}
 597
 598 %************************************************************************
 599 %*                                                                      *
 600 \subsection{Tagging}
 601 %*                                                                      *
 602 %************************************************************************
 603
 604 \begin{code}
 605 -- | Binders are /tagged/ with a t
 606 data TaggedBndr t = TB CoreBndr t       -- TB for "tagged binder"
 607
 608 type TaggedBind t = Bind (TaggedBndr t)
 609 type TaggedExpr t = Expr (TaggedBndr t)
 610 type TaggedArg  t = Arg  (TaggedBndr t)
 611 type TaggedAlt  t = Alt  (TaggedBndr t)
 612
 613 instance Outputable b => Outputable (TaggedBndr b) where
 614   ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
 615
 616 instance Outputable b => OutputableBndr (TaggedBndr b) where
 617   pprBndr _ b = ppr b   -- Simple
 618 \end{code}
 619
 620
 621 %************************************************************************
 622 %*                                                                      *
 623 \subsection{Core-constructing functions with checking}
 624 %*                                                                      *
 625 %************************************************************************
 626
 627 \begin{code}
 628 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
 629 -- use 'CoreUtils.mkCoreApps' if possible
 630 mkApps    :: Expr b -> [Arg b]  -> Expr b
 631 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 632 mkTyApps  :: Expr b -> [Type]   -> Expr b
 633 -- | Apply a list of type or value variables to a function expression in a nested fashion
 634 mkVarApps :: Expr b -> [Var] -> Expr b
 635 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
 636 -- use 'MkCore.mkCoreConApps' if possible
 637 mkConApp      :: DataCon -> [Arg b] -> Expr b
 638
 639 mkApps    f args = foldl App                       f args
 640 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
 641 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 642 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 643
 644
 645 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 646 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 647 mkIntLit      :: Integer -> Expr b
 648 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
 649 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
 650 mkIntLitInt   :: Int     -> Expr b
 651
 652 mkIntLit    n = Lit (mkMachInt n)
 653 mkIntLitInt n = Lit (mkMachInt (toInteger n))
 654
 655 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
 656 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 657 mkWordLit     :: Integer -> Expr b
 658 -- | Create a machine word literal expression of type  @Word#@ from a @Word@.
 659 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
 660 mkWordLitWord :: Word -> Expr b
 661
 662 mkWordLit     w = Lit (mkMachWord w)
 663 mkWordLitWord w = Lit (mkMachWord (toInteger w))
 664
 665 -- | Create a machine character literal expression of type @Char#@.
 666 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
 667 mkCharLit :: Char -> Expr b
 668 -- | Create a machine string literal expression of type @Addr#@.
 669 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
 670 mkStringLit :: String -> Expr b
 671
 672 mkCharLit   c = Lit (mkMachChar c)
 673 mkStringLit s = Lit (mkMachString s)
 674
 675 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
 676 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 677 mkFloatLit :: Rational -> Expr b
 678 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
 679 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
 680 mkFloatLitFloat :: Float -> Expr b
 681
 682 mkFloatLit      f = Lit (mkMachFloat f)
 683 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
 684
 685 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
 686 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 687 mkDoubleLit :: Rational -> Expr b
 688 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
 689 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
 690 mkDoubleLitDouble :: Double -> Expr b
 691
 692 mkDoubleLit       d = Lit (mkMachDouble d)
 693 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
 694
 695 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
 696 -- use 'CoreUtils.mkCoreLets' if possible
 697 mkLets        :: [Bind b] -> Expr b -> Expr b
 698 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
 699 -- use 'CoreUtils.mkCoreLams' if possible
 700 mkLams        :: [b] -> Expr b -> Expr b
 701
 702 mkLams binders body = foldr Lam body binders
 703 mkLets binds body   = foldr Let body binds
 704
 705
 706 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
 707 -- this can only be used to bind something in a non-recursive @let@ expression
 708 mkTyBind :: TyVar -> Type -> CoreBind
 709 mkTyBind tv ty      = NonRec tv (Type ty)
 710
 711 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 712 varToCoreExpr :: CoreBndr -> Expr b
 713 varToCoreExpr v | isId v = Var v
 714                 | otherwise = Type (mkTyVarTy v)
 715
 716 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 717 varsToCoreExprs vs = map varToCoreExpr vs
 718 \end{code}
 719
 720
 721 %************************************************************************
 722 %*                                                                      *
 723 \subsection{Simple access functions}
 724 %*                                                                      *
 725 %************************************************************************
 726
 727 \begin{code}
 728 -- | Extract every variable by this group
 729 bindersOf  :: Bind b -> [b]
 730 bindersOf (NonRec binder _) = [binder]
 731 bindersOf (Rec pairs)       = [binder | (binder, _) <- pairs]
 732
 733 -- | 'bindersOf' applied to a list of binding groups
 734 bindersOfBinds :: [Bind b] -> [b]
 735 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
 736
 737 rhssOfBind :: Bind b -> [Expr b]
 738 rhssOfBind (NonRec _ rhs) = [rhs]
 739 rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]
 740
 741 rhssOfAlts :: [Alt b] -> [Expr b]
 742 rhssOfAlts alts = [e | (_,_,e) <- alts]
 743
 744 -- | Collapse all the bindings in the supplied groups into a single
 745 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
 746 flattenBinds :: [Bind b] -> [(b, Expr b)]
 747 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
 748 flattenBinds (Rec prs1   : binds) = prs1 ++ flattenBinds binds
 749 flattenBinds []                   = []
 750 \end{code}
 751
 752 \begin{code}
 753 -- | We often want to strip off leading lambdas before getting down to
 754 -- business. This function is your friend.
 755 collectBinders               :: Expr b -> ([b],         Expr b)
 756 -- | Collect as many type bindings as possible from the front of a nested lambda
 757 collectTyBinders             :: CoreExpr -> ([TyVar],     CoreExpr)
 758 -- | Collect as many value bindings as possible from the front of a nested lambda
 759 collectValBinders            :: CoreExpr -> ([Id],        CoreExpr)
 760 -- | Collect type binders from the front of the lambda first,
 761 -- then follow up by collecting as many value bindings as possible
 762 -- from the resulting stripped expression
 763 collectTyAndValBinders       :: CoreExpr -> ([TyVar], [Id], CoreExpr)
 764
 765 collectBinders expr
 766   = go [] expr
 767   where
 768     go bs (Lam b e) = go (b:bs) e
 769     go bs e          = (reverse bs, e)
 770
 771 collectTyAndValBinders expr
 772   = (tvs, ids, body)
 773   where
 774     (tvs, body1) = collectTyBinders expr
 775     (ids, body)  = collectValBinders body1
 776
 777 collectTyBinders expr
 778   = go [] expr
 779   where
 780     go tvs (Lam b e) | isTyVar b = go (b:tvs) e
 781     go tvs e                     = (reverse tvs, e)
 782
 783 collectValBinders expr
 784   = go [] expr
 785   where
 786     go ids (Lam b e) | isId b = go (b:ids) e
 787     go ids body               = (reverse ids, body)
 788 \end{code}
 789
 790 \begin{code}
 791 -- | Takes a nested application expression and returns the the function
 792 -- being applied and the arguments to which it is applied
 793 collectArgs :: Expr b -> (Expr b, [Arg b])
 794 collectArgs expr
 795   = go expr []
 796   where
 797     go (App f a) as = go f (a:as)
 798     go e         as = (e, as)
 799 \end{code}
 800
 801 \begin{code}
 802 -- | Gets the cost centre enclosing an expression, if any.
 803 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
 804 coreExprCc :: Expr b -> CostCentre
 805 coreExprCc (Note (SCC cc) _)   = cc
 806 coreExprCc (Note _ e)          = coreExprCc e
 807 coreExprCc (Lam _ e)           = coreExprCc e
 808 coreExprCc _                   = noCostCentre
 809 \end{code}
 810
 811 %************************************************************************
 812 %*                                                                      *
 813 \subsection{Predicates}
 814 %*                                                                      *
 815 %************************************************************************
 816
 817 At one time we optionally carried type arguments through to runtime.
 818 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
 819 i.e. if type applications are actual lambdas because types are kept around
 820 at runtime.  Similarly isRuntimeArg.
 821
 822 \begin{code}
 823 -- | Will this variable exist at runtime?
 824 isRuntimeVar :: Var -> Bool
 825 isRuntimeVar = isId
 826
 827 -- | Will this argument expression exist at runtime?
 828 isRuntimeArg :: CoreExpr -> Bool
 829 isRuntimeArg = isValArg
 830
 831 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
 832 isValArg :: Expr b -> Bool
 833 isValArg (Type _) = False
 834 isValArg _        = True
 835
 836 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
 837 isTypeArg :: Expr b -> Bool
 838 isTypeArg (Type _) = True
 839 isTypeArg _        = False
 840
 841 -- | The number of binders that bind values rather than types
 842 valBndrCount :: [CoreBndr] -> Int
 843 valBndrCount = count isId
 844
 845 -- | The number of argument expressions that are values rather than types at their top level
 846 valArgCount :: [Arg b] -> Int
 847 valArgCount = count isValArg
 848 \end{code}
 849
 850
 851 %************************************************************************
 852 %*                                                                      *
 853 \subsection{Seq stuff}
 854 %*                                                                      *
 855 %************************************************************************
 856
 857 \begin{code}
 858 seqExpr :: CoreExpr -> ()
 859 seqExpr (Var v)         = v `seq` ()
 860 seqExpr (Lit lit)       = lit `seq` ()
 861 seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 862 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 863 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 864 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
 865 seqExpr (Cast e co)     = seqExpr e `seq` seqType co
 866 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
 867 seqExpr (Type t)        = seqType t
 868
 869 seqExprs :: [CoreExpr] -> ()
 870 seqExprs [] = ()
 871 seqExprs (e:es) = seqExpr e `seq` seqExprs es
 872
 873 seqNote :: Note -> ()
 874 seqNote (CoreNote s)   = s `seq` ()
 875 seqNote _              = ()
 876
 877 seqBndr :: CoreBndr -> ()
 878 seqBndr b = b `seq` ()
 879
 880 seqBndrs :: [CoreBndr] -> ()
 881 seqBndrs [] = ()
 882 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
 883
 884 seqBind :: Bind CoreBndr -> ()
 885 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
 886 seqBind (Rec prs)    = seqPairs prs
 887
 888 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
 889 seqPairs [] = ()
 890 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
 891
 892 seqAlts :: [CoreAlt] -> ()
 893 seqAlts [] = ()
 894 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
 895
 896 seqRules :: [CoreRule] -> ()
 897 seqRules [] = ()
 898 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
 899   = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
 900 seqRules (BuiltinRule {} : rules) = seqRules rules
 901 \end{code}
 902
 903 %************************************************************************
 904 %*                                                                      *
 905 \subsection{Annotated core}
 906 %*                                                                      *
 907 %************************************************************************
 908
 909 \begin{code}
 910 -- | Annotated core: allows annotation at every node in the tree
 911 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
 912
 913 -- | A clone of the 'Expr' type but allowing annotation at every tree node
 914 data AnnExpr' bndr annot
 915   = AnnVar      Id
 916   | AnnLit      Literal
 917   | AnnLam      bndr (AnnExpr bndr annot)
 918   | AnnApp      (AnnExpr bndr annot) (AnnExpr bndr annot)
 919   | AnnCase     (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
 920   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)
 921   | AnnCast     (AnnExpr bndr annot) Coercion
 922   | AnnNote     Note (AnnExpr bndr annot)
 923   | AnnType     Type
 924
 925 -- | A clone of the 'Alt' type but allowing annotation at every tree node
 926 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
 927
 928 -- | A clone of the 'Bind' type but allowing annotation at every tree node
 929 data AnnBind bndr annot
 930   = AnnNonRec bndr (AnnExpr bndr annot)
 931   | AnnRec    [(bndr, AnnExpr bndr annot)]
 932 \end{code}
 933
 934 \begin{code}
 935 deAnnotate :: AnnExpr bndr annot -> Expr bndr
 936 deAnnotate (_, e) = deAnnotate' e
 937
 938 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
 939 deAnnotate' (AnnType t)           = Type t
 940 deAnnotate' (AnnVar  v)           = Var v
 941 deAnnotate' (AnnLit  lit)         = Lit lit
 942 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 943 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
 944 deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
 945 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 946
 947 deAnnotate' (AnnLet bind body)
 948   = Let (deAnnBind bind) (deAnnotate body)
 949   where
 950     deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
 951     deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
 952
 953 deAnnotate' (AnnCase scrut v t alts)
 954   = Case (deAnnotate scrut) v t (map deAnnAlt alts)
 955
 956 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
 957 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
 958 \end{code}
 959
 960 \begin{code}
 961 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
 962 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
 963 collectAnnBndrs e
 964   = collect [] e
 965   where
 966     collect bs (_, AnnLam b body) = collect (b:bs) body
 967     collect bs body               = (reverse bs, body)
 968 \end{code}