X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=75f6a94eec7b2ed3120abd5ed01f05168eeaee83;hb=8d16c87c0557b60d2f2f5c3fa1a1bfa1605f07c9;hp=633d5beabc43ef895afa0b546a0689253fc2aafd;hpb=10cbc75d37064b3ef76ca3ccd219d66e445ecb0f;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 633d5be..75f6a94 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -10,11 +10,11 @@ suited to spineless tagless code generation. \begin{code} module StgSyn ( - GenStgArg(..), + GenStgArg(..), GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgCaseAlts(..), GenStgCaseDefault(..), + GenStgAlt, AltType(..), UpdateFlag(..), isUpdatable, @@ -24,18 +24,20 @@ module StgSyn ( -- 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 @@ -46,16 +48,25 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) -import Id ( Id, idName, idPrimRep, idType ) -import Name ( isDllName ) -import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) +import Var ( isId ) +import Id ( Id, idName, idType, idCafInfo ) +import IdInfo ( mayHaveCafRefs ) +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 Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) -import CmdLineOpts ( opt_SccProfilingOn ) +import Unique ( Unique ) +import Bitmap +import DynFlags ( DynFlags ) +import StaticFlags ( opt_SccProfilingOn ) \end{code} %************************************************************************ @@ -73,12 +84,8 @@ There is one SRT for each group of bindings. \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} %************************************************************************ @@ -95,30 +102,27 @@ data GenStgArg occ \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 :: DynFlags -> StgArg -> Bool -- Does this argument refer to something in a different DLL? -isDllArg (StgVarArg v) = isDllName (idName v) -isDllArg (StgLitArg lit) = isLitLitLit lit +isDllArg dflags (StgTypeArg v) = False +isDllArg dflags (StgVarArg v) = isDllName dflags (idName v) +isDllArg dflags (StgLitArg lit) = False -isDllConApp :: DataCon -> [StgArg] -> Bool +isDllConApp :: DynFlags -> 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 dflags con args + = isDllName dflags (dataConName con) || any (isDllArg dflags) args stgArgType :: StgArg -> Type -- 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} %************************************************************************ @@ -166,7 +170,7 @@ constructors, primitives, and literals. | 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. @@ -201,11 +205,11 @@ This has the same boxed/unboxed business as Core case expressions. (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 @@ -216,7 +220,10 @@ This has the same boxed/unboxed business as Core case expressions. 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} %************************************************************************ @@ -319,12 +326,12 @@ And so the code for let(rec)-things: | 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 @@ -361,6 +368,7 @@ data GenStgRhs bndr occ [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 @@ -390,20 +398,26 @@ The second flavour of right-hand-side is for constructors (simple but important) \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: @@ -438,53 +452,32 @@ pp_binder_info SatCallsOnly = ptext SLIT("sat-only") %* * %************************************************************************ -Just like in @CoreSyntax@ (except no type-world stuff). - -* Algebraic cases are done using - StgAlgAlts (Just tc) alts deflt +Very like in @CoreSyntax@ (except no type-world stuff). -* 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. +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} %************************************************************************ @@ -501,8 +494,7 @@ type StgArg = GenStgArg Id 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} %************************************************************************ @@ -533,6 +525,26 @@ isUpdatable Updatable = True %************************************************************************ %* * +\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@} %* * %************************************************************************ @@ -546,8 +558,10 @@ converted into the length and offset form by the SRT pass. \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 @@ -558,7 +572,7 @@ 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) +pprSRT (SRT off length bitmap) = parens (ppr off <> comma <> text "*bitmap*") \end{code} %************************************************************************ @@ -574,13 +588,12 @@ hoping he likes terminators instead... Ditto for case alternatives. 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) @@ -595,13 +608,14 @@ pprStgBindings binds = vcat (map pprGenStgBinding binds) 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} @@ -646,8 +660,8 @@ pprStgExpr (StgApp func args) 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("->"), @@ -700,19 +714,15 @@ pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) 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 ( @@ -720,32 +730,21 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts) 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} @@ -763,18 +762,18 @@ pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => 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) @@ -782,5 +781,5 @@ 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}