X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgSyn.lhs;h=f3d9c970315ec8cdcf0d00f218dec247dfeaee36;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=6de6376cfc06cbaba906ede24cce2d805a1822d6;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 6de6376..f3d9c97 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}
 
@@ -9,16 +9,14 @@ form of @CoreSyntax@, the style being one that happens to be ideally
 suited to spineless tagless code generation.
 
 \begin{code}
-#include "HsVersions.h"
-
 module StgSyn (
 	GenStgArg(..),
-	SYN_IE(GenStgLiveVars),
+	GenStgLiveVars,
 
 	GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
 	GenStgCaseAlts(..), GenStgCaseDefault(..),
 
-	UpdateFlag(..),
+	UpdateFlag(..), isUpdatable,
 
 	StgBinderInfo(..),
 	stgArgOcc, stgUnsatOcc, stgStdHeapOcc, stgNoUpdHeapOcc,
@@ -26,33 +24,34 @@ module StgSyn (
 	combineStgBinderInfo,
 
 	-- a set of synonyms for the most common (only :-) parameterisation
-	SYN_IE(StgArg), SYN_IE(StgLiveVars),
-	SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs),
-	SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault),
+	StgArg, StgLiveVars,
+	StgBinding, StgExpr, StgRhs,
+	StgCaseAlts, StgCaseDefault,
+
+	-- SRTs
+	SRT(..), noSRT,
 
-	pprPlainStgBinding,
+	pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
 	getArgPrimRep,
 	isLitLitArg,
 	stgArity,
 	collectFinalStgBinders
+
+#ifdef DEBUG
+	, pprStgLVs
+#endif
     ) where
 
-IMP_Ubiq(){-uitous-}
-
-import CostCentre	( showCostCentre )
-import Id		( idPrimRep, GenId{-instance NamedThing-} )
-import Literal		( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Name		( pprNonSym )
-import Outputable	( ifPprDebug, interppSP, interpp'SP,
-			  Outputable(..){-instance * Bool-}
-			)
-import PprStyle		( PprStyle(..) )
-import PprType		( GenType{-instance Outputable-} )
-import Pretty		-- all of it
-import PrimOp		( PrimOp{-instance Outputable-} )
-import Unique		( pprUnique )
-import UniqSet		( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) )
-import Util		( panic )
+#include "HsVersions.h"
+
+import CostCentre	( CostCentreStack, CostCentre )
+import Id		( idPrimRep, Id )
+import Const		( Con(..), DataCon, Literal,
+			  conPrimRep, isLitLitLit )
+import PrimRep		( PrimRep(..) )
+import Outputable
+import Type             ( Type )
+import UniqSet		( isEmptyUniqSet, uniqSetToList, UniqSet )
 \end{code}
 
 %************************************************************************
@@ -70,7 +69,6 @@ with respect to binder and occurrence information (just as in
 data GenStgBinding bndr occ
   = StgNonRec	bndr (GenStgRhs bndr occ)
   | StgRec	[(bndr, GenStgRhs bndr occ)]
-  | StgCoerceBinding bndr occ
 \end{code}
 
 %************************************************************************
@@ -82,15 +80,15 @@ data GenStgBinding bndr occ
 \begin{code}
 data GenStgArg occ
   = StgVarArg	occ
-  | StgLitArg	Literal
+  | StgConArg   Con		-- A literal or nullary data constructor
 \end{code}
 
 \begin{code}
 getArgPrimRep (StgVarArg  local) = idPrimRep local
-getArgPrimRep (StgLitArg  lit)	 = literalPrimRep lit
+getArgPrimRep (StgConArg  con)	 = conPrimRep con
 
-isLitLitArg (StgLitArg x) = isLitLitLit x
-isLitLitArg _		  = False
+isLitLitArg (StgConArg (Literal x)) = isLitLitLit x
+isLitLitArg _		            = False
 \end{code}
 
 %************************************************************************
@@ -120,10 +118,8 @@ type GenStgLiveVars occ = UniqSet occ
 
 data GenStgExpr bndr occ
   = StgApp
-	(GenStgArg occ)	-- function
+	occ		-- function
 	[GenStgArg occ]	-- arguments
-	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
-				-- including the function and args
 
     -- NB: a literal is: StgApp <lit-atom> [] ...
 \end{code}
@@ -134,20 +130,17 @@ data GenStgExpr bndr occ
 %*									*
 %************************************************************************
 
-There are two specialised forms of application, for
-constructors and primitives.
+There are a specialised forms of application, for
+constructors, primitives, and literals.
 \begin{code}
   | StgCon			-- always saturated
-	Id -- data constructor
+	Con
 	[GenStgArg occ]
-	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
-				-- including the constr and args
 
-  | StgPrim			-- always saturated
-	PrimOp
-	[GenStgArg occ]
-	(GenStgLiveVars occ)	-- Live vars in continuation; ie not
-				-- including the op and args
+	Type			-- Result type; this is needed for primops, where
+				-- we need to know the result type so that we can
+				-- assign result registers.
+
 \end{code}
 These forms are to do ``inline versions,'' as it were.
 An example might be: @f x = x:[]@.
@@ -175,10 +168,9 @@ This has the same boxed/unboxed business as Core case expressions.
 			-- binder-variables are NOT counted in the
 			-- free vars for the alt's RHS
 
-	Unique		-- Occasionally needed to compile case
-			-- statements, as the uniq for a local
-			-- variable to hold the tag of a primop with
-			-- algebraic result
+	bndr		-- binds the result of evaluating the scrutinee
+
+	SRT		-- The SRT for the continuation
 
 	(GenStgCaseAlts bndr occ)
 \end{code}
@@ -304,7 +296,6 @@ Finally for @scc@ expressions we introduce a new STG construct.
 
 \begin{code}
   | StgSCC
-	Type			-- the type of the body
 	CostCentre		-- label of SCC expression
 	(GenStgExpr bndr occ)	-- scc expression
   -- end of GenStgExpr
@@ -321,13 +312,14 @@ flavour is for closures:
 \begin{code}
 data GenStgRhs bndr occ
   = StgRhsClosure
-	CostCentre		-- cost centre to be attached (default is CCC)
+	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
 	[bndr]			-- arguments; if empty, then not a function;
-				-- as above, order is important
+				-- as above, order is important.
 	(GenStgExpr bndr occ)	-- body
 \end{code}
 An example may be in order.  Consider:
@@ -345,12 +337,12 @@ will be exactly that in parentheses above.
 The second flavour of right-hand-side is for constructors (simple but important):
 \begin{code}
   | StgRhsCon
-	CostCentre		-- Cost centre to be attached (default is CCC).
+	CostCentreStack		-- CCS to be attached (default is CurrentCCS).
 				-- Top-level (static) ones will end up with
-				-- DontCareCC, because we don't count static
-				-- data in heap profiles, and we don't set CCC
+				-- DontCareCCS, because we don't count static
+				-- data in heap profiles, and we don't set CCCS
 				-- from static closure.
-	Id			-- constructor
+	DataCon			-- constructor
 	[GenStgArg occ]	-- args
 \end{code}
 
@@ -408,7 +400,7 @@ Just like in @CoreSyntax@ (except no type-world stuff).
 \begin{code}
 data GenStgCaseAlts bndr occ
   = StgAlgAlts	Type	-- so we can find out things about constructor family
-		[(Id,				-- alts: data constructor,
+		[(DataCon,			-- alts: data constructor,
 		  [bndr],			-- constructor's parameters,
 		  [Bool],			-- "use mask", same length as
 						-- parameters; a True in a
@@ -424,10 +416,7 @@ data GenStgCaseAlts bndr occ
 data GenStgCaseDefault bndr occ
   = StgNoDefault				-- small con family: all
 						-- constructor accounted for
-  | StgBindDefault  bndr			-- form: var -> expr
-		    Bool			-- True <=> var is used in rhs
-						-- i.e., False <=> "_ -> expr"
-		    (GenStgExpr bndr occ)
+  | StgBindDefault (GenStgExpr bndr occ)
 \end{code}
 
 %************************************************************************
@@ -460,8 +449,33 @@ This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.
 data UpdateFlag = ReEntrant | Updatable | SingleEntry
 
 instance Outputable UpdateFlag where
-    ppr sty u
-      = ppChar (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
+    ppr u
+      = char (case u of { ReEntrant -> 'r';  Updatable -> 'u';  SingleEntry -> 's' })
+
+isUpdatable ReEntrant   = False
+isUpdatable SingleEntry = False
+isUpdatable Updatable   = True
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+\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.
+
+\begin{code}
+data SRT = NoSRT
+         | SRT !Int{-offset-} !Int{-length-}
+
+noSRT :: SRT
+noSRT = NoSRT
+
+pprSRT (NoSRT) = ptext SLIT("_no_srt_")
+pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
 \end{code}
 
 %************************************************************************
@@ -495,27 +509,37 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 
 \begin{code}
-pprStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> GenStgBinding bndr bdee -> Pretty
-
-pprStgBinding sty (StgNonRec bndr rhs)
-  = ppHang (ppCat [ppr sty bndr, ppEquals])
-    	 4 (ppBeside (ppr sty rhs) ppSemi)
+pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
+		 => GenStgBinding bndr bdee -> SDoc
 
-pprStgBinding sty (StgCoerceBinding bndr occ)
-  = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
-    	 4 (ppBeside (ppr sty occ) ppSemi)
+pprGenStgBinding (StgNonRec bndr rhs)
+  = hang (hsep [ppr bndr, equals])
+    	 4 ((<>) (ppr rhs) semi)
 
-pprStgBinding sty (StgRec pairs)
-  = ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
-	      (map (ppr_bind sty) pairs))
+pprGenStgBinding (StgRec pairs)
+  = vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
+	      (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
   where
-    ppr_bind sty (bndr, expr)
-      = ppHang (ppCat [ppr sty bndr, ppEquals])
-	     4 (ppBeside (ppr sty expr) ppSemi)
+    ppr_bind (bndr, expr)
+      = hang (hsep [ppr bndr, equals])
+	     4 ((<>) (ppr expr) semi)
+
+pprStgBinding  :: StgBinding -> SDoc
+pprStgBinding  bind  = pprGenStgBinding bind
+
+pprStgBindings :: [StgBinding] -> SDoc
+pprStgBindings binds = vcat (map pprGenStgBinding binds)
+
+pprGenStgBindingWithSRT	 
+	:: (Outputable bndr, Outputable bdee, Ord bdee) 
+	=> (GenStgBinding bndr bdee,[Id]) -> SDoc
+
+pprGenStgBindingWithSRT (bind,srt)  
+  = vcat [ pprGenStgBinding bind,
+	   ptext SLIT("SRT: ") <> ppr srt ]
 
-pprPlainStgBinding :: PprStyle -> StgBinding -> Pretty
-pprPlainStgBinding sty b = pprStgBinding sty b
+pprStgBindingsWithSRTs :: [(StgBinding,[Id])] -> SDoc
+pprStgBindingsWithSRTs binds = vcat (map pprGenStgBindingWithSRT binds)
 \end{code}
 
 \begin{code}
@@ -524,7 +548,7 @@ instance (Outputable bdee) => Outputable (GenStgArg bdee) where
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
 		=> Outputable (GenStgBinding bndr bdee) where
-    ppr = pprStgBinding
+    ppr = pprGenStgBinding
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
 		=> Outputable (GenStgExpr bndr bdee) where
@@ -532,37 +556,31 @@ instance (Outputable bndr, Outputable bdee, Ord bdee)
 
 instance (Outputable bndr, Outputable bdee, Ord bdee)
 		=> Outputable (GenStgRhs bndr bdee) where
-    ppr sty rhs = pprStgRhs sty rhs
+    ppr rhs = pprStgRhs rhs
 \end{code}
 
 \begin{code}
-pprStgArg :: (Outputable bdee) => PprStyle -> GenStgArg bdee -> Pretty
+pprStgArg :: (Outputable bdee) => GenStgArg bdee -> SDoc
 
-pprStgArg sty (StgVarArg var) = ppr sty var
-pprStgArg sty (StgLitArg lit) = ppr sty lit
+pprStgArg (StgVarArg var) = ppr var
+pprStgArg (StgConArg con) = ppr con
 \end{code}
 
 \begin{code}
-pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> GenStgExpr bndr bdee -> Pretty
+pprStgExpr :: (Outputable bndr, Outputable bdee, Ord bdee)
+	   => GenStgExpr bndr bdee -> SDoc
 -- special case
-pprStgExpr sty (StgApp func [] lvs)
-  = ppBeside (ppr sty func) (pprStgLVs sty lvs)
+pprStgExpr (StgApp func []) = ppr func
 
 -- general case
-pprStgExpr sty (StgApp func args lvs)
-  = ppHang (ppBeside (ppr sty func) (pprStgLVs sty lvs))
-	 4 (ppSep (map (ppr sty) args))
+pprStgExpr (StgApp func args)
+  = hang (ppr func)
+	 4 (sep (map (ppr) args))
 \end{code}
 
 \begin{code}
-pprStgExpr sty (StgCon con args lvs)
-  = ppBesides [ ppBeside (ppr sty con) (pprStgLVs sty lvs),
-		ppStr "! [", interppSP sty args, ppStr "]" ]
-
-pprStgExpr sty (StgPrim op args lvs)
-  = ppBesides [ ppr sty op, ppChar '#', pprStgLVs sty lvs,
-		ppStr " [", interppSP sty args, ppStr "]" ]
+pprStgExpr (StgCon con args _)
+  = hsep [ ppr con, brackets (interppSP args)]
 \end{code}
 
 \begin{code}
@@ -574,135 +592,139 @@ pprStgExpr sty (StgPrim op args lvs)
 --
 -- Very special!  Suspicious! (SLPJ)
 
-pprStgExpr sty (StgLet (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
+pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
 		    	expr@(StgLet _ _))
-  = ppAbove
-      (ppHang (ppBesides [ppStr "let { ", ppr sty bndr, ppStr " = ",
-			  ppStr (showCostCentre sty True{-as string-} cc),
-			  pp_binder_info sty bi,
-			  ppStr " [", ifPprDebug sty (interppSP sty free_vars), ppStr "] \\",
-			  ppr sty upd_flag, ppStr " [",
-			  interppSP sty args, ppStr "]"])
-	    8 (ppSep [ppCat [ppr sty rhs, ppStr "} in"]]))
-      (ppr sty expr)
+  = ($$)
+      (hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
+			  ppr cc,
+			  pp_binder_info bi,
+			  ptext SLIT(" ["), ifPprDebug (interppSP free_vars), ptext SLIT("] \\"),
+			  ppr upd_flag, ptext SLIT(" ["),
+			  interppSP args, char ']'])
+	    8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
+      (ppr expr)
 
 -- special case: let ... in let ...
 
-pprStgExpr sty (StgLet bind expr@(StgLet _ _))
-  = ppAbove
-      (ppSep [ppHang (ppStr "let {") 2 (ppCat [pprStgBinding sty bind, ppStr "} in"])])
-      (ppr sty expr)
+pprStgExpr (StgLet bind expr@(StgLet _ _))
+  = ($$)
+      (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
+      (ppr expr)
 
 -- general case
-pprStgExpr sty (StgLet bind expr)
-  = ppSep [ppHang (ppStr "let {") 2 (pprStgBinding sty bind),
-	   ppHang (ppStr "} in ") 2 (ppr sty expr)]
-
-pprStgExpr sty (StgLetNoEscape lvs_whole lvs_rhss bind expr)
-  = ppSep [ppHang (ppStr "let-no-escape {")
-	    	2 (pprStgBinding sty bind),
-	   ppHang (ppBeside (ppStr "} in ")
-		   (ifPprDebug sty (
-		    ppNest 4 (
-		      ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
-			     ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
-			     ppStr "]"]))))
-		2 (ppr sty expr)]
+pprStgExpr (StgLet bind expr)
+  = sep [hang (ptext SLIT("let {")) 2 (pprGenStgBinding bind),
+	   hang (ptext SLIT("} in ")) 2 (ppr expr)]
+
+pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr)
+  = sep [hang (ptext SLIT("let-no-escape {"))
+	    	2 (pprGenStgBinding bind),
+	   hang ((<>) (ptext SLIT("} in "))
+		   (ifPprDebug (
+		    nest 4 (
+		      hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+			     ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+			     char ']']))))
+		2 (ppr expr)]
 \end{code}
 
 \begin{code}
-pprStgExpr sty (StgSCC ty cc expr)
-  = ppSep [ ppCat [ppStr "_scc_", ppStr (showCostCentre sty True{-as string-} cc)],
-	    pprStgExpr sty expr ]
+pprStgExpr (StgSCC cc expr)
+  = sep [ hsep [ptext SLIT("_scc_"), ppr cc],
+	  pprStgExpr expr ]
 \end{code}
 
 \begin{code}
-pprStgExpr sty (StgCase expr lvs_whole lvs_rhss uniq alts)
-  = ppSep [ppSep [ppStr "case",
-	   ppNest 4 (ppCat [pprStgExpr sty expr,
-	     ifPprDebug sty (ppBeside (ppStr "::") (pp_ty alts))]),
-	   ppStr "of {"],
-	   ifPprDebug sty (
-	   ppNest 4 (
-	     ppBesides [ppStr  "-- lvs: [", interppSP sty (uniqSetToList lvs_whole),
-		    ppStr "]; rhs lvs: [", interppSP sty (uniqSetToList lvs_rhss),
-		    ppStr "]; uniq: ", pprUnique uniq])),
-	   ppNest 2 (ppr_alts sty alts),
-	   ppStr "}"]
+pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alts)
+  = sep [sep [ptext SLIT("case"),
+	   nest 4 (hsep [pprStgExpr expr,
+	     ifPprDebug (ptext SLIT("::") <> pp_ty alts)]),
+	   ptext SLIT("of"), ppr bndr, char '{'],
+	   ifPprDebug (
+	   nest 4 (
+	     hcat [ptext  SLIT("-- lvs: ["), interppSP (uniqSetToList lvs_whole),
+		    ptext SLIT("]; rhs lvs: ["), interppSP (uniqSetToList lvs_rhss),
+		    ptext SLIT("]; "),
+		    pprMaybeSRT srt])),
+	   nest 2 (ppr_alts alts),
+	   char '}']
   where
-    ppr_default sty StgNoDefault = ppNil
-    ppr_default sty (StgBindDefault bndr used expr)
-      = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
-      where
-    	pp_binder = if used then ppr sty bndr else ppChar '_'
+    ppr_default StgNoDefault = empty
+    ppr_default (StgBindDefault expr)
+      = hang (hsep [ptext SLIT("DEFAULT"), ptext SLIT("->")]) 4 (ppr expr)
 
-    pp_ty (StgAlgAlts  ty _ _) = ppr sty ty
-    pp_ty (StgPrimAlts ty _ _) = ppr sty ty
+    pp_ty (StgAlgAlts  ty _ _) = ppr ty
+    pp_ty (StgPrimAlts ty _ _) = ppr ty
 
-    ppr_alts sty (StgAlgAlts ty alts deflt)
-      = ppAboves [ ppAboves (map (ppr_bxd_alt sty) alts),
-		   ppr_default sty deflt ]
+    ppr_alts (StgAlgAlts ty alts deflt)
+      = vcat [ vcat (map (ppr_bxd_alt) alts),
+		   ppr_default deflt ]
       where
-	ppr_bxd_alt sty (con, params, use_mask, expr)
-	  = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"])
-		   4 (ppBeside (ppr sty expr) ppSemi)
+	ppr_bxd_alt (con, params, use_mask, expr)
+	  = hang (hsep [ppr con, interppSP params, ptext SLIT("->")])
+		   4 ((<>) (ppr expr) semi)
 
-    ppr_alts sty (StgPrimAlts ty alts deflt)
-      = ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
-		   ppr_default sty deflt ]
+    ppr_alts (StgPrimAlts ty alts deflt)
+      = vcat [ vcat (map (ppr_ubxd_alt) alts),
+		   ppr_default deflt ]
       where
-	ppr_ubxd_alt sty (lit, expr)
-	  = ppHang (ppCat [ppr sty lit, ppStr "->"])
-		 4 (ppBeside (ppr sty expr) ppSemi)
+	ppr_ubxd_alt (lit, expr)
+	  = hang (hsep [ppr lit, ptext SLIT("->")])
+		 4 ((<>) (ppr expr) semi)
 \end{code}
 
 \begin{code}
--- pprStgLVs :: PprStyle -> GenStgLiveVars occ -> Pretty
-
-pprStgLVs PprForUser lvs = ppNil
-
-pprStgLVs sty lvs
-  = if isEmptyUniqSet lvs then
-	ppNil
+pprStgLVs :: Outputable occ => GenStgLiveVars occ -> SDoc
+pprStgLVs lvs
+  = getPprStyle $ \ sty ->
+    if userStyle sty || isEmptyUniqSet lvs then
+	empty
     else
-	ppBesides [ppStr "{-lvs:", interpp'SP sty (uniqSetToList lvs), ppStr "-}"]
+	hcat [text "{-lvs:", interpp'SP (uniqSetToList lvs), text "-}"]
 \end{code}
 
 \begin{code}
-pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee) =>
-		PprStyle -> GenStgRhs bndr bdee -> Pretty
+pprStgRhs :: (Outputable bndr, Outputable bdee, Ord bdee)
+	  => GenStgRhs bndr bdee -> SDoc
 
 -- special case
-pprStgRhs sty (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [] lvs))
-  = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
-		pp_binder_info sty bi,
-		ppStr " [", ifPprDebug sty (ppr sty free_var),
-	    ppStr "] \\", ppr sty upd_flag, ppStr " [] ", ppr sty func ]
+pprStgRhs (StgRhsClosure cc bi srt [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 sty (StgRhsClosure cc bi free_vars upd_flag args body)
-  = ppHang (ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
-		pp_binder_info sty bi,
-		ppStr " [", ifPprDebug sty (interppSP sty free_vars),
-		ppStr "] \\", ppr sty upd_flag, ppStr " [", interppSP sty args, ppStr "]"])
-	 4 (ppr sty body)
+pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
+  = hang (hcat [ppr cc,
+		pp_binder_info bi,
+		pprMaybeSRT srt,
+		brackets (ifPprDebug (interppSP free_vars)),
+		ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
+	 4 (ppr body)
+
+pprStgRhs (StgRhsCon cc con args)
+  = hcat [ ppr cc,
+	   space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
 
-pprStgRhs sty (StgRhsCon cc con args)
-  = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc),
-		ppSP, ppr sty con, ppStr "! [", interppSP sty args, ppStr "]" ]
+pprMaybeSRT (NoSRT) = empty
+pprMaybeSRT srt     = ptext SLIT(" srt: ") <> pprSRT srt
 
 --------------
-pp_binder_info PprForUser _ = ppNil
 
-pp_binder_info sty NoStgBinderInfo = ppNil
+pp_binder_info NoStgBinderInfo = empty
 
 -- cases so boring that we print nothing
-pp_binder_info sty (StgBinderInfo True b c d e) = ppNil
+pp_binder_info (StgBinderInfo True b c d e) = empty
 
 -- general case
-pp_binder_info sty (StgBinderInfo a b c d e)
-  = ppBesides [ppChar '(', ppInterleave ppComma (map pp_bool [a,b,c,d,e]), ppChar ')']
-  where
-    pp_bool x = ppr (panic "pp_bool") x
+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
@@ -712,5 +734,5 @@ from the STG bindings.
 stgArity :: StgRhs -> Int
 
 stgArity (StgRhsCon _ _ _)	         = 0 -- it's a constructor, fully applied
-stgArity (StgRhsClosure _ _ _ _ args _ ) = length args
+stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
 \end{code}