X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=9b67515c671236f36a4f02f8fab77b8606972ebd;hp=65a1b406aaa714a88cb2f322b033ef574e8ccd10;hb=4c6a3f787abcaed009a574196d82237d9ae64fc8;hpb=a84a227cee9e87b4fa872366a4ac3ae0eeda16ef diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 65a1b40..9b67515 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[CoreSyn]{A data type for the Haskell compiler midsection} + +CoreSyn: A data type for the Haskell compiler midsection \begin{code} module CoreSyn ( @@ -40,24 +42,24 @@ module CoreSyn ( -- Core rules CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - RuleName, seqRules, + RuleName, seqRules, ruleArity, 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 Coercion ( Coercion ) -import Name ( Name ) -import OccName ( OccName ) -import Literal ( Literal, mkMachInt ) -import DataCon ( DataCon, dataConWorkId, dataConTag ) -import BasicTypes ( Activation ) +import StaticFlags +import CostCentre +import Var +import Type +import Coercion +import Name +import Literal +import DataCon +import BasicTypes import FastString import Outputable +import Util infixl 4 `mkApps`, `mkValApps`, `mkTyApps`, `mkVarApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) @@ -77,37 +79,17 @@ infixl 8 `App` -- App brackets to the left data Expr b -- "b" for the type of binders, = Var Id | Lit Literal - | App (Expr b) (Arg b) + | App (Expr b) (Arg b) -- See Note [CoreSyn let/app invariant] | Lam b (Expr b) - | Let (Bind b) (Expr b) + | Let (Bind b) (Expr b) -- See [CoreSyn let/app invariant], + -- and [CoreSyn letrec invariant] | 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 + -- See Note [CoreSyn case invariants] | Cast (Expr b) Coercion | 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 @@ -121,7 +103,61 @@ data AltCon = DataAlt DataCon -- Invariant: the DataCon is always from data Bind b = NonRec b (Expr b) | Rec [(b, (Expr b))] +\end{code} + +-------------------------- CoreSyn INVARIANTS --------------------------- + +Note [CoreSyn top-level invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHSs of all top-level lets must be of LIFTED type. + +Note [CoreSyn letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHS of a letrec must be of LIFTED type. + +Note [CoreSyn let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* The RHS of a non-recursive let, *and* the argument of an App, + 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] +This is intially enforced by DsUtils.mkDsLet and mkDsApp + +Note [CoreSyn case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +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 + +Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, + meaning that it covers all cases that can occur + + An "exhaustive" 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. + + +Note [CoreSyn let goal] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* 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. + +\begin{code} data Note = SCC CostCentre @@ -141,23 +177,6 @@ data Note -- 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. - %************************************************************************ %* * @@ -198,21 +217,34 @@ data CoreRule ru_rhs :: CoreExpr, -- Locality - ru_local :: Bool, -- The fn at the head of the rule is + 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 } + -- and is not an implicit Id (like a record sel + -- class op, or data con) + -- NB: ru_local is *not* used to decide orphan-hood + -- c.g. MkIface.coreRuleToIfaceRule + } | 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_nargs :: Int, -- Number of args that ru_try expects, + -- including type args ru_try :: [CoreExpr] -> Maybe CoreExpr } + -- This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned CoreExpr + -- is just the rewrite of ru_fn applied to the first ru_nargs args + -- See Note [Extra args in rule matching] in Rules.lhs +isBuiltinRule :: CoreRule -> Bool isBuiltinRule (BuiltinRule {}) = True isBuiltinRule _ = False +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + ruleName :: CoreRule -> RuleName ruleName = ru_name @@ -274,68 +306,71 @@ data UnfoldingGuidance -- a context (case (thing args) of ...), -- (where there are the right number of arguments.) +noUnfolding, evaldUnfolding :: Unfolding noUnfolding = NoUnfolding evaldUnfolding = OtherCon [] +mkOtherCon :: [AltCon] -> Unfolding mkOtherCon = OtherCon seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding e top b1 b2 g) = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g -seqUnfolding other = () +seqUnfolding _ = () +seqGuidance :: UnfoldingGuidance -> () seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () -seqGuidance other = () +seqGuidance _ = () \end{code} \begin{code} unfoldingTemplate :: Unfolding -> CoreExpr unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr unfoldingTemplate (CompulsoryUnfolding expr) = expr -unfoldingTemplate other = panic "getUnfoldingTemplate" +unfoldingTemplate _ = panic "getUnfoldingTemplate" maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr -maybeUnfoldingTemplate other = Nothing +maybeUnfoldingTemplate _ = Nothing otherCons :: Unfolding -> [AltCon] otherCons (OtherCon cons) = cons -otherCons other = [] +otherCons _ = [] isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald -isValueUnfolding other = False +isValueUnfolding _ = False isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon isEvaldUnfolding (OtherCon _) = True isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald -isEvaldUnfolding other = False +isEvaldUnfolding _ = False isCheapUnfolding :: Unfolding -> Bool isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap -isCheapUnfolding other = False +isCheapUnfolding _ = False isCompulsoryUnfolding :: Unfolding -> Bool isCompulsoryUnfolding (CompulsoryUnfolding _) = True -isCompulsoryUnfolding other = False +isCompulsoryUnfolding _ = False hasUnfolding :: Unfolding -> Bool hasUnfolding (CoreUnfolding _ _ _ _ _) = True hasUnfolding (CompulsoryUnfolding _) = True -hasUnfolding other = False +hasUnfolding _ = False hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False -hasSomeUnfolding other = True +hasSomeUnfolding _ = True neverUnfold :: Unfolding -> Bool neverUnfold NoUnfolding = True neverUnfold (OtherCon _) = True neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True -neverUnfold other = False +neverUnfold _ = False \end{code} @@ -363,12 +398,12 @@ 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 } +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT cmpAltCon :: AltCon -> AltCon -> Ordering -- Compares AltCons within a single list of alternatives cmpAltCon DEFAULT DEFAULT = EQ -cmpAltCon DEFAULT con = LT +cmpAltCon DEFAULT _ = LT cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 cmpAltCon (DataAlt _) DEFAULT = GT @@ -542,10 +577,10 @@ It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e \begin{code} coreExprCc :: Expr b -> CostCentre -coreExprCc (Note (SCC cc) e) = cc -coreExprCc (Note other_note e) = coreExprCc e +coreExprCc (Note (SCC cc) _) = cc +coreExprCc (Note _ e) = coreExprCc e coreExprCc (Lam _ e) = coreExprCc e -coreExprCc other = noCostCentre +coreExprCc _ = noCostCentre \end{code} @@ -564,30 +599,28 @@ Similarly isRuntimeArg. \begin{code} isRuntimeVar :: Var -> Bool -isRuntimeVar | opt_RuntimeTypes = \v -> True +isRuntimeVar | opt_RuntimeTypes = \_ -> True | otherwise = \v -> isId v isRuntimeArg :: CoreExpr -> Bool -isRuntimeArg | opt_RuntimeTypes = \e -> True +isRuntimeArg | opt_RuntimeTypes = \_ -> True | otherwise = \e -> isValArg e \end{code} \begin{code} +isValArg :: Expr b -> Bool isValArg (Type _) = False -isValArg other = True +isValArg _ = True +isTypeArg :: Expr b -> Bool isTypeArg (Type _) = True -isTypeArg other = False +isTypeArg _ = False valBndrCount :: [CoreBndr] -> Int -valBndrCount [] = 0 -valBndrCount (b : bs) | isId b = 1 + valBndrCount bs - | otherwise = valBndrCount bs +valBndrCount = count isId valArgCount :: [Arg b] -> Int -valArgCount [] = 0 -valArgCount (Type _ : args) = valArgCount args -valArgCount (other : args) = 1 + valArgCount args +valArgCount = count isValArg \end{code} @@ -609,26 +642,34 @@ seqExpr (Cast e co) = seqExpr e `seq` seqType co seqExpr (Note n e) = seqNote n `seq` seqExpr e seqExpr (Type t) = seqType t +seqExprs :: [CoreExpr] -> () seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es +seqNote :: Note -> () seqNote (CoreNote s) = s `seq` () -seqNote other = () +seqNote _ = () +seqBndr :: CoreBndr -> () seqBndr b = b `seq` () +seqBndrs :: [CoreBndr] -> () seqBndrs [] = () seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs +seqBind :: Bind CoreBndr -> () seqBind (NonRec b e) = seqBndr b `seq` seqExpr e seqBind (Rec prs) = seqPairs prs +seqPairs :: [(CoreBndr, CoreExpr)] -> () seqPairs [] = () seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs +seqAlts :: [CoreAlt] -> () seqAlts [] = () -seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts +seqRules :: [CoreRule] -> () seqRules [] = () seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules @@ -668,6 +709,7 @@ data AnnBind bndr annot deAnnotate :: AnnExpr bndr annot -> Expr bndr deAnnotate (_, e) = deAnnotate' e +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr deAnnotate' (AnnType t) = Type t deAnnotate' (AnnVar v) = Var v deAnnotate' (AnnLit lit) = Lit lit