\begin{code}
module StgSyn (
- GenStgArg(..),
+ GenStgArg(..),
GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
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,
+ -- StgOp
+ StgOp(..),
+
-- SRTs
- SRT(..), noSRT,
+ SRT(..), noSRT, nonEmptySRT,
- pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
- getArgPrimRep, pprStgAlts,
+ -- utils
+ stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep,
isLitLitArg, isDllConApp, isStgTypeArg,
- stgArity, stgArgType
+ stgArgType, stgBinders,
+
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
#ifdef DEBUG
, pprStgLVs
#include "HsVersions.h"
import CostCentre ( CostCentreStack, CostCentre )
-import Id ( Id, idName, idPrimRep, idType )
+import VarSet ( IdSet, isEmptyVarSet )
+import Var ( isId )
+import Id ( Id, idName, idPrimRep, idType, idCafInfo )
+import IdInfo ( mayHaveCafRefs )
import Name ( isDllName )
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
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)]
+
+stgBinders :: GenStgBinding bndr occ -> [bndr]
+stgBinders (StgNonRec b _) = [b]
+stgBinders (StgRec bs) = map fst bs
\end{code}
%************************************************************************
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) = isLitLitLit lit
-- 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}
%************************************************************************
| StgConApp DataCon
[GenStgArg occ] -- Saturated
- | StgPrimApp PrimOp
+ | 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.
(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
= 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
+ SRT -- The SRT reference
[bndr] -- arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr bndr occ) -- body
[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
+
+stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
+stgArgHasCafRefs _ = False
+\end{code}
- Bool -- Ditto for non-updatable x.
+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}
%************************************************************************
%************************************************************************
%* *
+\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@}
%* *
%************************************************************************
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-} !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 (SRT off len) = parens (ppr off <> comma <> ppr len)
+pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
+pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*")
\end{code}
%************************************************************************
pprGenStgBinding (StgNonRec bndr rhs)
= hang (hsep [ppr bndr, equals])
- 4 ((<>) (ppr rhs) semi)
+ 4 ((<>) (ppr rhs) semi)
pprGenStgBinding (StgRec pairs)
= vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
+ (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
= hang (hsep [ppr bndr, equals])
pprGenStgBindingWithSRT
:: (Outputable bndr, Outputable bdee, Ord bdee)
- => (GenStgBinding bndr bdee,[Id]) -> SDoc
+ => (GenStgBinding bndr bdee,[(Id,[Id])]) -> SDoc
-pprGenStgBindingWithSRT (bind,srt)
- = vcat [ pprGenStgBinding bind,
- ptext SLIT("SRT: ") <> ppr srt ]
+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])] -> SDoc
+pprStgBindingsWithSRTs :: [(StgBinding,[(Id,[Id])])] -> SDoc
pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
\end{code}
pprStgExpr (StgConApp con args)
= hsep [ ppr con, brackets (interppSP args)]
-pprStgExpr (StgPrimApp op args _)
- = hsep [ ppr op, brackets (interppSP args)]
+pprStgExpr (StgOpApp op args _)
+ = hsep [ pprStgOp op, brackets (interppSP args)]
pprStgExpr (StgLam _ bndrs body)
=sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
--
-- 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
pprStgDefault (StgBindDefault expr) = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")])
4 (ppr expr)
+pprStgOp (StgPrimOp op) = ppr op
+pprStgOp (StgFCallOp op _) = ppr op
\end{code}
\begin{code}
=> 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 srt [{-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 ]
+ ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, 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 srt 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, pprMaybeSRT srt, 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
-
---------------
-
-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])))
-\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