%
% (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,
isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs, coreExprCc, flattenBinds,
isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
Unfolding(..), UnfoldingGuidance(..),
noUnfolding, evaldUnfolding, mkOtherCon,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,
isExpandableUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
seqExpr, seqExprs, seqUnfolding,
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
CoreRule(..),
RuleName,
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.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
\end{code}
%************************************************************************
%* *
\subsection{The main data types}
%* *
%************************************************************************
These data types are the heart of the compiler
\begin{code}
infixl 8 `App`
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
type Arg b = Expr b
type Alt b = (AltCon, [b], Expr b)
data AltCon = DataAlt DataCon
| LitAlt Literal
| DEFAULT
deriving (Eq, Ord)
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
\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
| InlineMe
| CoreNote String
\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_local :: Bool
}
| BuiltinRule {
ru_name :: RuleName,
ru_fn :: Name,
ru_nargs :: Int,
ru_try :: [CoreExpr] -> Maybe CoreExpr
}
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]
| CompulsoryUnfolding CoreExpr
| CoreUnfolding
CoreExpr
Bool
Bool
Bool
Bool
UnfoldingGuidance
data UnfoldingGuidance
= UnfoldNever
| UnfoldIfGoodArgs Int
[Int]
Int
Int
noUnfolding :: Unfolding
evaldUnfolding :: Unfolding
noUnfolding = NoUnfolding
evaldUnfolding = OtherCon []
mkOtherCon :: [AltCon] -> Unfolding
mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 b3 g)
= seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` seqGuidance g
seqUnfolding _ = ()
seqGuidance :: UnfoldingGuidance -> ()
seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` ()
seqGuidance _ = ()
\end{code}
\begin{code}
unfoldingTemplate :: Unfolding -> CoreExpr
unfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = expr
unfoldingTemplate (CompulsoryUnfolding expr) = expr
unfoldingTemplate _ = panic "getUnfoldingTemplate"
maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr
maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _ _) = Just expr
maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr
maybeUnfoldingTemplate _ = Nothing
otherCons :: Unfolding -> [AltCon]
otherCons (OtherCon cons) = cons
otherCons _ = []
isValueUnfolding :: Unfolding -> Bool
isValueUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isValueUnfolding _ = False
isEvaldUnfolding :: Unfolding -> Bool
isEvaldUnfolding (OtherCon _) = True
isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _ _) = is_evald
isEvaldUnfolding _ = False
isCheapUnfolding :: Unfolding -> Bool
isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _ _) = is_cheap
isCheapUnfolding _ = False
isExpandableUnfolding :: Unfolding -> Bool
isExpandableUnfolding (CoreUnfolding _ _ _ _ is_expable _) = is_expable
isExpandableUnfolding _ = False
isCompulsoryUnfolding :: Unfolding -> Bool
isCompulsoryUnfolding (CompulsoryUnfolding _) = True
isCompulsoryUnfolding _ = False
hasUnfolding :: Unfolding -> Bool
hasUnfolding (CoreUnfolding _ _ _ _ _ _) = True
hasUnfolding (CompulsoryUnfolding _) = True
hasUnfolding _ = False
hasSomeUnfolding :: Unfolding -> Bool
hasSomeUnfolding NoUnfolding = False
hasSomeUnfolding _ = True
neverUnfold :: Unfolding -> Bool
neverUnfold NoUnfolding = True
neverUnfold (OtherCon _) = True
neverUnfold (CoreUnfolding _ _ _ _ _ UnfoldNever) = True
neverUnfold _ = False
\end{code}
%************************************************************************
%* *
\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) | isTyVar 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
\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}
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}