X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=633d5beabc43ef895afa0b546a0689253fc2aafd;hb=21a542ddc3d02e0d3a8be28e0aa00796970adb9e;hp=aacde304a87fc404c7a37908e5212a807fbf28c7;hpb=9579283cadf4ac68a6f4252244041b5127e16811;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index aacde30..633d5be 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -18,9 +18,8 @@ module StgSyn ( 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 @@ -31,11 +30,12 @@ module StgSyn ( -- SRTs SRT(..), noSRT, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, - getArgPrimRep, + -- utils + stgBindHasCafRefs, stgRhsArity, getArgPrimRep, isLitLitArg, isDllConApp, isStgTypeArg, - stgArity, stgArgType, - collectFinalStgBinders + stgArgType, stgBinders, + + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts #ifdef DEBUG , pprStgLVs @@ -45,15 +45,17 @@ module StgSyn ( #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 DataCon ( DataCon, dataConName, isNullaryDataCon ) +import DataCon ( DataCon, dataConName ) import PrimOp ( PrimOp ) -import PrimRep ( PrimRep(..) ) import Outputable import Type ( Type ) +import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) +import CmdLineOpts ( opt_SccProfilingOn ) \end{code} %************************************************************************ @@ -67,10 +69,16 @@ are the boring things [except note the @GenStgRhs@], parameterised 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} %************************************************************************ @@ -176,7 +184,7 @@ it encodes (\x -> e) as (let f = \x -> e in f) \begin{code} | StgLam Type -- Type of whole lambda (useful when making a binder for it) - [Id] + [bndr] StgExpr -- Body of lambda \end{code} @@ -350,10 +358,9 @@ data GenStgRhs bndr occ = 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 @@ -382,47 +389,47 @@ The second flavour of right-hand-side is for constructors (simple but important) [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 = NoStgBinderInfo - | StgBinderInfo - Bool -- At least one occurrence as an argument - - Bool -- At least one occurrence in an unsaturated application + | 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 -- This thing (f) has at least occurrence of the form: - -- x = [..] \u [] -> f a b c - -- where the application is saturated +noBinderInfo = NoStgBinderInfo +stgUnsatOcc = NoStgBinderInfo +stgSatOcc = SatCallsOnly - Bool -- Ditto for non-updatable x. - - 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 - -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} %************************************************************************ @@ -433,9 +440,33 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) 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 + +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. + \begin{code} data GenStgCaseAlts bndr occ - = StgAlgAlts Type -- so we can find out things about constructor family + = 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 @@ -444,7 +475,8 @@ data GenStgCaseAlts bndr occ -- used in the ... GenStgExpr bndr occ)] -- ...right-hand side. (GenStgCaseDefault bndr occ) - | StgPrimAlts Type -- so we can find out things about constructor family + + | StgPrimAlts TyCon [(Literal, -- alts: unboxed literal, GenStgExpr bndr occ)] -- rhs. (GenStgCaseDefault bndr occ) @@ -509,40 +541,28 @@ There is one SRT per top-level function group. Each local binding and 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} %************************************************************************ %* * -\subsection[Stg-utility-functions]{Utility functions} -%* * -%************************************************************************ - - -For doing interfaces, we want the exported top-level Ids from the -final pre-codegen STG code, so as to be sure we have the -latest/greatest pragma info. - -\begin{code} -collectFinalStgBinders - :: [StgBinding] -- input program - -> [Id] - -collectFinalStgBinders [] = [] -collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds -collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds -\end{code} - -%************************************************************************ -%* * \subsection[Stg-pretty-printing]{Pretty-printing} %* * %************************************************************************ @@ -554,13 +574,14 @@ hoping he likes terminators instead... Ditto for case alternatives. 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]) @@ -606,7 +627,7 @@ pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var pprStgArg (StgLitArg con) = ppr con -pprStgARg (StgTypeArg ty) = char '@' <+> ppr ty +pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty \end{code} \begin{code} @@ -642,7 +663,8 @@ pprStgExpr (StgLam _ bndrs body) -- -- 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(" = "), @@ -653,12 +675,14 @@ pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag a 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 @@ -696,31 +720,32 @@ pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts) ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss), ptext SLIT("]; "), pprMaybeSRT srt])), - nest 2 (ppr_alts alts), + nest 2 (pprStgAlts alts), char '}'] where - ppr_default StgNoDefault = empty - ppr_default (StgBindDefault expr) - = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr) - - pp_ty (StgAlgAlts ty _ _) = ppr ty - pp_ty (StgPrimAlts ty _ _) = ppr ty + pp_ty (StgAlgAlts maybe_tycon _ _) = ppr maybe_tycon + pp_ty (StgPrimAlts tycon _ _) = ppr tycon - ppr_alts (StgAlgAlts ty alts deflt) +pprStgAlts (StgAlgAlts _ alts deflt) = vcat [ vcat (map (ppr_bxd_alt) alts), - ppr_default deflt ] + pprStgDefault deflt ] where ppr_bxd_alt (con, params, use_mask, expr) = hang (hsep [ppr con, interppSP params, ptext SLIT("->")]) 4 ((<>) (ppr expr) semi) - ppr_alts (StgPrimAlts ty alts deflt) +pprStgAlts (StgPrimAlts _ alts deflt) = vcat [ vcat (map (ppr_ubxd_alt) alts), - ppr_default deflt ] + 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) + \end{code} \begin{code} @@ -738,20 +763,18 @@ pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) => 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) @@ -759,30 +782,5 @@ 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}