%
\begin{code}
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module CoreSyn (
-- ** 'Expr' construction
mkLets, mkLams,
- mkApps, mkTyApps, mkVarApps,
+ mkApps, mkTyApps, mkCoApps, mkVarApps,
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
- mkConApp, mkTyBind,
+ mkConApp, mkTyBind, mkCoBind,
varToCoreExpr, varsToCoreExprs,
- isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
+ isId, cmpAltCon, cmpAlt, ltAlt,
-- ** Simple 'Expr' access functions and predicates
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, coreExprCc, flattenBinds,
- isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
+ isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+ isRuntimeArg, isRuntimeVar,
+ notSccNote,
-- * Unfolding data types
- Unfolding(..), UnfoldingGuidance(..), InlineRuleInfo(..), InlSatFlag(..),
- -- Abstract everywhere but in CoreUnfold.lhs
-
+ Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
+ DFunArg(..), dfunArgExprs,
+
-- ** Constructing 'Unfolding's
noUnfolding, evaldUnfolding, mkOtherCon,
+ unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
-- ** Predicates and deconstruction on 'Unfolding'
- unfoldingTemplate, setUnfoldingTemplate,
+ unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,
maybeUnfoldingTemplate, otherCons, unfoldingArity,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
- isExpandableUnfolding, isConLikeUnfolding,
- isInlineRule, isInlineRule_maybe, isClosedUnfolding, hasSomeUnfolding,
- isStableUnfolding, canUnfold, neverUnfoldGuidance,
+ isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
+ isStableUnfolding, isStableCoreUnfolding_maybe,
+ isClosedUnfolding, hasSomeUnfolding,
+ canUnfold, neverUnfoldGuidance, isStableSource,
-- * Strictness
seqExpr, seqExprs, seqUnfolding,
-- * Annotated expression data types
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
+ -- ** Operations on annotated expressions
+ collectAnnArgs,
+
-- ** Operations on annotations
deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
-- * Core rule data types
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- RuleName,
+ RuleName, IdUnfoldingFun,
-- ** Operations on 'CoreRule's
- seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
+ seqRules, ruleArity, ruleName, ruleIdName, ruleActivation,
setRuleIdName,
- isBuiltinRule, isLocalRule
+ isBuiltinRule, isLocalRule,
+
+ -- * Core vectorisation declarations data type
+ CoreVect(..)
) where
#include "HsVersions.h"
import Outputable
import Util
+import Data.Data
import Data.Word
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
\end{code}
These data types are the heart of the compiler
\begin{code}
-infixl 8 `App` -- App brackets to the left
-
-- | This is the data type that represents GHCs core intermediate language. Currently
-- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
-- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
-- The type parameter @b@ is for the type of binders in the expression tree.
data Expr b
= Var Id -- ^ Variables
+
| Lit Literal -- ^ Primitive literals
+
| App (Expr b) (Arg b) -- ^ Applications: note that the argument may be a 'Type'.
--
-- See "CoreSyn#let_app_invariant" for another invariant
+
| Lam b (Expr b) -- ^ Lambda abstraction
+
| Let (Bind b) (Expr b) -- ^ Recursive and non recursive @let@s. Operationally
-- this corresponds to allocating a thunk for the things
-- bound and then executing the sub-expression.
-- the meaning of /lifted/ vs. /unlifted/).
--
-- #let_app_invariant#
- -- The right hand side of of a non-recursive 'Let' _and_ the argument of an 'App',
+ -- The right hand side of of a non-recursive 'Let'
+ -- _and_ the argument of an 'App',
-- /may/ be of unlifted type, but only if the expression
- -- is ok-for-speculation. This means that the let can be floated around
- -- without difficulty. For example, this is OK:
+ -- is ok-for-speculation. This means that the let can be floated
+ -- around without difficulty. For example, this is OK:
--
-- > y::Int# = x +# 1#
--
- -- But this is not, as it may affect termination if the expression is floated out:
+ -- But this is not, as it may affect termination if the
+ -- expression is floated out:
--
-- > y::Int# = fac 4#
--
-- At the moment, the rest of the compiler only deals with type-let
-- in a Let expression, rather than at top level. We may want to revist
-- this choice.
+
| Case (Expr b) b Type [Alt b] -- ^ Case split. Operationally this corresponds to evaluating
-- the scrutinee (expression examined) to weak head normal form
-- and then examining at most one level of resulting constructor (i.e. you
-- and the 'Type' must be that of all the case alternatives
--
-- #case_invariants#
- -- This is one of the more complicated elements of the Core language, and comes
- -- with a number of restrictions:
+ -- This is one of the more complicated elements of the Core language,
+ -- and comes with a number of restrictions:
--
- -- The 'DEFAULT' case alternative must be first in the list, if it occurs at all.
+ -- The 'DEFAULT' case alternative must be first in the list,
+ -- if it occurs at all.
--
-- The remaining cases are in order of increasing
-- tag (for 'DataAlts') or
-- lit (for 'LitAlts').
- -- This makes finding the relevant constructor easy, and makes comparison easier too.
+ -- This makes finding the relevant constructor easy,
+ -- and makes comparison easier too.
--
-- The list of alternatives must be exhaustive. An /exhaustive/ case
-- does not necessarily mention all constructors:
-- Blue -> ... ) ...
-- @
--
- -- The inner case does not need a @Red@ alternative, because @x@ can't be @Red@ at
- -- that program point.
- | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type. This is used to implement @newtype@s
- -- (a @newtype@ constructor or destructor just becomes a 'Cast' in Core) and GADTs.
+ -- The inner case does not need a @Red@ alternative, because @x@
+ -- can't be @Red@ at that program point.
+
+ | Cast (Expr b) Coercion -- ^ Cast an expression to a particular type.
+ -- This is used to implement @newtype@s (a @newtype@ constructor or
+ -- destructor just becomes a 'Cast' in Core) and GADTs.
+
| Note Note (Expr b) -- ^ Notes. These allow general information to be
-- added to expressions in the syntax tree
+
| Type Type -- ^ A type: this should only show up at the top
-- level of an Arg
+
+ | Coercion Coercion -- ^ A coercion
+ deriving (Data, Typeable)
-- | Type synonym for expressions that occur in function argument positions.
-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
-- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@
| LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@
| DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Data, Typeable)
-- | Binding, used for top level bindings in a module and local bindings in a @let@.
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
+ deriving (Data, Typeable)
\end{code}
-------------------------- CoreSyn INVARIANTS ---------------------------
data Note
= SCC CostCentre -- ^ A cost centre annotation for profiling
| CoreNote String -- ^ A generic core annotation, propagated but not used by GHC
+ deriving (Data, Typeable)
\end{code}
= Rule {
ru_name :: RuleName, -- ^ Name of the rule, for communication with the user
ru_act :: Activation, -- ^ When the rule is active
-
+
-- Rough-matching stuff
-- see comments with InstEnv.Instance( is_cls, is_rough )
ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule
-- See Note [OccInfo in unfoldings and rules]
-- Locality
+ ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated
+ -- @False@ <=> generated at the users behest
+ -- Main effect: reporting of orphan-hood
+
ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
-- defined in the same module as the rule
-- and is not an implicit 'Id' (like a record selector,
ru_fn :: Name, -- ^ As above
ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes,
-- if it fires, including type arguments
- ru_try :: [CoreExpr] -> Maybe CoreExpr
+ ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
-- ^ This function does the rewrite. It given too many
-- arguments, it simply discards them; the returned 'CoreExpr'
-- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args
}
-- See Note [Extra args in rule matching] in Rules.lhs
+type IdUnfoldingFun = Id -> Unfolding
+-- A function that embodies how to unfold an Id if you need
+-- to do that in the Rule. The reason we need to pass this info in
+-- is that whether an Id is unfoldable depends on the simplifier phase
+
isBuiltinRule :: CoreRule -> Bool
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
ruleName :: CoreRule -> RuleName
ruleName = ru_name
-ruleActivation_maybe :: CoreRule -> Maybe Activation
-ruleActivation_maybe (BuiltinRule { }) = Nothing
-ruleActivation_maybe (Rule { ru_act = act }) = Just act
+ruleActivation :: CoreRule -> Activation
+ruleActivation (BuiltinRule { }) = AlwaysActive
+ruleActivation (Rule { ru_act = act }) = act
-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side
ruleIdName :: CoreRule -> Name
%************************************************************************
+%* *
+\subsection{Vectorisation declarations}
+%* *
+%************************************************************************
+
+Representation of desugared vectorisation declarations that are fed to the vectoriser (via
+'ModGuts').
+
+\begin{code}
+data CoreVect = Vect Id (Maybe CoreExpr)
+\end{code}
+
+
+%************************************************************************
%* *
Unfoldings
%* *
--
-- Here, @f@ gets an @OtherCon []@ unfolding.
- | DFunUnfolding DataCon [CoreExpr]
- -- The Unfolding of a DFunId
+ | DFunUnfolding -- The Unfolding of a DFunId
+ -- See Note [DFun unfoldings]
-- df = /\a1..am. \d1..dn. MkD (op1 a1..am d1..dn)
-- (op2 a1..am d1..dn)
- -- where Arity = n, the number of dict args to the dfun
- -- The [CoreExpr] are the superclasses and methods [op1,op2],
- -- in positional order.
- -- They are usually variables, but can be trivial expressions
- -- instead (e.g. a type application).
-
- | CoreUnfolding { -- An unfolding for an Id with no pragma, or perhaps a NOINLINE pragma
- -- (For NOINLINE, the phase, if any, is in the InlinePragInfo for this Id.)
- uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
- uf_arity :: Arity, -- Number of value arguments expected
+
+ Arity -- Arity = m+n, the *total* number of args
+ -- (unusually, both type and value) to the dfun
+
+ DataCon -- The dictionary data constructor (possibly a newtype datacon)
+
+ [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order
+
+ | CoreUnfolding { -- An unfolding for an Id with no pragma,
+ -- or perhaps a NOINLINE pragma
+ -- (For NOINLINE, the phase, if any, is in the
+ -- InlinePragInfo for this Id.)
+ uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
+ uf_src :: UnfoldingSource, -- Where the unfolding came from
uf_is_top :: Bool, -- True <=> top level binding
- uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard a `seq` on
- -- this variable
- uf_is_conlike :: Bool, -- True <=> application of constructor or CONLIKE function
+ uf_arity :: Arity, -- Number of value arguments expected
+ uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard
+ -- a `seq` on this variable
+ uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function
-- Cached version of exprIsConLike
- uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand inside an inlining
+ uf_is_cheap :: Bool, -- True <=> doesn't waste (much) work to expand
+ -- inside an inlining
-- Cached version of exprIsCheap
uf_expandable :: Bool, -- True <=> can expand in RULE matching
-- Cached version of exprIsExpandable
-- uf_guidance: Tells us about the /size/ of the unfolding template
------------------------------------------------
+data DFunArg e -- Given (df a b d1 d2 d3)
+ = DFunPolyArg e -- Arg is (e a b d1 d2 d3)
+ | DFunConstArg e -- Arg is e, which is constant
+ | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed
+ deriving( Functor )
+
+ -- 'e' is often CoreExpr, which are usually variables, but can
+ -- be trivial expressions instead (e.g. a type application).
+
+dfunArgExprs :: [DFunArg e] -> [e]
+dfunArgExprs [] = []
+dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as
+dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as
+dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as
+
+
+------------------------------------------------
+data UnfoldingSource
+ = InlineRhs -- The current rhs of the function
+ -- Replace uf_tmpl each time around
+
+ | InlineStable -- From an INLINE or INLINABLE pragma
+ -- INLINE if guidance is UnfWhen
+ -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever
+ -- (well, technically an INLINABLE might be made
+ -- UnfWhen if it was small enough, and then
+ -- it will behave like INLINE outside the current
+ -- module, but that is the way automatic unfoldings
+ -- work so it is consistent with the intended
+ -- meaning of INLINABLE).
+ --
+ -- uf_tmpl may change, but only as a result of
+ -- gentle simplification, it doesn't get updated
+ -- to the current RHS during compilation as with
+ -- InlineRhs.
+ --
+ -- See Note [InlineRules]
+
+ | InlineCompulsory -- Something that *has* no binding, so you *must* inline it
+ -- Only a few primop-like things have this property
+ -- (see MkId.lhs, calls to mkCompulsoryUnfolding).
+ -- Inline absolutely always, however boring the context.
+
+ | InlineWrapper Id -- This unfolding is a the wrapper in a
+ -- worker/wrapper split from the strictness analyser
+ -- The Id is the worker-id
+ -- Used to abbreviate the uf_tmpl in interface files
+ -- which don't need to contain the RHS;
+ -- it can be derived from the strictness info
+
+
+
-- | 'UnfoldingGuidance' says when unfolding should take place
data UnfoldingGuidance
- = InlineRule { -- Be very keen to inline this; See Note [InlineRules]
- -- The uf_tmpl is the *original* RHS; do *not* replace it on
- -- each simlifier run. Hence, the *actual* RHS of the function
- -- may be different by now, because it may have been optimised.
-
- ir_sat :: InlSatFlag,
- ir_info :: InlineRuleInfo
+ = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl
+ -- Used (a) for small *and* cheap unfoldings
+ -- (b) for INLINE functions
+ -- See Note [INLINE for small functions] in CoreUnfold
+ ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated
+ ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring
+ -- So True,True means "always"
}
- | UnfoldIfGoodArgs { -- Arose from a normal Id; the info here is the
+ | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the
-- result of a simple analysis of the RHS
ug_args :: [Int], -- Discount if the argument is evaluated.
} -- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
- | UnfoldNever -- A variant of UnfoldIfGoodArgs, used for big RHSs
+ | UnfNever -- The RHS is big, so don't inline it
+\end{code}
+
-data InlineRuleInfo
- = InlAlways -- Inline absolutely always, however boring the context.
- -- There is /no original definition/. Only a few primop-like things
- -- have this property (see MkId.lhs, calls to mkCompulsoryUnfolding).
+Note [DFun unfoldings]
+~~~~~~~~~~~~~~~~~~~~~~
+The Arity in a DFunUnfolding is total number of args (type and value)
+that the DFun needs to produce a dictionary. That's not necessarily
+related to the ordinary arity of the dfun Id, esp if the class has
+one method, so the dictionary is represented by a newtype. Example
- | InlSmall -- The RHS is very small (eg no bigger than a call), so inline any
- -- /saturated/ application, regardless of context
- -- See Note [INLINE for small functions] in CoreUnfold
+ class C a where { op :: a -> Int }
+ instance C a -> C [a] where op xs = op (head xs)
- | InlVanilla
+The instance translates to
- | InlWrapper Id -- This unfolding is a the wrapper in a
- -- worker/wrapper split from the strictness analyser
- -- Used to abbreviate the uf_tmpl in interface files
- -- which don't need to contain the RHS;
- -- it can be derived from the strictness info
- -- [In principle this is orthogonal to the InlSmall/InVanilla thing,
- -- but it's convenient to have it here.]
+ $dfCList :: forall a. C a => C [a] -- Arity 2!
+ $dfCList = /\a.\d. $copList {a} d |> co
+
+ $copList :: forall a. C a => [a] -> Int -- Arity 2!
+ $copList = /\a.\d.\xs. op {a} d (head xs)
-data InlSatFlag = InlSat | InlUnSat
- -- Specifies whether to INLINE only if the thing is applied to 'arity' args
+Now we might encounter (op (dfCList {ty} d) a1 a2)
+and we want the (op (dfList {ty} d)) rule to fire, because $dfCList
+has all its arguments, even though its (value) arity is 2. That's
+why we record the number of expected arguments in the DFunUnfolding.
+
+Note that although it's an Arity, it's most convenient for it to give
+the *total* number of arguments, both type and value. See the use
+site in exprIsConApp_maybe.
+
+\begin{code}
+-- Constants for the UnfWhen constructor
+needSaturated, unSaturatedOk :: Bool
+needSaturated = False
+unSaturatedOk = True
+
+boringCxtNotOk, boringCxtOk :: Bool
+boringCxtOk = True
+boringCxtNotOk = False
------------------------------------------------
noUnfolding :: Unfolding
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
-seqGuidance (UnfoldIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
-seqGuidance _ = ()
+seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
+seqGuidance _ = ()
\end{code}
\begin{code}
+isStableSource :: UnfoldingSource -> Bool
+-- Keep the unfolding template
+isStableSource InlineCompulsory = True
+isStableSource InlineStable = True
+isStableSource (InlineWrapper {}) = True
+isStableSource InlineRhs = False
+
-- | Retrieves the template of an unfolding: panics if none is known
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
isExpandableUnfolding _ = False
-isInlineRule :: Unfolding -> Bool
-isInlineRule (CoreUnfolding { uf_guidance = InlineRule {}}) = True
-isInlineRule _ = False
+expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
+-- Expand an expandable unfolding; this is used in rule matching
+-- See Note [Expanding variables] in Rules.lhs
+-- The key point here is that CONLIKE things can be expanded
+expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
+expandUnfolding_maybe _ = Nothing
+
+isStableCoreUnfolding_maybe :: Unfolding -> Maybe UnfoldingSource
+isStableCoreUnfolding_maybe (CoreUnfolding { uf_src = src })
+ | isStableSource src = Just src
+isStableCoreUnfolding_maybe _ = Nothing
-isInlineRule_maybe :: Unfolding -> Maybe (InlineRuleInfo, InlSatFlag)
-isInlineRule_maybe (CoreUnfolding { uf_guidance =
- InlineRule { ir_info = inl, ir_sat = sat } }) = Just (inl,sat)
-isInlineRule_maybe _ = Nothing
+isCompulsoryUnfolding :: Unfolding -> Bool
+isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
+isCompulsoryUnfolding _ = False
isStableUnfolding :: Unfolding -> Bool
-- True of unfoldings that should not be overwritten
-- by a CoreUnfolding for the RHS of a let-binding
-isStableUnfolding (CoreUnfolding { uf_guidance = InlineRule {} }) = True
-isStableUnfolding (DFunUnfolding {}) = True
-isStableUnfolding _ = False
+isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
+isStableUnfolding (DFunUnfolding {}) = True
+isStableUnfolding _ = False
unfoldingArity :: Unfolding -> Arity
unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
isClosedUnfolding :: Unfolding -> Bool -- No free variables
isClosedUnfolding (CoreUnfolding {}) = False
+isClosedUnfolding (DFunUnfolding {}) = False
isClosedUnfolding _ = True
-- | Only returns False if there is no unfolding information available at all
hasSomeUnfolding _ = True
neverUnfoldGuidance :: UnfoldingGuidance -> Bool
-neverUnfoldGuidance UnfoldNever = True
-neverUnfoldGuidance _ = False
+neverUnfoldGuidance UnfNever = True
+neverUnfoldGuidance _ = False
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
canUnfold _ = False
\end{code}
-Note [InlineRule]
+Note [InlineRules]
~~~~~~~~~~~~~~~~~
When you say
{-# INLINE f #-}
you intend that calls (f e) are replaced by <rhs>[e/x] So we
should capture (\x.<rhs>) in the Unfolding of 'f', and never meddle
with it. Meanwhile, we can optimise <rhs> to our heart's content,
-leaving the original unfolding intact in Unfolding of 'f'.
+leaving the original unfolding intact in Unfolding of 'f'. For example
+ all xs = foldr (&&) True xs
+ any p = all . map p {-# INLINE any #-}
+We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
+which deforests well at the call site.
-So the representation of an Unfolding has changed quite a bit
-(see CoreSyn). An INLINE pragma gives rise to an InlineRule
-unfolding.
+So INLINE pragma gives rise to an InlineRule, which captures the original RHS.
Moreover, it's only used when 'f' is applied to the
specified number of arguments; that is, the number of argument on
mkApps :: Expr b -> [Arg b] -> Expr b
-- | Apply a list of type argument expressions to a function expression in a nested fashion
mkTyApps :: Expr b -> [Type] -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps :: Expr b -> [Coercion] -> Expr b
-- | Apply a list of type or value variables to a function expression in a nested fashion
mkVarApps :: Expr b -> [Var] -> Expr b
-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
+mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkTyBind :: TyVar -> Type -> CoreBind
mkTyBind tv ty = NonRec tv (Type ty)
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co = NonRec cv (Coercion co)
+
-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v = Var v
- | otherwise = Type (mkTyVarTy v)
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+ | isCoVar v = Coercion (mkCoVarCo v)
+ | otherwise = ASSERT( isId v ) Var v
varsToCoreExprs :: [CoreBndr] -> [Expr b]
varsToCoreExprs vs = map varToCoreExpr vs
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg = isValArg
--- | Returns @False@ iff the expression is a 'Type' expression at its top level
+-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
isValArg :: Expr b -> Bool
-isValArg (Type _) = False
-isValArg _ = True
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {}) = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _ = False
--- | Returns @True@ iff the expression is a 'Type' expression at its top level
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level. Note this does NOT include 'Coercion's.
isTypeArg :: Expr b -> Bool
-isTypeArg (Type _) = True
-isTypeArg _ = False
+isTypeArg (Type {}) = True
+isTypeArg _ = False
-- | The number of binders that bind values rather than types
valBndrCount :: [CoreBndr] -> Int
-- | The number of argument expressions that are values rather than types at their top level
valArgCount :: [Arg b] -> Int
valArgCount = count isValArg
+
+notSccNote :: Note -> Bool
+notSccNote (SCC {}) = False
+notSccNote _ = True
\end{code}
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
-seqExpr (Cast e co) = seqExpr e `seq` seqType co
+seqExpr (Cast e co) = seqExpr e `seq` seqCo co
seqExpr (Note n e) = seqNote n `seq` seqExpr e
-seqExpr (Type t) = seqType t
+seqExpr (Type t) = seqType t
+seqExpr (Coercion co) = seqCo co
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
| AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
- | AnnCast (AnnExpr bndr annot) Coercion
+ | AnnCast (AnnExpr bndr annot) (annot, Coercion)
+ -- Put an annotation on the (root of) the coercion
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
+ | AnnCoercion Coercion
-- | A clone of the 'Alt' type but allowing annotation at every tree node
type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
\end{code}
\begin{code}
+-- | Takes a nested application expression and returns the the function
+-- being applied and the arguments to which it is applied
+collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a])
+collectAnnArgs expr
+ = go expr []
+ where
+ go (_, AnnApp f a) as = go f (a:as)
+ go e as = (e, as)
+\end{code}
+
+\begin{code}
deAnnotate :: AnnExpr bndr annot -> Expr bndr
deAnnotate (_, e) = deAnnotate' e
deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
-deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnType t) = Type t
+deAnnotate' (AnnCoercion co) = Coercion co
deAnnotate' (AnnVar v) = Var v
deAnnotate' (AnnLit lit) = Lit lit
deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body)
deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co
+deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co
deAnnotate' (AnnNote note body) = Note note (deAnnotate body)
deAnnotate' (AnnLet bind body)
projects / ghc-hetmet.git / blobdiff