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, nonEmptySRT,
+ SRT(..),
-- utils
- stgBindHasCafRefs, stgArgHasCafRefs, 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 Var ( isId )
-import Id ( Id, idName, idPrimRep, idType, idCafInfo )
+import Id ( Id, idName, idType, idCafInfo )
import IdInfo ( mayHaveCafRefs )
-import Name ( isDllName )
-import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
+import Packages ( isDllName )
+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 UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
import Bitmap
-import CmdLineOpts ( opt_SccProfilingOn )
+import DynFlags ( DynFlags )
+import Packages ( HomeModules )
+import StaticFlags ( opt_SccProfilingOn )
\end{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}
%************************************************************************
\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
+isDllArg :: HomeModules -> 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 hmods (StgTypeArg v) = False
+isDllArg hmods (StgVarArg v) = isDllName hmods (idName v)
+isDllArg hmods (StgLitArg lit) = False
-isDllConApp :: DataCon -> [StgArg] -> Bool
+isDllConApp :: HomeModules -> 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
+isDllConApp hmods con args
+ = isDllName hmods (dataConName con) || any (isDllArg hmods) args
stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
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}
%************************************************************************
| StgLetNoEscape -- remember: ``advanced stuff''
(GenStgLiveVars occ) -- Live in the whole let-expression
-- Mustn't overwrite these stack slots
- -- *Doesn't* include binders of the let(rec).
+ -- *Doesn't* include binders of the let(rec).
(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.
+ -- *Does* include binders of the let(rec) if recursive.
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
%* *
%************************************************************************
-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
+Very like in @CoreSyntax@ (except no type-world stuff).
-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}
%************************************************************************
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}