X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCoreSyn.lhs;h=ea22eb585b1cdcfdc21ad3fb7ae483d19a6f61e7;hp=8c799b554580e85f3df5b87dfa867ea52ca8a6f1;hb=6084fb5517da34f65034370a3695e2af3b85ce2b;hpb=7b01315da1b2fab02d3778bedec3ae8c57a1bc42 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 8c799b5..ea22eb5 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -20,9 +20,8 @@ module CoreSyn ( isTyVar, isId, cmpAltCon, cmpAlt, ltAlt, bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, - collectArgs, - coreExprCc, - flattenBinds, + collectArgs, coreExprCc, + mkTyBind, flattenBinds, isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, @@ -43,23 +42,23 @@ module CoreSyn ( -- Core rules CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only RuleName, seqRules, ruleArity, - isBuiltinRule, ruleName, isLocalRule, ruleIdName + isBuiltinRule, ruleName, isLocalRule, ruleIdName, setRuleIdName ) where #include "HsVersions.h" -import StaticFlags import CostCentre import Var +import Id import Type import Coercion import Name -import OccName 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) @@ -138,7 +137,7 @@ Invariant: The remaining cases are in order of increasing Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, meaning that it covers all cases that can occur - An "exhausive" case does not necessarily mention all constructors: + An "exhaustive" case does not necessarily mention all constructors: data Foo = Red | Green | Blue ...case x of @@ -151,12 +150,23 @@ Invariant: The list of alternatives is ALWAYS EXHAUSTIVE, 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. +Note [Type let] +~~~~~~~~~~~~~~~ +We allow a *non-recursive* let to bind a type variable, thus + Let (NonRec tv (Type ty)) body +This can be very convenient for postponing type substitutions until +the next run of the simplifier. + +At the moment, the rest of the compiler only deals with type-let +in a Let expression, rather than at top level. We may want to revist +this choice. + \begin{code} data Note = SCC CostCentre @@ -196,8 +206,6 @@ A Rule is as the rule itself \begin{code} -type RuleName = FastString - data CoreRule = Rule { ru_name :: RuleName, @@ -217,19 +225,27 @@ 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 Note [Orphans] in InstEnv - 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 + 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 @@ -245,6 +261,9 @@ ruleIdName = ru_fn isLocalRule :: CoreRule -> Bool isLocalRule = ru_local + +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } \end{code} @@ -298,68 +317,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} @@ -378,7 +400,7 @@ neverUnfold other = False instance Outputable AltCon where ppr (DataAlt dc) = ppr dc ppr (LitAlt lit) = ppr lit - ppr DEFAULT = ptext SLIT("__DEFAULT") + ppr DEFAULT = ptext (sLit "__DEFAULT") instance Show AltCon where showsPrec p con = showsPrecSDoc p (ppr con) @@ -387,12 +409,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 @@ -491,6 +513,11 @@ mkCast e co = Cast e co %************************************************************************ \begin{code} +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + -- Note [Type let] + -- A non-recursive let can bind a type variable + bindersOf :: Bind b -> [b] bindersOf (NonRec binder _) = [binder] bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] @@ -566,10 +593,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} @@ -580,38 +607,31 @@ coreExprCc other = noCostCentre %* * %************************************************************************ +At one time we optionally carried type arguments through to runtime. @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. +at runtime. Similarly isRuntimeArg. \begin{code} isRuntimeVar :: Var -> Bool -isRuntimeVar | opt_RuntimeTypes = \v -> True - | otherwise = \v -> isId v +isRuntimeVar = isId isRuntimeArg :: CoreExpr -> Bool -isRuntimeArg | opt_RuntimeTypes = \e -> True - | otherwise = \e -> isValArg e -\end{code} +isRuntimeArg = isValArg -\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} @@ -633,26 +653,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 @@ -692,6 +720,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