2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
8 -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
11 Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
12 CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
13 TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
15 -- ** 'Expr' construction
17 mkApps, mkTyApps, mkVarApps,
19 mkIntLit, mkIntLitInt,
20 mkWordLit, mkWordLitWord,
21 mkCharLit, mkStringLit,
22 mkFloatLit, mkFloatLitFloat,
23 mkDoubleLit, mkDoubleLitDouble,
26 varToCoreExpr, varsToCoreExprs,
28 isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
30 -- ** Simple 'Expr' access functions and predicates
31 bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
32 collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
33 collectArgs, coreExprCc, flattenBinds,
35 isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
37 -- * Unfolding data types
38 Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..),
39 -- Abstract everywhere but in CoreUnfold.lhs
41 -- ** Constructing 'Unfolding's
42 noUnfolding, evaldUnfolding, mkOtherCon,
44 -- ** Predicates and deconstruction on 'Unfolding'
45 unfoldingTemplate, setUnfoldingTemplate,
46 maybeUnfoldingTemplate, otherCons, unfoldingArity,
47 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
48 isExpandableUnfolding, isConLikeUnfolding,
49 isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding,
50 isStableUnfolding, canUnfold, neverUnfoldGuidance,
53 seqExpr, seqExprs, seqUnfolding,
55 -- * Annotated expression data types
56 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
58 -- ** Operations on annotations
59 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
61 -- * Core rule data types
62 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
65 -- ** Operations on 'CoreRule's
66 seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
68 isBuiltinRule, isLocalRule
71 #include "HsVersions.h"
87 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
88 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
91 %************************************************************************
93 \subsection{The main data types}
95 %************************************************************************
97 These data types are the heart of the compiler
100 infixl 8 `App` -- App brackets to the left
102 -- | This is the data type that represents GHCs core intermediate language. Currently
103 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
104 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
106 -- We get from Haskell source to this Core language in a number of stages:
108 -- 1. The source code is parsed into an abstract syntax tree, which is represented
109 -- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames'
111 -- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName'
112 -- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical.
113 -- For example, this program:
116 -- f x = let f x = x + 1
120 -- Would be renamed by having 'Unique's attached so it looked something like this:
123 -- f_1 x_2 = let f_3 x_4 = x_4 + 1
127 -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating
128 -- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names.
130 -- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into
131 -- this 'Expr' type, which has far fewer constructors and hence is easier to perform
132 -- optimization, analysis and code generation on.
134 -- The type parameter @b@ is for the type of binders in the expression tree.
136 = Var Id -- ^ Variables
137 | Lit Literal -- ^ Primitive literals
138 | App (Expr b) (Arg b) -- ^ Applications: note that the argument may be a 'Type'.
140 -- See "CoreSyn#let_app_invariant" for another invariant
141 | Lam b (Expr b) -- ^ Lambda abstraction
142 | Let (Bind b) (Expr b) -- ^ Recursive and non recursive @let@s. Operationally
143 -- this corresponds to allocating a thunk for the things
144 -- bound and then executing the sub-expression.
146 -- #top_level_invariant#
147 -- #letrec_invariant#
149 -- The right hand sides of all top-level and recursive @let@s
150 -- /must/ be of lifted type (see "Type#type_classification" for
151 -- the meaning of /lifted/ vs. /unlifted/).
153 -- #let_app_invariant#
154 -- The right hand side of of a non-recursive 'Let' _and_ the argument of an 'App',
155 -- /may/ be of unlifted type, but only if the expression
156 -- is ok-for-speculation. This means that the let can be floated around
157 -- without difficulty. For example, this is OK:
159 -- > y::Int# = x +# 1#
161 -- But this is not, as it may affect termination if the expression is floated out:
163 -- > y::Int# = fac 4#
165 -- In this situation you should use @case@ rather than a @let@. The function
166 -- 'CoreUtils.needsCaseBinding' can help you determine which to generate, or
167 -- alternatively use 'MkCore.mkCoreLet' rather than this constructor directly,
168 -- which will generate a @case@ if necessary
171 -- We allow a /non-recursive/ let to bind a type variable, thus:
173 -- > Let (NonRec tv (Type ty)) body
175 -- This can be very convenient for postponing type substitutions until
176 -- the next run of the simplifier.
178 -- At the moment, the rest of the compiler only deals with type-let
179 -- in a Let expression, rather than at top level. We may want to revist
181 | Case (Expr b) b Type [Alt b] -- ^ Case split. Operationally this corresponds to evaluating
182 -- the scrutinee (expression examined) to weak head normal form
183 -- and then examining at most one level of resulting constructor (i.e. you
184 -- cannot do nested pattern matching directly with this).
186 -- The binder gets bound to the value of the scrutinee,
187 -- and the 'Type' must be that of all the case alternatives
190 -- This is one of the more complicated elements of the Core language, and comes
191 -- with a number of restrictions:
193 -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all.
195 -- The remaining cases are in order of increasing
196 -- tag (for 'DataAlts') or
197 -- lit (for 'LitAlts').
198 -- This makes finding the relevant constructor easy, and makes comparison easier too.
200 -- The list of alternatives must be exhaustive. An /exhaustive/ case
201 -- does not necessarily mention all constructors:
204 -- data Foo = Red | Green | Blue
207 -- other -> f (case x of
212 -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at
213 -- that program point.
214 | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type. This is used to implement @newtype@s
215 -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs.
216 | Note Note (Expr b) -- ^ Notes. These allow general information to be
217 -- added to expressions in the syntax tree
218 | Type Type -- ^ A type: this should only show up at the top
221 -- | Type synonym for expressions that occur in function argument positions.
222 -- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
225 -- | A case split alternative. Consists of the constructor leading to the alternative,
226 -- the variables bound from the constructor, and the expression to be executed given that binding.
227 -- The default alternative is @(DEFAULT, [], rhs)@
228 type Alt b = (AltCon, [b], Expr b)
230 -- | A case alternative constructor (i.e. pattern match)
231 data AltCon = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@.
232 -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
233 | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
234 | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
237 -- | Binding, used for top level bindings in a module and local bindings in a @let@.
238 data Bind b = NonRec b (Expr b)
239 | Rec [(b, (Expr b))]
242 -------------------------- CoreSyn INVARIANTS ---------------------------
244 Note [CoreSyn top-level invariant]
245 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
246 See #toplevel_invariant#
248 Note [CoreSyn letrec invariant]
249 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
250 See #letrec_invariant#
252 Note [CoreSyn let/app invariant]
253 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
254 See #let_app_invariant#
256 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
258 Note [CoreSyn case invariants]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 See #case_invariants#
262 Note [CoreSyn let goal]
263 ~~~~~~~~~~~~~~~~~~~~~~~
264 * The simplifier tries to ensure that if the RHS of a let is a constructor
265 application, its arguments are trivial, so that the constructor can be
275 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
277 = SCC CostCentre -- ^ A cost centre annotation for profiling
278 | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC
282 %************************************************************************
284 \subsection{Transformation rules}
286 %************************************************************************
288 The CoreRule type and its friends are dealt with mainly in CoreRules,
289 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
292 -- | A 'CoreRule' is:
294 -- * \"Local\" if the function it is a rule for is defined in the
295 -- same module as the rule itself.
297 -- * \"Orphan\" if nothing on the LHS is defined in the same module
298 -- as the rule itself
301 ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
302 ru_act :: Activation, -- ^ When the rule is active
304 -- Rough-matching stuff
305 -- see comments with InstEnv.Instance( is_cls, is_rough )
306 ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
307 ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side
309 -- Proper-matching stuff
310 -- see comments with InstEnv.Instance( is_tvs, is_tys )
311 ru_bndrs :: [CoreBndr], -- ^ Variables quantified over
312 ru_args :: [CoreExpr], -- ^ Left hand side arguments
314 -- And the right-hand side
315 ru_rhs :: CoreExpr, -- ^ Right hand side of the rule
316 -- Occurrence info is guaranteed correct
317 -- See Note [OccInfo in unfoldings and rules]
320 ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
321 -- defined in the same module as the rule
322 -- and is not an implicit 'Id' (like a record selector,
323 -- class operation, or data constructor)
325 -- NB: ru_local is *not* used to decide orphan-hood
326 -- c.g. MkIface.coreRuleToIfaceRule
329 -- | Built-in rules are used for constant folding
330 -- and suchlike. They have no free variables.
332 ru_name :: RuleName, -- ^ As above
333 ru_fn :: Name, -- ^ As above
334 ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
335 -- if it fires, including type arguments
336 ru_try :: [CoreExpr] -> Maybe CoreExpr
337 -- ^ This function does the rewrite. It given too many
338 -- arguments, it simply discards them; the returned 'CoreExpr'
339 -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
341 -- See Note [Extra args in rule matching] in Rules.lhs
343 isBuiltinRule :: CoreRule -> Bool
344 isBuiltinRule (BuiltinRule {}) = True
345 isBuiltinRule _ = False
347 -- | The number of arguments the 'ru_fn' must be applied
348 -- to before the rule can match on it
349 ruleArity :: CoreRule -> Int
350 ruleArity (BuiltinRule {ru_nargs = n}) = n
351 ruleArity (Rule {ru_args = args}) = length args
353 ruleName :: CoreRule -> RuleName
356 ruleActivation_maybe :: CoreRule -> Maybe Activation
357 ruleActivation_maybe (BuiltinRule { }) = Nothing
358 ruleActivation_maybe (Rule { ru_act = act }) = Just act
360 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
361 ruleIdName :: CoreRule -> Name
364 isLocalRule :: CoreRule -> Bool
365 isLocalRule = ru_local
367 -- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side
368 setRuleIdName :: Name -> CoreRule -> CoreRule
369 setRuleIdName nm ru = ru { ru_fn = nm }
373 %************************************************************************
377 %************************************************************************
379 The @Unfolding@ type is declared here to avoid numerous loops
382 -- | Records the /unfolding/ of an identifier, which is approximately the form the
383 -- identifier would have if we substituted its definition in for the identifier.
384 -- This type should be treated as abstract everywhere except in "CoreUnfold"
386 = NoUnfolding -- ^ We have no information about the unfolding
388 | OtherCon [AltCon] -- ^ It ain't one of these constructors.
389 -- @OtherCon xs@ also indicates that something has been evaluated
390 -- and hence there's no point in re-evaluating it.
391 -- @OtherCon []@ is used even for non-data-type values
392 -- to indicated evaluated-ness. Notably:
394 -- > data C = C !(Int -> Int)
395 -- > case x of { C f -> ... }
397 -- Here, @f@ gets an @OtherCon []@ unfolding.
399 | DFunUnfolding DataCon [CoreExpr]
400 -- The Unfolding of a DFunId
401 -- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
402 -- (op2 a1..am d1..dn)
403 -- where Arity = n, the number of dict args to the dfun
404 -- The [CoreExpr] are the superclasses and methods [op1,op2],
405 -- in positional order.
406 -- They are usually variables, but can be trivial expressions
407 -- instead (e.g. a type application).
409 | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
410 -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
411 uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
412 uf_arity :: Arity, -- Number of value arguments expected
413 uf_is_top :: Bool, -- True <=> top level binding
414 uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on
416 uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function
417 -- Cached version of exprIsConLike
418 uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining
419 -- Cached version of exprIsCheap
420 uf_expandable :: Bool, -- True <=> can expand in RULE matching
421 -- Cached version of exprIsExpandable
422 uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
424 -- ^ An unfolding with redundant cached information. Parameters:
426 -- uf_tmpl: Template used to perform unfolding;
427 -- NB: Occurrence info is guaranteed correct:
428 -- see Note [OccInfo in unfoldings and rules]
430 -- uf_is_top: Is this a top level binding?
432 -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
435 -- uf_is_cheap: Does this waste only a little work if we expand it inside an inlining?
436 -- Basically this is a cached version of 'exprIsCheap'
438 -- uf_guidance: Tells us about the /size/ of the unfolding template
440 ------------------------------------------------
441 -- | 'UnfoldingGuidance' says when unfolding should take place
442 data UnfoldingGuidance
443 = InlineRule { -- Be very keen to inline this; See Note [InlineRules]
444 -- The uf_tmpl is the *original* RHS; do *not* replace it on
445 -- each simlifier run. Hence, the *actual* RHS of the function
446 -- may be different by now, because it may have been optimised.
448 ir_sat :: InlSatFlag,
449 ir_info :: InlineRuleInfo
452 | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the
453 -- result of a simple analysis of the RHS
455 ug_args :: [Int], -- Discount if the argument is evaluated.
456 -- (i.e., a simplification will definitely
457 -- be possible). One elt of the list per *value* arg.
459 ug_size :: Int, -- The "size" of the unfolding.
461 ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in
462 } -- a context (case (thing args) of ...),
463 -- (where there are the right number of arguments.)
465 | UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs
468 = InlAlways -- Inline absolutely always, however boring the context.
469 -- There is /no original definition/. Only a few primop-like things
470 -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding).
472 | InlSmall -- The RHS is very small (eg no bigger than a call), so inline any
473 -- /saturated/ application, regardless of context
474 -- See Note [INLINE for small functions] in CoreUnfold
478 | InlWrapper Id -- This unfolding is a the wrapper in a
479 -- worker/wrapper split from the strictness analyser
480 -- The Id is the worker-id
481 -- Used to abbreviate the uf_tmpl in interface files
482 -- which don't need to contain the RHS;
483 -- it can be derived from the strictness info
484 -- [In principle this is orthogonal to the InlSmall/InVanilla thing,
485 -- but it's convenient to have it here.]
487 data InlSatFlag = InlSat | InlUnSat
488 -- Specifies whether to INLINE only if the thing is applied to 'arity' args
490 ------------------------------------------------
491 noUnfolding :: Unfolding
492 -- ^ There is no known 'Unfolding'
493 evaldUnfolding :: Unfolding
494 -- ^ This unfolding marks the associated thing as being evaluated
496 noUnfolding = NoUnfolding
497 evaldUnfolding = OtherCon []
499 mkOtherCon :: [AltCon] -> Unfolding
500 mkOtherCon = OtherCon
502 seqUnfolding :: Unfolding -> ()
503 seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
504 uf_is_value = b1, uf_is_cheap = b2,
505 uf_expandable = b3, uf_is_conlike = b4,
506 uf_arity = a, uf_guidance = g})
507 = seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
511 seqGuidance :: UnfoldingGuidance -> ()
512 seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
517 -- | Retrieves the template of an unfolding: panics if none is known
518 unfoldingTemplate :: Unfolding -> CoreExpr
519 unfoldingTemplate = uf_tmpl
521 setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
522 setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
524 -- | Retrieves the template of an unfolding if possible
525 maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
526 maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr
527 maybeUnfoldingTemplate _ = Nothing
529 -- | The constructors that the unfolding could never be:
530 -- returns @[]@ if no information is available
531 otherCons :: Unfolding -> [AltCon]
532 otherCons (OtherCon cons) = cons
535 -- | Determines if it is certainly the case that the unfolding will
536 -- yield a value (something in HNF): returns @False@ if unsure
537 isValueUnfolding :: Unfolding -> Bool
538 -- Returns False for OtherCon
539 isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
540 isValueUnfolding _ = False
542 -- | Determines if it possibly the case that the unfolding will
543 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
545 isEvaldUnfolding :: Unfolding -> Bool
546 -- Returns True for OtherCon
547 isEvaldUnfolding (OtherCon _) = True
548 isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
549 isEvaldUnfolding _ = False
551 -- | @True@ if the unfolding is a constructor application, the application
552 -- of a CONLIKE function or 'OtherCon'
553 isConLikeUnfolding :: Unfolding -> Bool
554 isConLikeUnfolding (OtherCon _) = True
555 isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con
556 isConLikeUnfolding _ = False
558 -- | Is the thing we will unfold into certainly cheap?
559 isCheapUnfolding :: Unfolding -> Bool
560 isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
561 isCheapUnfolding _ = False
563 isExpandableUnfolding :: Unfolding -> Bool
564 isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
565 isExpandableUnfolding _ = False
567 isInlineRule :: Unfolding -> Bool
568 isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
569 isInlineRule _ = False
571 isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag)
572 isInlineRule_maybe (CoreUnfolding { uf_guidance =
573 InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat)
574 isInlineRule_maybe _ = Nothing
576 isStableUnfolding :: Unfolding -> Bool
577 -- True of unfoldings that should not be overwritten
578 -- by a CoreUnfolding for the RHS of a let-binding
579 isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True
580 isStableUnfolding (DFunUnfolding {}) = True
581 isStableUnfolding _ = False
583 unfoldingArity :: Unfolding -> Arity
584 unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
585 unfoldingArity _ = panic "unfoldingArity"
587 isClosedUnfolding :: Unfolding -> Bool -- No free variables
588 isClosedUnfolding (CoreUnfolding {}) = False
589 isClosedUnfolding _ = True
591 -- | Only returns False if there is no unfolding information available at all
592 hasSomeUnfolding :: Unfolding -> Bool
593 hasSomeUnfolding NoUnfolding = False
594 hasSomeUnfolding _ = True
596 neverUnfoldGuidance :: UnfoldingGuidance -> Bool
597 neverUnfoldGuidance UnfoldNever = True
598 neverUnfoldGuidance _ = False
600 canUnfold :: Unfolding -> Bool
601 canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
610 you intend that calls (f e) are replaced by <rhs>[e/x] So we
611 should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
612 with it. Meanwhile, we can optimise <rhs> to our heart's content,
613 leaving the original unfolding intact in Unfolding of 'f'.
615 So the representation of an Unfolding has changed quite a bit
616 (see CoreSyn). An INLINE pragma gives rise to an InlineRule
619 Moreover, it's only used when 'f' is applied to the
620 specified number of arguments; that is, the number of argument on
621 the LHS of the '=' sign in the original source definition.
622 For example, (.) is now defined in the libraries like this
624 (.) f g = \x -> f (g x)
625 so that it'll inline when applied to two arguments. If 'x' appeared
628 it'd only inline when applied to three arguments. This slightly-experimental
629 change was requested by Roman, but it seems to make sense.
631 See also Note [Inlining an InlineRule] in CoreUnfold.
634 Note [OccInfo in unfoldings and rules]
635 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
636 In unfoldings and rules, we guarantee that the template is occ-analysed,
637 so that the occurence info on the binders is correct. This is important,
638 because the Simplifier does not re-analyse the template when using it. If
639 the occurrence info is wrong
640 - We may get more simpifier iterations than necessary, because
641 once-occ info isn't there
642 - More seriously, we may get an infinite loop if there's a Rec
643 without a loop breaker marked
646 %************************************************************************
648 \subsection{The main data type}
650 %************************************************************************
653 -- The Ord is needed for the FiniteMap used in the lookForConstructor
654 -- in SimplEnv. If you declared that lookForConstructor *ignores*
655 -- constructor-applications with LitArg args, then you could get
658 instance Outputable AltCon where
659 ppr (DataAlt dc) = ppr dc
660 ppr (LitAlt lit) = ppr lit
661 ppr DEFAULT = ptext (sLit "__DEFAULT")
663 instance Show AltCon where
664 showsPrec p con = showsPrecSDoc p (ppr con)
666 cmpAlt :: Alt b -> Alt b -> Ordering
667 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
669 ltAlt :: Alt b -> Alt b -> Bool
670 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
672 cmpAltCon :: AltCon -> AltCon -> Ordering
673 -- ^ Compares 'AltCon's within a single list of alternatives
674 cmpAltCon DEFAULT DEFAULT = EQ
675 cmpAltCon DEFAULT _ = LT
677 cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
678 cmpAltCon (DataAlt _) DEFAULT = GT
679 cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
680 cmpAltCon (LitAlt _) DEFAULT = GT
682 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
683 ppr con1 <+> ppr con2 )
687 %************************************************************************
689 \subsection{Useful synonyms}
691 %************************************************************************
694 -- | The common case for the type of binders and variables when
695 -- we are manipulating the Core language within GHC
697 -- | Expressions where binders are 'CoreBndr's
698 type CoreExpr = Expr CoreBndr
699 -- | Argument expressions where binders are 'CoreBndr's
700 type CoreArg = Arg CoreBndr
701 -- | Binding groups where binders are 'CoreBndr's
702 type CoreBind = Bind CoreBndr
703 -- | Case alternatives where binders are 'CoreBndr's
704 type CoreAlt = Alt CoreBndr
707 %************************************************************************
711 %************************************************************************
714 -- | Binders are /tagged/ with a t
715 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
717 type TaggedBind t = Bind (TaggedBndr t)
718 type TaggedExpr t = Expr (TaggedBndr t)
719 type TaggedArg t = Arg (TaggedBndr t)
720 type TaggedAlt t = Alt (TaggedBndr t)
722 instance Outputable b => Outputable (TaggedBndr b) where
723 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
725 instance Outputable b => OutputableBndr (TaggedBndr b) where
726 pprBndr _ b = ppr b -- Simple
730 %************************************************************************
732 \subsection{Core-constructing functions with checking}
734 %************************************************************************
737 -- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
738 -- use 'CoreUtils.mkCoreApps' if possible
739 mkApps :: Expr b -> [Arg b] -> Expr b
740 -- | Apply a list of type argument expressions to a function expression in a nested fashion
741 mkTyApps :: Expr b -> [Type] -> Expr b
742 -- | Apply a list of type or value variables to a function expression in a nested fashion
743 mkVarApps :: Expr b -> [Var] -> Expr b
744 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
745 -- use 'MkCore.mkCoreConApps' if possible
746 mkConApp :: DataCon -> [Arg b] -> Expr b
748 mkApps f args = foldl App f args
749 mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
750 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
751 mkConApp con args = mkApps (Var (dataConWorkId con)) args
754 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
755 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
756 mkIntLit :: Integer -> Expr b
757 -- | Create a machine integer literal expression of type @Int#@ from an @Int@.
758 -- If you want an expression of type @Int@ use 'MkCore.mkIntExpr'
759 mkIntLitInt :: Int -> Expr b
761 mkIntLit n = Lit (mkMachInt n)
762 mkIntLitInt n = Lit (mkMachInt (toInteger n))
764 -- | Create a machine word literal expression of type @Word#@ from an @Integer@.
765 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
766 mkWordLit :: Integer -> Expr b
767 -- | Create a machine word literal expression of type @Word#@ from a @Word@.
768 -- If you want an expression of type @Word@ use 'MkCore.mkWordExpr'
769 mkWordLitWord :: Word -> Expr b
771 mkWordLit w = Lit (mkMachWord w)
772 mkWordLitWord w = Lit (mkMachWord (toInteger w))
774 -- | Create a machine character literal expression of type @Char#@.
775 -- If you want an expression of type @Char@ use 'MkCore.mkCharExpr'
776 mkCharLit :: Char -> Expr b
777 -- | Create a machine string literal expression of type @Addr#@.
778 -- If you want an expression of type @String@ use 'MkCore.mkStringExpr'
779 mkStringLit :: String -> Expr b
781 mkCharLit c = Lit (mkMachChar c)
782 mkStringLit s = Lit (mkMachString s)
784 -- | Create a machine single precision literal expression of type @Float#@ from a @Rational@.
785 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
786 mkFloatLit :: Rational -> Expr b
787 -- | Create a machine single precision literal expression of type @Float#@ from a @Float@.
788 -- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr'
789 mkFloatLitFloat :: Float -> Expr b
791 mkFloatLit f = Lit (mkMachFloat f)
792 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
794 -- | Create a machine double precision literal expression of type @Double#@ from a @Rational@.
795 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
796 mkDoubleLit :: Rational -> Expr b
797 -- | Create a machine double precision literal expression of type @Double#@ from a @Double@.
798 -- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr'
799 mkDoubleLitDouble :: Double -> Expr b
801 mkDoubleLit d = Lit (mkMachDouble d)
802 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
804 -- | Bind all supplied binding groups over an expression in a nested let expression. Prefer to
805 -- use 'CoreUtils.mkCoreLets' if possible
806 mkLets :: [Bind b] -> Expr b -> Expr b
807 -- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
808 -- use 'CoreUtils.mkCoreLams' if possible
809 mkLams :: [b] -> Expr b -> Expr b
811 mkLams binders body = foldr Lam body binders
812 mkLets binds body = foldr Let body binds
815 -- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
816 -- this can only be used to bind something in a non-recursive @let@ expression
817 mkTyBind :: TyVar -> Type -> CoreBind
818 mkTyBind tv ty = NonRec tv (Type ty)
820 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
821 varToCoreExpr :: CoreBndr -> Expr b
822 varToCoreExpr v | isId v = Var v
823 | otherwise = Type (mkTyVarTy v)
825 varsToCoreExprs :: [CoreBndr] -> [Expr b]
826 varsToCoreExprs vs = map varToCoreExpr vs
830 %************************************************************************
832 \subsection{Simple access functions}
834 %************************************************************************
837 -- | Extract every variable by this group
838 bindersOf :: Bind b -> [b]
839 bindersOf (NonRec binder _) = [binder]
840 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
842 -- | 'bindersOf' applied to a list of binding groups
843 bindersOfBinds :: [Bind b] -> [b]
844 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
846 rhssOfBind :: Bind b -> [Expr b]
847 rhssOfBind (NonRec _ rhs) = [rhs]
848 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
850 rhssOfAlts :: [Alt b] -> [Expr b]
851 rhssOfAlts alts = [e | (_,_,e) <- alts]
853 -- | Collapse all the bindings in the supplied groups into a single
854 -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
855 flattenBinds :: [Bind b] -> [(b, Expr b)]
856 flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
857 flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
862 -- | We often want to strip off leading lambdas before getting down to
863 -- business. This function is your friend.
864 collectBinders :: Expr b -> ([b], Expr b)
865 -- | Collect as many type bindings as possible from the front of a nested lambda
866 collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
867 -- | Collect as many value bindings as possible from the front of a nested lambda
868 collectValBinders :: CoreExpr -> ([Id], CoreExpr)
869 -- | Collect type binders from the front of the lambda first,
870 -- then follow up by collecting as many value bindings as possible
871 -- from the resulting stripped expression
872 collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
877 go bs (Lam b e) = go (b:bs) e
878 go bs e = (reverse bs, e)
880 collectTyAndValBinders expr
883 (tvs, body1) = collectTyBinders expr
884 (ids, body) = collectValBinders body1
886 collectTyBinders expr
889 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
890 go tvs e = (reverse tvs, e)
892 collectValBinders expr
895 go ids (Lam b e) | isId b = go (b:ids) e
896 go ids body = (reverse ids, body)
900 -- | Takes a nested application expression and returns the the function
901 -- being applied and the arguments to which it is applied
902 collectArgs :: Expr b -> (Expr b, [Arg b])
906 go (App f a) as = go f (a:as)
911 -- | Gets the cost centre enclosing an expression, if any.
912 -- It looks inside lambdas because @(scc \"foo\" \\x.e) = \\x. scc \"foo\" e@
913 coreExprCc :: Expr b -> CostCentre
914 coreExprCc (Note (SCC cc) _) = cc
915 coreExprCc (Note _ e) = coreExprCc e
916 coreExprCc (Lam _ e) = coreExprCc e
917 coreExprCc _ = noCostCentre
920 %************************************************************************
922 \subsection{Predicates}
924 %************************************************************************
926 At one time we optionally carried type arguments through to runtime.
927 @isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
928 i.e. if type applications are actual lambdas because types are kept around
929 at runtime. Similarly isRuntimeArg.
932 -- | Will this variable exist at runtime?
933 isRuntimeVar :: Var -> Bool
936 -- | Will this argument expression exist at runtime?
937 isRuntimeArg :: CoreExpr -> Bool
938 isRuntimeArg = isValArg
940 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
941 isValArg :: Expr b -> Bool
942 isValArg (Type _) = False
945 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
946 isTypeArg :: Expr b -> Bool
947 isTypeArg (Type _) = True
950 -- | The number of binders that bind values rather than types
951 valBndrCount :: [CoreBndr] -> Int
952 valBndrCount = count isId
954 -- | The number of argument expressions that are values rather than types at their top level
955 valArgCount :: [Arg b] -> Int
956 valArgCount = count isValArg
960 %************************************************************************
962 \subsection{Seq stuff}
964 %************************************************************************
967 seqExpr :: CoreExpr -> ()
968 seqExpr (Var v) = v `seq` ()
969 seqExpr (Lit lit) = lit `seq` ()
970 seqExpr (App f a) = seqExpr f `seq` seqExpr a
971 seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
972 seqExpr (Let b e) = seqBind b `seq` seqExpr e
973 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
974 seqExpr (Cast e co) = seqExpr e `seq` seqType co
975 seqExpr (Note n e) = seqNote n `seq` seqExpr e
976 seqExpr (Type t) = seqType t
978 seqExprs :: [CoreExpr] -> ()
980 seqExprs (e:es) = seqExpr e `seq` seqExprs es
982 seqNote :: Note -> ()
983 seqNote (CoreNote s) = s `seq` ()
986 seqBndr :: CoreBndr -> ()
987 seqBndr b = b `seq` ()
989 seqBndrs :: [CoreBndr] -> ()
991 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
993 seqBind :: Bind CoreBndr -> ()
994 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
995 seqBind (Rec prs) = seqPairs prs
997 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
999 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
1001 seqAlts :: [CoreAlt] -> ()
1003 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
1005 seqRules :: [CoreRule] -> ()
1007 seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
1008 = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
1009 seqRules (BuiltinRule {} : rules) = seqRules rules
1012 %************************************************************************
1014 \subsection{Annotated core}
1016 %************************************************************************
1019 -- | Annotated core: allows annotation at every node in the tree
1020 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
1022 -- | A clone of the 'Expr' type but allowing annotation at every tree node
1023 data AnnExpr' bndr annot
1026 | AnnLam bndr (AnnExpr bndr annot)
1027 | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
1028 | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
1029 | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
1030 | AnnCast (AnnExpr bndr annot) Coercion
1031 | AnnNote Note (AnnExpr bndr annot)
1034 -- | A clone of the 'Alt' type but allowing annotation at every tree node
1035 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
1037 -- | A clone of the 'Bind' type but allowing annotation at every tree node
1038 data AnnBind bndr annot
1039 = AnnNonRec bndr (AnnExpr bndr annot)
1040 | AnnRec [(bndr, AnnExpr bndr annot)]
1044 deAnnotate :: AnnExpr bndr annot -> Expr bndr
1045 deAnnotate (_, e) = deAnnotate' e
1047 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
1048 deAnnotate' (AnnType t) = Type t
1049 deAnnotate' (AnnVar v) = Var v
1050 deAnnotate' (AnnLit lit) = Lit lit
1051 deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
1052 deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
1053 deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
1054 deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
1056 deAnnotate' (AnnLet bind body)
1057 = Let (deAnnBind bind) (deAnnotate body)
1059 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
1060 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
1062 deAnnotate' (AnnCase scrut v t alts)
1063 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
1065 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
1066 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
1070 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
1071 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
1075 collect bs (_, AnnLam b body) = collect (b:bs) body
1076 collect bs body = (reverse bs, body)