X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=201d86683457fbd8f6a1d8f0795151e80552281e;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=4c70bb33e1c0b963947407fe3f665c6d95892161;hpb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 4c70bb3..201d866 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -15,7 +15,7 @@ module CoreSyn ( mkConApp, varToCoreExpr, - isTyVar, isId, + isTyVar, isId, cmpAltCon, cmpAlt, ltAlt, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, @@ -26,37 +26,35 @@ module CoreSyn ( -- 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} @@ -78,13 +76,33 @@ data Expr b -- "b" for the type of binders, | 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 @@ -94,6 +112,7 @@ data AltCon = DataAlt DataCon | DEFAULT deriving (Eq, Ord) + data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] @@ -150,51 +169,65 @@ INVARIANTS: 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 %* * %************************************************************************ @@ -220,7 +253,7 @@ data Unfolding | 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 @@ -242,8 +275,10 @@ data UnfoldingGuidance -- 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) @@ -324,6 +359,26 @@ instance Outputable AltCon where 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} @@ -539,14 +594,15 @@ valArgCount (other : args) = 1 + valArgCount args \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 @@ -569,12 +625,10 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs 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} @@ -593,7 +647,8 @@ data AnnExpr' bndr annot | 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 @@ -622,8 +677,9 @@ deAnnotate' (AnnLet bind body) 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)