GenStgLiveVars,
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
- GenStgCaseAlts(..), GenStgCaseDefault(..),
+ GenStgAlt, AltType(..),
UpdateFlag(..), isUpdatable,
-- a set of synonyms for the most common (only :-) parameterisation
StgArg, StgLiveVars,
- StgBinding, StgExpr, StgRhs,
- StgCaseAlts, StgCaseDefault,
+ StgBinding, StgExpr, StgRhs, StgAlt,
-- StgOp
StgOp(..),
-- SRTs
- SRT(..), noSRT,
+ SRT(..),
-- utils
- stgBindHasCafRefs, stgRhsArity, getArgPrimRep,
- isLitLitArg, isDllConApp, isStgTypeArg,
- stgArgType, stgBinders,
+ stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+ isDllConApp, isStgTypeArg,
+ stgArgType,
- pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs
#ifdef DEBUG
, pprStgLVs
import CostCentre ( CostCentreStack, CostCentre )
import VarSet ( IdSet, isEmptyVarSet )
-import Id ( Id, idName, idPrimRep, idType )
+import Var ( isId )
+import Id ( Id, idName, idType, idCafInfo )
+import IdInfo ( mayHaveCafRefs )
import Name ( isDllName )
-import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+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}
\begin{code}
data GenStgBinding 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
+ = StgNonRec bndr (GenStgRhs bndr occ)
+ | StgRec [(bndr, GenStgRhs bndr occ)]
\end{code}
%************************************************************************
\end{code}
\begin{code}
-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 (StgTypeArg v) = False
isDllArg (StgVarArg v) = isDllName (idName v)
-isDllArg (StgLitArg lit) = isLitLitLit lit
+isDllArg (StgLitArg lit) = False
isDllConApp :: DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
-- 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}
%************************************************************************
(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
SRT -- The SRT for the continuation
- (GenStgCaseAlts bndr occ)
+ AltType
+
+ [GenStgAlt bndr occ] -- The DEFAULT case is always *first*
+ -- if it is there at all
\end{code}
%************************************************************************
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
!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
\end{code}
\begin{code}
-stgRhsArity :: GenStgRhs bndr occ -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args
+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}
\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
+stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
+stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
+stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
+
+rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
+ = isUpdatable upd || nonEmptySRT srt
+rhsHasCafRefs (StgRhsCon _ _ args)
+ = any stgArgHasCafRefs args
+
+stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
+stgArgHasCafRefs _ = False
\end{code}
Here's the @StgBinderInfo@ type, and its combining op:
%* *
%************************************************************************
-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
+Very like in @CoreSyntax@ (except no type-world stuff).
-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.
+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 (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
- -- param's position if it is
- -- used in the ...
- GenStgExpr bndr occ)] -- ...right-hand side.
- (GenStgCaseDefault bndr occ)
-
- | 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 (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}
%************************************************************************
\begin{code}
data SRT = NoSRT
- | SRTEntries IdSet -- generated by CoreToStg
- | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs
+ | SRTEntries IdSet
+ -- generated by CoreToStg
+ | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-}
+ -- generated by computeSRTs
noSRT :: SRT
noSRT = NoSRT
pprSRT (NoSRT) = ptext SLIT("_no_srt_")
pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
-pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
+pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*")
\end{code}
%************************************************************************
pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
=> GenStgBinding bndr bdee -> SDoc
-pprGenStgBinding (StgNonRec srt bndr rhs)
- = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals])
- 4 ((<>) (ppr rhs) semi)
+pprGenStgBinding (StgNonRec bndr rhs)
+ = hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr rhs) semi)
-pprGenStgBinding (StgRec srt pairs)
+pprGenStgBinding (StgRec pairs)
= vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- pprMaybeSRT srt :
(map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
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}
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
char ']']))))
2 (ppr expr)]
-\end{code}
-\begin{code}
pprStgExpr (StgSCC cc expr)
= sep [ hsep [ptext SLIT("_scc_"), ppr cc],
pprStgExpr expr ]
-\end{code}
-\begin{code}
-pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
= sep [sep [ptext SLIT("case"),
nest 4 (hsep [pprStgExpr expr,
- ifPprDebug (dcolon <+> pp_ty alts)]),
+ ifPprDebug (dcolon <+> ppr alt_type)]),
ptext SLIT("of"), ppr bndr, char '{'],
ifPprDebug (
nest 4 (
ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
ptext SLIT("]; "),
pprMaybeSRT srt])),
- nest 2 (pprStgAlts alts),
+ nest 2 (vcat (map pprStgAlt alts)),
char '}']
- where
- pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon
- pp_ty (StgPrimAlts tycon _ _) = ppr tycon
-
-pprStgAlts (StgAlgAlts _ alts deflt)
- = vcat [ vcat (map (ppr_bxd_alt) alts),
- pprStgDefault deflt ]
- where
- ppr_bxd_alt (con, params, use_mask, expr)
- = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
- 4 ((<>) (ppr expr) semi)
-
-pprStgAlts (StgPrimAlts _ alts deflt)
- = vcat [ vcat (map (ppr_ubxd_alt) alts),
- 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)
+
+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}
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi [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,
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 free_vars upd_flag args body)
+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, brackets (interppSP args)])
+ 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
+pprMaybeSRT srt = ptext SLIT("srt:") <> pprSRT srt
\end{code}
projects / ghc-hetmet.git / blobdiff