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(..), -- Both abstract everywhere but in CoreUnfold.lhs
40 -- ** Constructing 'Unfolding's
41 noUnfolding, evaldUnfolding, mkOtherCon,
43 -- ** Predicates and deconstruction on 'Unfolding'
44 unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
45 isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
46 isExpandableUnfolding, isCompulsoryUnfolding,
47 hasUnfolding, hasSomeUnfolding, neverUnfold,
50 seqExpr, seqExprs, seqUnfolding,
52 -- * Annotated expression data types
53 AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
55 -- ** Operations on annotations
56 deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
58 -- * Core rule data types
59 CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
62 -- ** Operations on 'CoreRule's
63 seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
65 isBuiltinRule, isLocalRule
68 #include "HsVersions.h"
84 infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
85 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
88 %************************************************************************
90 \subsection{The main data types}
92 %************************************************************************
94 These data types are the heart of the compiler
97 infixl 8 `App` -- App brackets to the left
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>.
103 -- We get from Haskell source to this Core language in a number of stages:
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'
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:
113 -- f x = let f x = x + 1
117 -- Would be renamed by having 'Unique's attached so it looked something like this:
120 -- f_1 x_2 = let f_3 x_4 = x_4 + 1
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.
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.
131 -- The type parameter @b@ is for the type of binders in the expression tree.
133 = Var Id -- ^ Variables
134 | Lit Literal -- ^ Primitive literals
135 | App (Expr b) (Arg b) -- ^ Applications: note that the argument may be a 'Type'.
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.
143 -- #top_level_invariant#
144 -- #letrec_invariant#
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/).
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:
156 -- > y::Int# = x +# 1#
158 -- But this is not, as it may affect termination if the expression is floated out:
160 -- > y::Int# = fac 4#
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
168 -- We allow a /non-recursive/ let to bind a type variable, thus:
170 -- > Let (NonRec tv (Type ty)) body
172 -- This can be very convenient for postponing type substitutions until
173 -- the next run of the simplifier.
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
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).
183 -- The binder gets bound to the value of the scrutinee,
184 -- and the 'Type' must be that of all the case alternatives
187 -- This is one of the more complicated elements of the Core language, and comes
188 -- with a number of restrictions:
190 -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all.
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.
197 -- The list of alternatives must be exhaustive. An /exhaustive/ case
198 -- does not necessarily mention all constructors:
201 -- data Foo = Red | Green | Blue
204 -- other -> f (case x of
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
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
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)
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 { _ -> ... }@
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))]
239 -------------------------- CoreSyn INVARIANTS ---------------------------
241 Note [CoreSyn top-level invariant]
242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
243 See #toplevel_invariant#
245 Note [CoreSyn letrec invariant]
246 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
247 See #letrec_invariant#
249 Note [CoreSyn let/app invariant]
250 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
251 See #let_app_invariant#
253 This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
255 Note [CoreSyn case invariants]
256 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
257 See #case_invariants#
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
272 -- | Allows attaching extra information to points in expressions rather than e.g. identifiers.
274 = SCC CostCentre -- ^ A cost centre annotation for profiling
276 | InlineMe -- ^ Instructs the core simplifer to treat the enclosed expression
277 -- as very small, and inline it at its call sites
279 | CoreNote String -- ^ A generic core annotation, propagated but not used by GHC
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:
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.
293 %************************************************************************
295 \subsection{Transformation rules}
297 %************************************************************************
299 The CoreRule type and its friends are dealt with mainly in CoreRules,
300 but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
303 -- | A 'CoreRule' is:
305 -- * \"Local\" if the function it is a rule for is defined in the
306 -- same module as the rule itself.
308 -- * \"Orphan\" if nothing on the LHS is defined in the same module
309 -- as the rule itself
312 ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
313 ru_act :: Activation, -- ^ When the rule is active
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
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
325 -- And the right-hand side
326 ru_rhs :: CoreExpr, -- ^ Right hand side of the rule
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)
334 -- NB: ru_local is *not* used to decide orphan-hood
335 -- c.g. MkIface.coreRuleToIfaceRule
338 -- | Built-in rules are used for constant folding
339 -- and suchlike. They have no free variables.
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
350 -- See Note [Extra args in rule matching] in Rules.lhs
352 isBuiltinRule :: CoreRule -> Bool
353 isBuiltinRule (BuiltinRule {}) = True
354 isBuiltinRule _ = False
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
362 ruleName :: CoreRule -> RuleName
365 ruleActivation_maybe :: CoreRule -> Maybe Activation
366 ruleActivation_maybe (BuiltinRule { }) = Nothing
367 ruleActivation_maybe (Rule { ru_act = act }) = Just act
369 -- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
370 ruleIdName :: CoreRule -> Name
373 isLocalRule :: CoreRule -> Bool
374 isLocalRule = ru_local
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 }
382 %************************************************************************
386 %************************************************************************
388 The @Unfolding@ type is declared here to avoid numerous loops
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"
395 = NoUnfolding -- ^ We have no information about the unfolding
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:
403 -- > data C = C !(Int -> Int)
404 -- > case x of { C f -> ... }
406 -- Here, @f@ gets an @OtherCon []@ unfolding.
408 | CompulsoryUnfolding CoreExpr -- ^ There is /no original definition/,
409 -- so you'd better unfold.
418 -- ^ An unfolding with redundant cached information. Parameters:
420 -- 1) Template used to perform unfolding; binder-info is correct
422 -- 2) Is this a top level binding?
424 -- 3) 'exprIsHNF' template (cached); it is ok to discard a 'seq' on
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'
430 -- 5) Tells us about the /size/ of the unfolding template
432 -- | When unfolding should take place
433 data UnfoldingGuidance
435 | UnfoldIfGoodArgs Int -- and "n" value args
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.
441 Int -- The "size" of the unfolding; to be elaborated
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.)
448 noUnfolding :: Unfolding
449 -- ^ There is no known 'Unfolding'
450 evaldUnfolding :: Unfolding
451 -- ^ This unfolding marks the associated thing as being evaluated
453 noUnfolding = NoUnfolding
454 evaldUnfolding = OtherCon []
456 mkOtherCon :: [AltCon] -> Unfolding
457 mkOtherCon = OtherCon
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
464 seqGuidance :: UnfoldingGuidance -> ()
465 seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
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"
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
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
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
494 -- | Determines if it possibly the case that the unfolding will
495 -- yield a value. Unlike 'isValueUnfolding' it returns @True@
497 isEvaldUnfolding :: Unfolding -> Bool
498 isEvaldUnfolding (OtherCon _) = True
499 isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
500 isEvaldUnfolding _ = False
502 -- | Is the thing we will unfold into certainly cheap?
503 isCheapUnfolding :: Unfolding -> Bool
504 isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
505 isCheapUnfolding _ = False
507 isExpandableUnfolding :: Unfolding -> Bool
508 isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
509 isExpandableUnfolding _ = False
511 -- | Must this unfolding happen for the code to be executable?
512 isCompulsoryUnfolding :: Unfolding -> Bool
513 isCompulsoryUnfolding (CompulsoryUnfolding _) = True
514 isCompulsoryUnfolding _ = False
516 -- | Do we have an available or compulsory unfolding?
517 hasUnfolding :: Unfolding -> Bool
518 hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
519 hasUnfolding (CompulsoryUnfolding _) = True
520 hasUnfolding _ = False
522 -- | Only returns False if there is no unfolding information available at all
523 hasSomeUnfolding :: Unfolding -> Bool
524 hasSomeUnfolding NoUnfolding = False
525 hasSomeUnfolding _ = True
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
537 %************************************************************************
539 \subsection{The main data type}
541 %************************************************************************
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
549 instance Outputable AltCon where
550 ppr (DataAlt dc) = ppr dc
551 ppr (LitAlt lit) = ppr lit
552 ppr DEFAULT = ptext (sLit "__DEFAULT")
554 instance Show AltCon where
555 showsPrec p con = showsPrecSDoc p (ppr con)
557 cmpAlt :: Alt b -> Alt b -> Ordering
558 cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
560 ltAlt :: Alt b -> Alt b -> Bool
561 ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
563 cmpAltCon :: AltCon -> AltCon -> Ordering
564 -- ^ Compares 'AltCon's within a single list of alternatives
565 cmpAltCon DEFAULT DEFAULT = EQ
566 cmpAltCon DEFAULT _ = LT
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
573 cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
574 ppr con1 <+> ppr con2 )
578 %************************************************************************
580 \subsection{Useful synonyms}
582 %************************************************************************
585 -- | The common case for the type of binders and variables when
586 -- we are manipulating the Core language within GHC
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
598 %************************************************************************
602 %************************************************************************
605 -- | Binders are /tagged/ with a t
606 data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
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)
613 instance Outputable b => Outputable (TaggedBndr b) where
614 ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
616 instance Outputable b => OutputableBndr (TaggedBndr b) where
617 pprBndr _ b = ppr b -- Simple
621 %************************************************************************
623 \subsection{Core-constructing functions with checking}
625 %************************************************************************
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
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
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
652 mkIntLit n = Lit (mkMachInt n)
653 mkIntLitInt n = Lit (mkMachInt (toInteger n))
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
662 mkWordLit w = Lit (mkMachWord w)
663 mkWordLitWord w = Lit (mkMachWord (toInteger w))
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
672 mkCharLit c = Lit (mkMachChar c)
673 mkStringLit s = Lit (mkMachString s)
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
682 mkFloatLit f = Lit (mkMachFloat f)
683 mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
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
692 mkDoubleLit d = Lit (mkMachDouble d)
693 mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
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
702 mkLams binders body = foldr Lam body binders
703 mkLets binds body = foldr Let body binds
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)
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)
716 varsToCoreExprs :: [CoreBndr] -> [Expr b]
717 varsToCoreExprs vs = map varToCoreExpr vs
721 %************************************************************************
723 \subsection{Simple access functions}
725 %************************************************************************
728 -- | Extract every variable by this group
729 bindersOf :: Bind b -> [b]
730 bindersOf (NonRec binder _) = [binder]
731 bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
733 -- | 'bindersOf' applied to a list of binding groups
734 bindersOfBinds :: [Bind b] -> [b]
735 bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
737 rhssOfBind :: Bind b -> [Expr b]
738 rhssOfBind (NonRec _ rhs) = [rhs]
739 rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
741 rhssOfAlts :: [Alt b] -> [Expr b]
742 rhssOfAlts alts = [e | (_,_,e) <- alts]
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
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)
768 go bs (Lam b e) = go (b:bs) e
769 go bs e = (reverse bs, e)
771 collectTyAndValBinders expr
774 (tvs, body1) = collectTyBinders expr
775 (ids, body) = collectValBinders body1
777 collectTyBinders expr
780 go tvs (Lam b e) | isTyVar b = go (b:tvs) e
781 go tvs e = (reverse tvs, e)
783 collectValBinders expr
786 go ids (Lam b e) | isId b = go (b:ids) e
787 go ids body = (reverse ids, body)
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])
797 go (App f a) as = go f (a:as)
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
811 %************************************************************************
813 \subsection{Predicates}
815 %************************************************************************
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.
823 -- | Will this variable exist at runtime?
824 isRuntimeVar :: Var -> Bool
827 -- | Will this argument expression exist at runtime?
828 isRuntimeArg :: CoreExpr -> Bool
829 isRuntimeArg = isValArg
831 -- | Returns @False@ iff the expression is a 'Type' expression at its top level
832 isValArg :: Expr b -> Bool
833 isValArg (Type _) = False
836 -- | Returns @True@ iff the expression is a 'Type' expression at its top level
837 isTypeArg :: Expr b -> Bool
838 isTypeArg (Type _) = True
841 -- | The number of binders that bind values rather than types
842 valBndrCount :: [CoreBndr] -> Int
843 valBndrCount = count isId
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
851 %************************************************************************
853 \subsection{Seq stuff}
855 %************************************************************************
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
869 seqExprs :: [CoreExpr] -> ()
871 seqExprs (e:es) = seqExpr e `seq` seqExprs es
873 seqNote :: Note -> ()
874 seqNote (CoreNote s) = s `seq` ()
877 seqBndr :: CoreBndr -> ()
878 seqBndr b = b `seq` ()
880 seqBndrs :: [CoreBndr] -> ()
882 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
884 seqBind :: Bind CoreBndr -> ()
885 seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
886 seqBind (Rec prs) = seqPairs prs
888 seqPairs :: [(CoreBndr, CoreExpr)] -> ()
890 seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
892 seqAlts :: [CoreAlt] -> ()
894 seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
896 seqRules :: [CoreRule] -> ()
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
903 %************************************************************************
905 \subsection{Annotated core}
907 %************************************************************************
910 -- | Annotated core: allows annotation at every node in the tree
911 type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
913 -- | A clone of the 'Expr' type but allowing annotation at every tree node
914 data AnnExpr' bndr annot
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)
925 -- | A clone of the 'Alt' type but allowing annotation at every tree node
926 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
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)]
935 deAnnotate :: AnnExpr bndr annot -> Expr bndr
936 deAnnotate (_, e) = deAnnotate' e
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)
947 deAnnotate' (AnnLet bind body)
948 = Let (deAnnBind bind) (deAnnotate body)
950 deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
951 deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
953 deAnnotate' (AnnCase scrut v t alts)
954 = Case (deAnnotate scrut) v t (map deAnnAlt alts)
956 deAnnAlt :: AnnAlt bndr annot -> Alt bndr
957 deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
961 -- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
962 collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
966 collect bs (_, AnnLam b body) = collect (b:bs) body
967 collect bs body = (reverse bs, body)