summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorÖmer Sinan Ağacan <omeragacan@gmail.com>2016-02-08 16:18:23 -0500
committerÖmer Sinan Ağacan <omeragacan@gmail.com>2016-02-08 16:19:28 -0500
commit023fc92f6f98a8bd003ce20083d3682aec865cb5 (patch)
treeb08895d5e7575cfc29fa0a13e37df4445b93f6bc /compiler
parent489a9a3beeeae3d150761ef863b4757eba0b02d9 (diff)
downloadhaskell-023fc92f6f98a8bd003ce20083d3682aec865cb5.tar.gz
Remove unused LiveVars and SRT fields of StgCase
We also need to update `stgBindHasCafRefs` assertion with this change, as we no longer have the pre-computed SRT, LiveVars etc. We rename it to `topStgBindHasCafRefs` and implement it like this: A non-updatable top-level binding may refer to a CAF by referring to a top-level definition with CAFs. A top-level definition may have CAFs if it's updatable. At this point (because this is done after TidyPgm) top-level Ids (whether imported or defined in this module) are GlobalIds, so the top-levelness test is easy. (see also comments in the code) Reviewers: bgamari, simonpj, austin Reviewed By: simonpj Subscribers: thomie Differential Revision: https://phabricator.haskell.org/D1889 GHC Trac Issues: #11550
Diffstat (limited to 'compiler')
-rw-r--r--compiler/codeGen/StgCmm.hs2
-rw-r--r--compiler/codeGen/StgCmmBind.hs4
-rw-r--r--compiler/codeGen/StgCmmExpr.hs6
-rw-r--r--compiler/main/HscMain.hs4
-rw-r--r--compiler/profiling/SCCfinal.hs24
-rw-r--r--compiler/simplStg/StgStats.hs6
-rw-r--r--compiler/simplStg/UnariseStg.hs26
-rw-r--r--compiler/stgSyn/CoreToStg.hs226
-rw-r--r--compiler/stgSyn/StgLint.hs8
-rw-r--r--compiler/stgSyn/StgSyn.hs170
10 files changed, 164 insertions, 312 deletions
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index b0dd9b11b8..9d14db9bb8 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -141,7 +141,7 @@ cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)
= cgTopRhsCon dflags bndr con args
-cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgTopRhs dflags rec bndr (StgRhsClosure cc bi fvs upd_flag args body)
= ASSERT(null fvs) -- There should be no free variables
cgTopRhsClosure dflags rec bndr cc bi upd_flag args body
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index fde662b317..ea05e8d488 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -210,7 +210,7 @@ cgRhs id (StgRhsCon cc con args)
buildDynCon id True cc con args
{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
-cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
+cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
= do dflags <- getDynFlags
mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
@@ -268,7 +268,7 @@ mkRhsClosure dflags bndr _cc _bi
expr
| let strip = snd . stripStgTicksTop (not . tickishIsCode)
, StgCase (StgApp scrutinee [{-no args-}])
- _ _ _ _ -- ignore uniq, etc.
+ _ -- ignore bndr
(AlgAlt _)
[(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
, StgApp selectee [{-no args-}] <- strip sel_expr
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 923450e6f3..0f3898bf81 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -71,7 +71,7 @@ cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr }
-cgExpr (StgLetNoEscape _ _ binds expr) =
+cgExpr (StgLetNoEscape binds expr) =
do { u <- newUnique
; let join_id = mkBlockId u
; cgLneBinds join_id binds
@@ -79,7 +79,7 @@ cgExpr (StgLetNoEscape _ _ binds expr) =
; emitLabel join_id
; return r }
-cgExpr (StgCase expr _live_vars _save_vars bndr _srt alt_type alts) =
+cgExpr (StgCase expr bndr alt_type alts) =
cgCase expr bndr alt_type alts
cgExpr (StgLam {}) = panic "cgExpr: StgLam"
@@ -140,7 +140,7 @@ cgLetNoEscapeRhsBody
-> Id
-> StgRhs
-> FCode (CgIdInfo, FCode ())
-cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd _ args body)
+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd args body)
= cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body
cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)
= cgLetNoEscapeClosure bndr local_cc cc [] (StgConApp con args)
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 58434e93c6..4b26cdb03e 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1436,8 +1436,8 @@ myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgBinding] -- output program
, CollectedCCs) -- cost centre info (declared and used)
myCoreToStg dflags this_mod prepd_binds = do
- stg_binds
- <- {-# SCC "Core2Stg" #-}
+ let stg_binds
+ = {-# SCC "Core2Stg" #-}
coreToStg dflags this_mod prepd_binds
(stg_binds2, cost_centre_info)
diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs
index 6cab87c9cd..6bd00b0f61 100644
--- a/compiler/profiling/SCCfinal.hs
+++ b/compiler/profiling/SCCfinal.hs
@@ -90,7 +90,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
----------
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
- do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
+ do_top_rhs _ (StgRhsClosure _ _ _ _ []
(StgTick (ProfNote _cc False{-not tick-} _push)
(StgConApp con args)))
| not (isDllConApp dflags mod_name con args)
@@ -100,7 +100,7 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- isDllConApp checks for LitLit args too
= return (StgRhsCon dontCareCCS con args)
- do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body)
+ do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
= do
-- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs)
@@ -119,11 +119,11 @@ stgMassageForProfiling dflags mod_name _us stg_binds
else
return all_cafs_ccs
body' <- do_expr body
- return (StgRhsClosure caf_ccs bi fv u srt [] body')
+ return (StgRhsClosure caf_ccs bi fv u [] body')
- do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body)
+ do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
= do body' <- do_expr body
- return (StgRhsClosure dontCareCCS bi fv u srt args body')
+ return (StgRhsClosure dontCareCCS bi fv u args body')
do_top_rhs _ (StgRhsCon _ con args)
-- Top-level (static) data is not counted in heap
@@ -155,10 +155,10 @@ stgMassageForProfiling dflags mod_name _us stg_binds
expr' <- do_expr expr
return (StgTick ti expr')
- do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
+ do_expr (StgCase expr bndr alt_type alts) = do
expr' <- do_expr expr
alts' <- mapM do_alt alts
- return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
+ return (StgCase expr' bndr alt_type alts')
where
do_alt (id, bs, use_mask, e) = do
e' <- do_expr e
@@ -168,9 +168,9 @@ stgMassageForProfiling dflags mod_name _us stg_binds
(b,e) <- do_let b e
return (StgLet b e)
- do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
+ do_expr (StgLetNoEscape b e) = do
(b,e) <- do_let b e
- return (StgLetNoEscape lvs1 lvs2 b e)
+ return (StgLetNoEscape b e)
do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
@@ -200,15 +200,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- allocation of the constructor to the wrong place (XXX)
-- We should really attach (PushCC cc CurrentCCS) to the rhs,
-- but need to reinstate PushCC for that.
- do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt []
+ do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
(StgTick (ProfNote cc False{-not tick-} _push)
(StgConApp con args)))
= do collectCC cc
return (StgRhsCon currentCCS con args)
- do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
+ do_rhs (StgRhsClosure _ bi fv u args expr) = do
expr' <- do_expr expr
- return (StgRhsClosure currentCCS bi fv u srt args expr')
+ return (StgRhsClosure currentCCS bi fv u args expr')
do_rhs (StgRhsCon _ con args)
= return (StgRhsCon currentCCS con args)
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index dd1f5a64d2..5860f61057 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -127,7 +127,7 @@ statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (_, StgRhsCon _ _ _)
= countOne (ConstructorBinds top)
-statRhs top (_, StgRhsClosure _ _ fv u _ _ body)
+statRhs top (_, StgRhsClosure _ _ fv u _ body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
@@ -153,7 +153,7 @@ statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgTick _ e) = statExpr e
-statExpr (StgLetNoEscape _ _ binds body)
+statExpr (StgLetNoEscape binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body `combineSE`
countOne LetNoEscapes
@@ -162,7 +162,7 @@ statExpr (StgLet binds body)
= statBinding False{-not top-level-} binds `combineSE`
statExpr body
-statExpr (StgCase expr _ _ _ _ _ alts)
+statExpr (StgCase expr _ _ alts)
= statExpr expr `combineSE`
stat_alts alts `combineSE`
countOne StgCases
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index b16220134d..705fce01b3 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -42,7 +42,6 @@ import MkId (realWorldPrimId)
import Type
import TysWiredIn
import DataCon
-import VarSet
import OccName
import Name
import Util
@@ -74,9 +73,9 @@ unariseBinding us rho bind = case bind of
unariseRhs :: UniqSupply -> UnariseEnv -> StgRhs -> StgRhs
unariseRhs us rho rhs = case rhs of
- StgRhsClosure ccs b_info fvs update_flag srt args expr
+ StgRhsClosure ccs b_info fvs update_flag args expr
-> StgRhsClosure ccs b_info (unariseIds rho fvs) update_flag
- (unariseSRT rho srt) args' (unariseExpr us' rho' expr)
+ args' (unariseExpr us' rho' expr)
where (us', rho', args') = unariseIdBinders us rho args
StgRhsCon ccs con args
-> StgRhsCon ccs con (unariseArgs rho args)
@@ -111,10 +110,8 @@ unariseExpr us rho (StgLam xs e)
where
(us', rho', xs') = unariseIdBinders us rho xs
-unariseExpr us rho (StgCase e case_lives alts_lives bndr srt alt_ty alts)
- = StgCase (unariseExpr us1 rho e) (unariseLives rho case_lives)
- (unariseLives rho alts_lives) bndr (unariseSRT rho srt)
- alt_ty alts'
+unariseExpr us rho (StgCase e bndr alt_ty alts)
+ = StgCase (unariseExpr us1 rho e) bndr alt_ty alts'
where
(us1, us2) = splitUniqSupply us
alts' = unariseAlts us2 rho alt_ty bndr alts
@@ -124,9 +121,8 @@ unariseExpr us rho (StgLet bind e)
where
(us1, us2) = splitUniqSupply us
-unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
- = StgLetNoEscape (unariseLives rho live_in_let) (unariseLives rho live_in_bind)
- (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
+unariseExpr us rho (StgLetNoEscape bind e)
+ = StgLetNoEscape (unariseBinding us1 rho bind) (unariseExpr us2 rho e)
where
(us1, us2) = splitUniqSupply us
@@ -161,13 +157,6 @@ unariseAlt us rho (con, xs, uses, e)
(us', rho', xs', uses') = unariseUsedIdBinders us rho xs uses
------------------------
-unariseSRT :: UnariseEnv -> SRT -> SRT
-unariseSRT _ NoSRT = NoSRT
-unariseSRT rho (SRTEntries ids) = SRTEntries (concatMapVarSet (unariseId rho) ids)
-
-unariseLives :: UnariseEnv -> StgLiveVars -> StgLiveVars
-unariseLives rho ids = concatMapVarSet (unariseId rho) ids
-
unariseArgs :: UnariseEnv -> [StgArg] -> [StgArg]
unariseArgs rho = concatMap (unariseArg rho)
@@ -212,6 +201,3 @@ unariseIdBinder us rho x = case repType (idType x) of
unboxedTupleBindersFrom :: UniqSupply -> Id -> [UnaryType] -> [Id]
unboxedTupleBindersFrom us x tys = zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys
where fs = occNameFS (getOccName x)
-
-concatMapVarSet :: (Var -> [Var]) -> VarSet -> VarSet
-concatMapVarSet f xs = mkVarSet [x' | x <- varSetElems xs, x' <- f x]
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 0f81ab3027..414571cbf8 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -50,11 +50,10 @@ import Control.Monad (liftM, ap)
-- Note [Live vs free]
-- ~~~~~~~~~~~~~~~~~~~
--
--- The actual Stg datatype is decorated with live variable information, as well
--- as free variable information. The two are not the same. Liveness is an
--- operational property rather than a semantic one. A variable is live at a
--- particular execution point if it can be referred to directly again. In
--- particular, a dead variable's stack slot (if it has one):
+-- The two are not the same. Liveness is an operational property rather
+-- than a semantic one. A variable is live at a particular execution
+-- point if it can be referred to directly again. In particular, a dead
+-- variable's stack slot (if it has one):
--
-- - should be stubbed to avoid space leaks, and
-- - may be reused for something else.
@@ -88,8 +87,7 @@ import Control.Monad (liftM, ap)
-- Note [Collecting live CAF info]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
--- In this pass we also collect information on which CAFs are live for
--- constructing SRTs (see SRT.hs).
+-- In this pass we also collect information on which CAFs are live.
--
-- A top-level Id has CafInfo, which is
--
@@ -108,24 +106,6 @@ import Control.Monad (liftM, ap)
-- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
-- pairs.
-
--- Note [Interaction of let-no-escape with SRTs]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Consider
---
--- let-no-escape x = ...caf1...caf2...
--- in
--- ...x...x...x...
---
--- where caf1,caf2 are CAFs. Since x doesn't have a closure, we
--- build SRTs just as if x's defn was inlined at each call site, and
--- that means that x's CAF refs get duplicated in the overall SRT.
---
--- This is unlike ordinary lets, in which the CAF refs are not duplicated.
---
--- We could fix this loss of (static) sharing by making a sort of pseudo-closure
--- for x, solely to put in the SRTs lower down.
-
-- Note [What is a non-escaping let]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
@@ -186,9 +166,9 @@ import Control.Monad (liftM, ap)
-- Setting variable info: top-level, binds, RHSs
-- --------------------------------------------------------------
-coreToStg :: DynFlags -> Module -> CoreProgram -> IO [StgBinding]
+coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
coreToStg dflags this_mod pgm
- = return pgm'
+ = pgm'
where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
@@ -273,7 +253,7 @@ consistentCafInfo id bind
safe = id_marked_caffy || not binding_is_caffy
exact = id_marked_caffy == binding_is_caffy
id_marked_caffy = mayHaveCafRefs (idCafInfo id)
- binding_is_caffy = stgBindHasCafRefs bind
+ binding_is_caffy = topStgBindHasCafRefs bind
is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"
coreToTopStgRhs
@@ -285,9 +265,8 @@ coreToTopStgRhs
coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
= do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs
- ; lv_info <- freeVarsToLiveVars rhs_fvs
- ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs
+ ; let stg_rhs = mkTopStgRhs dflags this_mod rhs_fvs bndr bndr_info new_rhs
stg_arity = stgRhsArity stg_rhs
; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,
rhs_fvs) }
@@ -314,7 +293,7 @@ coreToTopStgRhs dflags this_mod scope_fv_info (bndr, rhs)
text "STG arity:" <+> ppr stg_arity]
mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
- -> SRT -> Id -> StgBinderInfo -> StgExpr
+ -> Id -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
@@ -414,23 +393,12 @@ coreToStgExpr (Case scrut bndr _ alts) = do
alts_fvs_wo_bndr = bndr `minusFVBinder` alts_fvs
alts_escs_wo_bndr = alts_escs `delVarSet` bndr
- alts_lv_info <- freeVarsToLiveVars alts_fvs_wo_bndr
-
-- We tell the scrutinee that everything
-- live in the alts is live in it, too.
- (scrut2, scrut_fvs, _scrut_escs, scrut_lv_info)
- <- setVarsLiveInCont alts_lv_info $ do
- (scrut2, scrut_fvs, scrut_escs) <- coreToStgExpr scrut
- scrut_lv_info <- freeVarsToLiveVars scrut_fvs
- return (scrut2, scrut_fvs, scrut_escs, scrut_lv_info)
+ (scrut2, scrut_fvs, _scrut_escs) <- coreToStgExpr scrut
return (
- StgCase scrut2 (getLiveVars scrut_lv_info)
- (getLiveVars alts_lv_info)
- bndr'
- (mkSRT alts_lv_info)
- (mkStgAltType bndr alts)
- alts2,
+ StgCase scrut2 bndr' (mkStgAltType bndr alts) alts2,
scrut_fvs `unionFVInfo` alts_fvs_wo_bndr,
alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs
-- You might think we should have scrut_escs, not
@@ -682,39 +650,29 @@ coreToStgLet
-- is among the escaping vars
coreToStgLet let_no_escape bind body = do
- (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
- <- mfix $ \ ~(_, _, _, _, _, rec_body_fvs, _, _) -> do
-
- -- Do the bindings, setting live_in_cont to empty if
- -- we ain't in a let-no-escape world
- live_in_cont <- getVarsLiveInCont
- ( bind2, bind_fvs, bind_escs, bind_lv_info, env_ext)
- <- setVarsLiveInCont (if let_no_escape
- then live_in_cont
- else emptyLiveInfo)
- (vars_bind rec_body_fvs bind)
+ (bind2, bind_fvs, bind_escs,
+ body2, body_fvs, body_escs)
+ <- mfix $ \ ~(_, _, _, _, rec_body_fvs, _) -> do
+
+ ( bind2, bind_fvs, bind_escs, env_ext)
+ <- vars_bind rec_body_fvs bind
-- Do the body
extendVarEnvLne env_ext $ do
(body2, body_fvs, body_escs) <- coreToStgExpr body
- body_lv_info <- freeVarsToLiveVars body_fvs
- return (bind2, bind_fvs, bind_escs, getLiveVars bind_lv_info,
- body2, body_fvs, body_escs, getLiveVars body_lv_info)
+ return (bind2, bind_fvs, bind_escs,
+ body2, body_fvs, body_escs)
-- Compute the new let-expression
let
- new_let | let_no_escape = StgLetNoEscape live_in_whole_let bind_lvs bind2 body2
+ new_let | let_no_escape = StgLetNoEscape bind2 body2
| otherwise = StgLet bind2 body2
free_in_whole_let
= binders `minusFVBinders` (bind_fvs `unionFVInfo` body_fvs)
- live_in_whole_let
- = bind_lvs `unionVarSet` (body_lvs `delVarSetList` binders)
-
real_bind_escs = if let_no_escape then
bind_escs
else
@@ -747,49 +705,43 @@ coreToStgLet let_no_escape bind body = do
set_of_binders = mkVarSet binders
binders = bindersOf bind
- mk_binding bind_lv_info binder rhs
- = (binder, LetBound (NestedLet live_vars) (manifestArity rhs))
- where
- live_vars | let_no_escape = addLiveVar bind_lv_info binder
- | otherwise = unitLiveVar binder
- -- c.f. the invariant on NestedLet
+ mk_binding binder rhs
+ = (binder, LetBound NestedLet (manifestArity rhs))
vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
-> LneM (StgBinding,
FreeVarsInfo,
EscVarsSet, -- free vars; escapee vars
- LiveInfo, -- Vars and CAFs live in binding
[(Id, HowBound)]) -- extension to environment
vars_bind body_fvs (NonRec binder rhs) = do
- (rhs2, bind_fvs, bind_lv_info, escs) <- coreToStgRhs body_fvs [] (binder,rhs)
+ (rhs2, bind_fvs, escs) <- coreToStgRhs body_fvs (binder,rhs)
let
- env_ext_item = mk_binding bind_lv_info binder rhs
+ env_ext_item = mk_binding binder rhs
return (StgNonRec binder rhs2,
- bind_fvs, escs, bind_lv_info, [env_ext_item])
+ bind_fvs, escs, [env_ext_item])
vars_bind body_fvs (Rec pairs)
- = mfix $ \ ~(_, rec_rhs_fvs, _, bind_lv_info, _) ->
+ = mfix $ \ ~(_, rec_rhs_fvs, _, _) ->
let
rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
binders = map fst pairs
- env_ext = [ mk_binding bind_lv_info b rhs
+ env_ext = [ mk_binding b rhs
| (b,rhs) <- pairs ]
in
extendVarEnvLne env_ext $ do
- (rhss2, fvss, lv_infos, escss)
- <- mapAndUnzip4M (coreToStgRhs rec_scope_fvs binders) pairs
+ (rhss2, fvss, escss)
+ <- mapAndUnzip3M (coreToStgRhs rec_scope_fvs) pairs
let
bind_fvs = unionFVInfos fvss
- bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos
escs = unionVarSets escss
return (StgRec (binders `zip` rhss2),
- bind_fvs, escs, bind_lv_info, env_ext)
+ bind_fvs, escs, env_ext)
is_join_var :: Id -> Bool
@@ -798,37 +750,35 @@ is_join_var :: Id -> Bool
is_join_var j = occNameString (getOccName j) == "$j"
coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding
- -> [Id]
-> (Id,CoreExpr)
- -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet)
+ -> LneM (StgRhs, FreeVarsInfo, EscVarsSet)
-coreToStgRhs scope_fv_info binders (bndr, rhs) = do
+coreToStgRhs scope_fv_info (bndr, rhs) = do
(new_rhs, rhs_fvs, rhs_escs) <- coreToStgExpr rhs
- lv_info <- freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs)
- return (mkStgRhs rhs_fvs (mkSRT lv_info) bndr bndr_info new_rhs,
- rhs_fvs, lv_info, rhs_escs)
+ return (mkStgRhs rhs_fvs bndr bndr_info new_rhs,
+ rhs_fvs, rhs_escs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
-mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs :: FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs = mkStgRhs' con_updateable
where con_updateable _ _ = False
mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
- -> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
-mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
+ -> FreeVarsInfo -> Id -> StgBinderInfo -> StgExpr -> StgRhs
+mkStgRhs' con_updateable rhs_fvs bndr binder_info rhs
| StgLam bndrs body <- rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
- srt bndrs body
+ bndrs body
| StgConApp con args <- unticked_rhs
, not (con_updateable con args)
= StgRhsCon noCCS con args
| otherwise
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
- upd_flag srt [] rhs
+ upd_flag [] rhs
where
(_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
@@ -896,17 +846,10 @@ isPAP env _ = False
newtype LneM a = LneM
{ unLneM :: IdEnv HowBound
- -> LiveInfo -- Vars and CAFs live in continuation
-> a
}
-type LiveInfo = (StgLiveVars, -- Dynamic live variables;
- -- i.e. ones with a nested (non-top-level) binding
- CafSet) -- Static live variables;
- -- i.e. top-level variables that are CAFs or refer to them
-
type EscVarsSet = IdSet
-type CafSet = IdSet
data HowBound
= ImportBound -- Used only as a response to lookupBinding; never
@@ -920,10 +863,7 @@ data HowBound
data LetInfo
= TopLet -- top level things
- | NestedLet LiveInfo -- For nested things, what is live if this
- -- thing is live? Invariant: the binder
- -- itself is always a member of
- -- the dynamic set of its own LiveInfo
+ | NestedLet
isLetBound :: HowBound -> Bool
isLetBound (LetBound _ _) = True
@@ -948,31 +888,10 @@ topLevelBound _ = False
-- The set of dynamic live variables is guaranteed ot have no further
-- let-no-escaped variables in it.
-emptyLiveInfo :: LiveInfo
-emptyLiveInfo = (emptyVarSet,emptyVarSet)
-
-unitLiveVar :: Id -> LiveInfo
-unitLiveVar lv = (unitVarSet lv, emptyVarSet)
-
-unitLiveCaf :: Id -> LiveInfo
-unitLiveCaf caf = (emptyVarSet, unitVarSet caf)
-
-addLiveVar :: LiveInfo -> Id -> LiveInfo
-addLiveVar (lvs, cafs) id = (lvs `extendVarSet` id, cafs)
-
-unionLiveInfo :: LiveInfo -> LiveInfo -> LiveInfo
-unionLiveInfo (lv1,caf1) (lv2,caf2) = (lv1 `unionVarSet` lv2, caf1 `unionVarSet` caf2)
-
-mkSRT :: LiveInfo -> SRT
-mkSRT (_, cafs) = SRTEntries cafs
-
-getLiveVars :: LiveInfo -> StgLiveVars
-getLiveVars (lvs, _) = lvs
-
-- The std monad functions:
initLne :: IdEnv HowBound -> LneM a -> a
-initLne env m = unLneM m env emptyLiveInfo
+initLne env m = unLneM m env
@@ -980,11 +899,11 @@ initLne env m = unLneM m env emptyLiveInfo
{-# INLINE returnLne #-}
returnLne :: a -> LneM a
-returnLne e = LneM $ \_ _ -> e
+returnLne e = LneM $ \_ -> e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k = LneM $ \env lvs_cont
- -> unLneM (k (unLneM m env lvs_cont)) env lvs_cont
+thenLne m k = LneM $ \env
+ -> unLneM (k (unLneM m env)) env
instance Functor LneM where
fmap = liftM
@@ -997,27 +916,19 @@ instance Monad LneM where
(>>=) = thenLne
instance MonadFix LneM where
- mfix expr = LneM $ \env lvs_cont ->
- let result = unLneM (expr result) env lvs_cont
+ mfix expr = LneM $ \env ->
+ let result = unLneM (expr result) env
in result
-- Functions specific to this monad:
-getVarsLiveInCont :: LneM LiveInfo
-getVarsLiveInCont = LneM $ \_env lvs_cont -> lvs_cont
-
-setVarsLiveInCont :: LiveInfo -> LneM a -> LneM a
-setVarsLiveInCont new_lvs_cont expr
- = LneM $ \env _lvs_cont
- -> unLneM expr env new_lvs_cont
-
extendVarEnvLne :: [(Id, HowBound)] -> LneM a -> LneM a
extendVarEnvLne ids_w_howbound expr
- = LneM $ \env lvs_cont
- -> unLneM expr (extendVarEnvList env ids_w_howbound) lvs_cont
+ = LneM $ \env
+ -> unLneM expr (extendVarEnvList env ids_w_howbound)
lookupVarLne :: Id -> LneM HowBound
-lookupVarLne v = LneM $ \env _lvs_cont -> lookupBinding env v
+lookupVarLne v = LneM $ \env -> lookupBinding env v
lookupBinding :: IdEnv HowBound -> Id -> HowBound
lookupBinding env v = case lookupVarEnv env v of
@@ -1025,32 +936,6 @@ lookupBinding env v = case lookupVarEnv env v of
Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound
--- The result of lookupLiveVarsForSet, a set of live variables, is
--- only ever tacked onto a decorated expression. It is never used as
--- the basis of a control decision, which might give a black hole.
-
-freeVarsToLiveVars :: FreeVarsInfo -> LneM LiveInfo
-freeVarsToLiveVars fvs = LneM freeVarsToLiveVars'
- where
- freeVarsToLiveVars' _env live_in_cont = live_info
- where
- live_info = foldr unionLiveInfo live_in_cont lvs_from_fvs
- lvs_from_fvs = map do_one (allFreeIds fvs)
-
- do_one (v, how_bound)
- = case how_bound of
- ImportBound -> unitLiveCaf v -- Only CAF imports are
- -- recorded in fvs
- LetBound TopLet _
- | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
- | otherwise -> emptyLiveInfo
-
- LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
- -- (see the invariant on NestedLet)
-
- _lambda_or_case_binding -> unitLiveVar v -- Bound by lambda or case
-
-
-- ---------------------------------------------------------------------------
-- Free variable information
-- ---------------------------------------------------------------------------
@@ -1117,11 +1002,6 @@ lookupFVInfo fvs id
Nothing -> noBinderInfo
Just (_,_,info) -> info
-allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids
-allFreeIds fvs = ASSERT( all (isId . fst) ids ) ids
- where
- ids = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs]
-
-- Non-top-level things only, both type variables and ids
getFVs :: FreeVarsInfo -> [Var]
getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs,
@@ -1145,9 +1025,9 @@ check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_e
check_eq_how_bound _ _ = False
check_eq_li :: LetInfo -> LetInfo -> Bool
-check_eq_li (NestedLet _) (NestedLet _) = True
-check_eq_li TopLet TopLet = True
-check_eq_li _ _ = False
+check_eq_li NestedLet NestedLet = True
+check_eq_li TopLet TopLet = True
+check_eq_li _ _ = False
-- Misc.
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index a871778e32..df3c4e57df 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -124,10 +124,10 @@ lint_binds_help (binder, rhs)
lintStgRhs :: StgRhs -> LintM (Maybe Type) -- Just ty => type is exact
-lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
= lintStgExpr expr
-lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) $
addInScopeVars binders $ runMaybeT $ do
body_ty <- MaybeT $ lintStgExpr expr
@@ -176,7 +176,7 @@ lintStgExpr (StgLet binds body) = do
addInScopeVars binders $
lintStgExpr body
-lintStgExpr (StgLetNoEscape _ _ binds body) = do
+lintStgExpr (StgLetNoEscape binds body) = do
binders <- lintStgBinds binds
addLoc (BodyOfLetRec binders) $
addInScopeVars binders $
@@ -184,7 +184,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do
lintStgExpr (StgTick _ expr) = lintStgExpr expr
-lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
+lintStgExpr (StgCase scrut bndr alts_type alts) = runMaybeT $ do
_ <- MaybeT $ lintStgExpr scrut
in_scope <- MaybeT $ liftM Just $
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 204e843567..1fc84125f9 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -31,11 +31,8 @@ module StgSyn (
-- StgOp
StgOp(..),
- -- SRTs
- SRT(..),
-
-- utils
- stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
+ topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
isDllConApp,
stgArgType,
stripStgTicksTop,
@@ -69,7 +66,6 @@ import Type ( typePrimRep )
import UniqSet
import Unique ( Unique )
import Util
-import VarSet ( IdSet, isEmptyVarSet )
{-
************************************************************************
@@ -82,8 +78,6 @@ As usual, expressions are interesting; other things are boring. Here
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.
-}
data GenStgBinding bndr occ
@@ -237,23 +231,8 @@ 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,
- -- plus everything that happens after the case
- -- i.e., those which mustn't be overwritten
-
- (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
- -- binder-variables are NOT counted in the
- -- free vars for the alt's RHS
-
bndr -- binds the result of evaluating the scrutinee
- SRT -- The SRT for the continuation
-
AltType
[GenStgAlt bndr occ]
@@ -358,16 +337,7 @@ And so the code for let(rec)-things:
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
- | 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).
-
- (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.
-
+ | StgLetNoEscape
(GenStgBinding bndr occ) -- right hand sides (see below)
(GenStgExpr bndr occ) -- body
@@ -405,7 +375,6 @@ 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
@@ -436,24 +405,84 @@ The second flavour of right-hand-side is for constructors (simple but important)
[GenStgArg occ] -- args
stgRhsArity :: StgRhs -> Int
-stgRhsArity (StgRhsClosure _ _ _ _ _ bndrs _)
+stgRhsArity (StgRhsClosure _ _ _ _ bndrs _)
= ASSERT( all isId bndrs ) length bndrs
-- The arity never includes type parameters, but they should have gone by now
stgRhsArity (StgRhsCon _ _ _) = 0
-stgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
-stgBindHasCafRefs (StgNonRec _ rhs) = rhsHasCafRefs rhs
-stgBindHasCafRefs (StgRec binds) = any rhsHasCafRefs (map snd binds)
+-- Note [CAF consistency]
+-- ~~~~~~~~~~~~~~~~~~~~~~
+--
+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in
+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with
+-- reality.
+--
+-- Specifically, if the RHS mentions any Id that itself is marked
+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the
+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble
+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
+-- have taken place since then.
+
+topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
+topStgBindHasCafRefs (StgNonRec _ rhs)
+ = topRhsHasCafRefs rhs
+topStgBindHasCafRefs (StgRec binds)
+ = any topRhsHasCafRefs (map snd binds)
+
+topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
+topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
+ = -- See Note [CAF consistency]
+ isUpdatable upd || exprHasCafRefs body
+topRhsHasCafRefs (StgRhsCon _ _ args)
+ = any stgArgHasCafRefs args
+
+exprHasCafRefs :: GenStgExpr bndr Id -> Bool
+exprHasCafRefs (StgApp f args)
+ = stgIdHasCafRefs f || any stgArgHasCafRefs args
+exprHasCafRefs StgLit{}
+ = False
+exprHasCafRefs (StgConApp _ args)
+ = any stgArgHasCafRefs args
+exprHasCafRefs (StgOpApp _ args _)
+ = any stgArgHasCafRefs args
+exprHasCafRefs (StgLam _ body)
+ = exprHasCafRefs body
+exprHasCafRefs (StgCase scrt _ _ alts)
+ = exprHasCafRefs scrt || any altHasCafRefs alts
+exprHasCafRefs (StgLet bind body)
+ = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgLetNoEscape bind body)
+ = bindHasCafRefs bind || exprHasCafRefs body
+exprHasCafRefs (StgTick _ expr)
+ = exprHasCafRefs expr
+
+bindHasCafRefs :: GenStgBinding bndr Id -> Bool
+bindHasCafRefs (StgNonRec _ rhs)
+ = rhsHasCafRefs rhs
+bindHasCafRefs (StgRec binds)
+ = any rhsHasCafRefs (map snd binds)
rhsHasCafRefs :: GenStgRhs bndr Id -> Bool
-rhsHasCafRefs (StgRhsClosure _ _ _ upd srt _ _)
- = isUpdatable upd || nonEmptySRT srt
+rhsHasCafRefs (StgRhsClosure _ _ _ _ _ body)
+ = exprHasCafRefs body
rhsHasCafRefs (StgRhsCon _ _ args)
= any stgArgHasCafRefs args
+altHasCafRefs :: GenStgAlt bndr Id -> Bool
+altHasCafRefs (_, _, _, rhs) = exprHasCafRefs rhs
+
stgArgHasCafRefs :: GenStgArg Id -> Bool
-stgArgHasCafRefs (StgVarArg id) = mayHaveCafRefs (idCafInfo id)
-stgArgHasCafRefs _ = False
+stgArgHasCafRefs (StgVarArg id)
+ = stgIdHasCafRefs id
+stgArgHasCafRefs _
+ = False
+
+stgIdHasCafRefs :: Id -> Bool
+stgIdHasCafRefs id =
+ -- We are looking for occurrences of an Id that is bound at top level, and may
+ -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether
+ -- imported or defined in this module) are GlobalIds, so the test is easy.
+ isGlobalId id && mayHaveCafRefs (idCafInfo id)
-- Here's the @StgBinderInfo@ type, and its combining op:
@@ -494,7 +523,7 @@ 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
+where there's a module 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)
@@ -587,34 +616,6 @@ data StgOp
{-
************************************************************************
* *
-\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.
-
-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.
--}
-
-data SRT
- = NoSRT
- | SRTEntries IdSet
- -- generated by CoreToStg
-
-nonEmptySRT :: SRT -> Bool
-nonEmptySRT NoSRT = False
-nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
-
-pprSRT :: SRT -> SDoc
-pprSRT (NoSRT) = text "_no_srt_"
-pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
-
-{-
-************************************************************************
-* *
\subsection[Stg-pretty-printing]{Pretty-printing}
* *
************************************************************************
@@ -719,15 +720,10 @@ pprStgExpr (StgLet bind expr)
= sep [hang (text "let {") 2 (pprGenStgBinding bind),
hang (text "} in ") 2 (ppr expr)]
-pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
+pprStgExpr (StgLetNoEscape bind expr)
= sep [hang (text "let-no-escape {")
2 (pprGenStgBinding bind),
- hang (text "} in " <>
- ifPprDebug (
- nest 4 (
- hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
- text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss),
- char ']'])))
+ hang (text "} in ")
2 (ppr expr)]
pprStgExpr (StgTick tickish expr)
@@ -737,17 +733,11 @@ pprStgExpr (StgTick tickish expr)
else pprStgExpr expr
-pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts)
+pprStgExpr (StgCase expr bndr alt_type alts)
= sep [sep [text "case",
nest 4 (hsep [pprStgExpr expr,
ifPprDebug (dcolon <+> ppr alt_type)]),
text "of", pprBndr CaseBind bndr, char '{'],
- ifPprDebug (
- nest 4 (
- hcat [ptext (sLit "-- lvs: ["), interppSP (uniqSetToList lvs_whole),
- text "]; rhs lvs: [", interppSP (uniqSetToList lvs_rhss),
- text "]; ",
- pprMaybeSRT srt])),
nest 2 (vcat (map pprStgAlt alts)),
char '}']
@@ -780,25 +770,21 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag srt [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
= hcat [ ppr cc,
pp_binder_info bi,
brackets (ifPprDebug (ppr free_var)),
- text " \\", ppr upd_flag, pprMaybeSRT srt, ptext (sLit " [] "), ppr func ]
+ text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc bi free_vars upd_flag srt args body)
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
= sdocWithDynFlags $ \dflags ->
hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
pp_binder_info bi,
ifPprDebug (brackets (interppSP free_vars)),
- char '\\' <> ppr upd_flag, pprMaybeSRT srt, brackets (interppSP args)])
+ char '\\' <> ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
= hcat [ ppr cc,
space, ppr con, text "! ", brackets (interppSP args)]
-
-pprMaybeSRT :: SRT -> SDoc
-pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt = text "srt:" <> pprSRT srt