X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=704be4b1de1a4118f9f0208983a8b827f6f29a97;hb=83817d01dff687643eee23218435b968ba358a25;hp=577498d63dbdcf3dc3afa01a0b77eb43714dafe3;hpb=e7d21ee4f8ac907665a7e170c71d59e13a01da09;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 577498d..704be4b 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} @@ -9,17 +9,12 @@ form of @CoreSyntax@, the style being one that happens to be ideally suited to spineless tagless code generation. \begin{code} -#include "HsVersions.h" - module StgSyn ( - StgAtom(..), - StgLiveVars(..), + GenStgArg(..), + GenStgLiveVars, - StgBinding(..), StgExpr(..), StgRhs(..), - StgCaseAlternatives(..), StgCaseDefault(..), -#ifdef DPH - StgParCommunicate(..), -#endif {- Data Parallel Haskell -} + GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgCaseAlts(..), GenStgCaseDefault(..), UpdateFlag(..), @@ -29,119 +24,83 @@ module StgSyn ( combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation - PlainStgAtom(..), PlainStgLiveVars(..), PlainStgProgram(..), - PlainStgBinding(..), PlainStgExpr(..), PlainStgRhs(..), - PlainStgCaseAlternatives(..), PlainStgCaseDefault(..), - - pprPlainStgBinding, ---UNUSED: fvsFromAtoms, - getAtomKind, - isLitLitStgAtom, + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, + StgCaseAlts, StgCaseDefault, + + pprStgBinding, pprStgBindings, + getArgPrimRep, + isLitLitArg, stgArity, - collectExportedStgBinders, - - -- and to make the interface self-sufficient... - Outputable(..), NamedThing(..), Pretty(..), - Unique, ExportFlag, SrcLoc, PprStyle, PrettyRep, - - BasicLit, Class, ClassOp, - - Binds, Expr, GRHS, GRHSsAndBinds, InPat, - - Id, IdInfo, Maybe, Name, FullName, ShortName, - PrimKind, PrimOp, CostCentre, TyCon, TyVar, - UniqSet(..), UniqFM, Bag, - TyVarTemplate, UniType, TauType(..), - ThetaType(..), SigmaType(..), - TyVarEnv(..), IdEnv(..) - - IF_ATTACK_PRAGMAS(COMMA isLitLitLit) - IF_ATTACK_PRAGMAS(COMMA cmpTyCon COMMA cmpTyVar COMMA cmpClass) - IF_ATTACK_PRAGMAS(COMMA cmpUniType) + collectFinalStgBinders ) where -import AbsPrel ( getPrimOpResultInfo, PrimOpResultInfo(..), - PrimOp, PrimKind - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import AbsSyn ( Binds, Expr, GRHS, GRHSsAndBinds, InPat ) -import AbsUniType -import BasicLit ( typeOfBasicLit, kindOfBasicLit, isLitLitLit, - BasicLit(..) -- (..) for pragmas - ) -import Id ( getIdUniType, getIdKind, toplevelishId, - isTopLevId, Id, IdInfo - ) -import Maybes ( Maybe(..), catMaybes ) -import Outputable -import Pretty -import PrimKind ( PrimKind ) +#include "HsVersions.h" + import CostCentre ( showCostCentre, CostCentre ) -import UniqSet -import Unique -import Util +import Id ( idPrimRep, DataCon, + GenId{-instance NamedThing-}, Id ) +import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) +import Outputable +import PrimOp ( PrimOp{-instance Outputable-} ) +import Type ( Type ) +import Unique ( pprUnique, Unique ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) +import Util ( panic ) \end{code} %************************************************************************ %* * -\subsection[StgBinding]{@StgBinding@} +\subsection{@GenStgBinding@} %* * %************************************************************************ As usual, expressions are interesting; other things are boring. Here -are the boring things [except note the @StgRhs@], parameterised with -respect to binder and bindee information (just as in @CoreSyntax@): -\begin{code} -data StgBinding binder bindee - = StgNonRec binder (StgRhs binder bindee) - | StgRec [(binder, StgRhs binder bindee)] -\end{code} +are the boring things [except note the @GenStgRhs@], parameterised +with respect to binder and occurrence information (just as in +@CoreSyn@): -An @StgProgram@ is just a list of @StgBindings@; the -properties/restrictions-on this list are the same as for a -@CoreProgram@ (a list of @CoreBindings@). \begin{code} ---type StgProgram binder bindee = [StgBinding binder bindee] +data GenStgBinding bndr occ + = StgNonRec bndr (GenStgRhs bndr occ) + | StgRec [(bndr, GenStgRhs bndr occ)] + | StgCoerceBinding bndr occ -- UNUSED? \end{code} %************************************************************************ %* * -\subsection[StgAtom]{@StgAtom@} +\subsection{@GenStgArg@} %* * %************************************************************************ \begin{code} -data StgAtom bindee - = StgVarAtom bindee - | StgLitAtom BasicLit +data GenStgArg occ + = StgVarArg occ + | StgLitArg Literal + | StgConArg DataCon -- A nullary data constructor \end{code} \begin{code} -getAtomKind (StgVarAtom local) = getIdKind local -getAtomKind (StgLitAtom lit) = kindOfBasicLit lit +getArgPrimRep (StgVarArg local) = idPrimRep local +getArgPrimRep (StgConArg con) = idPrimRep con +getArgPrimRep (StgLitArg lit) = literalPrimRep lit -{- UNUSED happily -fvsFromAtoms :: [PlainStgAtom] -> (UniqSet Id) -- ToDo: this looks like a HACK to me (WDP) -fvsFromAtoms as = mkUniqSet [ id | (StgVarAtom id) <- as, not (toplevelishId id) ] --} - -isLitLitStgAtom (StgLitAtom x) = isLitLitLit x -isLitLitStgAtom _ = False +isLitLitArg (StgLitArg x) = isLitLitLit x +isLitLitArg _ = False \end{code} %************************************************************************ %* * -\subsection[StgExpr]{STG expressions} +\subsection{STG expressions} %* * %************************************************************************ -The @StgExpr@ data type is parameterised on binder and bindee info, as -before. +The @GenStgExpr@ data type is parameterised on binder and occurrence +info, as before. %************************************************************************ %* * -\subsubsection[StgExpr-application]{@StgExpr@ application} +\subsubsection{@GenStgExpr@ application} %* * %************************************************************************ @@ -153,13 +112,13 @@ their closures first.) There is no constructor for a lone variable; it would appear as @StgApp var [] _@. \begin{code} -type StgLiveVars bindee = UniqSet bindee +type GenStgLiveVars occ = UniqSet occ -data StgExpr binder bindee - = StgApp - (StgAtom bindee) -- function - [StgAtom bindee] -- arguments - (StgLiveVars bindee) -- Live vars in continuation; ie not +data GenStgExpr bndr occ + = StgApp + (GenStgArg occ) -- function + [GenStgArg occ] -- arguments + (GenStgLiveVars occ) -- Live vars in continuation; ie not -- including the function and args -- NB: a literal is: StgApp [] ... @@ -167,23 +126,23 @@ data StgExpr binder bindee %************************************************************************ %* * -\subsubsection[StgExpr-apps]{@StgConApp@ and @StgPrimApp@---saturated applications} +\subsubsection{@StgCon@ and @StgPrim@---saturated applications} %* * %************************************************************************ There are two specialised forms of application, for constructors and primitives. \begin{code} - | StgConApp -- always saturated + | StgCon -- always saturated Id -- data constructor - [StgAtom bindee] - (StgLiveVars bindee) -- Live vars in continuation; ie not + [GenStgArg occ] + (GenStgLiveVars occ) -- Live vars in continuation; ie not -- including the constr and args - | StgPrimApp -- always saturated + | StgPrim -- always saturated PrimOp - [StgAtom bindee] - (StgLiveVars bindee) -- Live vars in continuation; ie not + [GenStgArg occ] + (GenStgLiveVars occ) -- Live vars in continuation; ie not -- including the op and args \end{code} These forms are to do ``inline versions,'' as it were. @@ -191,21 +150,21 @@ An example might be: @f x = x:[]@. %************************************************************************ %* * -\subsubsection[StgExpr-case]{@StgExpr@: case-expressions} +\subsubsection{@GenStgExpr@: case-expressions} %* * %************************************************************************ This has the same boxed/unboxed business as Core case expressions. \begin{code} | StgCase - (StgExpr binder bindee) + (GenStgExpr bndr occ) -- the thing to examine - (StgLiveVars bindee) -- Live vars of whole case + (GenStgLiveVars occ) -- Live vars of whole case -- expression; i.e., those which mustn't be -- overwritten - (StgLiveVars bindee) -- Live vars of RHSs; + (GenStgLiveVars occ) -- Live vars of RHSs; -- i.e., those which must be saved before eval. -- -- note that an alt's constructor's @@ -217,12 +176,12 @@ This has the same boxed/unboxed business as Core case expressions. -- variable to hold the tag of a primop with -- algebraic result - (StgCaseAlternatives binder bindee) + (GenStgCaseAlts bndr occ) \end{code} %************************************************************************ %* * -\subsubsection[StgExpr-lets]{@StgExpr@: @let(rec)@-expressions} +\subsubsection{@GenStgExpr@: @let(rec)@-expressions} %* * %************************************************************************ @@ -304,7 +263,7 @@ f x y = let z = huge-expression in \item We may eventually want: \begin{verbatim} -let-literal x = BasicLit +let-literal x = Literal in e \end{verbatim} @@ -314,26 +273,26 @@ in e And so the code for let(rec)-things: \begin{code} | StgLet - (StgBinding binder bindee) -- right hand sides (see below) - (StgExpr binder bindee) -- body + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body | StgLetNoEscape -- remember: ``advanced stuff'' - (StgLiveVars bindee) -- Live in the whole let-expression + (GenStgLiveVars occ) -- Live in the whole let-expression -- Mustn't overwrite these stack slots -- *Doesn't* include binders of the let(rec). - (StgLiveVars bindee) -- Live in the right hand sides (only) + (GenStgLiveVars occ) -- Live in the right hand sides (only) -- These are the ones which must be saved on -- the stack if they aren't there already -- *Does* include binders of the let(rec) if recursive. - (StgBinding binder bindee) -- right hand sides (see below) - (StgExpr binder bindee) -- body + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body \end{code} %************************************************************************ %* * -\subsubsection[StgExpr-scc]{@StgExpr@: @scc@ expressions} +\subsubsection{@GenStgExpr@: @scc@ expressions} %* * %************************************************************************ @@ -341,52 +300,31 @@ Finally for @scc@ expressions we introduce a new STG construct. \begin{code} | StgSCC - UniType -- the type of the body + Type -- the type of the body CostCentre -- label of SCC expression - (StgExpr binder bindee) -- scc expression + (GenStgExpr bndr occ) -- scc expression + -- end of GenStgExpr \end{code} %************************************************************************ %* * -\subsection[DataParallel]{Data parallel extensions to STG syntax} -%* * -%************************************************************************ - -\begin{code} -#ifdef DPH - | StgParConApp -- saturated parallel constructor - Id - Int -- What parallel context - [StgAtom bindee] - (StgLiveVars bindee) - - | StgParComm - Int - (StgExpr binder bindee) -- The thing we are communicating - (StgParCommunicate binder bindee) -#endif {- Data Parallel Haskell -} - -- end of StgExpr -\end{code} - -%************************************************************************ -%* * -\subsection[StgRhs]{STG right-hand sides} +\subsection{STG right-hand sides} %* * %************************************************************************ Here's the rest of the interesting stuff for @StgLet@s; the first flavour is for closures: \begin{code} -data StgRhs binder bindee +data GenStgRhs bndr occ = StgRhsClosure CostCentre -- cost centre to be attached (default is CCC) StgBinderInfo -- Info about how this binder is used (see below) - [bindee] -- non-global free vars; a list, rather than + [occ] -- non-global free vars; a list, rather than -- a set, because order is important UpdateFlag -- ReEntrant | Updatable | SingleEntry - [binder] -- arguments; if empty, then not a function; + [bndr] -- arguments; if empty, then not a function; -- as above, order is important - (StgExpr binder bindee) -- body + (GenStgExpr bndr occ) -- body \end{code} An example may be in order. Consider: \begin{verbatim} @@ -409,14 +347,13 @@ The second flavour of right-hand-side is for constructors (simple but important) -- data in heap profiles, and we don't set CCC -- from static closure. Id -- constructor - [StgAtom bindee] -- args + [GenStgArg occ] -- args \end{code} Here's the @StgBinderInfo@ type, and its combining op: \begin{code} -data StgBinderInfo +data StgBinderInfo = NoStgBinderInfo - | StgBinderInfo Bool -- At least one occurrence as an argument @@ -431,7 +368,7 @@ data StgBinderInfo Bool -- At least one fake application occurrence, that is -- an StgApp f args where args is an empty list -- This is due to the fact that we do not have a - -- StgVar constructor. + -- StgVar constructor. -- Used by the lambda lifter. -- True => "at least one unsat app" is True too @@ -441,7 +378,7 @@ stgStdHeapOcc = StgBinderInfo False False True False False stgNoUpdHeapOcc = StgBinderInfo False False False True False stgNormalOcc = StgBinderInfo False False False False False -- [Andre] can't think of a good name for the last one. -stgFakeFunAppOcc = StgBinderInfo False True False False True +stgFakeFunAppOcc = StgBinderInfo False True False False True combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo @@ -465,81 +402,46 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) Just like in @CoreSyntax@ (except no type-world stuff). \begin{code} -data StgCaseAlternatives binder bindee - = StgAlgAlts UniType -- so we can find out things about constructor family +data GenStgCaseAlts bndr occ + = StgAlgAlts Type -- so we can find out things about constructor family [(Id, -- alts: data constructor, - [binder], -- constructor's parameters, + [bndr], -- constructor's parameters, [Bool], -- "use mask", same length as -- parameters; a True in a -- param's position if it is -- used in the ... - StgExpr binder bindee)] -- ...right-hand side. - (StgCaseDefault binder bindee) - | StgPrimAlts UniType -- so we can find out things about constructor family - [(BasicLit, -- alts: unboxed literal, - StgExpr binder bindee)] -- rhs. - (StgCaseDefault binder bindee) -#ifdef DPH - | StgParAlgAlts - UniType - Int -- What context we are in - [binder] - [(Id,StgExpr binder bindee)] - (StgCaseDefault binder bindee) - | StgParPrimAlts UniType - Int -- What context we are in - [(BasicLit, -- alts: unboxed literal, - StgExpr binder bindee)] -- rhs. - (StgCaseDefault binder bindee) -#endif {- Data Parallel Haskell -} - -data StgCaseDefault binder bindee + GenStgExpr bndr occ)] -- ...right-hand side. + (GenStgCaseDefault bndr occ) + | StgPrimAlts Type -- so we can find out things about constructor family + [(Literal, -- alts: unboxed literal, + GenStgExpr bndr occ)] -- rhs. + (GenStgCaseDefault bndr occ) + +data GenStgCaseDefault bndr occ = StgNoDefault -- small con family: all -- constructor accounted for - | StgBindDefault binder -- form: var -> expr + | StgBindDefault bndr -- form: var -> expr Bool -- True <=> var is used in rhs -- i.e., False <=> "_ -> expr" - (StgExpr binder bindee) + (GenStgExpr bndr occ) \end{code} %************************************************************************ %* * -\subsection[Stg-parComummunicate]{Communication operations} -%* * -%************************************************************************ - -\begin{code} -#ifdef DPH -data StgParCommunicate binder bindee - = StgParSend - [StgAtom bindee] -- Sending PODs - - | StgParFetch - [StgAtom bindee] -- Fetching PODs - - | StgToPodized -- Convert a POD to the podized form - - | StgFromPodized -- Convert a POD from the podized form -#endif {- Data Parallel Haskell -} -\end{code} - -%************************************************************************ -%* * -\subsection[PlainStg]{The Plain STG parameterisation} +\subsection[Stg]{The Plain STG parameterisation} %* * %************************************************************************ This happens to be the only one we use at the moment. \begin{code} -type PlainStgProgram = [StgBinding Id Id] -type PlainStgBinding = StgBinding Id Id -type PlainStgAtom = StgAtom Id -type PlainStgLiveVars= UniqSet Id -type PlainStgExpr = StgExpr Id Id -type PlainStgRhs = StgRhs Id Id -type PlainStgCaseAlternatives = StgCaseAlternatives Id Id -type PlainStgCaseDefault = StgCaseDefault Id Id +type StgBinding = GenStgBinding Id Id +type StgArg = GenStgArg Id +type StgLiveVars = GenStgLiveVars Id +type StgExpr = GenStgExpr Id Id +type StgRhs = GenStgRhs Id Id +type StgCaseAlts = GenStgCaseAlts Id Id +type StgCaseDefault = GenStgCaseDefault Id Id \end{code} %************************************************************************ @@ -547,15 +449,15 @@ type PlainStgCaseDefault = StgCaseDefault Id Id \subsubsection[UpdateFlag-datatype]{@UpdateFlag@} %* * %************************************************************************ - + This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. - + \begin{code} data UpdateFlag = ReEntrant | Updatable | SingleEntry - + instance Outputable UpdateFlag where - ppr sty u - = ppChar (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) + ppr u + = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) \end{code} %************************************************************************ @@ -570,29 +472,13 @@ final pre-codegen STG code, so as to be sure we have the latest/greatest pragma info. \begin{code} -collectExportedStgBinders - :: [PlainStgBinding] -- input: PlainStgProgram - -> [Id] -- exported top-level Ids +collectFinalStgBinders + :: [StgBinding] -- input program + -> [Id] -collectExportedStgBinders binds - = exported_from_here [] binds - where - exported_from_here es [] = es - - exported_from_here es ((StgNonRec b _) : binds) - = if not (isExported b) then - exported_from_here es binds - else - exported_from_here (b:es) binds - - exported_from_here es ((StgRec []) : binds) - = exported_from_here es binds - - exported_from_here es ((StgRec ((b, rhs) : pairs)) : binds) - = exported_from_here - es - (StgNonRec b rhs : (StgRec pairs : binds)) - -- OK, a total hack; laziness rules +collectFinalStgBinders [] = [] +collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds +collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds \end{code} %************************************************************************ @@ -605,277 +491,225 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's hoping he likes terminators instead... Ditto for case alternatives. \begin{code} -pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> StgBinding bndr bdee -> Pretty +pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgBinding bndr bdee -> SDoc -pprStgBinding sty (StgNonRec binder rhs) - = ppHang (ppCat [ppr sty binder, ppEquals]) - 4 (ppBeside (ppr sty rhs) ppSemi) +pprGenStgBinding (StgNonRec bndr rhs) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr rhs) semi) -pprStgBinding sty (StgRec pairs) - = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) : - (map (ppr_bind sty) pairs)) +pprGenStgBinding (StgCoerceBinding bndr occ) + = hang (hsep [ppr bndr, equals, ptext SLIT("{-Coerce-}")]) + 4 ((<>) (ppr occ) semi) + +pprGenStgBinding (StgRec pairs) + = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where - ppr_bind sty (binder, expr) - = ppHang (ppCat [ppr sty binder, ppEquals]) - 4 (ppBeside (ppr sty expr) ppSemi) + ppr_bind (bndr, expr) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr expr) semi) + +pprStgBinding :: StgBinding -> SDoc +pprStgBinding bind = pprGenStgBinding bind -pprPlainStgBinding :: PprStyle -> PlainStgBinding -> Pretty -pprPlainStgBinding sty b = pprStgBinding sty b +pprStgBindings :: [StgBinding] -> SDoc +pprStgBindings binds = vcat (map (pprGenStgBinding) binds) \end{code} \begin{code} -instance (Outputable bdee) => Outputable (StgAtom bdee) where - ppr = pprStgAtom +instance (Outputable bdee) => Outputable (GenStgArg bdee) where + ppr = pprStgArg instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (StgBinding bndr bdee) where - ppr = pprStgBinding + => Outputable (GenStgBinding bndr bdee) where + ppr = pprGenStgBinding instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (StgExpr bndr bdee) where + => Outputable (GenStgExpr bndr bdee) where ppr = pprStgExpr -{- OLD: -instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (StgCaseDefault bndr bdee) where - ppr sty deflt = panic "ppr:StgCaseDefault" --} - instance (Outputable bndr, Outputable bdee, Ord bdee) - => Outputable (StgRhs bndr bdee) where - ppr sty rhs = pprStgRhs sty rhs + => Outputable (GenStgRhs bndr bdee) where + ppr rhs = pprStgRhs rhs \end{code} \begin{code} -pprStgAtom :: (Outputable bdee) => PprStyle -> StgAtom bdee -> Pretty +pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc -pprStgAtom sty (StgVarAtom var) = ppr sty var -pprStgAtom sty (StgLitAtom lit) = ppr sty lit +pprStgArg (StgVarArg var) = ppr var +pprStgArg (StgConArg con) = ppr con +pprStgArg (StgLitArg lit) = ppr lit \end{code} \begin{code} -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> StgExpr bndr bdee -> Pretty +pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgExpr bndr bdee -> SDoc -- special case -pprStgExpr sty (StgApp func [] lvs) - = ppBeside (ppr sty func) (pprStgLVs sty lvs) +pprStgExpr (StgApp func [] lvs) + = (<>) (ppr func) (pprStgLVs lvs) -- general case -pprStgExpr sty (StgApp func args lvs) - = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs)) - 4 (ppSep (map (ppr sty) args)) +pprStgExpr (StgApp func args lvs) + = hang ((<>) (ppr func) (pprStgLVs lvs)) + 4 (sep (map (ppr) args)) \end{code} \begin{code} -pprStgExpr sty (StgConApp con args lvs) - = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs), - ppStr "! [", interppSP sty args, ppStr "]" ] +pprStgExpr (StgCon con args lvs) + = hcat [ (<>) (ppr con) (pprStgLVs lvs), + ptext SLIT("! ["), interppSP args, char ']' ] -pprStgExpr sty (StgPrimApp op args lvs) - = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs, - ppStr " [", interppSP sty args, ppStr "]" ] +pprStgExpr (StgPrim op args lvs) + = hcat [ ppr op, char '#', pprStgLVs lvs, + ptext SLIT(" ["), interppSP args, char ']' ] \end{code} \begin{code} -- special case: let v = -- in -- let ... --- in +-- in -- ... -- -- Very special! Suspicious! (SLPJ) -pprStgExpr sty (StgLet (StgNonRec binder (StgRhsClosure cc bi free_vars upd_flag args rhs)) +pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) expr@(StgLet _ _)) - = ppAbove - (ppHang (ppBesides [ppStr "let { ", ppr sty binder, ppStr " = ", - ppStr (showCostCentre sty True{-as string-} cc), - pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\", - ppr sty upd_flag, ppStr " [", - interppSP sty args, ppStr "]"]) - 8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]])) - (ppr sty expr) + = ($$) + (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "), + text (showCostCentre True{-as string-} cc), + pp_binder_info bi, + ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"), + ppr upd_flag, ptext SLIT(" ["), + interppSP args, char ']']) + 8 (sep [hsep [ppr rhs, ptext SLIT("} in")]])) + (ppr expr) -- special case: let ... in let ... -pprStgExpr sty (StgLet bind expr@(StgLet _ _)) - = ppAbove - (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])]) - (ppr sty expr) +pprStgExpr (StgLet bind expr@(StgLet _ _)) + = ($$) + (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])]) + (ppr expr) -- general case -pprStgExpr sty (StgLet bind expr) - = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind), - ppHang (ppStr "} in ") 2 (ppr sty expr)] - -pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr) - = ppSep [ppHang (ppStr "let-no-escape {") - 2 (pprStgBinding sty bind), - ppHang (ppBeside (ppStr "} in ") - (ifPprDebug sty ( - ppNest 4 ( - ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), - ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), - ppStr "]"])))) - 2 (ppr sty expr)] +pprStgExpr (StgLet bind expr) + = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind), + hang (ptext SLIT("} in ")) 2 (ppr expr)] + +pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) + = sep [hang (ptext SLIT("let-no-escape {")) + 2 (pprGenStgBinding bind), + hang ((<>) (ptext SLIT("} in ")) + (ifPprDebug ( + nest 4 ( + hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + char ']'])))) + 2 (ppr expr)] \end{code} \begin{code} -pprStgExpr sty (StgSCC ty cc expr) - = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)], - pprStgExpr sty expr ] +pprStgExpr (StgSCC ty cc expr) + = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)], + pprStgExpr expr ] \end{code} \begin{code} -pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts) - = ppSep [ppSep [ppStr "case", - ppNest 4 (ppCat [pprStgExpr sty expr, - ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]), - ppStr "of {"], - ifPprDebug sty ( - ppNest 4 ( - ppBesides [ppStr "-- lvs: [", interppSP sty (uniqSetToList lvs_whole), - ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss), - ppStr "]; uniq: ", pprUnique uniq])), - ppNest 2 (ppr_alts sty alts), - ppStr "}"] +pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts) + = sep [sep [ptext SLIT("case"), + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (ptext SLIT("::") <> pp_ty alts)]), + ptext SLIT("of {")], + ifPprDebug ( + nest 4 ( + hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + ptext SLIT("]; uniq: "), pprUnique uniq])), + nest 2 (ppr_alts alts), + char '}'] where - pp_ty (StgAlgAlts ty _ _) = ppr sty ty - pp_ty (StgPrimAlts ty _ _) = ppr sty ty - - ppr_alts sty (StgAlgAlts ty alts deflt) - = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts), - ppr_default sty deflt ] + ppr_default StgNoDefault = empty + ppr_default (StgBindDefault bndr used expr) + = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr) where - ppr_bxd_alt sty (con, params, use_mask, expr) - = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"]) - 4 (ppBeside (ppr sty expr) ppSemi) - where - ppr_con sty con - = if isOpLexeme con - then ppBesides [ppLparen, ppr sty con, ppRparen] - else ppr sty con - - ppr_alts sty (StgPrimAlts ty alts deflt) - = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts), - ppr_default sty deflt ] - where - ppr_ubxd_alt sty (lit, expr) - = ppHang (ppCat [ppr sty lit, ppStr "->"]) - 4 (ppBeside (ppr sty expr) ppSemi) - -#ifdef DPH - ppr_alts sty (StgParAlgAlts ty dim params alts deflt) - = ppAboves [ ppBeside (ppCat (map (ppr sty) params)) - (ppCat [ppStr "|" , ppr sty dim , ppStr "|"]), - ppAboves (map (ppr_bxd_alt sty) alts), - ppr_default sty deflt ] - where - ppr_bxd_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 - - ppr_alts sty (StgParPrimAlts ty dim alts deflt) - = ppAboves [ ifPprShowAll sty (ppr sty ty), - ppCat [ppStr "|" , ppr sty dim , ppStr "|"], - ppAboves (map (ppr_ubxd_alt sty) alts), - ppr_default sty deflt ] - where - ppr_ubxd_alt sty (lit, expr) - = ppHang (ppCat [ppStr "\\/", ppr sty lit, ppStr "->"]) 4 (ppr sty expr) -#endif {- Data Parallel Haskell -} + pp_binder = if used then ppr bndr else char '_' + + pp_ty (StgAlgAlts ty _ _) = ppr ty + pp_ty (StgPrimAlts ty _ _) = ppr ty - ppr_default sty StgNoDefault = ppNil - ppr_default sty (StgBindDefault binder used expr) - = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) + ppr_alts (StgAlgAlts ty alts deflt) + = vcat [ vcat (map (ppr_bxd_alt) alts), + ppr_default deflt ] where - pp_binder = if used then ppr sty binder else ppChar '_' -\end{code} + ppr_bxd_alt (con, params, use_mask, expr) + = hang (hsep [ppr con, interppSP params, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) -\begin{code} -#ifdef DPH -pprStgExpr sty (StgParConApp con dim args lvs) - = ppBesides [ppr sty con, pprStgLVs sty lvs, ppStr "!<<" ,ppr sty dim , - ppStr ">> [", interppSP sty args, ppStr "]" ] - -pprStgExpr sty (StgParComm dim expr comm) - = ppSep [ppSep [ppStr "COMM ", - ppNest 2 (pprStgExpr sty expr),ppStr "{"], - ppNest 2 (ppr_comm sty comm), - ppStr "}"] - where - ppr_comm sty (StgParSend args) - = ppSep [ppStr "SEND [",interppSP sty args, ppStr "]" ] - ppr_comm sty (StgParFetch args) - = ppSep [ppStr "FETCH [",interppSP sty args, ppStr "]" ] - ppr_comm sty (StgToPodized) - = ppStr "ToPodized" - ppr_comm sty (StgFromPodized) - = ppStr "FromPodized" -#endif {- Data Parallel Haskell -} + ppr_alts (StgPrimAlts ty alts deflt) + = vcat [ vcat (map (ppr_ubxd_alt) alts), + ppr_default deflt ] + where + ppr_ubxd_alt (lit, expr) + = hang (hsep [ppr lit, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) \end{code} \begin{code} --- pprStgLVs :: PprStyle -> StgLiveVars bindee -> Pretty - -pprStgLVs PprForUser lvs = ppNil - -pprStgLVs sty lvs - = if isEmptyUniqSet lvs then - ppNil +pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc +pprStgLVs lvs + = getPprStyle $ \ sty -> + if userStyle sty || isEmptyUniqSet lvs then + empty else - ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"] + hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] \end{code} \begin{code} -pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> StgRhs bndr bdee -> Pretty +pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgRhs bndr bdee -> SDoc -- special case -pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) - = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), - pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (ppr sty free_var), - ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ] +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs)) + = hcat [ text (showCostCentre True{-as String-} cc), + pp_binder_info bi, + brackets (ifPprDebug (ppr free_var)), + ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ] + -- general case -pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) - = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), - pp_binder_info sty bi, - ppStr " [", ifPprDebug sty (interppSP sty free_vars), - ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"]) - 4 (ppr sty body) +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) + = hang (hcat [text (showCostCentre True{-as String-} cc), + pp_binder_info bi, + brackets (ifPprDebug (interppSP free_vars)), + ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)]) + 4 (ppr body) -pprStgRhs sty (StgRhsCon cc con args) - = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), - ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ] +pprStgRhs (StgRhsCon cc con args) + = hcat [ text (showCostCentre True{-as String-} cc), + space, ppr con, ptext SLIT("! "), brackets (interppSP args)] -------------- -pp_binder_info PprForUser _ = ppNil -pp_binder_info sty NoStgBinderInfo = ppNil +pp_binder_info NoStgBinderInfo = empty -- cases so boring that we print nothing -pp_binder_info sty (StgBinderInfo True b c d e) = ppNil +pp_binder_info (StgBinderInfo True b c d e) = empty -- general case -pp_binder_info sty (StgBinderInfo a b c d e) - = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')'] - where - pp_bool x = ppr (panic "pp_bool") x +pp_binder_info (StgBinderInfo a b c d e) + = getPprStyle $ \ sty -> + if userStyle sty then + empty + else + parens (hsep (punctuate comma (map ppr [a,b,c,d,e]))) \end{code} Collect @IdInfo@ stuff that is most easily just snaffled straight from the STG bindings. \begin{code} -stgArity :: PlainStgRhs -> Int +stgArity :: StgRhs -> Int stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied stgArity (StgRhsClosure _ _ _ _ args _ ) = length args