X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=a6f1868b6ea8c3580b97d9cbcdd730f6ec03715c;hb=f714e6b642fd614a9971717045ae47c3d871275e;hp=1f676346be2285c623cbaa4afec6e069b434990e;hpb=01ccc13fce6a0fb9e8cd19a5b5697da62feb1750;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 1f67634..a6f1868 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -10,32 +10,34 @@ suited to spineless tagless code generation. \begin{code} module StgSyn ( - GenStgArg(..), + GenStgArg(..), GenStgLiveVars, GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), - GenStgCaseAlts(..), GenStgCaseDefault(..), + GenStgAlt, AltType(..), 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 StgArg, StgLiveVars, - StgBinding, StgExpr, StgRhs, - StgCaseAlts, StgCaseDefault, + StgBinding, StgExpr, StgRhs, StgAlt, + + -- StgOp + StgOp(..), -- SRTs - SRT(..), noSRT, + SRT(..), + + -- utils + stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, + isDllConApp, isStgTypeArg, + stgArgType, - pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, - getArgPrimRep, - isLitLitArg, - stgArity, - collectFinalStgBinders + pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs #ifdef DEBUG , pprStgLVs @@ -45,13 +47,25 @@ module StgSyn ( #include "HsVersions.h" import CostCentre ( CostCentreStack, CostCentre ) -import Id ( idPrimRep, Id ) -import Const ( Con(..), DataCon, Literal, - conPrimRep, isLitLitLit ) -import PrimRep ( PrimRep(..) ) +import VarSet ( IdSet, isEmptyVarSet ) +import Var ( isId ) +import Id ( Id, idName, idType, idCafInfo ) +import IdInfo ( mayHaveCafRefs ) +import Name ( 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 Unique ( Unique ) +import Bitmap +import CmdLineOpts ( opt_SccProfilingOn ) \end{code} %************************************************************************ @@ -65,6 +79,8 @@ 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) @@ -80,15 +96,31 @@ data GenStgBinding bndr occ \begin{code} data GenStgArg occ = StgVarArg occ - | StgConArg Con -- A literal or nullary data constructor + | StgLitArg Literal + | StgTypeArg Type -- For when we want to preserve all type info \end{code} \begin{code} -getArgPrimRep (StgVarArg local) = idPrimRep local -getArgPrimRep (StgConArg con) = conPrimRep con - -isLitLitArg (StgConArg (Literal x)) = isLitLitLit x -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) = False + +isDllConApp :: 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 + +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} %************************************************************************ @@ -119,31 +151,45 @@ type GenStgLiveVars occ = UniqSet occ data GenStgExpr bndr occ = StgApp occ -- function - [GenStgArg occ] -- arguments - - -- NB: a literal is: StgApp [] ... + [GenStgArg occ] -- arguments; may be empty \end{code} %************************************************************************ %* * -\subsubsection{@StgCon@ and @StgPrim@---saturated applications} +\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications} %* * %************************************************************************ There are a specialised forms of application, for constructors, primitives, and literals. \begin{code} - | StgCon -- always saturated - Con - [GenStgArg occ] + | StgLit Literal + + | StgConApp DataCon + [GenStgArg occ] -- Saturated + + | 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. +\end{code} - Type -- Result type; this is needed for primops, where - -- we need to know the result type so that we can - -- assign result registers. +%************************************************************************ +%* * +\subsubsection{@StgLam@} +%* * +%************************************************************************ +StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished +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) + [bndr] + StgExpr -- Body of lambda \end{code} -These forms are to do ``inline versions,'' as it were. -An example might be: @f x = x:[]@. + %************************************************************************ %* * @@ -157,11 +203,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 @@ -172,7 +218,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} %************************************************************************ @@ -314,10 +363,10 @@ 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 + SRT -- The SRT reference [bndr] -- arguments; if empty, then not a function; -- as above, order is important. (GenStgExpr bndr occ) -- body @@ -346,47 +395,53 @@ The second flavour of right-hand-side is for constructors (simple but important) [GenStgArg occ] -- args \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 +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 Id -> Bool +stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs +stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds) - Bool -- At least one occurrence in an unsaturated application +rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _) + = isUpdatable upd || nonEmptySRT srt +rhsHasCafRefs (StgRhsCon _ _ args) + = any stgArgHasCafRefs args - Bool -- This thing (f) has at least occurrence of the form: - -- x = [..] \u [] -> f a b c - -- where the application is saturated +stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id) +stgArgHasCafRefs _ = False +\end{code} - Bool -- Ditto for non-updatable x. +Here's the @StgBinderInfo@ type, and its combining op: +\begin{code} +data StgBinderInfo + = NoStgBinderInfo + | 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 -- 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 +noBinderInfo = NoStgBinderInfo +stgUnsatOcc = NoStgBinderInfo +stgSatOcc = SatCallsOnly -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} %************************************************************************ @@ -395,28 +450,32 @@ combineStgBinderInfo (StgBinderInfo arg1 unsat1 std_heap1 upd_heap1 fkap1) %* * %************************************************************************ -Just like in @CoreSyntax@ (except no type-world stuff). +Very like in @CoreSyntax@ (except no type-world stuff). + +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 Type -- so we can find out things about constructor family - [(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 Type -- so we can find out things about constructor family - [(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} %************************************************************************ @@ -433,8 +492,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} %************************************************************************ @@ -465,44 +523,54 @@ isUpdatable Updatable = True %************************************************************************ %* * -\subsubsection[Static Reference Tables]{@SRT@} +\subsubsection{StgOp} %* * %************************************************************************ -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. +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 SRT = NoSRT - | SRT !Int{-offset-} !Int{-length-} +data StgOp = StgPrimOp PrimOp -noSRT :: SRT -noSRT = NoSRT - -pprSRT (NoSRT) = ptext SLIT("_no_srt_") -pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len) + | 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} + %************************************************************************ -%* * -\subsection[Stg-utility-functions]{Utility functions} -%* * +%* * +\subsubsection[Static Reference Tables]{@SRT@} +%* * %************************************************************************ +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. -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. +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} -collectFinalStgBinders - :: [StgBinding] -- input program - -> [Id] +data SRT = NoSRT + | SRTEntries IdSet + -- generated by CoreToStg + | SRT !Int{-offset-} !Int{-length-} !Bitmap{-bitmap-} + -- generated by computeSRTs -collectFinalStgBinders [] = [] -collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds -collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds +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 length bitmap) = parens (ppr off <> comma <> text "*bitmap*") \end{code} %************************************************************************ @@ -520,11 +588,11 @@ pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) pprGenStgBinding (StgNonRec bndr rhs) = hang (hsep [ppr bndr, equals]) - 4 ((<>) (ppr rhs) semi) + 4 ((<>) (ppr rhs) semi) pprGenStgBinding (StgRec pairs) = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) : - (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) + (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))]) where ppr_bind (bndr, expr) = hang (hsep [ppr bndr, equals]) @@ -538,13 +606,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} @@ -569,14 +638,15 @@ instance (Outputable bndr, Outputable bdee, Ord bdee) pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc pprStgArg (StgVarArg var) = ppr var -pprStgArg (StgConArg con) = ppr con +pprStgArg (StgLitArg con) = ppr con +pprStgArg (StgTypeArg ty) = char '@' <+> ppr ty \end{code} \begin{code} pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) => GenStgExpr bndr bdee -> SDoc -- special case -pprStgExpr (StgApp func []) = ppr func +pprStgExpr (StgLit lit) = ppr lit -- general case pprStgExpr (StgApp func args) @@ -585,8 +655,15 @@ pprStgExpr (StgApp func args) \end{code} \begin{code} -pprStgExpr (StgCon con args _) +pprStgExpr (StgConApp con args) = hsep [ ppr con, brackets (interppSP args)] + +pprStgExpr (StgOpApp op args _) + = hsep [ pprStgOp op, brackets (interppSP args)] + +pprStgExpr (StgLam _ bndrs body) + =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"), + pprStgExpr body ] \end{code} \begin{code} @@ -598,7 +675,8 @@ pprStgExpr (StgCon con args _) -- -- 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(" = "), @@ -609,12 +687,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 @@ -632,19 +712,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 ( @@ -652,31 +728,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 (ppr_alts alts), + nest 2 (vcat (map pprStgAlt 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 - - ppr_alts (StgAlgAlts ty alts deflt) - = vcat [ vcat (map (ppr_bxd_alt) alts), - ppr_default 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) - = vcat [ vcat (map (ppr_ubxd_alt) alts), - ppr_default deflt ] - where - ppr_ubxd_alt (lit, expr) - = hang (hsep [ppr lit, ptext SLIT("->")]) - 4 ((<>) (ppr expr) semi) + +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} @@ -694,20 +760,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 srt [{-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 ] + ptext SLIT(" \\"), ppr upd_flag, pprMaybeSRT srt, 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 srt 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, pprMaybeSRT srt, brackets (interppSP args)]) 4 (ppr body) pprStgRhs (StgRhsCon cc con args) @@ -715,30 +779,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}