module CoreSyn (
Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..),
CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
- TaggedExpr, TaggedAlt, TaggedBind, TaggedArg,
+ TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
mkLets, mkLams,
mkApps, mkTyApps, mkValApps, mkVarApps,
mkConApp,
varToCoreExpr,
- isTyVar, isId,
+ isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
- collectArgs, collectBindersIgnoringNotes,
+ collectArgs,
coreExprCc,
flattenBinds,
- isValArg, isTypeArg, valArgCount, valBndrCount,
+ isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-- Unfoldings
Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
- noUnfolding, mkOtherCon,
+ noUnfolding, evaldUnfolding, mkOtherCon,
unfoldingTemplate, maybeUnfoldingTemplate, otherCons,
isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding,
hasUnfolding, hasSomeUnfolding, neverUnfold,
-- Seq stuff
- seqRules, seqExpr, seqExprs, seqUnfolding,
+ seqExpr, seqExprs, seqUnfolding,
-- Annotated expressions
AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
- deAnnotate, deAnnotate', deAnnAlt,
+ deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
-- Core rules
- CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- IdCoreRule,
- RuleName,
- emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
- isBuiltinRule
+ RuleName, seqRules,
+ isBuiltinRule, ruleName, isLocalRule, ruleIdName
) where
#include "HsVersions.h"
+import StaticFlags ( opt_RuntimeTypes )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
+import Name ( Name )
+import OccName ( OccName )
import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConId )
-import VarSet
+import DataCon ( DataCon, dataConWorkId, dataConTag )
+import BasicTypes ( Activation )
+import FastString
import Outputable
\end{code}
| App (Expr b) (Arg b)
| Lam b (Expr b)
| Let (Bind b) (Expr b)
- | Case (Expr b) b [Alt b] -- Binder gets bound to value of scrutinee
- -- DEFAULT case must be last, if it occurs at all
+ | Case (Expr b) b Type [Alt b] -- Binder gets bound to value of scrutinee
+ -- Invariant: The list of alternatives is ALWAYS EXHAUSTIVE,
+ -- meaning that it covers all cases that can occur
+ -- See the example below
+ --
+ -- Invariant: The DEFAULT case must be *first*, if it occurs at all
+ -- Invariant: The remaining cases are in order of increasing
+ -- tag (for DataAlts)
+ -- lit (for LitAlts)
+ -- This makes finding the relevant constructor easy,
+ -- and makes comparison easier too
| Note Note (Expr b)
| Type Type -- This should only show up at the top
-- level of an Arg
+-- An "exhausive" case does not necessarily mention all constructors:
+-- data Foo = Red | Green | Blue
+--
+-- ...case x of
+-- Red -> True
+-- other -> f (case x of
+-- Green -> ...
+-- Blue -> ... )
+-- The inner case does not need a Red alternative, because x can't be Red at
+-- that program point.
+
+
type Arg b = Expr b -- Can be a Type
type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative
| DEFAULT
deriving (Eq, Ord)
+
data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
| InlineMe -- Instructs simplifer to treat the enclosed expression
-- as very small, and inline it at its call sites
+ | CoreNote String -- A generic core annotation, propagated but not used by GHC
+
-- NOTE: we also treat expressions wrapped in InlineMe as
-- 'cheap' and 'dupable' (in the sense of exprIsCheap, exprIsDupable)
-- What this means is that we obediently inline even things that don't
The CoreRule type and its friends are dealt with mainly in CoreRules,
but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation.
-\begin{code}
-data CoreRules
- = Rules [CoreRule]
- VarSet -- Locally-defined free vars of RHSs
-
-emptyCoreRules :: CoreRules
-emptyCoreRules = Rules [] emptyVarSet
+A Rule is
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
+ "local" if the function it is a rule for is defined in the
+ same module as the rule itself.
-rulesRhsFreeVars :: CoreRules -> VarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
-
-rulesRules :: CoreRules -> [CoreRule]
-rulesRules (Rules rules _) = rules
-\end{code}
+ "orphan" if nothing on the LHS is defined in the same module
+ as the rule itself
\begin{code}
-type RuleName = FAST_STRING
-type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
+type RuleName = FastString
data CoreRule
- = Rule RuleName
- [CoreBndr] -- Forall'd variables
- [CoreExpr] -- LHS args
- CoreExpr -- RHS
-
- | BuiltinRule -- Built-in rules are used for constant folding
- -- and suchlike. It has no free variables.
- ([CoreExpr] -> Maybe (RuleName, CoreExpr))
-
-isBuiltinRule (BuiltinRule _) = True
-isBuiltinRule _ = False
+ = Rule {
+ ru_name :: RuleName,
+ 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 at the head of this rule
+ ru_rough :: [Maybe Name], -- Name at the head of each argument
+
+ -- Proper-matching stuff
+ -- see comments with InstEnv.Instance( is_tvs, is_tys )
+ ru_bndrs :: [CoreBndr], -- Forall'd variables
+ ru_args :: [CoreExpr], -- LHS args
+
+ -- And the right-hand side
+ ru_rhs :: CoreExpr,
+
+ -- Locality
+ ru_local :: Bool, -- The fn at the head of the rule is
+ -- defined in the same module as the rule
+
+ -- Orphan-hood; see comments is InstEnv.Instance( is_orph )
+ ru_orph :: Maybe OccName }
+
+ | BuiltinRule { -- Built-in rules are used for constant folding
+ ru_name :: RuleName, -- and suchlike. It has no free variables.
+ ru_fn :: Name, -- Name of the Id at
+ -- the head of this rule
+ ru_try :: [CoreExpr] -> Maybe CoreExpr }
+
+isBuiltinRule (BuiltinRule {}) = True
+isBuiltinRule _ = False
+
+ruleName :: CoreRule -> RuleName
+ruleName = ru_name
+
+ruleIdName :: CoreRule -> Name
+ruleIdName = ru_fn
+
+isLocalRule :: CoreRule -> Bool
+isLocalRule = ru_local
\end{code}
%************************************************************************
%* *
-\subsection{@Unfolding@ type}
+ Unfoldings
%* *
%************************************************************************
| CoreUnfolding -- An unfolding with redundant cached information
CoreExpr -- Template; binder-info is correct
Bool -- True <=> top level binding
- Bool -- exprIsValue template (cached); it is ok to discard a `seq` on
+ Bool -- exprIsHNF template (cached); it is ok to discard a `seq` on
-- this variable
Bool -- True <=> doesn't waste (much) work to expand inside an inlining
-- Basically it's exprIsCheap
-- a context (case (thing args) of ...),
-- (where there are the right number of arguments.)
-noUnfolding = NoUnfolding
-mkOtherCon = OtherCon
+noUnfolding = NoUnfolding
+evaldUnfolding = OtherCon []
+
+mkOtherCon = OtherCon
seqUnfolding :: Unfolding -> ()
seqUnfolding (CoreUnfolding e top b1 b2 g)
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 = case a1 `cmpAlt` a2 of { LT -> True; other -> False }
+
+cmpAltCon :: AltCon -> AltCon -> Ordering
+-- Compares AltCons within a single list of alternatives
+cmpAltCon DEFAULT DEFAULT = EQ
+cmpAltCon DEFAULT con = 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}
Binders are ``tagged'' with a \tr{t}:
\begin{code}
-type Tagged t = (CoreBndr, t)
+data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder"
-type TaggedBind t = Bind (Tagged t)
-type TaggedExpr t = Expr (Tagged t)
-type TaggedArg t = Arg (Tagged t)
-type TaggedAlt t = Alt (Tagged 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 -- Simple
\end{code}
mkLams :: [b] -> Expr b -> Expr b
mkLit lit = Lit lit
-mkConApp con args = mkApps (Var (dataConId con)) args
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
\begin{code}
collectBinders :: Expr b -> ([b], Expr b)
-collectBindersIgnoringNotes :: Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
go bs (Lam b e) = go (b:bs) e
go bs e = (reverse bs, e)
--- This one ignores notes. It's used in CoreUnfold and StrAnal
--- when we aren't going to put the expression back together from
--- the pieces, so we don't mind losing the Notes
-collectBindersIgnoringNotes expr
- = go [] expr
- where
- go bs (Lam b e) = go (b:bs) e
- go bs (Note _ e) = go bs e
- go bs e = (reverse bs, e)
-
collectTyAndValBinders expr
= (tvs, ids, body)
where
%* *
%************************************************************************
+@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 | opt_RuntimeTypes = \v -> True
+ | otherwise = \v -> isId v
+
+isRuntimeArg :: CoreExpr -> Bool
+isRuntimeArg | opt_RuntimeTypes = \e -> True
+ | otherwise = \e -> isValArg e
+\end{code}
+
\begin{code}
isValArg (Type _) = False
isValArg other = True
\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 as) = seqExpr e `seq` seqBndr b `seq` seqAlts as
-seqExpr (Note n e) = seqNote n `seq` seqExpr e
-seqExpr (Type t) = seqType t
+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
+-- gaw 2004
+seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
+seqExpr (Note n e) = seqNote n `seq` seqExpr e
+seqExpr (Type t) = seqType t
seqExprs [] = ()
seqExprs (e:es) = seqExpr e `seq` seqExprs es
seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2
+seqNote (CoreNote s) = s `seq` ()
seqNote other = ()
seqBndr b = b `seq` ()
seqAlts [] = ()
seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts
-seqRules :: CoreRules -> ()
-seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs
-
-seq_rules [] = ()
-seq_rules (Rule fs bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules
-seq_rules (BuiltinRule _ : rules) = seq_rules rules
+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}
| AnnLit Literal
| AnnLam bndr (AnnExpr bndr annot)
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
- | AnnCase (AnnExpr bndr annot) bndr [AnnAlt bndr annot]
+-- gaw 2004
+ | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
| AnnNote Note (AnnExpr bndr annot)
| AnnType Type
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-deAnnotate' (AnnCase scrut v alts)
- = Case (deAnnotate scrut) v (map deAnnAlt alts)
+-- gaw 2004
+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}