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