X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=c0d94bcc09ea2344741a564d9c8e015cde5a4e24;hb=9fc29e6eedbb0cee53960a0664d99c0b2c33f3d7;hp=456a7f8e56e47d9deb239432eadb05b445bc0549;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 456a7f8..c0d94bc 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-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} @@ -9,16 +9,14 @@ 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 ( GenStgArg(..), - GenStgLiveVars(..), + GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgCaseAlts(..), GenStgCaseDefault(..), - UpdateFlag(..), + UpdateFlag(..), isUpdatable, StgBinderInfo(..), stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc, @@ -26,42 +24,36 @@ module StgSyn ( combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation - StgArg(..), StgLiveVars(..), - StgBinding(..), StgExpr(..), StgRhs(..), - StgCaseAlts(..), StgCaseDefault(..), - - pprPlainStgBinding, - getArgPrimRep, - isLitLitArg, - stgArity, - collectExportedStgBinders - - -- and to make the interface self-sufficient... + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, + StgCaseAlts, StgCaseDefault, + + -- SRTs + SRT(..), noSRT, + + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, + getArgPrimRep, pprStgAlts, + isLitLitArg, isDllConApp, isStgTypeArg, + stgArity, stgArgType, + collectFinalStgBinders + +#ifdef DEBUG + , pprStgLVs +#endif ) where -import Ubiq{-uitous-} - -{- -import PrelInfo ( getPrimOpResultInfo, PrimOpResultInfo(..), - PrimOp, PrimRep - IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp) - IF_ATTACK_PRAGMAS(COMMA pprPrimOp) - ) -import HsSyn ( HsBinds, HsExpr, GRHS, GRHSsAndBinds, InPat ) -import Type -import Literal ( literalPrimRep, isLitLitLit, - Literal(..) -- (..) for pragmas - ) -import Id ( idType, getIdPrimRep, toplevelishId, - isTopLevId, Id, IdInfo - ) -import Maybes ( Maybe(..), catMaybes ) +#include "HsVersions.h" + +import CostCentre ( CostCentreStack, CostCentre ) +import Id ( Id, idName, idPrimRep, idType ) +import Name ( isDllName ) +import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) +import DataCon ( DataCon, dataConName ) +import PrimOp ( PrimOp ) import Outputable -import Pretty -import CostCentre ( showCostCentre, CostCentre ) -import UniqSet -import Util --} +import Type ( Type ) +import TyCon ( TyCon ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) \end{code} %************************************************************************ @@ -90,15 +82,35 @@ data GenStgBinding bndr occ \begin{code} data GenStgArg occ = StgVarArg occ - | StgLitArg Literal + | StgLitArg Literal + | StgTypeArg Type -- For when we want to preserve all type info \end{code} \begin{code} -getArgPrimRep (StgVarArg local) = getIdPrimRep local -getArgPrimRep (StgLitArg lit) = literalPrimRep lit - -isLitLitArg (StgLitArg x) = isLitLitLit x -isLitLitArg _ = False +getArgPrimRep (StgVarArg local) = idPrimRep local +getArgPrimRep (StgLitArg lit) = literalPrimRep lit + +isLitLitArg (StgLitArg lit) = isLitLitLit lit +isLitLitArg _ = False + +isStgTypeArg (StgTypeArg _) = True +isStgTypeArg other = False + +isDllArg :: StgArg -> Bool + -- Does this argument refer to something in a different DLL? +isDllArg (StgVarArg v) = isDllName (idName v) +isDllArg (StgLitArg lit) = isLitLitLit lit + +isDllConApp :: DataCon -> [StgArg] -> Bool + -- Does this constructor application refer to + -- anything in a different DLL? + -- If so, we can't allocate it statically +isDllConApp con args = isDllName (dataConName con) || any isDllArg args + +stgArgType :: StgArg -> Type + -- Very half baked becase we have lost the type arguments +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit \end{code} %************************************************************************ @@ -128,37 +140,46 @@ type GenStgLiveVars occ = UniqSet occ data GenStgExpr bndr occ = StgApp - (GenStgArg occ) -- function - [GenStgArg occ] -- arguments - (GenStgLiveVars occ) -- Live vars in continuation; ie not - -- including the function and args + occ -- function + [GenStgArg occ] -- arguments; may be empty +\end{code} - -- NB: a literal is: StgApp [] ... +%************************************************************************ +%* * +\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} +%* * +%************************************************************************ + +There are a specialised forms of application, for +constructors, primitives, and literals. +\begin{code} + | StgLit Literal + + | StgConApp DataCon + [GenStgArg occ] -- Saturated + + | StgPrimApp PrimOp + [GenStgArg occ] -- Saturated + Type -- Result type; we need to know the result type + -- so that we can assign result registers. \end{code} %************************************************************************ %* * -\subsubsection{@StgCon@ and @StgPrim@---saturated applications} +\subsubsection{@StgLam@} %* * %************************************************************************ -There are two specialised forms of application, for -constructors and primitives. +StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished +it encodes (\x -> e) as (let f = \x -> e in f) + \begin{code} - | StgCon -- always saturated - Id -- data constructor - [GenStgArg occ] - (GenStgLiveVars occ) -- Live vars in continuation; ie not - -- including the constr and args - - | StgPrim -- always saturated - PrimOp - [GenStgArg occ] - (GenStgLiveVars occ) -- Live vars in continuation; ie not - -- including the op and args + | StgLam + Type -- Type of whole lambda (useful when making a binder for it) + [bndr] + StgExpr -- Body of lambda \end{code} -These forms are to do ``inline versions,'' as it were. -An example might be: @f x = x:[]@. + %************************************************************************ %* * @@ -183,10 +204,9 @@ This has the same boxed/unboxed business as Core case expressions. -- binder-variables are NOT counted in the -- free vars for the alt's RHS - Unique -- Occasionally needed to compile case - -- statements, as the uniq for a local - -- variable to hold the tag of a primop with - -- algebraic result + bndr -- binds the result of evaluating the scrutinee + + SRT -- The SRT for the continuation (GenStgCaseAlts bndr occ) \end{code} @@ -312,7 +332,6 @@ Finally for @scc@ expressions we introduce a new STG construct. \begin{code} | StgSCC - Type -- the type of the body CostCentre -- label of SCC expression (GenStgExpr bndr occ) -- scc expression -- end of GenStgExpr @@ -329,13 +348,14 @@ flavour is for closures: \begin{code} data GenStgRhs bndr occ = StgRhsClosure - CostCentre -- cost centre to be attached (default is CCC) + CostCentreStack -- CCS to be attached (default is CurrentCCS) StgBinderInfo -- Info about how this binder is used (see below) + SRT -- The closures's SRT [occ] -- non-global free vars; a list, rather than -- a set, because order is important UpdateFlag -- ReEntrant | Updatable | SingleEntry [bndr] -- arguments; if empty, then not a function; - -- as above, order is important + -- as above, order is important. (GenStgExpr bndr occ) -- body \end{code} An example may be in order. Consider: @@ -353,12 +373,12 @@ will be exactly that in parentheses above. The second flavour of right-hand-side is for constructors (simple but important): \begin{code} | StgRhsCon - CostCentre -- Cost centre to be attached (default is CCC). + CostCentreStack -- CCS to be attached (default is CurrentCCS). -- Top-level (static) ones will end up with - -- DontCareCC, because we don't count static - -- data in heap profiles, and we don't set CCC + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS -- from static closure. - Id -- constructor + DataCon -- constructor [GenStgArg occ] -- args \end{code} @@ -413,10 +433,34 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) Just like in @CoreSyntax@ (except no type-world stuff). +* Algebraic cases are done using + StgAlgAlts (Just tc) alts deflt + +* Polymorphic cases, or case of a function type, are done using + StgAlgAlts Nothing [] (StgBindDefault e) + +* Primitive cases are done using + StgPrimAlts tc alts deflt + +We thought of giving polymorphic cases their own constructor, +but we get a bit more code sharing this way + +The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not +to be abstract; that is, we can see its representation. This is +important because the code generator uses it to determine return +conventions etc. But it's not trivial where there's a moduule loop +involved, because some versions of a type constructor might not have +all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures +that it gets the TyCon from the constructors or literals (which are +guaranteed to have the Real McCoy) rather than from the scrutinee type. + \begin{code} data GenStgCaseAlts bndr occ - = StgAlgAlts Type -- so we can find out things about constructor family - [(Id, -- alts: data constructor, + = StgAlgAlts (Maybe TyCon) -- Just tc => scrutinee type is + -- an algebraic data type + -- Nothing => scrutinee type is a type + -- variable or function type + [(DataCon, -- alts: data constructor, [bndr], -- constructor's parameters, [Bool], -- "use mask", same length as -- parameters; a True in a @@ -424,7 +468,8 @@ data GenStgCaseAlts bndr occ -- used in the ... GenStgExpr bndr occ)] -- ...right-hand side. (GenStgCaseDefault bndr occ) - | StgPrimAlts Type -- so we can find out things about constructor family + + | StgPrimAlts TyCon [(Literal, -- alts: unboxed literal, GenStgExpr bndr occ)] -- rhs. (GenStgCaseDefault bndr occ) @@ -432,10 +477,7 @@ data GenStgCaseAlts bndr occ data GenStgCaseDefault bndr occ = StgNoDefault -- small con family: all -- constructor accounted for - | StgBindDefault bndr -- form: var -> expr - Bool -- True <=> var is used in rhs - -- i.e., False <=> "_ -> expr" - (GenStgExpr bndr occ) + | StgBindDefault (GenStgExpr bndr occ) \end{code} %************************************************************************ @@ -464,12 +506,43 @@ type StgCaseDefault = GenStgCaseDefault Id Id This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module. +A @ReEntrant@ closure may be entered multiple times, but should not be +updated or blackholed. An @Updatable@ closure should be updated after +evaluation (and may be blackholed during evaluation). A @SingleEntry@ +closure will only be entered once, and so need not be updated but may +safely be blackholed. + \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' }) + +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True +\end{code} + +%************************************************************************ +%* * +\subsubsection[Static Reference Tables]{@SRT@} +%* * +%************************************************************************ + +There is one SRT per top-level function group. Each local binding and +case expression within this binding group has a subrange of the whole +SRT, expressed as an offset and length. + +\begin{code} +data SRT = NoSRT + | SRT !Int{-offset-} !Int{-length-} + +noSRT :: SRT +noSRT = NoSRT + +pprSRT (NoSRT) = ptext SLIT("_no_srt_") +pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len) \end{code} %************************************************************************ @@ -484,26 +557,13 @@ final pre-codegen STG code, so as to be sure we have the latest/greatest pragma info. \begin{code} -collectExportedStgBinders +collectFinalStgBinders :: [StgBinding] -- input program - -> [Id] -- exported top-level Ids - -collectExportedStgBinders binds - = ex [] binds - where - ex es [] = es + -> [Id] - ex es ((StgNonRec b _) : binds) - = if not (isExported b) then - ex es binds - else - ex (b:es) binds - - ex es ((StgRec []) : binds) = ex es binds - - ex es ((StgRec ((b, rhs) : pairs)) : binds) - = ex 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} %************************************************************************ @@ -516,23 +576,37 @@ 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 -> GenStgBinding bndr bdee -> Pretty +pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgBinding bndr bdee -> SDoc -pprStgBinding sty (StgNonRec bndr rhs) - = ppHang (ppCat [ppr sty bndr, 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 (StgRec pairs) + = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where - ppr_bind sty (bndr, expr) - = ppHang (ppCat [ppr sty bndr, 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 -> StgBinding -> Pretty -pprPlainStgBinding sty b = pprStgBinding sty b +pprStgBindings :: [StgBinding] -> SDoc +pprStgBindings binds = vcat (map pprGenStgBinding binds) + +pprGenStgBindingWithSRT + :: (Outputable bndr, Outputable bdee, Ord bdee) + => (GenStgBinding bndr bdee,[Id]) -> SDoc + +pprGenStgBindingWithSRT (bind,srt) + = vcat [ pprGenStgBinding bind, + ptext SLIT("SRT: ") <> ppr srt ] + +pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc +pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) \end{code} \begin{code} @@ -541,7 +615,7 @@ instance (Outputable bdee) => Outputable (GenStgArg bdee) where instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgBinding bndr bdee) where - ppr = pprStgBinding + ppr = pprGenStgBinding instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgExpr bndr bdee) where @@ -549,37 +623,39 @@ instance (Outputable bndr, Outputable bdee, Ord bdee) instance (Outputable bndr, Outputable bdee, Ord bdee) => Outputable (GenStgRhs bndr bdee) where - ppr sty rhs = pprStgRhs sty rhs + ppr rhs = pprStgRhs rhs \end{code} \begin{code} -pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty +pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc -pprStgArg sty (StgVarArg var) = ppr sty var -pprStgArg sty (StgLitArg lit) = ppr sty lit +pprStgArg (StgVarArg var) = ppr var +pprStgArg (StgLitArg con) = ppr con +pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty \end{code} \begin{code} -pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => - PprStyle -> GenStgExpr 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 (StgLit lit) = ppr lit -- 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) + = hang (ppr func) + 4 (sep (map (ppr) args)) \end{code} \begin{code} -pprStgExpr sty (StgCon con args lvs) - = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs), - ppStr "! [", interppSP sty args, ppStr "]" ] +pprStgExpr (StgConApp con args) + = hsep [ ppr con, brackets (interppSP args)] + +pprStgExpr (StgPrimApp op args _) + = hsep [ ppr op, brackets (interppSP args)] -pprStgExpr sty (StgPrim op args lvs) - = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs, - ppStr " [", interppSP sty args, ppStr "]" ] +pprStgExpr (StgLam _ bndrs body) + =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"), + pprStgExpr body ] \end{code} \begin{code} @@ -591,140 +667,140 @@ pprStgExpr sty (StgPrim op args lvs) -- -- Very special! Suspicious! (SLPJ) -pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) +pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs)) expr@(StgLet _ _)) - = ppAbove - (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, 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(" = "), + ppr 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 cc expr) + = sep [ hsep [ptext SLIT("_scc_"), ppr 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 bndr srt alts) + = sep [sep [ptext SLIT("case"), + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (dcolon <+> pp_ty alts)]), + ptext SLIT("of"), ppr bndr, char '{'], + ifPprDebug ( + nest 4 ( + hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole), + ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), + ptext SLIT("]; "), + pprMaybeSRT srt])), + nest 2 (pprStgAlts alts), + char '}'] where - pp_ty (StgAlgAlts ty _ _) = ppr sty ty - pp_ty (StgPrimAlts ty _ _) = ppr sty ty + pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon + pp_ty (StgPrimAlts tycon _ _) = ppr tycon - ppr_alts sty (StgAlgAlts ty alts deflt) - = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts), - ppr_default sty deflt ] +pprStgAlts (StgAlgAlts _ alts deflt) + = vcat [ vcat (map (ppr_bxd_alt) alts), + pprStgDefault deflt ] 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) + ppr_bxd_alt (con, params, use_mask, expr) + = hang (hsep [ppr con, interppSP params, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) - ppr_default sty StgNoDefault = ppNil - ppr_default sty (StgBindDefault bndr used expr) - = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr) +pprStgAlts (StgPrimAlts _ alts deflt) + = vcat [ vcat (map (ppr_ubxd_alt) alts), + pprStgDefault deflt ] where - pp_binder = if used then ppr sty bndr else ppChar '_' -\end{code} + ppr_ubxd_alt (lit, expr) + = hang (hsep [ppr lit, ptext SLIT("->")]) + 4 ((<>) (ppr expr) semi) -\begin{code} --- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty +pprStgDefault StgNoDefault = empty +pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) + 4 (ppr expr) -pprStgLVs PprForUser lvs = ppNil +\end{code} -pprStgLVs sty lvs - = if isEmptyUniqSet lvs then - ppNil +\begin{code} +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 -> GenStgRhs 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 srt [free_var] upd_flag [{-no args-}] (StgApp func [])) + = hcat [ ppr cc, + pp_binder_info bi, + pprMaybeSRT srt, + 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 srt free_vars upd_flag args body) + = hang (hcat [ppr cc, + pp_binder_info bi, + pprMaybeSRT srt, + 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 [ ppr cc, + space, ppr con, ptext SLIT("! "), brackets (interppSP args)] + +pprMaybeSRT (NoSRT) = empty +pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt -------------- -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 @@ -734,5 +810,5 @@ from the STG bindings. stgArity :: StgRhs -> Int stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied -stgArity (StgRhsClosure _ _ _ _ args _ ) = length args +stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args \end{code}