X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=31e2057f560c59d468a8df627d7c23847783f896;hb=cbc2146f970905a626c4ef364f08b75965c8bf8e;hp=2de6d625cc4e47699b16e37cd679456b8c36b46b;hpb=3af411e913102d8ec1234f32abe99374f077e3f7;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 2de6d62..31e2057 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -31,10 +31,10 @@ module StgSyn ( StgOp(..), -- SRTs - SRT(..), noSRT, + SRT(..), noSRT, nonEmptySRT, -- utils - stgBindHasCafRefs, stgRhsArity, getArgPrimRep, + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, getArgPrimRep, isLitLitArg, isDllConApp, isStgTypeArg, stgArgType, stgBinders, @@ -50,7 +50,8 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) import Var ( isId ) -import Id ( Id, idName, idPrimRep, idType ) +import Id ( Id, idName, idPrimRep, idType, idCafInfo ) +import IdInfo ( mayHaveCafRefs ) import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) import ForeignCall ( ForeignCall ) @@ -62,6 +63,7 @@ import Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) +import Bitmap import CmdLineOpts ( opt_SccProfilingOn ) \end{code} @@ -80,12 +82,12 @@ 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)] + = 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 +stgBinders (StgNonRec b _) = [b] +stgBinders (StgRec bs) = map fst bs \end{code} %************************************************************************ @@ -210,11 +212,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 @@ -370,6 +372,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 @@ -400,7 +403,7 @@ The second flavour of right-hand-side is for constructors (simple but important) \begin{code} stgRhsArity :: StgRhs -> Int -stgRhsArity (StgRhsClosure _ _ _ _ bndrs _) = count isId bndrs +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. @@ -408,14 +411,17 @@ 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: @@ -578,8 +584,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 @@ -590,7 +598,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} %************************************************************************ @@ -606,13 +614,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) @@ -627,13 +634,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} @@ -797,18 +805,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) @@ -816,5 +824,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}