X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreSyn.lhs;h=4c70bb33e1c0b963947407fe3f665c6d95892161;hb=49bff3215bf3fe9ada24dac2cf80f97db4e597dd;hp=1cdba666a082cfb7ddb046704de6fce7d091ac7a;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 1cdba66..4c70bb3 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -1,738 +1,639 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CoreSyn]{A data type for the Haskell compiler midsection} \begin{code} -#include "HsVersions.h" - module CoreSyn ( - CoreBinding(..), CoreExpr(..), CoreAtom(..), - CoreCaseAlternatives(..), CoreCaseDefault(..), -#ifdef DPH - CoreParQuals(..), - CoreParCommunicate(..), -#endif {- Data Parallel Haskell -} - mkCoTyApp, - pprCoreBinding, pprCoreExpr, - - CoreArg(..), applyToArgs, decomposeArgs, collectArgs, - - -- and to make the interface self-sufficient ... - Id, UniType, TyVar, TyCon, PrimOp, BasicLit, - PprStyle, PrettyRep, CostCentre, Maybe + Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..), + CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), + + mkLets, mkLams, + mkApps, mkTyApps, mkValApps, mkVarApps, + mkLit, mkIntLitInt, mkIntLit, + mkConApp, + varToCoreExpr, + + isTyVar, isId, + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, + collectArgs, + coreExprCc, + flattenBinds, + + 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, 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 -import AbsPrel ( PrimOp, PrimKind - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AbsUniType ( isPrimType, pprParendUniType, TyVar, TyCon, UniType - IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar) - IF_ATTACK_PRAGMAS(COMMA cmpUniType) - ) -import BasicLit ( BasicLit ) -import Id ( getIdUniType, isBottomingId, Id - IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) - ) +#include "HsVersions.h" + +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 -import Pretty -import CostCentre ( showCostCentre, CostCentre ) -import Util \end{code} %************************************************************************ %* * -\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @CoreBinding@} +\subsection{The main data types} %* * %************************************************************************ -Core programs, bindings, expressions, etc., are parameterised with -respect to the information kept about binding and bound occurrences of -variables, called {\em binders} and {\em bindees}, respectively. [I -don't really like the pair of names; I prefer {\em binder} and {\em -bounder}. Or {\em binder} and {\em var}.] +These data types are the heart of the compiler -A @CoreBinding@ is either a single non-recursive binding of a -``binder'' to an expression, or a mutually-recursive blob of same. \begin{code} -data CoreBinding binder bindee - = CoNonRec binder (CoreExpr binder bindee) - | CoRec [(binder, CoreExpr binder bindee)] +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 + 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[CoreAtom]{Core atoms: @CoreAtom@} +\subsection{Transformation rules} %* * %************************************************************************ -Same deal as @StgAtoms@, except that, for @Core@, the atomic object -may need to be applied to some types. +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 + +rulesRhsFreeVars :: CoreRules -> VarSet +rulesRhsFreeVars (Rules _ fvs) = fvs + +rulesRules :: CoreRules -> [CoreRule] +rulesRules (Rules rules _) = rules +\end{code} \begin{code} -data CoreAtom bindee - = CoVarAtom bindee - | CoLitAtom BasicLit +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} + %************************************************************************ %* * -\subsection[CoreExpr]{Core expressions: @CoreExpr@} +\subsection{@Unfolding@ type} %* * %************************************************************************ -@CoreExpr@ is the heart of the ``core'' data types; it is -(more-or-less) boiled-down second-order polymorphic lambda calculus. -For types in the core world, we just keep using @UniTypes@. -\begin{code} -data CoreExpr binder bindee - = CoVar bindee - | CoLit BasicLit -- literal constants -\end{code} +The @Unfolding@ type is declared here to avoid numerous loops, but it +should be abstract everywhere except in CoreUnfold.lhs -@CoCons@ and @CoPrims@ are saturated constructor and primitive-op -applications (see the comment). Note: @CoCon@s are only set up by the -simplifier (and by the desugarer when it knows what it's doing). The -desugarer sets up constructors as applications of global @CoVars@s. \begin{code} - | CoCon Id [UniType] [CoreAtom bindee] - -- saturated constructor application: - -- the constructor is a function of the form: - -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> - -- where "/\" is a type lambda and "\" the - -- regular kind; there will be "m" UniTypes and - -- "n" bindees in the CoCon args. - - | CoPrim PrimOp [UniType] [CoreAtom bindee] - -- saturated primitive operation; - -- comment on CoCons applies here, too. - -- The types work the same way - -- (PrimitiveOps may be polymorphic). -\end{code} +data Unfolding + = NoUnfolding -Lambdas have multiple binders; this is good for the lambda lifter. -Single binders may be simulated easily with multiple binders; vice -versa is a pain. -\begin{code} - | CoLam [binder] -- lambda var_1 ... var_n -> CoreExpr - (CoreExpr binder bindee) - | CoTyLam TyVar -- Lambda TyVar -> CoreExpr - (CoreExpr binder bindee) - - | CoApp (CoreExpr binder bindee) - (CoreAtom bindee) - | CoTyApp (CoreExpr binder bindee) - UniType -- type application -\end{code} + | 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. -Case expressions (\tr{case CoreExpr of }): there -are really two flavours masquerading here---those for scrutinising -{\em algebraic} types and those for {\em primitive} types. Please see -under @CoreCaseAlternatives@. -\begin{code} - | CoCase (CoreExpr binder bindee) - (CoreCaseAlternatives binder bindee) -\end{code} + | CompulsoryUnfolding CoreExpr -- There is no "original" definition, + -- so you'd better unfold. -A Core case expression \tr{case e of v -> ...} implies evaluation of -\tr{e}; it is not equivalent to \tr{let v = in ...} (as with a Haskell -\tr{case}). + | 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. -Non-recursive @CoLets@ only have one binding; having more than one -doesn't buy you much, and it is an easy way to mess up variable -scoping. -\begin{code} - | CoLet (CoreBinding binder bindee) - (CoreExpr binder bindee) - -- both recursive and non-. - -- The "CoreBinding" records that information -\end{code} -@build@ as a function is a *PAIN*. See Andy's thesis for -futher details. This is equivalent to: -@ - build unitype (/\ tyvar \ c n -> expr) -@ -\begin{code} ---ANDY: --- | CoBuild UniType TyVar binder binder (CoreExpr binder bindee) -\end{code} +data UnfoldingGuidance + = UnfoldNever + | UnfoldIfGoodArgs Int -- and "n" value args -@CoZfExpr@ exist in the core language, along with their qualifiers. After -succesive optimisations to the sequential bindings, we desugar the -@CoZfExpr@ into a subset of the core language without them - ``podization''. -\begin{code} -#ifdef DPH - | CoZfExpr (CoreExpr binder bindee) - (CoreParQuals binder bindee) -#endif {- Data Parallel Haskell -} -\end{code} + [Int] -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. -@CoParCon@ is the parallel equivalent to the sequential @CoCon@ expression. -They are introduced into the core syntax by a pass of the compiler that -removes the parallel ZF expressions, and {\em vectorises} ordinary sequential -functions. -\begin{code} -#ifdef DPH - | CoParCon Id Int [UniType] [CoreExpr binder bindee] --ToDo:DPH: CoreAtom -#endif {- Data Parallel Haskell -} -\end{code} + Int -- The "size" of the unfolding; to be elaborated + -- later. ToDo -@CoParCommunicate@ constructs are introduced by the desugaring of parallel -ZF expressions. -\begin{code} -#ifdef DPH - | CoParComm - Int - (CoreExpr binder bindee) - (CoreParCommunicate binder bindee) -#endif {- Data Parallel Haskell -} -\end{code} + 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.) -@CoParZipWith@ constructs are introduced whenever podization fails during the -desuagring of ZF expressions. These constructs represent zipping the function -represented by the first @CoreExpr@ with the list of @CoreExpr@'s (hopefully -we wont see this that often in the resultant program :-). +noUnfolding = NoUnfolding +mkOtherCon = OtherCon -\begin{code} -#ifdef DPH - | CoParZipWith - Int - (CoreExpr binder bindee) - [CoreExpr binder bindee] -#endif {- Data Parallel Haskell -} +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} -For cost centre scc expressions we introduce a new core construct -@CoSCC@ so transforming passes have to deal with it explicitly. The -alternative of using a new PrimativeOp may result in a bad -transformations of which we are unaware. \begin{code} - | CoSCC CostCentre -- label of scc - (CoreExpr binder bindee) -- scc expression +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 --- end of CoreExpr +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[CoreParQualifiers]{Parallel qualifiers in @CoreExpr@} +\subsection{The main data type} %* * %************************************************************************ \begin{code} -#ifdef DPH -data CoreParQuals binder bindee - = CoAndQuals (CoreParQuals binder bindee) - (CoreParQuals binder bindee) - | CoParFilter (CoreExpr binder bindee) - | CoDrawnGen [binder] - (binder) - (CoreExpr binder bindee) - | CoIndexGen [CoreExpr binder bindee] - (binder) - (CoreExpr binder bindee) -#endif {- Data Parallel Haskell -} +-- 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} + %************************************************************************ %* * -\subsection[ParCommunicate]{Parallel Communication primitives} +\subsection{Useful synonyms} %* * %************************************************************************ + +The common case + \begin{code} -#ifdef DPH -data CoreParCommunicate binder bindee - = CoParSend [CoreExpr binder bindee] -- fns of form Integer -> Integer - | CoParFetch [CoreExpr binder bindee] -- to determine where moved - | CoToPodized - | CoFromPodized -#endif {- Data Parallel Haskell -} +type CoreBndr = Var +type CoreExpr = Expr CoreBndr +type CoreArg = Arg CoreBndr +type CoreBind = Bind CoreBndr +type CoreAlt = Alt CoreBndr \end{code} +Binders are ``tagged'' with a \tr{t}: + +\begin{code} +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 '>' + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple +\end{code} + + %************************************************************************ %* * -\subsection[CoreCaseAlternatives]{Case alternatives in @CoreExpr@} +\subsection{Core-constructing functions with checking} %* * %************************************************************************ -We have different kinds of @case@s, the differences being reflected in -the kinds of alternatives a case has. We maintain a distinction -between cases for scrutinising algebraic datatypes, as opposed to -primitive types. In both cases, we carry around a @TyCon@, as a -handle with which we can get info about the case (e.g., total number -of data constructors for this type). - -For example: -\begin{verbatim} -let# x=e in b -\end{verbatim} -becomes -\begin{verbatim} -CoCase e [ CoBindDefaultAlt x -> b ] -\end{verbatim} - \begin{code} -data CoreCaseAlternatives binder bindee - - = CoAlgAlts [(Id, -- alts: data constructor, - [binder], -- constructor's parameters, - CoreExpr binder bindee)] -- rhs. - (CoreCaseDefault binder bindee) - - | CoPrimAlts [(BasicLit, -- alts: unboxed literal, - CoreExpr binder bindee)] -- rhs. - (CoreCaseDefault binder bindee) -#ifdef DPH - | CoParAlgAlts - TyCon - Int - [binder] - [(Id, - CoreExpr binder bindee)] - (CoreCaseDefault binder bindee) - - | CoParPrimAlts - TyCon - Int - [(BasicLit, - CoreExpr binder bindee)] - (CoreCaseDefault binder bindee) -#endif {- Data Parallel Haskell -} - --- obvious things: if there are no alts in the list, then the default --- can't be CoNoDefault. - -data CoreCaseDefault binder bindee - = CoNoDefault -- small con family: all - -- constructor accounted for - | CoBindDefault binder -- form: var -> expr; - (CoreExpr binder bindee) -- "binder" may or may not - -- be used in RHS. +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 + +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 + +mkLit lit = Lit lit +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr Let body binds + +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[CoreSyn-arguments]{Core ``argument'' wrapper type} +\subsection{Simple access functions} %* * %************************************************************************ \begin{code} -data CoreArg bindee - = TypeArg UniType - | ValArg (CoreAtom bindee) +bindersOf :: Bind b -> [b] +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] -instance Outputable bindee => Outputable (CoreArg bindee) where - ppr sty (ValArg atom) = ppr sty atom - ppr sty (TypeArg ty) = ppr sty ty -\end{code} +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds -\begin{code} -mkCoTyApp expr ty = CoTyApp expr ty - -{- OLD: unboxed tyapps now allowed! -mkCoTyApp expr ty -#ifdef DEBUG - | isPrimType ty && not (error_app expr) - = pprPanic "mkCoTyApp:" (ppr PprDebug ty) -#endif - | otherwise = ty_app - where - ty_app = CoTyApp expr ty +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] - error_app (CoVar id) {-| isBottomingId id-} = True -- debugging - -- OOPS! can't do this because it forces - -- the bindee type to be Id (ToDo: what?) WDP 95/02 - error_app _ = False --} -\end{code} - -\begin{code} -applyToArgs :: CoreExpr binder bindee - -> [CoreArg bindee] - -> CoreExpr binder bindee +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] -applyToArgs fun [] = fun -applyToArgs fun (ValArg val : args) = applyToArgs (CoApp fun val) args -applyToArgs fun (TypeArg ty : args) = applyToArgs (mkCoTyApp fun ty) args +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} -@decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block -on the front of the args. Pretty common. +We often want to strip off leading lambdas before getting down to +business. @collectBinders@ is your friend. + +We expect (by convention) type-, and value- lambdas in that +order. \begin{code} -decomposeArgs :: [CoreArg bindee] - -> ([UniType], [CoreAtom bindee], [CoreArg bindee]) +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) -decomposeArgs [] = ([],[],[]) +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) -decomposeArgs (TypeArg ty : args) - = case (decomposeArgs args) of { (tys, vals, rest) -> - (ty:tys, vals, rest) } +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) -decomposeArgs (ValArg val : args) - = case (do_vals args) of { (vals, rest) -> - ([], val:vals, rest) } +collectValBinders expr + = go [] expr where - do_vals (ValArg val : args) - = case (do_vals args) of { (vals, rest) -> - (val:vals, rest) } - - do_vals args = ([], args) + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) \end{code} + @collectArgs@ takes an application expression, returning the function and the arguments to which it is applied. \begin{code} -collectArgs :: CoreExpr binder bindee - -> (CoreExpr binder bindee, [CoreArg bindee]) - +collectArgs :: Expr b -> (Expr b, [Arg b]) collectArgs expr - = collect expr [] + = go expr [] where - collect (CoApp fun arg) args = collect fun (ValArg arg : args) - collect (CoTyApp fun ty) args = collect fun (TypeArg ty : args) - collect other_expr args = (other_expr, args) + go (App f a) as = go f (a:as) + go e as = (e, as) +\end{code} + +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 -> CostCentre +coreExprCc (Note (SCC cc) e) = cc +coreExprCc (Note other_note e) = coreExprCc e +coreExprCc (Lam _ e) = coreExprCc e +coreExprCc other = noCostCentre \end{code} + + %************************************************************************ %* * -\subsection[CoreSyn-output]{Instance declarations for output} +\subsection{Predicates} %* * %************************************************************************ -@pprCoreBinding@ and @pprCoreExpr@ let you give special printing -function for ``major'' binders (those next to equal signs :-), -``minor'' ones (lambda-bound, case-bound), and bindees. They would -usually be called through some intermediary. +@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} -pprCoreBinding - :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders - -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreBinding bndr bdee - -> Pretty - -pprCoreBinding sty pbdr1 pbdr2 pbdee (CoNonRec binder expr) - = ppHang (ppCat [pbdr1 sty binder, ppEquals]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) - -pprCoreBinding sty pbdr1 pbdr2 pbdee (CoRec binds) - = ppAboves [ifPprDebug sty (ppStr "{- CoRec -}"), - ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end CoRec -}")] - where - ppr_bind (binder, expr) - = ppHang (ppCat [pbdr1 sty binder, ppEquals]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) +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} -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreBinding bndr bdee) where - ppr sty bind = pprCoreBinding sty ppr ppr ppr bind +isValArg (Type _) = False +isValArg other = True -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreExpr bndr bdee) where - ppr sty expr = pprCoreExpr sty ppr ppr ppr expr +isTypeArg (Type _) = True +isTypeArg other = False -instance Outputable bdee => Outputable (CoreAtom bdee) where - ppr sty atom = pprCoreAtom sty ppr atom -\end{code} +valBndrCount :: [CoreBndr] -> Int +valBndrCount [] = 0 +valBndrCount (b : bs) | isId b = 1 + valBndrCount bs + | otherwise = valBndrCount bs -\begin{code} -pprCoreAtom - :: PprStyle - -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreAtom bdee - -> Pretty - -pprCoreAtom sty pbdee (CoLitAtom lit) = ppr sty lit -pprCoreAtom sty pbdee (CoVarAtom v) = pbdee sty v +valArgCount :: [Arg b] -> Int +valArgCount [] = 0 +valArgCount (Type _ : args) = valArgCount args +valArgCount (other : args) = 1 + valArgCount args \end{code} -\begin{code} -pprCoreExpr, pprParendCoreExpr - :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders - -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreExpr bndr bdee - -> Pretty - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoVar name) = pbdee sty name - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLit literal) = ppr sty literal - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con [] []) = ppr sty con - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con types args) - = ppHang (ppBesides [ppr sty con, ppChar '!']) - 4 (ppSep ( (map (pprParendUniType sty) types) - ++ (map (pprCoreAtom sty pbdee) args))) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoPrim prim tys args) - = ppHang (ppBesides [ppr sty prim, ppChar '!']) - 4 (ppSep ( (map (pprParendUniType sty) tys) - ++ (map (pprCoreAtom sty pbdee) args) )) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLam binders expr) - = ppHang (ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) binders), ppStr "->"]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr) - = ppHang (ppCat [ppStr "/\\", interppSP sty (tyvar:tyvars), - ppStr "->", pp_varss var_lists]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr_after) - where - (tyvars, var_lists, expr_after) = collect_tyvars expr - - collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, vs, e_after ) - where (tyvs, vs, e_after) = collect_tyvars e - collect_tyvars e@(CoLam _ _) = ( [], vss, e_after ) - where (vss, e_after) = collect_vars e - collect_tyvars other_e = ( [], [], other_e ) - - collect_vars (CoLam vars e) = (vars:varss, e_after) - where (varss, e_after) = collect_vars e - collect_vars other_e = ( [], other_e ) - - pp_varss [] = ppNil - pp_varss (vars:varss) - = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars), - ppStr "->", pp_varss varss] - -pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(CoApp fun_expr atom) - = let - (fun, args) = collect_args expr [] - in - ppHang (pprParendCoreExpr sty pbdr1 pbdr2 pbdee fun) - 4 (ppSep (map (pprCoreAtom sty pbdee) args)) - where - collect_args (CoApp fun arg) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty) - = ppHang (ppBeside pp_note (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr)) - 4 (pprParendUniType sty ty) - where - pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ") - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCase expr alts) - = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr), - ppStr "of {"], - ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts), - ppStr "}"] - --- special cases: let ... in let ... --- ("disgusting" SLPJ) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind@(CoNonRec binder rhs@(CoLet _ _)) body) - = ppAboves [ - ppCat [ppStr "let {", pbdr1 sty binder, ppEquals], - ppNest 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs), - ppStr "} in", - pprCoreExpr sty pbdr1 pbdr2 pbdee body ] - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind@(CoNonRec binder rhs) expr@(CoLet _ _)) - = ppAbove - (ppHang (ppStr "let {") - 2 (ppCat [ppHang (ppCat [pbdr1 sty binder, ppEquals]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee rhs), - ppStr "} in"])) - (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) - --- general case (recursive case, too) -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind expr) - = ppSep [ppHang (ppStr "let {") 2 (pprCoreBinding sty pbdr1 pbdr2 pbdee bind), - ppHang (ppStr "} in ") 2 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr)] - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoSCC cc expr) - = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], - pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] -#ifdef DPH -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoZfExpr expr quals) - = ppHang (ppCat [ppStr "<<" , pprCoreExpr sty pbdr1 pbdr2 pbdee expr , ppStr "|"]) - 4 (ppSep [pprParQuals sty pbdr1 pbdr2 pbdee quals, ppStr ">>"]) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParCon con dim types args) - = ppHang (ppBesides [ppr sty con, ppStr "!<<" , ppr sty dim , ppStr ">>"]) - 4 (ppSep ( (map (pprParendUniType sty) types) - ++ (map (pprParendCoreExpr sty pbdr1 pbdr2 pbdee) args) )) - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParComm dim expr comType) - = ppSep [ppSep [ppStr "COMM", - ppNest 2 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr),ppStr "{"], - ppNest 2 (ppr sty comType), - ppStr "}"] - -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoParZipWith dim expr exprs) - = ppHang (ppBesides [ ppStr "CoParZipWith {" , ppr sty dim , ppStr "}", - pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr]) - 4 (ppr sty exprs) -#endif {- Data Parallel Haskell -} -\end{code} +%************************************************************************ +%* * +\subsection{Seq stuff} +%* * +%************************************************************************ \begin{code} -pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(CoVar _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e -pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(CoLit _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e -pprParendCoreExpr sty pbdr1 pbdr2 pbdee other_e - = ppBesides [ppLparen, pprCoreExpr sty pbdr1 pbdr2 pbdee other_e, ppRparen] -\end{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 -\begin{code} -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreCaseAlternatives bndr bdee) where - ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts -\end{code} +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es -\begin{code} -pprCoreCaseAlts - :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders - -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreCaseAlternatives bndr bdee - -> Pretty - -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoAlgAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), - pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ] - where - ppr_alt (con, params, expr) - = ppHang (ppCat [ppr_con con, - ppInterleave ppSP (map (pbdr2 sty) params), - ppStr "->"]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) - where - ppr_con con - = if isOpLexeme con - then ppBesides [ppLparen, ppr sty con, ppRparen] - else ppr sty con - -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoPrimAlts alts deflt) - = ppAboves [ ppAboves (map ppr_alt alts), - pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ] - where - ppr_alt (lit, expr) - = ppHang (ppCat [ppr sty lit, ppStr "->"]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) - -#ifdef DPH --- ToDo: niceties of printing --- using special binder/bindee printing funs, rather than just "ppr" - -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoParAlgAlts tycon dim params alts deflt) - = ppAboves [ ifPprShowAll sty (ppr sty tycon), - ppBeside (ppCat (map (ppr sty) params)) - (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]), - ppAboves (map (ppr_alt sty) alts), - ppr sty deflt ] - where - ppr_alt sty (con, expr) - = ppHang (ppCat [ppStr "\\/", ppr_con sty con, ppStr "->"]) - 4 (ppr sty expr) - where - ppr_con sty con - = if isOpLexeme con - then ppBesides [ppLparen, ppr sty con, ppRparen] - else ppr sty con - -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoParPrimAlts tycon dim alts deflt) - = ppAboves [ ifPprShowAll sty (ppr sty tycon), - ppCat [ppStr "|" , ppr sty dim , ppStr "|"], - ppAboves (map (ppr_alt sty) alts), - ppr sty deflt ] - where - ppr_alt sty (lit, expr) - = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr) +seqNote (Coerce t1 t2) = seqType t1 `seq` seqType t2 +seqNote (CoreNote s) = s `seq` () +seqNote other = () -#endif /* Data Parallel Haskell */ -\end{code} +seqBndr b = b `seq` () -\begin{code} -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreCaseDefault bndr bdee) where - ppr sty deflt = pprCoreCaseDefault sty ppr ppr ppr deflt -\end{code} +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs -\begin{code} -pprCoreCaseDefault - :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders - -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreCaseDefault bndr bdee - -> Pretty - -pprCoreCaseDefault sty pbdr1 pbdr2 pbdee CoNoDefault = ppNil - -pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (CoBindDefault binder expr) - = ppHang (ppCat [pbdr2 sty binder, ppStr "->"]) - 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) +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} +%* * +%************************************************************************ + \begin{code} -#ifdef DPH -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreParQuals bndr bdee) where - ppr sty qual = pprParQuals sty ppr ppr ppr qual - -pprParQuals sty pbdr1 pbdr2 pbdee (CoAndQuals x y) - = ppAboves [(ppBesides [pprParQuals sty pbdr1 pbdr2 pbdee x , ppComma]) , pprParQuals sty pbdr1 pbdr2 pbdee y] - -pprParQuals sty pbdr1 pbdr2 pbdee (CoDrawnGen pats pat expr) - = ppCat [ppStr "(|", - ppInterleave ppComma (map (ppr sty) pats), - ppSemi, ppr sty pat,ppStr "|)", - ppStr "<<-", pprCoreExpr sty pbdr1 pbdr2 pbdee expr] - -pprParQuals sty pbdr1 pbdr2 pbdee (CoIndexGen exprs pat expr) - = ppCat [ppStr "(|", - ppInterleave ppComma (map (pprCoreExpr sty pbdr1 pbdr2 pbdee) exprs), - ppSemi, ppr sty pat,ppStr "|)", - ppStr "<<=", pprCoreExpr sty pbdr1 pbdr2 pbdee expr] - -pprParQuals sty pbdr1 pbdr2 pbdee (CoParFilter expr) - = pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr -#endif {- Data Parallel Haskell -} +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +data AnnExpr' bndr annot + = AnnVar Id + | 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 (AnnExpr bndr annot) + | AnnType Type + +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) + +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] \end{code} \begin{code} -#ifdef DPH -instance (Outputable bndr, Outputable bdee) - => Outputable (CoreParCommunicate bndr bdee) where - ppr sty c = pprCoreParCommunicate sty ppr ppr ppr c - -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoParSend fns) - = ppHang - (ppStr "SEND") - 4 - (ppAboves (zipWith ppSendFns fns ([1..]::[Int]))) - where - ppSendFns expr dim - = ppCat [ppStr "Dim" , ppr sty dim , ppStr "=" , - pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] - -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoParFetch fns) - = ppHang - (ppStr "FETCH") - 4 - (ppAboves (zipWith ppSendFns fns ([1..]::[Int]))) +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +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) + = Let (deAnnBind bind) (deAnnotate body) where - ppSendFns expr dim - = ppCat [ppStr "Dim" , ppr sty dim , ppStr "=" , - pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] + deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) + deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoToPodized) - = ppStr "ConvertToPodized" +deAnnotate' (AnnCase scrut v alts) + = Case (deAnnotate scrut) v (map deAnnAlt alts) -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoFromPodized) - = ppStr "ConvertFromPodized" -#endif {- Data Parallel Haskell -} +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}