mkConApp,
varToCoreExpr,
- isTyVar, isId,
+ isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
collectArgs,
-- 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, collectAnnBndrs,
-- Core rules
- CoreRules(..), -- Representation needed by friends
CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only
- IdCoreRule,
- RuleName,
- emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules,
- isBuiltinRule, ruleName
+ RuleName, seqRules,
+ isBuiltinRule, ruleName, isLocalRule, ruleIdName
) where
#include "HsVersions.h"
-import CmdLineOpts ( opt_RuntimeTypes )
+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, dataConWorkId )
+import DataCon ( DataCon, dataConWorkId, dataConTag )
import BasicTypes ( Activation )
-import VarSet
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
- -- Invariant: the list of alternatives is ALWAYS EXHAUSTIVE
- -- Invariant: the DEFAULT case must be *first*, 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))]
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 = FastString
-type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them
data CoreRule
- = Rule RuleName
- Activation -- When the rule is active
- [CoreBndr] -- Forall'd variables
- [CoreExpr] -- LHS args
- CoreExpr -- RHS
+ = 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
- | BuiltinRule -- Built-in rules are used for constant folding
- RuleName -- and suchlike. It has no free variables.
- ([CoreExpr] -> Maybe CoreExpr)
+ruleName :: CoreRule -> RuleName
+ruleName = ru_name
-isBuiltinRule (BuiltinRule _ _) = True
-isBuiltinRule _ = False
+ruleIdName :: CoreRule -> Name
+ruleIdName = ru_fn
-ruleName :: CoreRule -> RuleName
-ruleName (Rule n _ _ _ _) = n
-ruleName (BuiltinRule n _) = n
+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}
\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
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)
projects / ghc-hetmet.git / blobdiff