X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=4c70bb33e1c0b963947407fe3f665c6d95892161;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=73558197c00deed6dccb5d51c36b321f1ee304d7;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 7355819..4c70bb3 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -5,37 +5,59 @@ \begin{code} module CoreSyn ( - Expr(..), Alt, Bind(..), Arg(..), Note(..), + 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, - mkLit, mkStringLit, mkConApp, mkPrimApp, mkNote, mkNilExpr, - bindNonRec, mkIfThenElse, varToCoreExpr, + mkLets, mkLams, + mkApps, mkTyApps, mkValApps, mkVarApps, + mkLit, mkIntLitInt, mkIntLit, + mkConApp, + varToCoreExpr, - bindersOf, rhssOfBind, rhssOfAlts, isDeadBinder, isTyVar, isId, + isTyVar, isId, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, - collectArgs, + collectArgs, coreExprCc, + flattenBinds, - isValArg, isTypeArg, valArgCount, + isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, + + -- Unfoldings + Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs + noUnfolding, mkOtherCon, + unfoldingTemplate, maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, + + -- Seq stuff + seqRules, seqExpr, seqExprs, seqUnfolding, -- Annotated expressions - AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, 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 ) where #include "HsVersions.h" -import TysWiredIn ( boolTy, stringTy, nilDataCon ) -import CostCentre ( CostCentre, isDupdCC, noCostCentre ) -import Var ( Var, GenId, Id, TyVar, IdOrTyVar, isTyVar, isId, idType ) -import Id ( mkWildId, getInlinePragma ) -import Type ( GenType, Type, mkTyVarTy, isUnLiftedType ) -import IdInfo ( InlinePragInfo(..) ) -import BasicTypes ( Unused ) -import Const ( Con(..), DataCon, Literal(NoRepStr), PrimOp ) -import TysWiredIn ( trueDataCon, falseDataCon ) +import CmdLineOpts ( opt_RuntimeTypes ) +import CostCentre ( CostCentre, noCostCentre ) +import Var ( Var, Id, TyVar, isTyVar, isId ) +import Type ( Type, mkTyVarTy, seqType ) +import Literal ( Literal, mkMachInt ) +import DataCon ( DataCon, dataConWorkId ) +import BasicTypes ( Activation ) +import VarSet +import FastString import Outputable \end{code} @@ -48,154 +70,336 @@ import Outputable These data types are the heart of the compiler \begin{code} -data Expr b f -- "b" for the type of binders, - -- "f" for the flexi slot in types - = Var (GenId f) - | Con Con [Arg b f] -- Guaranteed saturated - | App (Expr b f) (Arg b f) - | Lam b (Expr b f) - | Let (Bind b f) (Expr b f) - | Case (Expr b f) b [Alt b f] -- Binder gets bound to value of scrutinee - -- DEFAULT case must be last, if it occurs at all - | Note (Note f) (Expr b f) - | Type (GenType f) -- This should only show up at the top - -- level of an Arg - -type Arg b f = Expr b f -- Can be a Type - -type Alt b f = (Con, [b], Expr b f) - -- (DEFAULT, [], rhs) is the default alternative - -- Remember, a Con can be a literal or a data constructor - -data Bind b f = NonRec b (Expr b f) - | Rec [(b, (Expr b f))] - -data Note f +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) + | 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 + | Note Note (Expr b) + | Type Type -- This should only show up at the top + -- level of an Arg + +type Arg b = Expr b -- Can be a Type + +type Alt b = (AltCon, [b], Expr b) -- (DEFAULT, [], rhs) is the default alternative + +data AltCon = DataAlt DataCon + | LitAlt Literal + | DEFAULT + deriving (Eq, Ord) + +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + +data Note = SCC CostCentre | Coerce - (GenType f) -- The to-type: type of whole coerce expression - (GenType f) -- The from-type: type of enclosed expression + Type -- The to-type: type of whole coerce expression + Type -- The from-type: type of enclosed expression | InlineCall -- Instructs simplifier to inline -- the enclosed call + + | 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. + %************************************************************************ %* * -\subsection{Useful synonyms} +\subsection{Transformation rules} %* * %************************************************************************ -The common case +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. \begin{code} -type CoreBndr = IdOrTyVar -type CoreExpr = Expr CoreBndr Unused -type CoreArg = Arg CoreBndr Unused -type CoreBind = Bind CoreBndr Unused -type CoreAlt = Alt CoreBndr Unused -type CoreNote = Note Unused +data CoreRules + = Rules [CoreRule] + VarSet -- Locally-defined free vars of RHSs + +emptyCoreRules :: CoreRules +emptyCoreRules = Rules [] emptyVarSet + +isEmptyCoreRules :: CoreRules -> Bool +isEmptyCoreRules (Rules rs _) = null rs + +rulesRhsFreeVars :: CoreRules -> VarSet +rulesRhsFreeVars (Rules _ fvs) = fvs + +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules +\end{code} + +\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 + + | BuiltinRule -- Built-in rules are used for constant folding + RuleName -- and suchlike. It has no free variables. + ([CoreExpr] -> Maybe CoreExpr) + +isBuiltinRule (BuiltinRule _ _) = True +isBuiltinRule _ = False + +ruleName :: CoreRule -> RuleName +ruleName (Rule n _ _ _ _) = n +ruleName (BuiltinRule n _) = n \end{code} -Binders are ``tagged'' with a \tr{t}: + +%************************************************************************ +%* * +\subsection{@Unfolding@ type} +%* * +%************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops, but it +should be abstract everywhere except in CoreUnfold.lhs \begin{code} -type Tagged t = (CoreBndr, t) +data Unfolding + = NoUnfolding + + | OtherCon [AltCon] -- It ain't one of these + -- (OtherCon xs) also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- OtherCon [] is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- data C = C !(Int -> Int) + -- case x of { C f -> ... } + -- Here, f gets an OtherCon [] unfolding. + + | CompulsoryUnfolding CoreExpr -- There is no "original" definition, + -- so you'd better unfold. + + | 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 + -- this variable + Bool -- True <=> doesn't waste (much) work to expand inside an inlining + -- Basically it's exprIsCheap + UnfoldingGuidance -- Tells about the *size* of the template. + + +data UnfoldingGuidance + = UnfoldNever + | UnfoldIfGoodArgs Int -- and "n" value args + + [Int] -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + Int -- The "size" of the unfolding; to be elaborated + -- later. ToDo + + Int -- Scrutinee discount: the discount to substract if the thing is in + -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + +noUnfolding = NoUnfolding +mkOtherCon = OtherCon + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding e top b1 b2 g) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` seqGuidance g +seqUnfolding other = () + +seqGuidance (UnfoldIfGoodArgs n ns a b) = n `seq` sum ns `seq` a `seq` b `seq` () +seqGuidance other = () +\end{code} -type TaggedBind t = Bind (Tagged t) Unused -type TaggedExpr t = Expr (Tagged t) Unused -type TaggedArg t = Arg (Tagged t) Unused -type TaggedAlt t = Alt (Tagged t) Unused +\begin{code} +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate (CoreUnfolding expr _ _ _ _) = expr +unfoldingTemplate (CompulsoryUnfolding expr) = expr +unfoldingTemplate other = panic "getUnfoldingTemplate" + +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding expr _ _ _ _) = Just expr +maybeUnfoldingTemplate (CompulsoryUnfolding expr) = Just expr +maybeUnfoldingTemplate other = Nothing + +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons other = [] + +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald +isValueUnfolding other = False + +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding _ _ is_evald _ _) = is_evald +isEvaldUnfolding other = False + +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding _ _ _ is_cheap _) = is_cheap +isCheapUnfolding other = False + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CompulsoryUnfolding _) = True +isCompulsoryUnfolding other = False + +hasUnfolding :: Unfolding -> Bool +hasUnfolding (CoreUnfolding _ _ _ _ _) = True +hasUnfolding (CompulsoryUnfolding _) = True +hasUnfolding other = False + +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding other = True + +neverUnfold :: Unfolding -> Bool +neverUnfold NoUnfolding = True +neverUnfold (OtherCon _) = True +neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True +neverUnfold other = False \end{code} %************************************************************************ %* * -\subsection{Core-constructing functions with checking} +\subsection{The main data type} %* * %************************************************************************ \begin{code} -mkApps :: Expr b f -> [Arg b f] -> Expr b f -mkTyApps :: Expr b f -> [GenType f] -> Expr b f -mkValApps :: Expr b f -> [Expr b f] -> Expr b f - -mkApps f args = foldl App f args -mkTyApps f args = foldl (\ e a -> App e (Type a)) f args -mkValApps f args = foldl (\ e a -> App e a) f args +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = ptext SLIT("__DEFAULT") + +instance Show AltCon where + showsPrec p con = showsPrecSDoc p (ppr con) +\end{code} -mkLit :: Literal -> Expr b f -mkStringLit :: String -> Expr b f -mkConApp :: DataCon -> [Arg b f] -> Expr b f -mkPrimApp :: PrimOp -> [Arg b f] -> Expr b f -mkLit lit = Con (Literal lit) [] -mkStringLit str = Con (Literal (NoRepStr (_PK_ str) stringTy)) [] -mkConApp con args = Con (DataCon con) args -mkPrimApp op args = Con (PrimOp op) args +%************************************************************************ +%* * +\subsection{Useful synonyms} +%* * +%************************************************************************ -mkNilExpr :: Type -> CoreExpr -mkNilExpr ty = Con (DataCon nilDataCon) [Type ty] +The common case -varToCoreExpr :: CoreBndr -> CoreExpr -varToCoreExpr v | isId v = Var v - | otherwise = Type (mkTyVarTy v) +\begin{code} +type CoreBndr = Var +type CoreExpr = Expr CoreBndr +type CoreArg = Arg CoreBndr +type CoreBind = Bind CoreBndr +type CoreAlt = Alt CoreBndr \end{code} -\end{code} +Binders are ``tagged'' with a \tr{t}: \begin{code} -mkLets :: [Bind b f] -> Expr b f -> Expr b f -mkLets binds body = foldr Let body binds +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" -mkLams :: [b] -> Expr b f -> Expr b f -mkLams binders body = foldr Lam body binders -\end{code} +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) -\begin{code} -bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr --- (bindNonRec x r b) produces either --- let x = r in b --- or --- case r of x { _DEFAULT_ -> b } --- --- depending on whether x is unlifted or not -bindNonRec bndr rhs body - | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)] - | otherwise = Let (NonRec bndr rhs) body - -mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -mkIfThenElse guard then_expr else_expr - = Case guard (mkWildId boolTy) - [ (DataCon trueDataCon, [], then_expr), - (DataCon falseDataCon, [], else_expr) ] +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple \end{code} -mkNote removes redundant coercions, and SCCs where possible + +%************************************************************************ +%* * +\subsection{Core-constructing functions with checking} +%* * +%************************************************************************ \begin{code} -mkNote :: Note f -> Expr b f -> Expr b f -mkNote (Coerce to_ty1 from_ty1) (Note (Coerce to_ty2 from_ty2) expr) - = ASSERT( from_ty1 == to_ty2 ) - mkNote (Coerce to_ty1 from_ty2) expr +mkApps :: Expr b -> [Arg b] -> Expr b +mkTyApps :: Expr b -> [Type] -> Expr b +mkValApps :: Expr b -> [Expr b] -> Expr b +mkVarApps :: Expr b -> [Var] -> Expr b -mkNote (SCC cc1) expr@(Note (SCC cc2) _) - | isDupdCC cc1 -- Discard the outer SCC provided we don't need - = expr -- to track its entry count +mkApps f args = foldl App f args +mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkValApps f args = foldl (\ e a -> App e a) f args +mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars + +mkLit :: Literal -> Expr b +mkIntLit :: Integer -> Expr b +mkIntLitInt :: Int -> Expr b +mkConApp :: DataCon -> [Arg b] -> Expr b +mkLets :: [Bind b] -> Expr b -> Expr b +mkLams :: [b] -> Expr b -> Expr b -mkNote note@(SCC cc1) expr@(Lam x e) -- Move _scc_ inside lambda - = Lam x (mkNote note e) +mkLit lit = Lit lit +mkConApp con args = mkApps (Var (dataConWorkId con)) args --- Slide InlineCall in around the function -mkNote InlineCall (App f a) = App (mkNote InlineCall f) a -mkNote InlineCall (Var v) = Note InlineCall (Var v) -mkNote InlineCall expr = expr +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr Let body binds -mkNote note expr = Note note expr +mkIntLit n = Lit (mkMachInt n) +mkIntLitInt n = Lit (mkMachInt (toInteger n)) + +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isId v = Var v + | otherwise = Type (mkTyVarTy v) \end{code} + %************************************************************************ %* * \subsection{Simple access functions} @@ -203,22 +407,24 @@ mkNote note expr = Note note expr %************************************************************************ \begin{code} -bindersOf :: Bind b f -> [b] +bindersOf :: Bind b -> [b] bindersOf (NonRec binder _) = [binder] bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] -rhssOfBind :: Bind b f -> [Expr b f] +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] rhssOfBind (NonRec _ rhs) = [rhs] rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] -rhssOfAlts :: [Alt b f] -> [Expr b f] +rhssOfAlts :: [Alt b] -> [Expr b] rhssOfAlts alts = [e | (_,_,e) <- alts] -isDeadBinder :: CoreBndr -> Bool -isDeadBinder bndr | isId bndr = case getInlinePragma bndr of - IAmDead -> True - other -> False - | otherwise = False -- TyVars count as not dead +flattenBinds :: [Bind b] -> [(b, Expr b)] -- Get all the lhs/rhs pairs +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] \end{code} We often want to strip off leading lambdas before getting down to @@ -228,10 +434,16 @@ We expect (by convention) type-, and value- lambdas in that order. \begin{code} -collectBinders :: Expr b f -> ([b], Expr b f) -collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) -collectValBinders :: CoreExpr -> ([Id], CoreExpr) -collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) collectTyAndValBinders expr = (tvs, ids, body) @@ -239,12 +451,6 @@ collectTyAndValBinders expr (tvs, body1) = collectTyBinders expr (ids, body) = collectValBinders body1 -collectBinders expr - = go [] expr - where - go tvs (Lam b e) = go (b:tvs) e - go tvs e = (reverse tvs, e) - collectTyBinders expr = go [] expr where @@ -263,7 +469,7 @@ collectValBinders expr and the arguments to which it is applied. \begin{code} -collectArgs :: Expr b f -> (Expr b f, [Arg b f]) +collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr = go expr [] where @@ -275,7 +481,7 @@ coreExprCc gets the cost centre enclosing an expression, if any. It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e \begin{code} -coreExprCc :: Expr b f -> CostCentre +coreExprCc :: Expr b -> CostCentre coreExprCc (Note (SCC cc) e) = cc coreExprCc (Note other_note e) = coreExprCc e coreExprCc (Lam _ e) = coreExprCc e @@ -283,12 +489,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 @@ -296,7 +519,12 @@ isValArg other = True isTypeArg (Type _) = True isTypeArg other = False -valArgCount :: [Arg b f] -> Int +valBndrCount :: [CoreBndr] -> Int +valBndrCount [] = 0 +valBndrCount (b : bs) | isId b = 1 + valBndrCount bs + | otherwise = valBndrCount bs + +valArgCount :: [Arg b] -> Int valArgCount [] = 0 valArgCount (Type _ : args) = valArgCount args valArgCount (other : args) = 1 + valArgCount args @@ -305,6 +533,54 @@ valArgCount (other : args) = 1 + valArgCount args %************************************************************************ %* * +\subsection{Seq stuff} +%* * +%************************************************************************ + +\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 + +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` () + +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs [] = () +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 +\end{code} + + + +%************************************************************************ +%* * \subsection{Annotated core; annotation at every node in the tree} %* * %************************************************************************ @@ -314,15 +590,15 @@ type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) data AnnExpr' bndr annot = AnnVar Id - | AnnCon Con [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] | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnNote (Note Unused) (AnnExpr bndr annot) + | AnnNote Note (AnnExpr bndr annot) | AnnType Type -type AnnAlt bndr annot = (Con, [bndr], AnnExpr bndr annot) +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) data AnnBind bndr annot = AnnNonRec bndr (AnnExpr bndr annot) @@ -330,24 +606,34 @@ data AnnBind bndr annot \end{code} \begin{code} -deAnnotate :: AnnExpr bndr annot -> Expr bndr Unused +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e -deAnnotate (_, AnnType t) = Type t -deAnnotate (_, AnnVar v) = Var v -deAnnotate (_, AnnCon con args) = Con con (map deAnnotate args) -deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body) -deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate (_, AnnNote note body) = Note note (deAnnotate body) +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnNote note body) = Note note (deAnnotate body) -deAnnotate (_, AnnLet bind body) +deAnnotate' (AnnLet bind body) = Let (deAnnBind bind) (deAnnotate body) where deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] -deAnnotate (_, AnnCase scrut v alts) +deAnnotate' (AnnCase scrut v alts) = Case (deAnnotate scrut) v (map deAnnAlt alts) - where - deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) + +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}