%
-% (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}
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgCaseAlts(..), GenStgCaseDefault(..),
- 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
StgBinding, StgExpr, StgRhs,
StgCaseAlts, StgCaseDefault,
- pprStgBinding, pprStgBindings,
- getArgPrimRep,
- isLitLitArg,
- stgArity,
- collectFinalStgBinders
+ -- SRTs
+ SRT(..), noSRT,
+
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
+ getArgPrimRep, pprStgAlts,
+ isLitLitArg, isDllConApp, isStgTypeArg,
+ stgArity, stgArgType
+
+#ifdef DEBUG
+ , pprStgLVs
+#endif
) where
#include "HsVersions.h"
-import CostCentre ( showCostCentre, CostCentre )
-import Id ( idPrimRep, DataCon,
- GenId{-instance NamedThing-}, Id )
-import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
+import CostCentre ( CostCentreStack, CostCentre )
+import Id ( Id, idName, idPrimRep, idType )
+import Name ( isDllName )
+import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+import DataCon ( DataCon, dataConName )
+import PrimOp ( PrimOp )
import Outputable
-import PrimOp ( PrimOp{-instance Outputable-} )
import Type ( Type )
-import Unique ( pprUnique, Unique )
+import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
-import Util ( panic )
\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
+getArgPrimRep (StgVarArg local) = idPrimRep local
+getArgPrimRep (StgLitArg lit) = literalPrimRep lit
+
+isLitLitArg (StgLitArg lit) = isLitLitLit lit
+isLitLitArg _ = False
+
+isStgTypeArg (StgTypeArg _) = True
+isStgTypeArg other = False
+
+isDllArg :: StgArg -> Bool
+ -- Does this argument refer to something in a different DLL?
+isDllArg (StgVarArg v) = isDllName (idName v)
+isDllArg (StgLitArg lit) = isLitLitLit lit
+
+isDllConApp :: DataCon -> [StgArg] -> Bool
+ -- Does this constructor application refer to
+ -- anything in a different DLL?
+ -- If so, we can't allocate it statically
+isDllConApp con args = isDllName (dataConName con) || any isDllArg args
+
+stgArgType :: StgArg -> Type
+ -- Very half baked becase we have lost the type arguments
+stgArgType (StgVarArg v) = idType v
+stgArgType (StgLitArg lit) = literalType lit
\end{code}
%************************************************************************
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
+
+ | StgPrimApp PrimOp
+ [GenStgArg occ] -- Saturated
+ Type -- Result type; we need to know the result type
+ -- so that we can assign result registers.
\end{code}
%************************************************************************
%* *
-\subsubsection{@StgCon@ and @StgPrim@---saturated applications}
+\subsubsection{@StgLam@}
%* *
%************************************************************************
-There are two specialised forms of application, for
-constructors and primitives.
+StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
+it encodes (\x -> e) as (let f = \x -> e in f)
+
\begin{code}
- | StgCon -- always saturated
- Id -- data constructor
- [GenStgArg occ]
- (GenStgLiveVars occ) -- Live vars in continuation; ie not
- -- including the constr and args
-
- | StgPrim -- always saturated
- PrimOp
- [GenStgArg occ]
- (GenStgLiveVars occ) -- Live vars in continuation; ie not
- -- including the op and args
+ | StgLam
+ Type -- Type of whole lambda (useful when making a binder for it)
+ [bndr]
+ StgExpr -- Body of lambda
\end{code}
-These forms are to do ``inline versions,'' as it were.
-An example might be: @f x = x:[]@.
+
%************************************************************************
%* *
-- binder-variables are NOT counted in the
-- free vars for the alt's RHS
- Unique -- Occasionally needed to compile case
- -- statements, as the uniq for a local
- -- variable to hold the tag of a primop with
- -- algebraic result
+ bndr -- binds the result of evaluating the scrutinee
+
+ SRT -- The SRT for the continuation
(GenStgCaseAlts bndr occ)
\end{code}
\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)
+ SRT -- The closures's SRT
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
UpdateFlag -- ReEntrant | Updatable | SingleEntry
[bndr] -- arguments; if empty, then not a function;
- -- as above, order is important
+ -- as above, order is important.
(GenStgExpr bndr occ) -- body
\end{code}
An example may be in order. Consider:
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}
\begin{code}
data StgBinderInfo
= NoStgBinderInfo
- | StgBinderInfo
- Bool -- At least one occurrence as an argument
-
- Bool -- At least one occurrence in an unsaturated application
-
- Bool -- This thing (f) has at least occurrence of the form:
- -- x = [..] \u [] -> f a b c
- -- where the application is saturated
+ | 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 -- Ditto for non-updatable x.
+noBinderInfo = NoStgBinderInfo
+stgUnsatOcc = NoStgBinderInfo
+stgSatOcc = SatCallsOnly
- 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
-
-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).
+* Algebraic cases are done using
+ StgAlgAlts (Just tc) alts deflt
+
+* Polymorphic cases, or case of a function type, are done using
+ StgAlgAlts Nothing [] (StgBindDefault e)
+
+* Primitive cases are done using
+ StgPrimAlts tc alts deflt
+
+We thought of giving polymorphic cases their own constructor,
+but we get a bit more code sharing this way
+
+The type constructor in StgAlgAlts/StgPrimAlts is guaranteed not
+to be abstract; that is, we can see its representation. This is
+important because the code generator uses it to determine return
+conventions etc. But it's not trivial where there's a moduule loop
+involved, because some versions of a type constructor might not have
+all the constructors visible. So mkStgAlgAlts (in CoreToStg) ensures
+that it gets the TyCon from the constructors or literals (which are
+guaranteed to have the Real McCoy) rather than from the scrutinee type.
+
\begin{code}
data GenStgCaseAlts bndr occ
- = StgAlgAlts Type -- so we can find out things about constructor family
- [(Id, -- alts: data constructor,
+ = StgAlgAlts (Maybe TyCon) -- Just tc => scrutinee type is
+ -- an algebraic data type
+ -- Nothing => scrutinee type is a type
+ -- variable or function type
+ [(DataCon, -- alts: data constructor,
[bndr], -- constructor's parameters,
[Bool], -- "use mask", same length as
-- parameters; a True in a
-- used in the ...
GenStgExpr bndr occ)] -- ...right-hand side.
(GenStgCaseDefault bndr occ)
- | StgPrimAlts Type -- so we can find out things about constructor family
+
+ | StgPrimAlts TyCon
[(Literal, -- alts: unboxed literal,
GenStgExpr bndr occ)] -- rhs.
(GenStgCaseDefault bndr occ)
data GenStgCaseDefault bndr occ
= StgNoDefault -- small con family: all
-- constructor accounted for
- | StgBindDefault bndr -- form: var -> expr
- Bool -- True <=> var is used in rhs
- -- i.e., False <=> "_ -> expr"
- (GenStgExpr bndr occ)
+ | StgBindDefault (GenStgExpr bndr occ)
\end{code}
%************************************************************************
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}
%************************************************************************
-%* *
-\subsection[Stg-utility-functions]{Utility functions}
-%* *
+%* *
+\subsubsection[Static Reference Tables]{@SRT@}
+%* *
%************************************************************************
-
-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.
+There is one SRT per top-level function group. Each local binding and
+case expression within this binding group has a subrange of the whole
+SRT, expressed as an offset and length.
\begin{code}
-collectFinalStgBinders
- :: [StgBinding] -- input program
- -> [Id]
+data SRT = NoSRT
+ | SRT !Int{-offset-} !Int{-length-}
+
+noSRT :: SRT
+noSRT = NoSRT
-collectFinalStgBinders [] = []
-collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
-collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
+pprSRT (NoSRT) = ptext SLIT("_no_srt_")
+pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
\end{code}
%************************************************************************
pprStgBinding bind = pprGenStgBinding bind
pprStgBindings :: [StgBinding] -> SDoc
-pprStgBindings binds = vcat (map (pprGenStgBinding) binds)
+pprStgBindings binds = vcat (map pprGenStgBinding binds)
+
+pprGenStgBindingWithSRT
+ :: (Outputable bndr, Outputable bdee, Ord bdee)
+ => (GenStgBinding bndr bdee,[Id]) -> SDoc
+
+pprGenStgBindingWithSRT (bind,srt)
+ = vcat [ pprGenStgBinding bind,
+ ptext SLIT("SRT: ") <> ppr srt ]
+
+pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
+pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
\end{code}
\begin{code}
pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
pprStgArg (StgVarArg var) = ppr var
-pprStgArg (StgConArg con) = ppr con
-pprStgArg (StgLitArg lit) = ppr lit
+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 (StgApp func [] lvs)
- = (<>) (ppr func) (pprStgLVs lvs)
+pprStgExpr (StgLit lit) = ppr lit
-- general case
-pprStgExpr (StgApp func args lvs)
- = hang ((<>) (ppr func) (pprStgLVs lvs))
+pprStgExpr (StgApp func args)
+ = hang (ppr func)
4 (sep (map (ppr) args))
\end{code}
\begin{code}
-pprStgExpr (StgCon con args lvs)
- = hcat [ (<>) (ppr con) (pprStgLVs lvs),
- ptext SLIT("! ["), interppSP args, char ']' ]
+pprStgExpr (StgConApp con args)
+ = hsep [ ppr con, brackets (interppSP args)]
+
+pprStgExpr (StgPrimApp op args _)
+ = hsep [ ppr op, brackets (interppSP args)]
-pprStgExpr (StgPrim op args lvs)
- = hcat [ ppr op, char '#', pprStgLVs lvs,
- ptext SLIT(" ["), interppSP args, char ']' ]
+pprStgExpr (StgLam _ bndrs body)
+ =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
+ pprStgExpr body ]
\end{code}
\begin{code}
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
expr@(StgLet _ _))
= ($$)
(hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
- text (showCostCentre True{-as string-} cc),
+ ppr cc,
pp_binder_info bi,
ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
ppr upd_flag, ptext SLIT(" ["),
\end{code}
\begin{code}
-pprStgExpr (StgSCC ty cc expr)
- = sep [ hsep [ptext SLIT("_scc_"), text (showCostCentre True{-as string-} cc)],
- pprStgExpr expr ]
+pprStgExpr (StgSCC cc expr)
+ = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
+ pprStgExpr expr ]
\end{code}
\begin{code}
-pprStgExpr (StgCase expr lvs_whole lvs_rhss uniq alts)
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
- ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
- ptext SLIT("of {")],
+ ifPprDebug (dcolon <+> pp_ty alts)]),
+ ptext SLIT("of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
hcat [ptext SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
- ptext SLIT("]; uniq: "), pprUnique uniq])),
- nest 2 (ppr_alts alts),
+ ptext SLIT("]; "),
+ pprMaybeSRT srt])),
+ nest 2 (pprStgAlts alts),
char '}']
where
- ppr_default StgNoDefault = empty
- ppr_default (StgBindDefault bndr used expr)
- = hang (hsep [pp_binder, ptext SLIT("->")]) 4 (ppr expr)
- where
- pp_binder = if used then ppr bndr else char '_'
-
- pp_ty (StgAlgAlts ty _ _) = ppr ty
- pp_ty (StgPrimAlts ty _ _) = ppr ty
+ pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon
+ pp_ty (StgPrimAlts tycon _ _) = ppr tycon
- ppr_alts (StgAlgAlts ty alts deflt)
+pprStgAlts (StgAlgAlts _ alts deflt)
= vcat [ vcat (map (ppr_bxd_alt) alts),
- ppr_default deflt ]
+ pprStgDefault deflt ]
where
ppr_bxd_alt (con, params, use_mask, expr)
= hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
4 ((<>) (ppr expr) semi)
- ppr_alts (StgPrimAlts ty alts deflt)
+pprStgAlts (StgPrimAlts _ alts deflt)
= vcat [ vcat (map (ppr_ubxd_alt) alts),
- ppr_default deflt ]
+ pprStgDefault deflt ]
where
ppr_ubxd_alt (lit, expr)
= hang (hsep [ppr lit, ptext SLIT("->")])
4 ((<>) (ppr expr) semi)
+
+pprStgDefault StgNoDefault = empty
+pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
+ 4 (ppr expr)
+
\end{code}
\begin{code}
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
- = hcat [ text (showCostCentre True{-as String-} cc),
+pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
+ = hcat [ ppr cc,
pp_binder_info bi,
+ pprMaybeSRT srt,
brackets (ifPprDebug (ppr free_var)),
ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
- = hang (hcat [text (showCostCentre True{-as String-} cc),
+pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
+ = hang (hcat [ppr cc,
pp_binder_info bi,
+ pprMaybeSRT srt,
brackets (ifPprDebug (interppSP free_vars)),
ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
- = hcat [ text (showCostCentre True{-as String-} cc),
+ = hcat [ ppr cc,
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
---------------
-
-pp_binder_info NoStgBinderInfo = empty
-
--- cases so boring that we print nothing
-pp_binder_info (StgBinderInfo True b c d e) = empty
-
--- general case
-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])))
+pprMaybeSRT (NoSRT) = empty
+pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
\end{code}
Collect @IdInfo@ stuff that is most easily just snaffled straight
stgArity :: StgRhs -> Int
stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
-stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
+stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
\end{code}