[project @ 2001-09-26 15:11:50 by simonpj]

-------------------------------
	Code generation and SRT hygiene
	-------------------------------

This is a big tidy up commit.  I don't think it breaks anything,
but it certainly makes the code clearer (to me).

I'm not certain that you can use it without sucking in my other
big commit... they come from the same tree.


Core-to-STG, live variables and Static Reference Tables (SRTs)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
I did a big tidy-up of the live-variable computation in CoreToStg.
The key idea is that the live variables consist of two parts:
	dynamic live vars
	static live vars (CAFs)

These two always travel round together, but they were always
treated separately by the code until now. Now it's a new data type:

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

There's lots of documentation in CoreToStg.

Code generation
~~~~~~~~~~~~~~~
Arising from this, I found that SRT labels were stored in
a LambdaFormInfo during code generation, whereas they *ought*
to be in the ClosureInfo (which in turn contains a LambdaFormInfo).

This led to lots of changes in ClosureInfo, and I took the opportunity
to make it into a labelled record.

Similarly, I made the data type in AbstractC a bit more explicit:

  -- C_SRT is what StgSyn.SRT gets translated to...
  -- we add a label for the table, and expect only the 'offset/length' form

data C_SRT = NoC_SRT
	   | C_SRT CLabel !Int{-offset-} !Int{-length-}

(Previously there were bottoms lying around.)

9 files changed, 220 insertions, 242 deletions

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index d9dc5c807a..43147e5a4f 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
+% $Id: CgCase.lhs,v 1.53 2001/09/26 15:11:50 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -402,8 +402,8 @@ cgEvalAlts cc_slot bndr srt alts
          	[alt] -> let lbl = mkReturnInfoLabel uniq in
 			 cgUnboxedTupleAlt uniq cc_slot True alt
 				`thenFC` \ abs_c ->
-		  	 getSRTLabel `thenFC` \srt_label -> 
-		  	 absC (CRetDirect uniq abs_c (srt_label, srt) 
+		  	 getSRTInfo srt		 `thenFC` \ srt_info -> 
+		  	 absC (CRetDirect uniq abs_c srt_info
 					liveness_mask) `thenC`
 		  	returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 	 	_ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
@@ -442,9 +442,9 @@ cgEvalAlts cc_slot bndr srt alts
     	getAbsC (cgPrimEvalAlts bndr tycon alts deflt) 	`thenFC` \ abs_c ->
 
     	-- Generate the labelled block, starting with restore-cost-centre
-    	getSRTLabel 					`thenFC` \srt_label ->
+    	getSRTInfo srt					`thenFC` \srt_info ->
     	absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
-			(srt_label,srt) liveness_mask)	`thenC`
+			 srt_info liveness_mask)	`thenC`
 
 	-- Return an amode for the block
     	returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
@@ -807,7 +807,7 @@ mkReturnVector :: Unique
 	       -> FCode CAddrMode
 
 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
-  = getSRTLabel `thenFC` \srt_label ->
+  = getSRTInfo srt		`thenFC` \ srt_info ->
     let
      (return_vec_amode, vtbl_body) = case ret_conv of {
 
@@ -815,7 +815,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
       UnvectoredReturn 0 ->
 	ASSERT(null tagged_alt_absCs)
     	(CLbl ret_label RetRep,
-	 absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+	 absC (CRetDirect uniq deflt_absC srt_info liveness));
 
       UnvectoredReturn n ->
         -- find the tag explicitly rather than using tag_reg for now.
@@ -827,7 +827,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
     	(CLbl ret_label RetRep,
 	 absC (CRetDirect uniq 
 			    (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
-			    (srt_label, srt)
+			    srt_info
 			    liveness));
 
       VectoredReturn table_size ->
@@ -835,9 +835,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
 	  (vector_table, alts_absC) = 
 	    unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 
-	  ret_vector = CRetVector vtbl_label
-			  vector_table
-			  (srt_label, srt) liveness
+	  ret_vector = CRetVector vtbl_label vector_table srt_info liveness
 	in
     	(CLbl vtbl_label DataPtrRep, 
 	 -- alts come first, because we don't want to declare all the symbols
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 5cc5ed4340..ea8f34cb50 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.48 2001/09/10 10:07:21 rje Exp $
+% $Id: CgClosure.lhs,v 1.49 2001/09/26 15:11:50 simonpj Exp $
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -73,17 +73,19 @@ They should have no free variables.
 cgTopRhsClosure :: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
+		-> SRT
 		-> [Id]		-- Args
 		-> StgExpr
 		-> LambdaFormInfo
 		-> FCode (Id, CgIdInfo)
 
-cgTopRhsClosure id ccs binder_info args body lf_info
+cgTopRhsClosure id ccs binder_info srt args body lf_info
   = 
     -- LAY OUT THE OBJECT
+    getSRTInfo srt		`thenFC` \ srt_info ->
     let
     	name          = idName id
-	closure_info  = layOutStaticNoFVClosure name lf_info
+	closure_info  = layOutStaticNoFVClosure name lf_info srt_info
     	closure_label = mkClosureLabel name
     	cg_id_info    = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
     in
@@ -147,7 +149,8 @@ cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
     getArgAmodes payload			`thenFC` \ amodes ->
     let
 	(closure_info, amodes_w_offsets)
-	  = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
+	  = layOutDynClosure (idName binder) getAmodeRep amodes lf_info NoC_SRT
+		-- No SRT for a standard-form closure
 
 	(use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
     in
@@ -166,13 +169,14 @@ Here's the general case.
 cgRhsClosure	:: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
+		-> SRT
 		-> [Id]			-- Free vars
 		-> [Id]			-- Args
 		-> StgExpr
 		-> LambdaFormInfo
 		-> FCode (Id, CgIdInfo)
 
-cgRhsClosure binder cc binder_info fvs args body lf_info
+cgRhsClosure binder cc binder_info srt fvs args body lf_info
   = (
   	-- LAY OUT THE OBJECT
 	--
@@ -192,12 +196,14 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
 			 else fvs
     in
     mapFCs getCAddrModeAndInfo reduced_fvs	`thenFC` \ fvs_w_amodes_and_info ->
+    getSRTInfo srt				`thenFC` \ srt_info ->
     let
 	closure_info :: ClosureInfo
 	bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
 
 	(closure_info, bind_details)
-	  = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
+	  = layOutDynClosure (idName binder) get_kind
+			     fvs_w_amodes_and_info lf_info srt_info
 
 	bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
 
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index aa2aec3162..954dca8d2f 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -38,9 +38,9 @@ import CgHeapery	( allocDynClosure, inPlaceAllocDynClosure )
 import CgTailCall	( performReturn, mkStaticAlgReturnCode, doTailCall,
 			  mkUnboxedTupleReturnCode )
 import CLabel		( mkClosureLabel )
-import ClosureInfo	( mkConLFInfo, mkLFArgument,
-			  layOutDynCon, layOutDynClosure,
-			  layOutStaticClosure, closureSize
+import ClosureInfo	( mkConLFInfo, mkLFArgument, closureLFInfo,
+			  layOutDynConstr, layOutDynClosure,
+			  layOutStaticConstr, closureSize
 			)
 import CostCentre	( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
 			  currentCCS )
@@ -71,19 +71,15 @@ cgTopRhsCon :: Id		-- Name of thing bound to this RHS
 cgTopRhsCon id con args
   = ASSERT(not (isDllConApp con args))	-- checks for litlit args too
     ASSERT(length args == dataConRepArity con)
-    let
-	name          = idName id
-    	closure_label = mkClosureLabel name
-	lf_info       = mkConLFInfo con
-    in
 
-    (
 	-- LAY IT OUT
     getArgAmodes args		`thenFC` \ amodes ->
 
     let
-	(closure_info, amodes_w_offsets)
-	  = layOutStaticClosure name getAmodeRep amodes lf_info
+	name          = idName id
+    	closure_label = mkClosureLabel name
+	lf_info	      = closureLFInfo closure_info
+	(closure_info, amodes_w_offsets) = layOutStaticConstr name con getAmodeRep amodes
     in
 
 	-- BUILD THE OBJECT
@@ -93,7 +89,7 @@ cgTopRhsCon id con args
 	    (mkCCostCentreStack dontCareCCS) -- because it's static data
 	    (map fst amodes_w_offsets)) -- Sorted into ptrs first, then nonptrs
 
-    ) `thenC`
+    							`thenC`
 
 	-- RETURN
     returnFC (id, stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info)
@@ -186,7 +182,7 @@ buildDynCon binder ccs con args
     returnFC (heapIdInfo binder hp_off lf_info)
   where
     (closure_info, amodes_w_offsets)
-      = layOutDynClosure (idName binder) getAmodeRep args lf_info
+      = layOutDynClosure (idName binder) getAmodeRep args lf_info NoC_SRT
     lf_info = mkConLFInfo con
 
     use_cc	-- cost-centre to stick in the object
@@ -220,7 +216,9 @@ bindConArgs con args
     mapCs bind_arg args_w_offsets
    where
      bind_arg (arg, offset) = bindNewToNode arg offset mkLFArgument
-     (_, args_w_offsets) = layOutDynCon con idPrimRep args
+     (_, args_w_offsets)    = layOutDynConstr bogus_name con idPrimRep args
+
+bogus_name = panic "bindConArgs"
 \end{code}
 
 Unboxed tuples are handled slightly differently - the object is
@@ -235,8 +233,8 @@ bindUnboxedTupleComponents
 
 bindUnboxedTupleComponents args
  =  -- Assign as many components as possible to registers
-    let (arg_regs, leftovers) = assignRegs [] (map idPrimRep args)
-	(reg_args, stk_args) = splitAt (length arg_regs) args
+    let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
+	(reg_args, stk_args)   = splitAt (length arg_regs) args
     in
 
     -- Allocate the rest on the stack (ToDo: separate out pointers)
@@ -338,11 +336,9 @@ cgReturnDataCon con amodes
 	   setEndOfBlockInfo (EndOfBlockInfo new_sp (OnStack new_sp)) $
 	   performReturn (AbsCNop) (mkStaticAlgReturnCode con)
 
-	where (closure_info, stuff) 
-		  = layOutDynClosure (dataConName con) 
-			getAmodeRep amodes lf_info
-
-	      lf_info = mkConLFInfo con
+	where
+	   (closure_info, stuff) 
+		  = layOutDynConstr (dataConName con) con getAmodeRep amodes
 
       other_sequel	-- The usual case
 
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 9c205cc267..5a2b6be1dc 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -13,9 +13,7 @@ import CgMonad
 
 import AbsCUtils	( mkAbstractCs, mkAbsCStmts )
 import CgTailCall	( performReturn, mkStaticAlgReturnCode )
-import ClosureInfo	( layOutStaticClosure, layOutDynCon,
-			  mkConLFInfo, ClosureInfo
-			)
+import ClosureInfo	( layOutStaticConstr, layOutDynConstr, ClosureInfo )
 import DataCon		( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon )
 import Name		( getOccName )
 import OccName		( occNameUserString )
@@ -114,8 +112,7 @@ genConInfo comp_info tycon data_con
     -- To allow the debuggers, interpreters, etc to cope with static
     -- data structures (ie those built at compile time), we take care that
     -- info-table contains the information we need.
-    (static_ci,_) = layOutStaticClosure con_name typePrimRep arg_tys 
-				(mkConLFInfo data_con)
+    (static_ci,_) = layOutStaticConstr con_name data_con typePrimRep arg_tys
 
     body       = (initC comp_info (
 	    	      profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC`
@@ -149,7 +146,7 @@ mkConCodeAndInfo con
 	arg_tys = dataConRepArgTys con
 
 	(closure_info, arg_things)
-		= layOutDynCon con typePrimRep arg_tys
+		= layOutDynConstr (dataConName con) con typePrimRep arg_tys
 
 	body_code
 		= -- NB: We don't set CC when entering data (WDP 94/06)
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index f4ad2a1c68..6905285371 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgExpr.lhs,v 1.43 2001/05/22 13:43:15 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.44 2001/09/26 15:11:50 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -35,7 +35,7 @@ import CgTailCall	( cgTailCall, performReturn, performPrimReturn,
 			  tailCallPrimOp, returnUnboxedTuple
 			)
 import ClosureInfo	( mkClosureLFInfo, mkSelectorLFInfo,
-			  mkApLFInfo, layOutDynCon )
+			  mkApLFInfo, layOutDynConstr )
 import CostCentre	( sccAbleCostCentre, isSccCountCostCentre )
 import Id		( idPrimRep, idType, Id )
 import VarSet
@@ -325,15 +325,14 @@ mkRhsClosure	bndr cc	bi srt
     cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
   where
     lf_info 		  = mkSelectorLFInfo (idType bndr) offset_into_int 
-				(isUpdatable upd_flag)
-    (_, params_w_offsets) = layOutDynCon con idPrimRep params
+						(isUpdatable upd_flag)
+    (_, params_w_offsets) = layOutDynConstr bogus_name con idPrimRep params	-- Just want the layout
     maybe_offset	  = assocMaybe params_w_offsets selectee
     Just the_offset 	  = maybe_offset
     offset_into_int       = the_offset - fixedHdrSize
     is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+    bogus_name		  = panic "mkRhsClosure"
 \end{code}
-
-
 Ap thunks
 ~~~~~~~~~
 
@@ -377,11 +376,9 @@ The default case
 ~~~~~~~~~~~~~~~~
 \begin{code}
 mkRhsClosure bndr cc bi srt fvs upd_flag args body
-  = getSRTLabel		`thenFC` \ srt_label ->
-    let lf_info = 
-	  mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt
-    in
-    cgRhsClosure bndr cc bi fvs args body lf_info
+  = cgRhsClosure bndr cc bi srt fvs args body lf_info
+  where
+    lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
 \end{code}
 
 
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 07cacd4841..a5b0a20d8b 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
 %
-% $Id: CgLetNoEscape.lhs,v 1.14 2000/07/11 16:03:37 simonmar Exp $
+% $Id: CgLetNoEscape.lhs,v 1.15 2001/09/26 15:11:50 simonpj Exp $
 %
 %********************************************************
 %*							*
@@ -170,12 +170,12 @@ cgLetNoEscapeClosure
 	(allocStackTop retPrimRepSize	`thenFC` \_ ->
 	 nukeDeadBindings full_live_in_rhss)
 
-	(deAllocStackTop retPrimRepSize   `thenFC` \_ ->
-	 buildContLivenessMask uniq 	  `thenFC` \ liveness ->
+	(deAllocStackTop retPrimRepSize		`thenFC` \_ ->
+	 buildContLivenessMask uniq		`thenFC` \ liveness ->
      	 forkAbsC (cgLetNoEscapeBody binder cc args body uniq) 
 						`thenFC` \ code ->
-	 getSRTLabel 				`thenFC` \ srt_label -> 
-	 absC (CRetDirect uniq code (srt_label,srt) liveness)
+	 getSRTInfo srt				`thenFC` \ srt_info -> 
+	 absC (CRetDirect uniq code srt_info liveness)
 		`thenC` returnFC ())
 	    	    	    	     	`thenFC` \ (vSp, _) ->
 
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index ac50b28599..780db6445d 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgMonad.lhs,v 1.29 2001/08/31 12:39:06 rje Exp $
+% $Id: CgMonad.lhs,v 1.30 2001/09/26 15:11:50 simonpj Exp $
 %
 \section[CgMonad]{The code generation monad}
 
@@ -23,7 +23,7 @@ module CgMonad (
 	EndOfBlockInfo(..),
 	setEndOfBlockInfo, getEndOfBlockInfo,
 
-	setSRTLabel, getSRTLabel,
+	setSRTLabel, getSRTLabel, getSRTInfo,
 	setTickyCtrLabel, getTickyCtrLabel,
 
 	StackUsage, Slot(..), HeapUsage,
@@ -53,6 +53,7 @@ import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
 import {-# SOURCE #-} CgUsages  ( getSpRelOffset )
 
 import AbsCSyn
+import StgSyn		( SRT(..) )
 import AbsCUtils	( mkAbsCStmts )
 import CmdLineOpts	( opt_SccProfilingOn, opt_DoTickyProfiling )
 import CLabel           ( CLabel, mkUpdInfoLabel, mkTopTickyCtrLabel )
@@ -615,15 +616,19 @@ getEndOfBlockInfo = do
 \end{code}
 
 \begin{code}
-getSRTLabel :: FCode CLabel
-getSRTLabel = do 
-	(MkCgInfoDown _ _ srt _ _) <- getInfoDown
-	return srt
+getSRTInfo :: SRT -> FCode C_SRT
+getSRTInfo NoSRT	 = return NoC_SRT
+getSRTInfo (SRT off len) = do srt_lbl <- getSRTLabel
+			      return (C_SRT srt_lbl off len)
+
+getSRTLabel :: FCode CLabel	-- Used only by cgPanic
+getSRTLabel = do MkCgInfoDown _ _ srt_lbl _ _ <- getInfoDown
+		 return srt_lbl
 
 setSRTLabel :: CLabel -> Code -> Code
-setSRTLabel srt code = do
-	(MkCgInfoDown c_info statics _ ticky eob_info) <- getInfoDown
-	withInfoDown code (MkCgInfoDown c_info statics srt ticky eob_info)
+setSRTLabel srt_lbl code
+  = do  MkCgInfoDown c_info statics _ ticky eob_info <- getInfoDown
+	withInfoDown code (MkCgInfoDown c_info statics srt_lbl ticky eob_info)
 \end{code}
 
 \begin{code}
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index 2801d453ee..6ba2ec0074 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: ClosureInfo.lhs,v 1.47 2001/05/22 13:43:15 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $
 %
 \section[ClosureInfo]{Data structures which describe closures}
 
@@ -23,8 +23,8 @@ module ClosureInfo (
 	closureGoodStuffSize, closurePtrsSize,
 	slopSize,
 
-	layOutDynClosure, layOutDynCon, layOutStaticClosure,
-	layOutStaticNoFVClosure,
+	layOutDynClosure, layOutDynConstr, layOutStaticClosure,
+	layOutStaticNoFVClosure, layOutStaticConstr,
 	mkVirtHeapOffsets,
 
 	nodeMustPointToIt, getEntryConvention, 
@@ -36,7 +36,7 @@ module ClosureInfo (
 	slowFunEntryCodeRequired, funInfoTableRequired,
 
 	closureName, infoTableLabelFromCI, fastLabelFromCI,
-	closureLabelFromCI,
+	closureLabelFromCI, closureSRT,
 	entryLabelFromCI, 
 	closureLFInfo, closureSMRep, closureUpdReqd,
 	closureSingleEntry, closureReEntrant, closureSemiTag,
@@ -51,14 +51,12 @@ module ClosureInfo (
 	cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
 	maybeSelectorInfo,
 
-	infoTblNeedsSRT,
 	staticClosureNeedsLink,
-	getSRTInfo
     ) where
 
 #include "HsVersions.h"
 
-import AbsCSyn		( MagicId, node, VirtualHeapOffset, HeapOffset )
+import AbsCSyn		( MagicId, node, VirtualHeapOffset, HeapOffset, C_SRT(..), needsSRT )
 import StgSyn
 import CgMonad
 
@@ -95,22 +93,24 @@ import Util		( mapAccumL )
 import Outputable
 \end{code}
 
-The ``wrapper'' data type for closure information:
-
-\begin{code}
-data ClosureInfo
-  = MkClosureInfo
-	Name			-- The thing bound to this closure
-	LambdaFormInfo		-- info derivable from the *source*
-	SMRep			-- representation used by storage manager
-\end{code}
-
 %************************************************************************
 %*									*
 \subsection[ClosureInfo-datatypes]{Data types for closure information}
 %*									*
 %************************************************************************
 
+The ``wrapper'' data type for closure information:
+
+\begin{code}
+data ClosureInfo
+  = MkClosureInfo {
+	closureName   :: Name,			-- The thing bound to this closure
+	closureLFInfo :: LambdaFormInfo,	-- Info derivable from the *source*
+	closureSMRep  :: SMRep,			-- representation used by storage manager
+	closureSRT    :: C_SRT			-- What SRT applies to this closure
+    }
+\end{code}
+
 %************************************************************************
 %*									*
 \subsubsection[LambdaFormInfo-datatype]{@LambdaFormInfo@: source-derivable info}
@@ -124,8 +124,6 @@ data LambdaFormInfo
 	TopLevelFlag	-- True if top level
 	!Int		-- Arity
 	!Bool		-- True <=> no fvs
-	CLabel		-- SRT label
-	SRT		-- SRT info
 
   | LFCon		-- Constructor
 	DataCon		-- The constructor
@@ -141,8 +139,6 @@ data LambdaFormInfo
 	!Bool		-- True <=> no free vars
 	Bool		-- True <=> updatable (i.e., *not* single-entry)
 	StandardFormInfo
-	CLabel		-- SRT label
-	SRT		-- SRT info
 
   | LFArgument		-- Used for function arguments.  We know nothing about
 			-- this closure.  Treat like updatable "LFThunk"...
@@ -209,23 +205,20 @@ mkClosureLFInfo :: Id		-- The binder
 		-> [Id]		-- Free vars
 		-> UpdateFlag 	-- Update flag
 		-> [Id] 	-- Args
-		-> CLabel	-- SRT label
-		-> SRT		-- SRT info
 		-> LambdaFormInfo
 
-mkClosureLFInfo bndr top fvs upd_flag args@(_:_) srt_label srt -- Non-empty args
-  = LFReEntrant (idType bndr) top (length args) (null fvs) srt_label srt
+mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
+  = LFReEntrant (idType bndr) top (length args) (null fvs)
 
-mkClosureLFInfo bndr top fvs ReEntrant [] srt_label srt
-  = LFReEntrant (idType bndr) top 0 (null fvs) srt_label srt
+mkClosureLFInfo bndr top fvs ReEntrant []
+  = LFReEntrant (idType bndr) top 0 (null fvs)
 
-mkClosureLFInfo bndr top fvs upd_flag [] srt_label srt
+mkClosureLFInfo bndr top fvs upd_flag []
 #ifdef DEBUG
   | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
 #endif
   | otherwise
   = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
-	srt_label srt
   where
     ty = idType bndr
 \end{code}
@@ -242,14 +235,10 @@ mkConLFInfo con
 
 mkSelectorLFInfo rhs_ty offset updatable
   = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
-	(error "mkSelectorLFInfo: no srt label")
-	(error "mkSelectorLFInfo: no srt")
 
 mkApLFInfo rhs_ty upd_flag arity
-  = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag) 
-	(ApThunk arity)
-	(error "mkApLFInfo: no srt label")
-	(error "mkApLFInfo: no srt")
+  = LFThunk rhs_ty NotTopLevel (arity == 0)
+	    (isUpdatable upd_flag) (ApThunk arity)
 \end{code}
 
 Miscellaneous LF-infos.
@@ -262,8 +251,6 @@ mkLFImported :: Id -> LambdaFormInfo
 mkLFImported id
   = case idCgArity id of
       n | n > 0 -> LFReEntrant (idType id) TopLevel n True  -- n > 0
-		       (error "mkLFImported: no srt label") 
-		       (error "mkLFImported: no srt")
       other -> LFImported	-- Not sure of exact arity
 \end{code}
 
@@ -275,24 +262,30 @@ mkLFImported id
 
 \begin{code}
 closureSize :: ClosureInfo -> HeapOffset
-closureSize cl_info@(MkClosureInfo _ _ sm_rep)
-  = fixedHdrSize + closureNonHdrSize cl_info
+closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
 
 closureNonHdrSize :: ClosureInfo -> Int
-closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
-  = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) 
-    --ToDo: pass lf_info?
+closureNonHdrSize cl_info
+  = tot_wds + computeSlopSize tot_wds 
+			      (closureSMRep cl_info)
+			      (closureUpdReqd cl_info) 
   where
     tot_wds = closureGoodStuffSize cl_info
 
+slopSize :: ClosureInfo -> Int
+slopSize cl_info
+  = computeSlopSize (closureGoodStuffSize cl_info)
+		    (closureSMRep cl_info)
+		    (closureUpdReqd cl_info)
+
 closureGoodStuffSize :: ClosureInfo -> Int
-closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
-  = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
+closureGoodStuffSize cl_info
+  = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
     in	ptrs + nonptrs
 
 closurePtrsSize :: ClosureInfo -> Int
-closurePtrsSize (MkClosureInfo _ _ sm_rep)
-  = let (ptrs, _) = sizes_from_SMRep sm_rep
+closurePtrsSize cl_info
+  = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
     in	ptrs
 
 -- not exported:
@@ -330,10 +323,6 @@ Static closures have an extra ``static link field'' at the end, but we
 don't bother taking that into account here.
 
 \begin{code}
-slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
-  = computeSlopSize (closureGoodStuffSize cl_info) sm_rep	
-         (closureUpdReqd cl_info)
-
 computeSlopSize :: Int -> SMRep -> Bool -> Int
 
 computeSlopSize tot_wds (GenericRep _ _ _ _) True		-- Updatable
@@ -361,11 +350,13 @@ layOutDynClosure, layOutStaticClosure
 	-> (a -> PrimRep)    	    -- how to get a PrimRep for the fields
 	-> [a]			    -- the "things" being layed out
 	-> LambdaFormInfo	    -- what sort of closure it is
+	-> C_SRT
 	-> (ClosureInfo,	    -- info about the closure
 	    [(a, VirtualHeapOffset)])	-- things w/ offsets pinned on them
 
-layOutDynClosure name kind_fn things lf_info
-  = (MkClosureInfo name lf_info sm_rep,
+layOutDynClosure name kind_fn things lf_info srt_info
+  = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+		     closureSMRep = sm_rep, closureSRT = srt_info },
      things_w_offsets)
   where
     (tot_wds,		 -- #ptr_wds + #nonptr_wds
@@ -374,16 +365,20 @@ layOutDynClosure name kind_fn things lf_info
     sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
 \end{code}
 
-A wrapper for when used with data constructors:
+Wrappers for when used with data constructors:
 
 \begin{code}
-layOutDynCon :: DataCon
-	     -> (a -> PrimRep)
-	     -> [a]
-	     -> (ClosureInfo, [(a,VirtualHeapOffset)])
+layOutDynConstr, layOutStaticConstr
+	:: Name 	-- Of the closure
+	-> DataCon 	
+	-> (a -> PrimRep) -> [a]
+	-> (ClosureInfo, [(a,VirtualHeapOffset)])
+
+layOutDynConstr name data_con kind_fn args
+  = layOutDynClosure name kind_fn args (mkConLFInfo data_con) NoC_SRT
 
-layOutDynCon con kind_fn args
-  = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con)
+layOutStaticConstr name data_con kind_fn things
+  = layOutStaticClosure name kind_fn things (mkConLFInfo data_con) NoC_SRT
 \end{code}
 
 %************************************************************************
@@ -399,11 +394,13 @@ Static closures for functions are laid out using
 layOutStaticNoFVClosure.
 
 \begin{code}
-layOutStaticClosure name kind_fn things lf_info
-  = (MkClosureInfo name lf_info 
-	(GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type),
+layOutStaticClosure name kind_fn things lf_info srt_info
+  = (MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+		     closureSMRep = rep, closureSRT = srt_info },
      things_w_offsets)
   where
+    rep = GenericRep is_static ptr_wds (tot_wds - ptr_wds) closure_type
+
     (tot_wds,		 -- #ptr_wds + #nonptr_wds
      ptr_wds,		 -- #ptr_wds
      things_w_offsets) = mkVirtHeapOffsets kind_fn things
@@ -414,10 +411,12 @@ layOutStaticClosure name kind_fn things lf_info
     closure_type = getClosureType is_static tot_wds ptr_wds lf_info
     is_static    = True
 
-layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
-layOutStaticNoFVClosure name lf_info
-  = MkClosureInfo name lf_info (GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info))
+layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> C_SRT -> ClosureInfo
+layOutStaticNoFVClosure name lf_info srt_info
+  = MkClosureInfo { closureName = name, closureLFInfo = lf_info,
+		    closureSMRep = rep, closureSRT = srt_info }
   where
+    rep = GenericRep is_static 0 0 (getClosureType is_static 0 0 lf_info)
     is_static = True
 \end{code}
 
@@ -459,13 +458,13 @@ getClosureType is_static tot_wds ptr_wds lf_info
 		| specialised_rep mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n
 		| otherwise			       -> CONSTR
 
-  	LFReEntrant _ _ _ _ _ _
+  	LFReEntrant _ _ _ _ 
 		| specialised_rep mAX_SPEC_FUN_SIZE -> FUN_p_n
 		| otherwise			    -> FUN
 
-	LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR
+	LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
 
-	LFThunk _ _ _ _ _ _ _
+	LFThunk _ _ _ _ _
 		| specialised_rep mAX_SPEC_THUNK_SIZE -> THUNK_p_n
 		| otherwise			      -> THUNK
 
@@ -525,7 +524,7 @@ nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
 nodeMustPointToIt lf_info
 
   = case lf_info of
-	LFReEntrant ty top arity no_fvs _ _ -> returnFC (
+	LFReEntrant ty top arity no_fvs -> returnFC (
 	    not no_fvs ||   -- Certainly if it has fvs we need to point to it
 	    isNotTopLevel top
 		    -- If it is not top level we will point to it
@@ -552,7 +551,7 @@ nodeMustPointToIt lf_info
 	-- having Node point to the result of an update.  SLPJ
 	-- 27/11/92.
 
-	LFThunk _ _ no_fvs updatable NonStandardThunk _ _
+	LFThunk _ _ no_fvs updatable NonStandardThunk
 	  -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
 
 	  -- For the non-updatable (single-entry case):
@@ -562,7 +561,7 @@ nodeMustPointToIt lf_info
 	  -- or profiling (in which case we need to recover the cost centre
 	  --		 from inside it)
 
-	LFThunk _ _ no_fvs updatable some_standard_form_thunk _ _
+	LFThunk _ _ no_fvs updatable some_standard_form_thunk
 	  -> returnFC True
 	  -- Node must point to any standard-form thunk.
 
@@ -635,7 +634,7 @@ getEntryConvention name lf_info arg_kinds
 
     case lf_info of
 
-	LFReEntrant _ _ arity _ _ _ ->
+	LFReEntrant _ _ arity _ ->
 	    if arity == 0 || (length arg_kinds) < arity then
 		StdEntry (mkStdEntryLabel name)
 	    else
@@ -661,7 +660,7 @@ getEntryConvention name lf_info arg_kinds
 			     -- Should have no args (meaning what?)
 			     StdEntry (mkConEntryLabel (dataConName tup))
 
-	LFThunk _ _ _ updatable std_form_info _ _
+	LFThunk _ _ _ updatable std_form_info
 	  -> if updatable || opt_DoTickyProfiling  -- to catch double entry
 		|| opt_SMP  -- always enter via node on SMP, since the
 			    -- thunk might have been blackholed in the 
@@ -695,16 +694,15 @@ blackHoleOnEntry :: ClosureInfo -> Bool
 -- Single-entry ones have no fvs to plug, and we trust they don't form part 
 -- of a loop.
 
-blackHoleOnEntry (MkClosureInfo _ _ rep) 
-  | isStaticRep rep 
-  = False
-	-- Never black-hole a static closure
+blackHoleOnEntry cl_info
+  | isStaticRep (closureSMRep cl_info)
+  = False	-- Never black-hole a static closure
 
-blackHoleOnEntry (MkClosureInfo _ lf_info _)
-  = case lf_info of
-	LFReEntrant _ _ _ _ _ _	  -> False
+  | otherwise
+  = case closureLFInfo cl_info of
+	LFReEntrant _ _ _ _	  -> False
 	LFLetNoEscape _		  -> False
-	LFThunk _ _ no_fvs updatable _ _ _
+	LFThunk _ _ no_fvs updatable _
 	  -> if updatable
 	     then not opt_OmitBlackHoling
 	     else opt_DoTickyProfiling || not no_fvs
@@ -715,45 +713,36 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _)
 
 isStandardFormThunk :: LambdaFormInfo -> Bool
 
-isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _) _ _) = True
-isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _) _ _)	    = True
-isStandardFormThunk other_lf_info 			    = False
+isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True
+isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _))	= True
+isStandardFormThunk other_lf_info 			= False
 
-maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _
-			(SelectorThunk offset) _ _) _) = Just offset
+maybeSelectorInfo (MkClosureInfo { closureLFInfo = LFThunk _ _ _ _ (SelectorThunk offset) }) 
+		    = Just offset
 maybeSelectorInfo _ = Nothing
 \end{code}
 
 -----------------------------------------------------------------------------
 SRT-related stuff
 
-
 \begin{code}
-infoTblNeedsSRT :: ClosureInfo -> Bool
-infoTblNeedsSRT (MkClosureInfo _ info _) =
-  case info of
-    LFThunk _ _ _ _ _ _ NoSRT   -> False
-    LFThunk _ _ _ _ _ _ _       -> True
-
-    LFReEntrant _ _ _ _ _ NoSRT -> False
-    LFReEntrant _ _ _ _ _ _     -> True
-
-    _ -> False
-
 staticClosureNeedsLink :: ClosureInfo -> Bool
-staticClosureNeedsLink (MkClosureInfo _ info _) =
-  case info of
-    LFThunk _ _ _ _ _ _ NoSRT   -> False
-    LFReEntrant _ _ _ _ _ NoSRT -> False
-    LFCon _ True                -> False -- zero arity constructors
-    _ -> True
-
-getSRTInfo :: ClosureInfo -> (CLabel, SRT)
-getSRTInfo  (MkClosureInfo _ info _) =
-  case info of
-    LFThunk _ _ _ _ _ lbl srt   -> (lbl,srt)
-    LFReEntrant _ _ _ _ lbl srt -> (lbl,srt)
-    _ -> panic "getSRTInfo"
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph.  But it only needs such a field if either
+-- 	a) it has an SRT
+--	b) it's a non-nullary constructor
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink (MkClosureInfo { closureName = name, closureSRT = srt, closureLFInfo = info })
+  = needsSRT srt || constructor_srt
+  where
+    constructor_srt 
+      = case info of
+	  LFThunk _ _ _ _ _    -> False
+	  LFReEntrant _ _ _ _  -> False
+	  LFCon   _ is_nullary -> not is_nullary
+	  LFTuple _ is_nullary -> not is_nullary
+	  other		       -> pprPanic "staticClosureNeedsLink" (ppr name)
 \end{code}
 
 Avoiding generating entries and info tables
@@ -824,7 +813,7 @@ staticClosureRequired
 	-> LambdaFormInfo
 	-> Bool
 staticClosureRequired binder bndr_info
-		      (LFReEntrant _ top_level _ _ _ _)	-- It's a function
+		      (LFReEntrant _ top_level _ _)	-- It's a function
   = ASSERT( isTopLevel top_level )
 	-- Assumption: it's a top-level, no-free-var binding
 	not (satCallsOnly bndr_info)
@@ -847,7 +836,7 @@ funInfoTableRequired
 	-> StgBinderInfo
 	-> LambdaFormInfo
 	-> Bool
-funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _ _ _)
+funInfoTableRequired binder bndr_info (LFReEntrant _ top_level _ _)
   =    isNotTopLevel top_level
     || not (satCallsOnly bndr_info)
 
@@ -863,36 +852,27 @@ funInfoTableRequired other_binder_info binder other_lf_info = True
 \begin{code}
 
 isStaticClosure :: ClosureInfo -> Bool
-isStaticClosure  (MkClosureInfo _ _ rep) = isStaticRep  rep
-
-closureName :: ClosureInfo -> Name
-closureName (MkClosureInfo name _ _) = name
-
-closureSMRep :: ClosureInfo -> SMRep
-closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
-
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
 
 closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = upd
-closureUpdReqd (MkClosureInfo _ (LFBlackHole _) _)           = True
+closureUpdReqd (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = upd
+closureUpdReqd (MkClosureInfo { closureLFInfo = LFBlackHole _ })           = True
 	-- Black-hole closures are allocated to receive the results of an
 	-- alg case with a named default... so they need to be updated.
-closureUpdReqd other_closure			       = False
+closureUpdReqd other_closure = False
 
 closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd
-closureSingleEntry other_closure			   = False
+closureSingleEntry (MkClosureInfo { closureLFInfo = LFThunk _ _ _ upd _ }) = not upd
+closureSingleEntry other_closure = False
 
 closureReEntrant :: ClosureInfo -> Bool
-closureReEntrant (MkClosureInfo _ (LFReEntrant _ _ _ _ _ _) _) = True
+closureReEntrant (MkClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
 closureReEntrant other_closure = False
 \end{code}
 
 \begin{code}
 closureSemiTag :: ClosureInfo -> Maybe Int
-closureSemiTag (MkClosureInfo _ lf_info _)
+closureSemiTag (MkClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
       LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
       LFTuple _ _      -> Just 0
@@ -902,10 +882,10 @@ closureSemiTag (MkClosureInfo _ lf_info _)
 \begin{code}
 isToplevClosure :: ClosureInfo -> Bool
 
-isToplevClosure (MkClosureInfo _ lf_info _)
+isToplevClosure (MkClosureInfo { closureLFInfo = lf_info })
   = case lf_info of
-      LFReEntrant _ TopLevel _ _ _ _ -> True
-      LFThunk _ TopLevel _ _ _ _ _   -> True
+      LFReEntrant _ TopLevel _ _ -> True
+      LFThunk _ TopLevel _ _ _   -> True
       other -> False
 \end{code}
 
@@ -913,24 +893,24 @@ Label generation.
 
 \begin{code}
 fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _)
+fastLabelFromCI (MkClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ _ arity _ })
   = mkFastEntryLabel name arity
 
-fastLabelFromCI (MkClosureInfo name _ _)
-  = pprPanic "fastLabelFromCI" (ppr name)
+fastLabelFromCI cl_info
+  = pprPanic "fastLabelFromCI" (ppr (closureName cl_info))
 
 infoTableLabelFromCI :: ClosureInfo -> CLabel
-infoTableLabelFromCI (MkClosureInfo id lf_info rep)
+infoTableLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
   = case lf_info of
 	LFCon con _ 	 -> mkConInfoPtr con rep
 	LFTuple tup _	 -> mkConInfoPtr tup rep
 
 	LFBlackHole info -> info
 
-	LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ -> 
+	LFThunk _ _ _ upd_flag (SelectorThunk offset) -> 
 		mkSelectorInfoLabel upd_flag offset
 
-	LFThunk _ _ _ upd_flag (ApThunk arity) _ _ -> 
+	LFThunk _ _ _ upd_flag (ApThunk arity) -> 
 		mkApInfoTableLabel upd_flag arity
 
 	other -> {-NO: if isStaticRep rep
@@ -949,12 +929,12 @@ mkConEntryPtr con rep
   | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
   | otherwise       = mkConEntryLabel       (dataConName con)
 
-closureLabelFromCI (MkClosureInfo id _ other_rep)   = mkClosureLabel id
+closureLabelFromCI cl_info = mkClosureLabel (closureName cl_info)
 
 entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo id lf_info rep)
+entryLabelFromCI (MkClosureInfo { closureName = id, closureLFInfo = lf_info, closureSMRep = rep })
   = case lf_info of
-	LFThunk _ _ _ upd_flag std_form_info _ _ -> thunkEntryLabel id std_form_info upd_flag
+	LFThunk _ _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
 	LFCon con _			     -> mkConEntryPtr con rep
 	LFTuple tup _			     -> mkConEntryPtr tup rep
 	other				     -> mkStdEntryLabel id
@@ -973,15 +953,15 @@ thunkEntryLabel thunk_id _ is_updatable
 \begin{code}
 allocProfilingMsg :: ClosureInfo -> FAST_STRING
 
-allocProfilingMsg (MkClosureInfo _ lf_info _)
-  = case lf_info of
-      LFReEntrant _ _ _ _ _ _	-> SLIT("TICK_ALLOC_FUN")
-      LFCon _ _			-> SLIT("TICK_ALLOC_CON")
-      LFTuple _ _		-> SLIT("TICK_ALLOC_CON")
-      LFThunk _ _ _ True _ _ _  -> SLIT("TICK_ALLOC_UP_THK")  -- updatable
-      LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK")  -- nonupdatable
-      LFBlackHole _		-> SLIT("TICK_ALLOC_BH")
-      LFImported		-> panic "TICK_ALLOC_IMP"
+allocProfilingMsg cl_info
+  = case closureLFInfo cl_info of
+      LFReEntrant _ _ _ _   -> SLIT("TICK_ALLOC_FUN")
+      LFCon _ _		    -> SLIT("TICK_ALLOC_CON")
+      LFTuple _ _	    -> SLIT("TICK_ALLOC_CON")
+      LFThunk _ _ _ True _  -> SLIT("TICK_ALLOC_UP_THK")  -- updatable
+      LFThunk _ _ _ False _ -> SLIT("TICK_ALLOC_SE_THK")  -- nonupdatable
+      LFBlackHole _	    -> SLIT("TICK_ALLOC_BH")
+      LFImported	    -> panic "TICK_ALLOC_IMP"
 \end{code}
 
 We need a black-hole closure info to pass to @allocDynClosure@ when we
@@ -990,11 +970,17 @@ ways to build an LFBlackHole, maintaining the invariant that it really
 is a black hole and not something else.
 
 \begin{code}
-cafBlackHoleClosureInfo (MkClosureInfo name _ _)
-  = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep
-
-seCafBlackHoleClosureInfo (MkClosureInfo name _ _)
-  = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep
+cafBlackHoleClosureInfo cl_info
+  = MkClosureInfo { closureName   = closureName cl_info,
+		    closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
+		    closureSMRep  = BlackHoleRep,
+		    closureSRT    = NoC_SRT  }
+
+seCafBlackHoleClosureInfo cl_info
+  = MkClosureInfo { closureName   = closureName cl_info,
+		    closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
+		    closureSMRep  = BlackHoleRep,
+		    closureSRT    = NoC_SRT }
 \end{code}
 
 %************************************************************************
@@ -1014,13 +1000,10 @@ in the closure info using @closureTypeDescr@.
 
 \begin{code}
 closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _ _ _) _)
-  = getTyDescription ty
-closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _ _ _) _)
-  = getTyDescription ty
-closureTypeDescr (MkClosureInfo name (LFCon data_con _) _)
-  = occNameUserString (getOccName (dataConTyCon data_con))
-closureTypeDescr (MkClosureInfo name lf _)
-  = showSDoc (ppr name)
+closureTypeDescr cl_info
+  = case closureLFInfo cl_info of
+	LFThunk ty _ _ _ _   -> getTyDescription ty
+	LFReEntrant ty _ _ _ -> getTyDescription ty
+	LFCon data_con _     -> occNameUserString (getOccName (dataConTyCon data_con))
+	other		     -> showSDoc (ppr (closureName cl_info))
 \end{code}
-
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 2b15e21547..d6b5d0f2cb 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -50,8 +50,6 @@ import ErrUtils		( dumpIfSet_dyn, showPass )
 import Panic		( assertPanic )
 
 #ifdef DEBUG
-import Id		( idCafInfo )
-import IdInfo		( mayHaveCafRefs )
 import Outputable
 #endif
 \end{code}
@@ -266,11 +264,9 @@ cgTopRhs bndr (StgRhsCon cc con args) srt
 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
   =     -- There should be no free variables
     ASSERT(null fvs)
-
-    getSRTLabel `thenFC` \srt_label ->
-    let lf_info = 
-	  mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt
+    let 
+	lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args
     in
-    maybeGlobaliseId bndr `thenFC` \ bndr' ->
-    forkStatics (cgTopRhsClosure bndr' cc bi args body lf_info)
+    maybeGlobaliseId bndr			`thenFC` \ bndr' ->
+    forkStatics (cgTopRhsClosure bndr' cc bi srt args body lf_info)
 \end{code}