diff options
Diffstat (limited to 'ghc/compiler')
| -rw-r--r-- | ghc/compiler/coreSyn/CoreSyn.lhs | 554 |
1 files changed, 147 insertions, 407 deletions
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 1cdba666a0..f7accde8ee 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -7,31 +7,22 @@ #include "HsVersions.h" module CoreSyn ( - CoreBinding(..), CoreExpr(..), CoreAtom(..), - CoreCaseAlternatives(..), CoreCaseDefault(..), -#ifdef DPH - CoreParQuals(..), - CoreParCommunicate(..), -#endif {- Data Parallel Haskell -} - mkCoTyApp, + GenCoreBinding(..), GenCoreExpr(..), GenCoreAtom(..), + GenCoreCaseAlternatives(..), GenCoreCaseDefault(..), pprCoreBinding, pprCoreExpr, - CoreArg(..), applyToArgs, decomposeArgs, collectArgs, + GenCoreArg(..), applyToArgs, decomposeArgs, collectArgs, -- and to make the interface self-sufficient ... - Id, UniType, TyVar, TyCon, PrimOp, BasicLit, - PprStyle, PrettyRep, CostCentre, Maybe ) where -import AbsPrel ( PrimOp, PrimKind +import PrelInfo ( PrimOp, PrimRep 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 Type ( isPrimType, pprParendUniType, TyVar, TyCon, Type ) -import BasicLit ( BasicLit ) +import Literal ( Literal ) import Id ( getIdUniType, isBottomingId, Id IF_ATTACK_PRAGMAS(COMMA bottomIsGuaranteed) ) @@ -43,218 +34,109 @@ import Util %************************************************************************ %* * -\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @CoreBinding@} +\subsection[CoreTopBinding_and_CoreBinding]{@CoreTopBinding@ and @GenCoreBinding@} %* * %************************************************************************ 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 +variables, called {\em binders} and {\em val_occ tyvar uvars}, respectively. [I don't really like the pair of names; I prefer {\em binder} and {\em bounder}. Or {\em binder} and {\em var}.] -A @CoreBinding@ is either a single non-recursive binding of a +A @GenCoreBinding@ 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)] +data GenCoreBinding val_bdr val_occ tyvar uvar + = NonRec val_bdr (GenCoreExpr val_bdr val_occ tyvar uvar) + | Rec [(val_bdr, GenCoreExpr val_bdr val_occ tyvar uvar)] \end{code} -%************************************************************************ -%* * -\subsection[CoreAtom]{Core atoms: @CoreAtom@} -%* * -%************************************************************************ - -Same deal as @StgAtoms@, except that, for @Core@, the atomic object -may need to be applied to some types. - -\begin{code} -data CoreAtom bindee - = CoVarAtom bindee - | CoLitAtom BasicLit -\end{code} %************************************************************************ %* * -\subsection[CoreExpr]{Core expressions: @CoreExpr@} +\subsection[GenCoreExpr]{Core expressions: @GenCoreExpr@} %* * %************************************************************************ -@CoreExpr@ is the heart of the ``core'' data types; it is +@GenCoreExpr@ 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@. +For types in the core world, we just keep using @Types@. \begin{code} -data CoreExpr binder bindee - = CoVar bindee - | CoLit BasicLit -- literal constants +data GenCoreExpr val_bdr val_occ tyvar uvar + = Var val_occ + | Lit Literal -- literal constants \end{code} -@CoCons@ and @CoPrims@ are saturated constructor and primitive-op -applications (see the comment). Note: @CoCon@s are only set up by the +@Cons@ and @Prims@ are saturated constructor and primitive-op +applications (see the comment). Note: @Con@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. +desugarer sets up constructors as applications of global @Vars@s. + \begin{code} - | CoCon Id [UniType] [CoreAtom bindee] - -- saturated constructor application: - -- the constructor is a function of the form: - -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> - -- <expr> 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). + | Con Id (GenType tyvar) [GenCoreArg val_occ tyvar uvar] + -- Saturated constructor application: + -- The constructor is a function of the form: + -- /\ a1 -> ... /\ am -> \ b1 -> ... \ bn -> + -- <expr> where "/\" is a type lambda and "\" the + -- regular kind; there will be "m" Types and + -- "n" bindees in the Con args. + -- + -- The type given is the result type of the application; + -- you can figure out the argument types from it if you want. + + | Prim PrimOp Type [GenCoreArg val_occ tyvar uvar] + -- saturated primitive operation; + -- comment on Cons applies here, too. + -- The types work the same way + -- (PrimitiveOps may be polymorphic). \end{code} -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. +Ye olde abstraction and application operators. \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 + | Lam (GenCoreBinder val_bdr tyvar uvar) + (GenCoreExpr val_bdr val_occ tyvar uvar) + + | App (GenCoreExpr val_bdr val_occ tyvar uvar) + (GenCoreArg val_occ tyvar uvar) \end{code} -Case expressions (\tr{case CoreExpr of <List of alternatives>}): there +Case expressions (\tr{case <expr> of <List of alternatives>}): there are really two flavours masquerading here---those for scrutinising {\em algebraic} types and those for {\em primitive} types. Please see -under @CoreCaseAlternatives@. +under @GenCoreCaseAlternatives@. \begin{code} - | CoCase (CoreExpr binder bindee) - (CoreCaseAlternatives binder bindee) + | Case (GenCoreExpr val_bdr val_occ tyvar uvar) + (GenCoreCaseAlternatives val_bdr val_occ tyvar uvar) \end{code} 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}). -Non-recursive @CoLets@ only have one binding; having more than one +Non-recursive @Lets@ 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} - -@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} - -@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} - -@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} - -@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 :-). - -\begin{code} -#ifdef DPH - | CoParZipWith - Int - (CoreExpr binder bindee) - [CoreExpr binder bindee] -#endif {- Data Parallel Haskell -} + | Let (GenCoreBinding val_bdr val_occ tyvar uvar) + (GenCoreExpr binder val_occ tyvar uvar) + -- both recursive and non-. + -- The "GenCoreBinding" records that information \end{code} For cost centre scc expressions we introduce a new core construct -@CoSCC@ so transforming passes have to deal with it explicitly. The +@SCC@ 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 - --- end of CoreExpr + | SCC CostCentre -- label of scc + (GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression \end{code} %************************************************************************ %* * -\subsection[CoreParQualifiers]{Parallel qualifiers in @CoreExpr@} -%* * -%************************************************************************ - -\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 -} -\end{code} - -%************************************************************************ -%* * -\subsection[ParCommunicate]{Parallel Communication primitives} -%* * -%************************************************************************ -\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 -} -\end{code} - -%************************************************************************ -%* * -\subsection[CoreCaseAlternatives]{Case alternatives in @CoreExpr@} +\subsection{Case alternatives in @GenCoreExpr@} %* * %************************************************************************ @@ -271,45 +153,29 @@ let# x=e in b \end{verbatim} becomes \begin{verbatim} -CoCase e [ CoBindDefaultAlt x -> b ] +Case e [ BindDefaultAlt 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 -} +data GenCoreCaseAlternatives val_bdr val_occ tyvar uvar + + = AlgAlts [(Id, -- alts: data constructor, + [val_bdr], -- constructor's parameters, + GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. + (GenCoreCaseDefault val_bdr val_occ tyvar uvar) + + | PrimAlts [(Literal, -- alts: unboxed literal, + GenCoreExpr val_bdr val_occ tyvar uvar)] -- rhs. + (GenCoreCaseDefault val_bdr val_occ tyvar uvar) -- obvious things: if there are no alts in the list, then the default --- can't be CoNoDefault. +-- can't be NoDefault. -data CoreCaseDefault binder bindee - = CoNoDefault -- small con family: all +data GenCoreCaseDefault val_bdr val_occ tyvar uvar + = NoDefault -- small con family: all -- constructor accounted for - | CoBindDefault binder -- form: var -> expr; - (CoreExpr binder bindee) -- "binder" may or may not + | BindDefault val_bdr -- form: var -> expr; + (GenCoreExpr val_bdr val_occ tyvar uvar) -- "val_bdr" may or may not -- be used in RHS. \end{code} @@ -320,51 +186,37 @@ data CoreCaseDefault binder bindee %************************************************************************ \begin{code} -data CoreArg bindee - = TypeArg UniType - | ValArg (CoreAtom bindee) +data GenCoreAtom val_occ tyvar uvar + = LitAtom Literal + | VarAtom val_occ + | TyAtom (GenType tyvar) + | UsageAtom (Usage uvar) -instance Outputable bindee => Outputable (CoreArg bindee) where - ppr sty (ValArg atom) = ppr sty atom - ppr sty (TypeArg ty) = ppr sty ty -\end{code} -\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 +===+*** fix from here down ****=== +================================= - 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 --} +instance Outputable bindee => Outputable (GenCoreArg bindee) where + ppr sty (ValArg atom) = ppr sty atom + ppr sty (TypeArg ty) = ppr sty ty \end{code} \begin{code} -applyToArgs :: CoreExpr binder bindee - -> [CoreArg bindee] - -> CoreExpr binder bindee +applyToArgs :: GenCoreExpr val_bdr bindee + -> [GenCoreArg bindee] + -> GenCoreExpr val_bdr bindee applyToArgs fun [] = fun -applyToArgs fun (ValArg val : args) = applyToArgs (CoApp fun val) args -applyToArgs fun (TypeArg ty : args) = applyToArgs (mkCoTyApp fun ty) args +applyToArgs fun (ValArg val : args) = applyToArgs (App fun val) args +applyToArgs fun (TypeArg ty : args) = applyToArgs (CoTyApp fun ty) args \end{code} @decomposeArgs@ just pulls of the contiguous TypeArg-then-ValArg block on the front of the args. Pretty common. \begin{code} -decomposeArgs :: [CoreArg bindee] - -> ([UniType], [CoreAtom bindee], [CoreArg bindee]) +decomposeArgs :: [GenCoreArg bindee] + -> ([Type], [GenCoreAtom bindee], [GenCoreArg bindee]) decomposeArgs [] = ([],[],[]) @@ -379,7 +231,7 @@ decomposeArgs (ValArg val : args) do_vals (ValArg val : args) = case (do_vals args) of { (vals, rest) -> (val:vals, rest) } - + do_vals args = ([], args) \end{code} @@ -387,13 +239,13 @@ decomposeArgs (ValArg val : args) and the arguments to which it is applied. \begin{code} -collectArgs :: CoreExpr binder bindee - -> (CoreExpr binder bindee, [CoreArg bindee]) +collectArgs :: GenCoreExpr val_bdr bindee + -> (GenCoreExpr val_bdr bindee, [GenCoreArg bindee]) collectArgs expr = collect expr [] where - collect (CoApp fun arg) args = collect fun (ValArg arg : args) + collect (App 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) \end{code} @@ -405,43 +257,43 @@ collectArgs expr %************************************************************************ @pprCoreBinding@ and @pprCoreExpr@ let you give special printing -function for ``major'' binders (those next to equal signs :-), +function for ``major'' val_bdrs (those next to equal signs :-), ``minor'' ones (lambda-bound, case-bound), and bindees. They would usually be called through some intermediary. \begin{code} pprCoreBinding :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs + -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreBinding bndr bdee + -> GenCoreBinding bndr bdee -> Pretty -pprCoreBinding sty pbdr1 pbdr2 pbdee (CoNonRec binder expr) - = ppHang (ppCat [pbdr1 sty binder, ppEquals]) +pprCoreBinding sty pbdr1 pbdr2 pbdee (NonRec val_bdr expr) + = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals]) 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) -pprCoreBinding sty pbdr1 pbdr2 pbdee (CoRec binds) - = ppAboves [ifPprDebug sty (ppStr "{- CoRec -}"), +pprCoreBinding sty pbdr1 pbdr2 pbdee (Rec binds) + = ppAboves [ifPprDebug sty (ppStr "{- Rec -}"), ppAboves (map ppr_bind binds), - ifPprDebug sty (ppStr "{- end CoRec -}")] + ifPprDebug sty (ppStr "{- end Rec -}")] where - ppr_bind (binder, expr) - = ppHang (ppCat [pbdr1 sty binder, ppEquals]) + ppr_bind (val_bdr, expr) + = ppHang (ppCat [pbdr1 sty val_bdr, ppEquals]) 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) \end{code} \begin{code} instance (Outputable bndr, Outputable bdee) - => Outputable (CoreBinding bndr bdee) where + => Outputable (GenCoreBinding bndr bdee) where ppr sty bind = pprCoreBinding sty ppr ppr ppr bind instance (Outputable bndr, Outputable bdee) - => Outputable (CoreExpr bndr bdee) where + => Outputable (GenCoreExpr bndr bdee) where ppr sty expr = pprCoreExpr sty ppr ppr ppr expr -instance Outputable bdee => Outputable (CoreAtom bdee) where +instance Outputable bdee => Outputable (GenCoreAtom bdee) where ppr sty atom = pprCoreAtom sty ppr atom \end{code} @@ -449,40 +301,40 @@ instance Outputable bdee => Outputable (CoreAtom bdee) where pprCoreAtom :: PprStyle -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreAtom bdee + -> GenCoreAtom bdee -> Pretty -pprCoreAtom sty pbdee (CoLitAtom lit) = ppr sty lit -pprCoreAtom sty pbdee (CoVarAtom v) = pbdee sty v +pprCoreAtom sty pbdee (LitAtom lit) = ppr sty lit +pprCoreAtom sty pbdee (VarAtom v) = pbdee sty v \end{code} \begin{code} pprCoreExpr, pprParendCoreExpr :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs + -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreExpr bndr bdee + -> GenCoreExpr bndr bdee -> Pretty -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoVar name) = pbdee sty name +pprCoreExpr sty pbdr1 pbdr2 pbdee (Var name) = pbdee sty name -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLit literal) = ppr sty literal +pprCoreExpr sty pbdr1 pbdr2 pbdee (Lit literal) = ppr sty literal -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con [] []) = ppr sty con +pprCoreExpr sty pbdr1 pbdr2 pbdee (Con con [] []) = ppr sty con -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCon con types args) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Con 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) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Prim 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 "->"]) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Lam val_bdr expr) + = ppHang (ppCat [ppStr "\\", pbdr2 sty val_bdr, ppStr "->"]) 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr) @@ -494,11 +346,11 @@ pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar 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 ) + collect_tyvars e@(Lam _ _) = ( [], 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) + collect_vars (Lam var e) = ([var]:varss, e_after) where (varss, e_after) = collect_vars e collect_vars other_e = ( [], other_e ) @@ -507,14 +359,14 @@ pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyLam tyvar expr) = ppCat [ppStr "\\", ppInterleave ppSP (map (pbdr2 sty) vars), ppStr "->", pp_varss varss] -pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(CoApp fun_expr atom) +pprCoreExpr sty pbdr1 pbdr2 pbdee expr@(App 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 (App fun arg) args = collect_args fun (arg:args) collect_args fun args = (fun, args) pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty) @@ -523,7 +375,7 @@ pprCoreExpr sty pbdr1 pbdr2 pbdee (CoTyApp expr ty) where pp_note = ifPprShowAll sty (ppStr "{-CoTyApp-} ") -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCase expr alts) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Case expr alts) = ppSep [ppSep [ppStr "case", ppNest 4 (pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr), ppStr "of {"], ppNest 2 (pprCoreCaseAlts sty pbdr1 pbdr2 pbdee alts), @@ -532,75 +384,54 @@ pprCoreExpr sty pbdr1 pbdr2 pbdee (CoCase expr alts) -- special cases: let ... in let ... -- ("disgusting" SLPJ) -pprCoreExpr sty pbdr1 pbdr2 pbdee (CoLet bind@(CoNonRec binder rhs@(CoLet _ _)) body) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = ppAboves [ - ppCat [ppStr "let {", pbdr1 sty binder, ppEquals], + ppCat [ppStr "let {", pbdr1 sty val_bdr, 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 _ _)) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = ppAbove (ppHang (ppStr "let {") - 2 (ppCat [ppHang (ppCat [pbdr1 sty binder, ppEquals]) + 2 (ppCat [ppHang (ppCat [pbdr1 sty val_bdr, 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) +pprCoreExpr sty pbdr1 pbdr2 pbdee (Let 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) +pprCoreExpr sty pbdr1 pbdr2 pbdee (SCC 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} \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 e@(Var _) = pprCoreExpr sty pbdr1 pbdr2 pbdee e +pprParendCoreExpr sty pbdr1 pbdr2 pbdee e@(Lit _) = 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} \begin{code} instance (Outputable bndr, Outputable bdee) - => Outputable (CoreCaseAlternatives bndr bdee) where + => Outputable (GenCoreCaseAlternatives bndr bdee) where ppr sty alts = pprCoreCaseAlts sty ppr ppr ppr alts \end{code} \begin{code} pprCoreCaseAlts :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs + -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreCaseAlternatives bndr bdee + -> GenCoreCaseAlternatives bndr bdee -> Pretty -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoAlgAlts alts deflt) +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (AlgAlts alts deflt) = ppAboves [ ppAboves (map ppr_alt alts), pprCoreCaseDefault sty pbdr1 pbdr2 pbdee deflt ] where @@ -615,124 +446,33 @@ pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoAlgAlts alts deflt) then ppBesides [ppLparen, ppr sty con, ppRparen] else ppr sty con -pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (CoPrimAlts alts deflt) +pprCoreCaseAlts sty pbdr1 pbdr2 pbdee (PrimAlts 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) - -#endif /* Data Parallel Haskell */ \end{code} \begin{code} instance (Outputable bndr, Outputable bdee) - => Outputable (CoreCaseDefault bndr bdee) where + => Outputable (GenCoreCaseDefault bndr bdee) where ppr sty deflt = pprCoreCaseDefault sty ppr ppr ppr deflt \end{code} \begin{code} pprCoreCaseDefault :: PprStyle - -> (PprStyle -> bndr -> Pretty) -- to print "major" binders - -> (PprStyle -> bndr -> Pretty) -- to print "minor" binders + -> (PprStyle -> bndr -> Pretty) -- to print "major" val_bdrs + -> (PprStyle -> bndr -> Pretty) -- to print "minor" val_bdrs -> (PprStyle -> bdee -> Pretty) -- to print bindees - -> CoreCaseDefault bndr bdee + -> GenCoreCaseDefault bndr bdee -> Pretty -pprCoreCaseDefault sty pbdr1 pbdr2 pbdee CoNoDefault = ppNil +pprCoreCaseDefault sty pbdr1 pbdr2 pbdee NoDefault = ppNil -pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (CoBindDefault binder expr) - = ppHang (ppCat [pbdr2 sty binder, ppStr "->"]) +pprCoreCaseDefault sty pbdr1 pbdr2 pbdee (BindDefault val_bdr expr) + = ppHang (ppCat [pbdr2 sty val_bdr, ppStr "->"]) 4 (pprCoreExpr sty pbdr1 pbdr2 pbdee expr) \end{code} - -\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 -} -\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]))) - where - ppSendFns expr dim - = ppCat [ppStr "Dim" , ppr sty dim , ppStr "=" , - pprParendCoreExpr sty pbdr1 pbdr2 pbdee expr ] - -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoToPodized) - = ppStr "ConvertToPodized" - -pprCoreParCommunicate sty pbdr1 pbdr2 pbdee (CoFromPodized) - = ppStr "ConvertFromPodized" -#endif {- Data Parallel Haskell -} -\end{code} |