%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
\begin{code}
module CoreSyn (
Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
mkLets, mkLams,
mkApps, mkTyApps, mkVarApps,
mkIntLit, mkIntLitInt,
mkWordLit, mkWordLitWord,
mkCharLit, mkStringLit,
mkFloatLit, mkFloatLitFloat,
mkDoubleLit, mkDoubleLitDouble,
mkConApp, mkTyBind,
varToCoreExpr, varsToCoreExprs,
isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, coreExprCc, flattenBinds,
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
notSccNote,
Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..),
noUnfolding, evaldUnfolding, mkOtherCon,
unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,
unfoldingTemplate, setUnfoldingTemplate, expandUnfolding_maybe,
maybeUnfoldingTemplate, otherCons, unfoldingArity,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,
isStableUnfolding, isStableUnfolding_maybe,
isClosedUnfolding, hasSomeUnfolding,
canUnfold, neverUnfoldGuidance, isStableSource,
seqExpr, seqExprs, seqUnfolding,
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
collectAnnArgs,
deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
CoreRule(..),
RuleName, IdUnfoldingFun,
seqRules, ruleArity, ruleName, ruleIdName, ruleActivation_maybe,
setRuleIdName,
isBuiltinRule, isLocalRule
) where
#include "HsVersions.h"
import CostCentre
import Var
import Type
import Coercion
import Name
import Literal
import DataCon
import BasicTypes
import FastString
import Outputable
import Util
import Data.Data
import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
\end{code}
%************************************************************************
%* *
\subsection{The main data types}
%* *
%************************************************************************
These data types are the heart of the compiler
\begin{code}
data Expr b
= Var Id
| Lit Literal
| App (Expr b) (Arg b)
| Lam b (Expr b)
| Let (Bind b) (Expr b)
| Case (Expr b) b Type [Alt b]
| Cast (Expr b) Coercion
| Note Note (Expr b)
| Type Type
deriving (Data, Typeable)
type Arg b = Expr b
type Alt b = (AltCon, [b], Expr b)
data AltCon = DataAlt DataCon
| LitAlt Literal
| DEFAULT
deriving (Eq, Ord, Data, Typeable)
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
deriving (Data, Typeable)
\end{code}
Note [CoreSyn toplevel invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #toplevel_invariant#
Note [CoreSyn letrec invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #letrec_invariant#
Note [CoreSyn let/app invariant]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #let_app_invariant#
This is intially enforced by DsUtils.mkCoreLet and mkCoreApp
Note [CoreSyn case invariants]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See #case_invariants#
Note [CoreSyn let goal]
~~~~~~~~~~~~~~~~~~~~~~~
* The simplifier tries to ensure that if the RHS of a let is a constructor
application, its arguments are trivial, so that the constructor can be
inlined vigorously.
Note [Type let]
~~~~~~~~~~~~~~~
See #type_let#
\begin{code}
data Note
= SCC CostCentre
| CoreNote String
deriving (Data, Typeable)
\end{code}
%************************************************************************
%* *
\subsection{Transformation rules}
%* *
%************************************************************************
The CoreRule type and its friends are dealt with mainly in CoreRules,
but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
\begin{code}
data CoreRule
= Rule {
ru_name :: RuleName,
ru_act :: Activation,
ru_fn :: Name,
ru_rough :: [Maybe Name],
ru_bndrs :: [CoreBndr],
ru_args :: [CoreExpr],
ru_rhs :: CoreExpr,
ru_auto :: Bool,
ru_local :: Bool
}
| BuiltinRule {
ru_name :: RuleName,
ru_fn :: Name,
ru_nargs :: Int,
ru_try :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
}
type IdUnfoldingFun = Id -> Unfolding
isBuiltinRule :: CoreRule -> Bool
isBuiltinRule (BuiltinRule {}) = True
isBuiltinRule _ = False
ruleArity :: CoreRule -> Int
ruleArity (BuiltinRule {ru_nargs = n}) = n
ruleArity (Rule {ru_args = args}) = length args
ruleName :: CoreRule -> RuleName
ruleName = ru_name
ruleActivation_maybe :: CoreRule -> Maybe Activation
ruleActivation_maybe (BuiltinRule { }) = Nothing
ruleActivation_maybe (Rule { ru_act = act }) = Just act
ruleIdName :: CoreRule -> Name
ruleIdName = ru_fn
isLocalRule :: CoreRule -> Bool
isLocalRule = ru_local
setRuleIdName :: Name -> CoreRule -> CoreRule
setRuleIdName nm ru = ru { ru_fn = nm }
\end{code}
%************************************************************************
%* *
Unfoldings
%* *
%************************************************************************
The @Unfolding@ type is declared here to avoid numerous loops
\begin{code}
data Unfolding
= NoUnfolding
| OtherCon [AltCon]
| DFunUnfolding
Arity
DataCon
[CoreExpr]
| CoreUnfolding {
uf_tmpl :: CoreExpr,
uf_src :: UnfoldingSource,
uf_is_top :: Bool,
uf_arity :: Arity,
uf_is_value :: Bool,
uf_is_conlike :: Bool,
uf_is_cheap :: Bool,
uf_expandable :: Bool,
uf_guidance :: UnfoldingGuidance
}
data UnfoldingSource
= InlineRhs
| InlineStable
| InlineCompulsory
| InlineWrapper Id
data UnfoldingGuidance
= UnfWhen {
ug_unsat_ok :: Bool,
ug_boring_ok :: Bool
}
| UnfIfGoodArgs {
ug_args :: [Int],
ug_size :: Int,
ug_res :: Int
}
| UnfNever
\end{code}
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
class C a where { op :: a -> Int }
instance C a -> C [a] where op xs = op (head xs)
The instance translates to
$dfCList :: forall a. C a => C [a]
$dfCList = /\a.\d. $copList {a} d |> co
$copList :: forall a. C a => [a] -> Int
$copList = /\a.\d.\xs. op {a} d (head xs)
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}
needSaturated, unSaturatedOk :: Bool
needSaturated = False
unSaturatedOk = True
boringCxtNotOk, boringCxtOk :: Bool
boringCxtOk = True
boringCxtNotOk = False
noUnfolding :: Unfolding
evaldUnfolding :: Unfolding
noUnfolding = NoUnfolding
evaldUnfolding = OtherCon []
mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,
uf_is_value = b1, uf_is_cheap = b2,
uf_expandable = b3, uf_is_conlike = b4,
uf_arity = a, uf_guidance = g})
= seqExpr e `seq` top `seq` b1 `seq` a `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` ()
seqGuidance _ = ()
\end{code}
\begin{code}
isStableSource :: UnfoldingSource -> Bool
isStableSource InlineCompulsory = True
isStableSource InlineStable = True
isStableSource (InlineWrapper {}) = True
isStableSource InlineRhs = False
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate = uf_tmpl
setUnfoldingTemplate :: Unfolding -> CoreExpr -> Unfolding
setUnfoldingTemplate unf rhs = unf { uf_tmpl = rhs }
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) = Just expr
maybeUnfoldingTemplate _ = Nothing
otherCons :: Unfolding -> [AltCon]
otherCons (OtherCon cons) = cons
otherCons _ = []
isValueUnfolding :: Unfolding -> Bool
isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
isValueUnfolding _ = False
isEvaldUnfolding :: Unfolding -> Bool
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald
isEvaldUnfolding _ = False
isConLikeUnfolding :: Unfolding -> Bool
isConLikeUnfolding (OtherCon _) = True
isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con
isConLikeUnfolding _ = False
isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding { uf_is_cheap = is_cheap }) = is_cheap
isCheapUnfolding _ = False
isExpandableUnfolding :: Unfolding -> Bool
isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable
isExpandableUnfolding _ = False
expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr
expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs
expandUnfolding_maybe _ = Nothing
isStableUnfolding_maybe :: Unfolding -> Maybe (UnfoldingSource, Bool)
isStableUnfolding_maybe (CoreUnfolding { uf_src = src, uf_guidance = guide })
| isStableSource src
= Just (src, unsat_ok)
where
unsat_ok = case guide of
UnfWhen unsat_ok _ -> unsat_ok
_ -> needSaturated
isStableUnfolding_maybe _ = Nothing
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True
isCompulsoryUnfolding _ = False
isStableUnfolding :: Unfolding -> Bool
isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src
isStableUnfolding (DFunUnfolding {}) = True
isStableUnfolding _ = False
unfoldingArity :: Unfolding -> Arity
unfoldingArity (CoreUnfolding { uf_arity = arity }) = arity
unfoldingArity _ = panic "unfoldingArity"
isClosedUnfolding :: Unfolding -> Bool
isClosedUnfolding (CoreUnfolding {}) = False
isClosedUnfolding (DFunUnfolding {}) = False
isClosedUnfolding _ = True
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding _ = True
neverUnfoldGuidance :: UnfoldingGuidance -> Bool
neverUnfoldGuidance UnfNever = True
neverUnfoldGuidance _ = False
canUnfold :: Unfolding -> Bool
canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g)
canUnfold _ = False
\end{code}
Note [InlineRules]
~~~~~~~~~~~~~~~~~
When you say
f x = <rhs>
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'. For example
all xs = foldr (&&) True xs
any p = all . map p
We optimise any's RHS fully, but leave the InlineRule saying "all . map p",
which deforests well at the call site.
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
the LHS of the '=' sign in the original source definition.
For example, (.) is now defined in the libraries like this
(.) f g = \x -> f (g x)
so that it'll inline when applied to two arguments. If 'x' appeared
on the left, thus
(.) f g x = f (g x)
it'd only inline when applied to three arguments. This slightlyexperimental
change was requested by Roman, but it seems to make sense.
See also Note [Inlining an InlineRule] in CoreUnfold.
Note [OccInfo in unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In unfoldings and rules, we guarantee that the template is occanalysed,
so that the occurence info on the binders is correct. This is important,
because the Simplifier does not reanalyse the template when using it. If
the occurrence info is wrong
We may get more simpifier iterations than necessary, because
onceocc info isn't there
More seriously, we may get an infinite loop if there's a Rec
without a loop breaker marked
%************************************************************************
%* *
\subsection{The main data type}
%* *
%************************************************************************
\begin{code}
instance Outputable AltCon where
ppr (DataAlt dc) = ppr dc
ppr (LitAlt lit) = ppr lit
ppr DEFAULT = ptext (sLit "__DEFAULT")
instance Show AltCon where
showsPrec p con = showsPrecSDoc p (ppr con)
cmpAlt :: Alt b -> Alt b -> Ordering
cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2
ltAlt :: Alt b -> Alt b -> Bool
ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT
cmpAltCon :: AltCon -> AltCon -> Ordering
cmpAltCon DEFAULT DEFAULT = EQ
cmpAltCon DEFAULT _ = LT
cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2
cmpAltCon (DataAlt _) DEFAULT = GT
cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
cmpAltCon (LitAlt _) DEFAULT = GT
cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
ppr con1 <+> ppr con2 )
LT
\end{code}
%************************************************************************
%* *
\subsection{Useful synonyms}
%* *
%************************************************************************
\begin{code}
type CoreBndr = Var
type CoreExpr = Expr CoreBndr
type CoreArg = Arg CoreBndr
type CoreBind = Bind CoreBndr
type CoreAlt = Alt CoreBndr
\end{code}
%************************************************************************
%* *
\subsection{Tagging}
%* *
%************************************************************************
\begin{code}
data TaggedBndr t = TB CoreBndr t
type TaggedBind t = Bind (TaggedBndr t)
type TaggedExpr t = Expr (TaggedBndr t)
type TaggedArg t = Arg (TaggedBndr t)
type TaggedAlt t = Alt (TaggedBndr t)
instance Outputable b => Outputable (TaggedBndr b) where
ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b
\end{code}
%************************************************************************
%* *
\subsection{Coreconstructing functions with checking}
%* *
%************************************************************************
\begin{code}
mkApps :: Expr b -> [Arg b] -> Expr b
mkTyApps :: Expr b -> [Type] -> Expr b
mkVarApps :: Expr b -> [Var] -> Expr b
mkConApp :: DataCon -> [Arg b] -> Expr b
mkApps f args = foldl App f args
mkTyApps f args = foldl (\ e a -> App e (Type a)) f args
mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkIntLit :: Integer -> Expr b
mkIntLitInt :: Int -> Expr b
mkIntLit n = Lit (mkMachInt n)
mkIntLitInt n = Lit (mkMachInt (toInteger n))
mkWordLit :: Integer -> Expr b
mkWordLitWord :: Word -> Expr b
mkWordLit w = Lit (mkMachWord w)
mkWordLitWord w = Lit (mkMachWord (toInteger w))
mkCharLit :: Char -> Expr b
mkStringLit :: String -> Expr b
mkCharLit c = Lit (mkMachChar c)
mkStringLit s = Lit (mkMachString s)
mkFloatLit :: Rational -> Expr b
mkFloatLitFloat :: Float -> Expr b
mkFloatLit f = Lit (mkMachFloat f)
mkFloatLitFloat f = Lit (mkMachFloat (toRational f))
mkDoubleLit :: Rational -> Expr b
mkDoubleLitDouble :: Double -> Expr b
mkDoubleLit d = Lit (mkMachDouble d)
mkDoubleLitDouble d = Lit (mkMachDouble (toRational d))
mkLets :: [Bind b] -> Expr b -> Expr b
mkLams :: [b] -> Expr b -> Expr b
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
mkTyBind :: TyVar -> Type -> CoreBind
mkTyBind tv ty = NonRec tv (Type ty)
varToCoreExpr :: CoreBndr -> Expr b
varToCoreExpr v | isId v = Var v
| otherwise = Type (mkTyVarTy v)
varsToCoreExprs :: [CoreBndr] -> [Expr b]
varsToCoreExprs vs = map varToCoreExpr vs
\end{code}
%************************************************************************
%* *
\subsection{Simple access functions}
%* *
%************************************************************************
\begin{code}
bindersOf :: Bind b -> [b]
bindersOf (NonRec binder _) = [binder]
bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
bindersOfBinds :: [Bind b] -> [b]
bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
rhssOfBind :: Bind b -> [Expr b]
rhssOfBind (NonRec _ rhs) = [rhs]
rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
rhssOfAlts :: [Alt b] -> [Expr b]
rhssOfAlts alts = [e | (_,_,e) <- alts]
flattenBinds :: [Bind b] -> [(b, Expr b)]
flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
flattenBinds [] = []
\end{code}
\begin{code}
collectBinders :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
collectBinders expr
= go [] expr
where
go bs (Lam b e) = go (b:bs) e
go bs e = (reverse bs, e)
collectTyAndValBinders expr
= (tvs, ids, body)
where
(tvs, body1) = collectTyBinders expr
(ids, body) = collectValBinders body1
collectTyBinders expr
= go [] expr
where
go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
go tvs e = (reverse tvs, e)
collectValBinders expr
= go [] expr
where
go ids (Lam b e) | isId b = go (b:ids) e
go ids body = (reverse ids, body)
\end{code}
\begin{code}
collectArgs :: Expr b -> (Expr b, [Arg b])
collectArgs expr
= go expr []
where
go (App f a) as = go f (a:as)
go e as = (e, as)
\end{code}
\begin{code}
coreExprCc :: Expr b -> CostCentre
coreExprCc (Note (SCC cc) _) = cc
coreExprCc (Note _ e) = coreExprCc e
coreExprCc (Lam _ e) = coreExprCc e
coreExprCc _ = noCostCentre
\end{code}
%************************************************************************
%* *
\subsection{Predicates}
%* *
%************************************************************************
At one time we optionally carried type arguments through to runtime.
@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime,
i.e. if type applications are actual lambdas because types are kept around
at runtime. Similarly isRuntimeArg.
\begin{code}
isRuntimeVar :: Var -> Bool
isRuntimeVar = isId
isRuntimeArg :: CoreExpr -> Bool
isRuntimeArg = isValArg
isValArg :: Expr b -> Bool
isValArg (Type _) = False
isValArg _ = True
isTypeArg :: Expr b -> Bool
isTypeArg (Type _) = True
isTypeArg _ = False
valBndrCount :: [CoreBndr] -> Int
valBndrCount = count isId
valArgCount :: [Arg b] -> Int
valArgCount = count isValArg
notSccNote :: Note -> Bool
notSccNote (SCC {}) = False
notSccNote _ = True
\end{code}
%************************************************************************
%* *
\subsection{Seq stuff}
%* *
%************************************************************************
\begin{code}
seqExpr :: CoreExpr -> ()
seqExpr (Var v) = v `seq` ()
seqExpr (Lit lit) = lit `seq` ()
seqExpr (App f a) = seqExpr f `seq` seqExpr a
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 (Note n e) = seqNote n `seq` seqExpr e
seqExpr (Type t) = seqType t
seqExprs :: [CoreExpr] -> ()
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote :: Note -> ()
seqNote (CoreNote s) = s `seq` ()
seqNote _ = ()
seqBndr :: CoreBndr -> ()
seqBndr b = b `seq` ()
seqBndrs :: [CoreBndr] -> ()
seqBndrs [] = ()
seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
seqBind :: Bind CoreBndr -> ()
seqBind (NonRec b e) = seqBndr b `seq` seqExpr e
seqBind (Rec prs) = seqPairs prs
seqPairs :: [(CoreBndr, CoreExpr)] -> ()
seqPairs [] = ()
seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs
seqAlts :: [CoreAlt] -> ()
seqAlts [] = ()
seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
seqRules :: [CoreRule] -> ()
seqRules [] = ()
seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules)
= seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules
seqRules (BuiltinRule {} : rules) = seqRules rules
\end{code}
%************************************************************************
%* *
\subsection{Annotated core}
%* *
%************************************************************************
\begin{code}
type AnnExpr bndr annot = (annot, AnnExpr' bndr annot)
data AnnExpr' bndr annot
= AnnVar Id
| AnnLit Literal
| AnnLam bndr (AnnExpr bndr annot)
| 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
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
data AnnBind bndr annot
= AnnNonRec bndr (AnnExpr bndr annot)
| AnnRec [(bndr, AnnExpr bndr annot)]
\end{code}
\begin{code}
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' (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' (AnnNote note body) = Note note (deAnnotate body)
deAnnotate' (AnnLet bind body)
= Let (deAnnBind bind) (deAnnotate body)
where
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
deAnnotate' (AnnCase scrut v t alts)
= Case (deAnnotate scrut) v t (map deAnnAlt alts)
deAnnAlt :: AnnAlt bndr annot -> Alt bndr
deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
\end{code}
\begin{code}
collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs e
= collect [] e
where
collect bs (_, AnnLam b body) = collect (b:bs) body
collect bs body = (reverse bs, body)
\end{code}