X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=201d86683457fbd8f6a1d8f0795151e80552281e;hb=380148608fa354ac972d45aa933400a1a5c4dd7f;hp=3cce2d5053e8c133ac877dbbdcc1603d78783287;hpb=bca9dd54c2b39638cb4638aaccf6015a104a1df5;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 3cce2d5..201d866 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -7,7 +7,7 @@ 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, @@ -15,44 +15,47 @@ module CoreSyn ( 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} @@ -73,12 +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 - -- 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 @@ -88,6 +112,7 @@ data AltCon = DataAlt DataCon | DEFAULT deriving (Eq, Ord) + data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] @@ -103,8 +128,37 @@ data Note | 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. + %************************************************************************ %* * @@ -115,46 +169,65 @@ data Note 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 %* * %************************************************************************ @@ -180,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 @@ -202,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) @@ -284,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} @@ -306,12 +401,18 @@ type CoreAlt = Alt CoreBndr 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} @@ -340,7 +441,7 @@ mkLets :: [Bind b] -> Expr b -> Expr b 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 @@ -389,7 +490,6 @@ order. \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) @@ -400,16 +500,6 @@ collectBinders expr 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 @@ -454,12 +544,29 @@ coreExprCc other = noCostCentre \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 @@ -487,19 +594,21 @@ 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 seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 +seqNote (CoreNote s) = s `seq` () seqNote other = () seqBndr b = b `seq` () @@ -516,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} @@ -540,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 @@ -569,9 +677,19 @@ 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) - 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}