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,
- bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 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',
+ AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,
+ 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
+-- look like valuse. This is sometimes important:
+-- {-# INLINE f #-}
+-- f = g . h
+-- Here, f looks like a redex, and we aren't going to inline (.) because it's
+-- inside an INLINE, so it'll stay looking like a redex. Nevertheless, we
+-- should inline f even inside lambdas. In effect, we should trust the programmer.
\end{code}
+INVARIANTS:
+
+* The RHS of a letrec, and the RHSs of all top-level lets,
+ must be of LIFTED type.
+
+* The RHS of a let, 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. e.g.
+ y::Int# = x +# 1# ok
+ y::Int# = fac 4# not ok [use case instead]
+
+* The argument of an App can be of any type.
+
+* 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.
+
%************************************************************************
%* *
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
-
-isEmptyCoreRules :: CoreRules -> Bool
-isEmptyCoreRules (Rules rs _) = null rs
+A Rule is
-rulesRhsFreeVars :: CoreRules -> VarSet
-rulesRhsFreeVars (Rules _ fvs) = fvs
+ "local" if the function it is a rule for is defined in the
+ same module as the rule itself.
-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 (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 '>'
-type TaggedBind t = Bind (Tagged t)
-type TaggedExpr t = Expr (Tagged t)
-type TaggedArg t = Arg (Tagged t)
-type TaggedAlt t = Alt (Tagged t)
+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
\end{code}
+
%************************************************************************
%* *
\subsection{Predicates}
%* *
%************************************************************************
+@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)
- where
- deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)
+-- 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}