%
-% (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}
suited to spineless tagless code generation.
\begin{code}
-#include "HsVersions.h"
-
module StgSyn (
- GenStgArg(..),
- SYN_IE(GenStgLiveVars),
+ GenStgArg(..),
+ GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
- GenStgCaseAlts(..), GenStgCaseDefault(..),
+ GenStgAlt, AltType(..),
- UpdateFlag(..),
+ UpdateFlag(..), isUpdatable,
- StgBinderInfo(..),
- stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
- stgNormalOcc, stgFakeFunAppOcc,
+ StgBinderInfo,
+ noBinderInfo, stgSatOcc, stgUnsatOcc, satCallsOnly,
combineStgBinderInfo,
-- a set of synonyms for the most common (only :-) parameterisation
- SYN_IE(StgArg), SYN_IE(StgLiveVars),
- SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs),
- SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault),
-
- pprPlainStgBinding,
- getArgPrimRep,
- isLitLitArg,
- stgArity,
- collectFinalStgBinders
+ 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
-IMP_Ubiq(){-uitous-}
-
-import CostCentre ( showCostCentre )
-import Id ( idPrimRep, SYN_IE(DataCon), GenId{-instance NamedThing-} )
-import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Name ( pprNonSym )
-import Outputable ( ifPprDebug, interppSP, interpp'SP,
- Outputable(..){-instance * Bool-}
- )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import Pretty -- all of it
-import PrimOp ( PrimOp{-instance Outputable-} )
-import Unique ( pprUnique )
-import UniqSet ( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) )
-import Util ( panic )
+#include "HsVersions.h"
+
+import CostCentre ( CostCentreStack, CostCentre )
+import VarSet ( IdSet, isEmptyVarSet )
+import Var ( isId )
+import Id ( Id, idName, idType, idCafInfo )
+import IdInfo ( mayHaveCafRefs )
+import Name ( 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 CmdLineOpts ( opt_SccProfilingOn )
\end{code}
%************************************************************************
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)]
- | StgCoerceBinding bndr occ
\end{code}
%************************************************************************
\begin{code}
data GenStgArg occ
= StgVarArg occ
- | StgLitArg Literal
- | StgConArg DataCon -- A nullary data constructor
+ | StgLitArg Literal
+ | StgTypeArg Type -- For when we want to preserve all type info
\end{code}
\begin{code}
-getArgPrimRep (StgVarArg local) = idPrimRep local
-getArgPrimRep (StgConArg con) = idPrimRep con
-getArgPrimRep (StgLitArg lit) = literalPrimRep lit
-
-isLitLitArg (StgLitArg x) = isLitLitLit x
-isLitLitArg _ = False
+isStgTypeArg (StgTypeArg _) = True
+isStgTypeArg other = False
+
+isDllArg :: StgArg -> Bool
+ -- Does this argument refer to something in a different DLL?
+isDllArg (StgTypeArg v) = False
+isDllArg (StgVarArg v) = isDllName (idName v)
+isDllArg (StgLitArg lit) = False
+
+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
+stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg"
\end{code}
%************************************************************************
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}
+
+%************************************************************************
+%* *
+\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}
+%* *
+%************************************************************************
- -- NB: a literal is: StgApp <lit-atom> [] ...
+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{@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:[]@.
+
%************************************************************************
%* *
(GenStgExpr bndr occ)
-- the thing to examine
- (GenStgLiveVars occ) -- Live vars of whole case
- -- expression; i.e., those which mustn't be
- -- overwritten
+ (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;
+ (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
- 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
- (GenStgCaseAlts bndr occ)
+ SRT -- The SRT for the continuation
+
+ AltType
+
+ [GenStgAlt bndr occ] -- The DEFAULT case is always *first*
+ -- if it is there at all
\end{code}
%************************************************************************
\begin{code}
| StgSCC
- Type -- the type of the body
CostCentre -- label of SCC expression
(GenStgExpr bndr occ) -- scc expression
-- end of GenStgExpr
\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)
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
- UpdateFlag -- ReEntrant | Updatable | SingleEntry
+ !UpdateFlag -- ReEntrant | Updatable | SingleEntry
+ SRT -- The SRT reference
[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:
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}
-Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
-data StgBinderInfo
- = NoStgBinderInfo
- | StgBinderInfo
- Bool -- At least one occurrence as an argument
+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}
- Bool -- At least one occurrence in an unsaturated application
+\begin{code}
+stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
+stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
+stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
- Bool -- This thing (f) has at least occurrence of the form:
- -- x = [..] \u [] -> f a b c
- -- where the application is saturated
+rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
+ = isUpdatable upd || nonEmptySRT srt
+rhsHasCafRefs (StgRhsCon _ _ args)
+ = any stgArgHasCafRefs args
- Bool -- Ditto for non-updatable x.
+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
- 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.
- -- Used by the lambda lifter.
- -- True => "at least one unsat app" is True too
+noBinderInfo = NoStgBinderInfo
+stgUnsatOcc = NoStgBinderInfo
+stgSatOcc = SatCallsOnly
-stgArgOcc = StgBinderInfo True False False False False
-stgUnsatOcc = StgBinderInfo False True False False False
-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
+satCallsOnly :: StgBinderInfo -> Bool
+satCallsOnly SatCallsOnly = True
+satCallsOnly NoStgBinderInfo = False
combineStgBinderInfo :: StgBinderInfo -> StgBinderInfo -> StgBinderInfo
+combineStgBinderInfo SatCallsOnly SatCallsOnly = SatCallsOnly
+combineStgBinderInfo info1 info2 = NoStgBinderInfo
-combineStgBinderInfo NoStgBinderInfo info2 = info2
-combineStgBinderInfo info1 NoStgBinderInfo = info1
-combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1)
- (StgBinderInfo arg2 unsat2 std_heap2 upd_heap2 fkap2)
- = StgBinderInfo (arg1 || arg2)
- (unsat1 || unsat2)
- (std_heap1 || std_heap2)
- (upd_heap1 || upd_heap2)
- (fkap1 || fkap2)
+--------------
+pp_binder_info NoStgBinderInfo = empty
+pp_binder_info SatCallsOnly = ptext SLIT("sat-only")
\end{code}
%************************************************************************
%* *
%************************************************************************
-Just like in @CoreSyntax@ (except no type-world stuff).
+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}
-data GenStgCaseAlts bndr occ
- = StgAlgAlts Type -- so we can find out things about constructor family
- [(Id, -- 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.
- (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 bndr -- form: var -> expr
- Bool -- True <=> var is used in rhs
- -- i.e., False <=> "_ -> expr"
- (GenStgExpr bndr occ)
+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}
%************************************************************************
type StgLiveVars = GenStgLiveVars Id
type StgExpr = GenStgExpr Id Id
type StgRhs = GenStgRhs Id Id
-type StgCaseAlts = GenStgCaseAlts Id Id
-type StgCaseDefault = GenStgCaseDefault Id Id
+type StgAlt = GenStgAlt Id Id
\end{code}
%************************************************************************
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}
%************************************************************************
-%* *
-\subsection[Stg-utility-functions]{Utility functions}
-%* *
+%* *
+\subsubsection{StgOp}
+%* *
%************************************************************************
-
-For doing interfaces, we want the exported top-level Ids from the
-final pre-codegen STG code, so as to be sure we have the
-latest/greatest pragma info.
+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}
-collectFinalStgBinders
- :: [StgBinding] -- input program
- -> [Id]
+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@}
+%* *
+%************************************************************************
-collectFinalStgBinders [] = []
-collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
-collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
+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}
%************************************************************************
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 (StgCoerceBinding bndr occ)
- = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
- 4 (ppBeside (ppr sty occ) ppSemi)
-
-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,[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 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
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 (StgConArg con) = ppr sty con
-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 sty (StgPrim op args lvs)
- = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
- ppStr " [", interppSP sty args, ppStr "]" ]
+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}
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+{-
+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi 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)]
-\end{code}
-
-\begin{code}
-pprStgExpr sty (StgSCC ty cc expr)
- = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
- pprStgExpr sty 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 "}"]
- where
- ppr_default sty StgNoDefault = ppNil
- ppr_default sty (StgBindDefault bndr used expr)
- = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
- where
- pp_binder = if used then ppr sty bndr else ppChar '_'
-
- 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 ]
- where
- ppr_bxd_alt sty (con, params, use_mask, expr)
- = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"])
- 4 (ppBeside (ppr sty expr) ppSemi)
-
- 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)
+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 :: PprStyle -> GenStgLiveVars occ -> 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 -> 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 ]
--- 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 sty (StgRhsCon cc con args)
- = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
- ppSP, ppr sty con, ppStr "! [", interppSP sty args, ppStr "]" ]
-
---------------
-pp_binder_info PprForUser _ = ppNil
-
-pp_binder_info sty NoStgBinderInfo = ppNil
-
--- cases so boring that we print nothing
-pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
+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
-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
-\end{code}
-
-Collect @IdInfo@ stuff that is most easily just snaffled straight
-from the STG bindings.
-
-\begin{code}
-stgArity :: StgRhs -> Int
-
-stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
-stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
+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