--- /dev/null
+%
+% (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 = <very specific thing>
+-- 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}
projects / ghc-hetmet.git / blobdiff