-- SRTs
SRT(..), noSRT,
- pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
- getArgPrimRep, pprStgAlts,
+ -- utils
+ stgBindHasCafRefs, stgRhsArity, getArgPrimRep,
isLitLitArg, isDllConApp, isStgTypeArg,
- stgArity, stgArgType
+ stgArgType, stgBinders,
+
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
#ifdef DEBUG
, pprStgLVs
#include "HsVersions.h"
import CostCentre ( CostCentreStack, CostCentre )
+import VarSet ( IdSet, isEmptyVarSet )
import Id ( Id, idName, idPrimRep, idType )
import Name ( isDllName )
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
import Type ( Type )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
+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)]
+ = StgNonRec SRT bndr (GenStgRhs bndr occ)
+ | StgRec SRT [(bndr, GenStgRhs bndr occ)]
+
+stgBinders :: GenStgBinding bndr occ -> [bndr]
+stgBinders (StgNonRec _ b _) = [b]
+stgBinders (StgRec _ bs) = map fst bs
\end{code}
%************************************************************************
= StgRhsClosure
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
+ !UpdateFlag -- ReEntrant | Updatable | SingleEntry
[bndr] -- arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr bndr occ) -- body
[GenStgArg occ] -- args
\end{code}
+\begin{code}
+stgRhsArity :: GenStgRhs bndr occ -> Int
+stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args
+stgRhsArity (StgRhsCon _ _ _) = 0
+\end{code}
+
+\begin{code}
+stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool
+stgBindHasCafRefs (StgNonRec srt _ rhs)
+ = nonEmptySRT srt || rhsIsUpdatable rhs
+stgBindHasCafRefs (StgRec srt binds)
+ = nonEmptySRT srt || any rhsIsUpdatable (map snd binds)
+
+rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd
+rhsIsUpdatable _ = False
+\end{code}
+
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
data StgBinderInfo
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
- | SRT !Int{-offset-} !Int{-length-}
+ | SRTEntries IdSet -- generated by CoreToStg
+ | SRT !Int{-offset-} !Int{-length-} -- 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 len) = parens (ppr off <> comma <> ppr len)
\end{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 (StgNonRec srt bndr rhs)
+ = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr rhs) semi)
-pprGenStgBinding (StgRec pairs)
+pprGenStgBinding (StgRec srt pairs)
= vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
+ pprMaybeSRT srt :
+ (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
= hang (hsep [ppr bndr, equals])
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
+{-
+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(" = "),
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")])])
+ (sep [hang (ptext SLIT("let {"))
+ 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
(ppr expr)
-- general case
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc bi [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 srt free_vars upd_flag args body)
- = hang (hcat [ppr cc,
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+ = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
pp_binder_info bi,
- pprMaybeSRT srt,
- brackets (ifPprDebug (interppSP free_vars)),
- ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
+ ifPprDebug (brackets (interppSP free_vars)),
+ char '\\' <> ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
-\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
+pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt
\end{code}
projects / ghc-hetmet.git / blobdiff