X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FstgSyn%2FStgSyn.lhs;fp=compiler%2FstgSyn%2FStgSyn.lhs;h=f1c50cc8fd017d2a8e67dc56e4fafdaa99b36af1;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=0000000000000000000000000000000000000000;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs new file mode 100644 index 0000000..f1c50cc --- /dev/null +++ b/compiler/stgSyn/StgSyn.lhs @@ -0,0 +1,786 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation} + +This data type represents programs just before code generation +(conversion to @AbstractC@): basically, what we have is a stylised +form of @CoreSyntax@, the style being one that happens to be ideally +suited to spineless tagless code generation. + +\begin{code} +module StgSyn ( + GenStgArg(..), + GenStgLiveVars, + + GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), + GenStgAlt, AltType(..), + + UpdateFlag(..), isUpdatable, + + StgBinderInfo, + noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly, + combineStgBinderInfo, + + -- a set of synonyms for the most common (only :-) parameterisation + StgArg, StgLiveVars, + StgBinding, StgExpr, StgRhs, StgAlt, + + -- StgOp + StgOp(..), + + -- SRTs + SRT(..), + + -- utils + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + isDllConApp, isStgTypeArg, + stgArgType, + + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs + +#ifdef DEBUG + , pprStgLVs +#endif + ) where + +#include "HsVersions.h" + +import CostCentre ( CostCentreStack, CostCentre ) +import VarSet ( IdSet, isEmptyVarSet ) +import Var ( isId ) +import Id ( Id, idName, idType, idCafInfo ) +import IdInfo ( mayHaveCafRefs ) +import Packages ( isDllName ) +import Literal ( Literal, literalType ) +import ForeignCall ( ForeignCall ) +import DataCon ( DataCon, dataConName ) +import CoreSyn ( AltCon ) +import PprCore ( {- instances -} ) +import PrimOp ( PrimOp ) +import Outputable +import Util ( count ) +import Type ( Type ) +import TyCon ( TyCon ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) +import Unique ( Unique ) +import Bitmap +import DynFlags ( DynFlags ) +import Packages ( HomeModules ) +import StaticFlags ( opt_SccProfilingOn ) +\end{code} + +%************************************************************************ +%* * +\subsection{@GenStgBinding@} +%* * +%************************************************************************ + +As usual, expressions are interesting; other things are boring. Here +are the boring things [except note the @GenStgRhs@], parameterised +with respect to binder and occurrence information (just as in +@CoreSyn@): + +There is one SRT for each group of bindings. + +\begin{code} +data GenStgBinding bndr occ + = StgNonRec bndr (GenStgRhs bndr occ) + | StgRec [(bndr, GenStgRhs bndr occ)] +\end{code} + +%************************************************************************ +%* * +\subsection{@GenStgArg@} +%* * +%************************************************************************ + +\begin{code} +data GenStgArg occ + = StgVarArg occ + | StgLitArg Literal + | StgTypeArg Type -- For when we want to preserve all type info +\end{code} + +\begin{code} +isStgTypeArg (StgTypeArg _) = True +isStgTypeArg other = False + +isDllArg :: HomeModules -> StgArg -> Bool + -- Does this argument refer to something in a different DLL? +isDllArg hmods (StgTypeArg v) = False +isDllArg hmods (StgVarArg v) = isDllName hmods (idName v) +isDllArg hmods (StgLitArg lit) = False + +isDllConApp :: HomeModules -> DataCon -> [StgArg] -> Bool + -- Does this constructor application refer to + -- anything in a different DLL? + -- If so, we can't allocate it statically +isDllConApp hmods con args + = isDllName hmods (dataConName con) || any (isDllArg hmods) args + +stgArgType :: StgArg -> Type + -- Very half baked becase we have lost the type arguments +stgArgType (StgVarArg v) = idType v +stgArgType (StgLitArg lit) = literalType lit +stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg" +\end{code} + +%************************************************************************ +%* * +\subsection{STG expressions} +%* * +%************************************************************************ + +The @GenStgExpr@ data type is parameterised on binder and occurrence +info, as before. + +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@ application} +%* * +%************************************************************************ + +An application is of a function to a list of atoms [not expressions]. +Operationally, we want to push the arguments on the stack and call the +function. (If the arguments were expressions, we would have to build +their closures first.) + +There is no constructor for a lone variable; it would appear as +@StgApp var [] _@. +\begin{code} +type GenStgLiveVars occ = UniqSet occ + +data GenStgExpr bndr occ + = StgApp + occ -- function + [GenStgArg occ] -- arguments; may be empty +\end{code} + +%************************************************************************ +%* * +\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 + + | StgOpApp StgOp -- Primitive op or foreign call + [GenStgArg occ] -- Saturated + Type -- Result type; we need to know the result type + -- so that we can assign result registers. +\end{code} + +%************************************************************************ +%* * +\subsubsection{@StgLam@} +%* * +%************************************************************************ + +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} + | StgLam + Type -- Type of whole lambda (useful when making a binder for it) + [bndr] + StgExpr -- Body of lambda +\end{code} + + +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@: case-expressions} +%* * +%************************************************************************ + +This has the same boxed/unboxed business as Core case expressions. +\begin{code} + | StgCase + (GenStgExpr bndr occ) + -- the thing to examine + + (GenStgLiveVars occ) -- Live vars of whole case expression, + -- plus everything that happens after the case + -- i.e., those which mustn't be overwritten + + (GenStgLiveVars occ) -- Live vars of RHSs (plus what happens afterwards) + -- i.e., those which must be saved before eval. + -- + -- note that an alt's constructor's + -- binder-variables are NOT counted in the + -- free vars for the alt's RHS + + bndr -- binds the result of evaluating the scrutinee + + SRT -- The SRT for the continuation + + AltType + + [GenStgAlt bndr occ] -- The DEFAULT case is always *first* + -- if it is there at all +\end{code} + +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@: @let(rec)@-expressions} +%* * +%************************************************************************ + +The various forms of let(rec)-expression encode most of the +interesting things we want to do. +\begin{enumerate} +\item +\begin{verbatim} +let-closure x = [free-vars] expr [args] +in e +\end{verbatim} +is equivalent to +\begin{verbatim} +let x = (\free-vars -> \args -> expr) free-vars +\end{verbatim} +\tr{args} may be empty (and is for most closures). It isn't under +circumstances like this: +\begin{verbatim} +let x = (\y -> y+z) +\end{verbatim} +This gets mangled to +\begin{verbatim} +let-closure x = [z] [y] (y+z) +\end{verbatim} +The idea is that we compile code for @(y+z)@ in an environment in which +@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an +offset from the stack pointer. + +(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.) + +\item +\begin{verbatim} +let-constructor x = Constructor [args] +in e +\end{verbatim} + +(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.) + +\item +Letrec-expressions are essentially the same deal as +let-closure/let-constructor, so we use a common structure and +distinguish between them with an @is_recursive@ boolean flag. + +\item +\begin{verbatim} +let-unboxed u = an arbitrary arithmetic expression in unboxed values +in e +\end{verbatim} +All the stuff on the RHS must be fully evaluated. No function calls either! + +(We've backed away from this toward case-expressions with +suitably-magical alts ...) + +\item +~[Advanced stuff here! Not to start with, but makes pattern matching +generate more efficient code.] + +\begin{verbatim} +let-escapes-not fail = expr +in e' +\end{verbatim} +Here the idea is that @e'@ guarantees not to put @fail@ in a data structure, +or pass it to another function. All @e'@ will ever do is tail-call @fail@. +Rather than build a closure for @fail@, all we need do is to record the stack +level at the moment of the @let-escapes-not@; then entering @fail@ is just +a matter of adjusting the stack pointer back down to that point and entering +the code for it. + +Another example: +\begin{verbatim} +f x y = let z = huge-expression in + if y==1 then z else + if y==2 then z else + 1 +\end{verbatim} + +(A let-escapes-not is an @StgLetNoEscape@.) + +\item +We may eventually want: +\begin{verbatim} +let-literal x = Literal +in e +\end{verbatim} + +(ToDo: is this obsolete?) +\end{enumerate} + +And so the code for let(rec)-things: +\begin{code} + | StgLet + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body + + | StgLetNoEscape -- remember: ``advanced stuff'' + (GenStgLiveVars occ) -- Live in the whole let-expression + -- Mustn't overwrite these stack slots + -- *Doesn't* include binders of the let(rec). + + (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. + + (GenStgBinding bndr occ) -- right hand sides (see below) + (GenStgExpr bndr occ) -- body +\end{code} + +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@: @scc@ expressions} +%* * +%************************************************************************ + +Finally for @scc@ expressions we introduce a new STG construct. + +\begin{code} + | StgSCC + CostCentre -- label of SCC expression + (GenStgExpr bndr occ) -- scc expression + -- end of GenStgExpr +\end{code} + +%************************************************************************ +%* * +\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 GenStgRhs bndr occ + = StgRhsClosure + CostCentreStack -- CCS to be attached (default is CurrentCCS) + StgBinderInfo -- Info about how this binder is used (see below) + [occ] -- non-global free vars; a list, rather than + -- a set, because order is important + !UpdateFlag -- ReEntrant | Updatable | SingleEntry + SRT -- The SRT reference + [bndr] -- arguments; if empty, then not a function; + -- as above, order is important. + (GenStgExpr bndr occ) -- body +\end{code} +An example may be in order. Consider: +\begin{verbatim} +let t = \x -> \y -> ... x ... y ... p ... q in e +\end{verbatim} +Pulling out the free vars and stylising somewhat, we get the equivalent: +\begin{verbatim} +let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q +\end{verbatim} +Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are +offsets from @Node@ into the closure, and the code ptr for the closure +will be exactly that in parentheses above. + +The second flavour of right-hand-side is for constructors (simple but important): +\begin{code} + | StgRhsCon + CostCentreStack -- CCS to be attached (default is CurrentCCS). + -- Top-level (static) ones will end up with + -- DontCareCCS, because we don't count static + -- data in heap profiles, and we don't set CCCS + -- from static closure. + DataCon -- constructor + [GenStgArg occ] -- args +\end{code} + +\begin{code} +stgRhsArity :: StgRhs -> Int +stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _) = count isId bndrs + -- The arity never includes type parameters, so + -- when keeping type arguments and binders in the Stg syntax + -- (opt_RuntimeTypes) we have to fliter out the type binders. +stgRhsArity (StgRhsCon _ _ _) = 0 +\end{code} + +\begin{code} +stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool +stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs +stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) + +rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) + = isUpdatable upd || nonEmptySRT srt +rhsHasCafRefs (StgRhsCon _ _ args) + = any stgArgHasCafRefs args + +stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id) +stgArgHasCafRefs _ = False +\end{code} + +Here's the @StgBinderInfo@ type, and its combining op: +\begin{code} +data StgBinderInfo + = NoStgBinderInfo + | SatCallsOnly -- All occurrences are *saturated* *function* calls + -- This means we don't need to build an info table and + -- slow entry code for the thing + -- Thunks never get this value + +noBinderInfo = NoStgBinderInfo +stgUnsatOcc = NoStgBinderInfo +stgSatOcc = SatCallsOnly + +satCallsOnly :: StgBinderInfo -> Bool +satCallsOnly SatCallsOnly = True +satCallsOnly NoStgBinderInfo = False + +combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo +combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly +combineStgBinderInfo info1 info2 = NoStgBinderInfo + +-------------- +pp_binder_info NoStgBinderInfo = empty +pp_binder_info SatCallsOnly = ptext SLIT("sat-only") +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-case-alternatives]{STG case alternatives} +%* * +%************************************************************************ + +Very like in @CoreSyntax@ (except no type-world stuff). + +The type constructor 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} +type GenStgAlt bndr occ + = (AltCon, -- alts: data constructor, + [bndr], -- constructor's parameters, + [Bool], -- "use mask", same length as + -- parameters; a True in a + -- param's position if it is + -- used in the ... + GenStgExpr bndr occ) -- ...right-hand side. + +data AltType + = PolyAlt -- Polymorphic (a type variable) + | UbxTupAlt TyCon -- Unboxed tuple + | AlgAlt TyCon -- Algebraic data type; the AltCons will be DataAlts + | PrimAlt TyCon -- Primitive data type; the AltCons will be LitAlts +\end{code} + +%************************************************************************ +%* * +\subsection[Stg]{The Plain STG parameterisation} +%* * +%************************************************************************ + +This happens to be the only one we use at the moment. + +\begin{code} +type StgBinding = GenStgBinding Id Id +type StgArg = GenStgArg Id +type StgLiveVars = GenStgLiveVars Id +type StgExpr = GenStgExpr Id Id +type StgRhs = GenStgRhs Id Id +type StgAlt = GenStgAlt Id Id +\end{code} + +%************************************************************************ +%* * +\subsubsection[UpdateFlag-datatype]{@UpdateFlag@} +%* * +%************************************************************************ + +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 u + = char (case u of { ReEntrant -> 'r'; Updatable -> 'u'; SingleEntry -> 's' }) + +isUpdatable ReEntrant = False +isUpdatable SingleEntry = False +isUpdatable Updatable = True +\end{code} + +%************************************************************************ +%* * +\subsubsection{StgOp} +%* * +%************************************************************************ + +An StgOp allows us to group together PrimOps and ForeignCalls. +It's quite useful to move these around together, notably +in StgOpApp and COpStmt. + +\begin{code} +data StgOp = StgPrimOp PrimOp + + | StgFCallOp ForeignCall Unique + -- The Unique is occasionally needed by the C pretty-printer + -- (which lacks a unique supply), notably when generating a + -- typedef for foreign-export-dynamic +\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. + +In CoreToStg we collect the list of CafRefs at each SRT site, which is later +converted into the length and offset form by the SRT pass. + +\begin{code} +data SRT = NoSRT + | SRTEntries IdSet + -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} + -- generated by computeSRTs + +noSRT :: SRT +noSRT = NoSRT + +nonEmptySRT NoSRT = False +nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs) +nonEmptySRT _ = True + +pprSRT (NoSRT) = ptext SLIT("_no_srt_") +pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids +pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*") +\end{code} + +%************************************************************************ +%* * +\subsection[Stg-pretty-printing]{Pretty-printing} +%* * +%************************************************************************ + +Robin Popplestone asked for semi-colon separators on STG binds; here's +hoping he likes terminators instead... Ditto for case alternatives. + +\begin{code} +pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgBinding bndr bdee -> SDoc + +pprGenStgBinding (StgNonRec bndr rhs) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr rhs) semi) + +pprGenStgBinding (StgRec pairs) + = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) + where + ppr_bind (bndr, expr) + = hang (hsep [ppr bndr, equals]) + 4 ((<>) (ppr expr) semi) + +pprStgBinding :: StgBinding -> SDoc +pprStgBinding bind = pprGenStgBinding bind + +pprStgBindings :: [StgBinding] -> SDoc +pprStgBindings binds = vcat (map pprGenStgBinding binds) + +pprGenStgBindingWithSRT + :: (Outputable bndr, Outputable bdee, Ord bdee) + => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc + +pprGenStgBindingWithSRT (bind,srts) + = vcat (pprGenStgBinding bind : map pprSRT srts) + where pprSRT (id,srt) = + ptext SLIT("SRT") <> parens (ppr id) <> ptext SLIT(": ") <> ppr srt + +pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc +pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds) +\end{code} + +\begin{code} +instance (Outputable bdee) => Outputable (GenStgArg bdee) where + ppr = pprStgArg + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgBinding bndr bdee) where + ppr = pprGenStgBinding + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgExpr bndr bdee) where + ppr = pprStgExpr + +instance (Outputable bndr, Outputable bdee, Ord bdee) + => Outputable (GenStgRhs bndr bdee) where + ppr rhs = pprStgRhs rhs +\end{code} + +\begin{code} +pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc + +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) + => GenStgExpr bndr bdee -> SDoc +-- special case +pprStgExpr (StgLit lit) = ppr lit + +-- general case +pprStgExpr (StgApp func args) + = hang (ppr func) + 4 (sep (map (ppr) args)) +\end{code} + +\begin{code} +pprStgExpr (StgConApp con args) + = hsep [ ppr con, brackets (interppSP args)] + +pprStgExpr (StgOpApp op args _) + = hsep [ pprStgOp op, brackets (interppSP args)] + +pprStgExpr (StgLam _ bndrs body) + =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"), + pprStgExpr body ] +\end{code} + +\begin{code} +-- special case: let v = +-- in +-- let ... +-- in +-- ... +-- +-- Very special! Suspicious! (SLPJ) + +{- +pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs)) + expr@(StgLet _ _)) + = ($$) + (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 (StgLet bind expr@(StgLet _ _)) + = ($$) + (sep [hang (ptext SLIT("let {")) + 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])]) + (ppr expr) + +-- general case +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)] + +pprStgExpr (StgSCC cc expr) + = sep [ hsep [ptext SLIT("_scc_"), ppr cc], + pprStgExpr expr ] + +pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) + = sep [sep [ptext SLIT("case"), + nest 4 (hsep [pprStgExpr expr, + ifPprDebug (dcolon <+> ppr alt_type)]), + 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 (vcat (map pprStgAlt alts)), + char '}'] + +pprStgAlt (con, params, use_mask, expr) + = hang (hsep [ppr con, interppSP params, ptext SLIT("->")]) + 4 (ppr expr <> semi) + +pprStgOp (StgPrimOp op) = ppr op +pprStgOp (StgFCallOp op _) = ppr op + +instance Outputable AltType where + ppr PolyAlt = ptext SLIT("Polymorphic") + ppr (UbxTupAlt tc) = ptext SLIT("UbxTup") <+> ppr tc + ppr (AlgAlt tc) = ptext SLIT("Alg") <+> ppr tc + ppr (PrimAlt tc) = ptext SLIT("Prim") <+> ppr tc +\end{code} + +\begin{code} +pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc +pprStgLVs lvs + = getPprStyle $ \ sty -> + if userStyle sty || isEmptyUniqSet lvs then + empty + else + hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"] +\end{code} + +\begin{code} +pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) + => GenStgRhs bndr bdee -> SDoc + +-- special case +pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func [])) + = hcat [ ppr cc, + pp_binder_info bi, + brackets (ifPprDebug (ppr free_var)), + ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, ptext SLIT(" [] "), ppr func ] + +-- general case +pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body) + = hang (hsep [if opt_SccProfilingOn then ppr cc else empty, + pp_binder_info bi, + ifPprDebug (brackets (interppSP free_vars)), + char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)]) + 4 (ppr body) + +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 +\end{code}