Added an SRT to each CmmCall and added the current SRT to the CgMonad

12 files changed, 117 insertions, 79 deletions

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index a473e9158e..11a3c3e1d8 100644
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -95,7 +95,6 @@ cgCase	:: StgExpr
 	-> StgLiveVars
 	-> StgLiveVars
 	-> Id
-	-> SRT
 	-> AltType
 	-> [StgAlt]
 	-> Code
@@ -104,7 +103,7 @@ cgCase	:: StgExpr
 Special case #1: case of literal.
 
 \begin{code}
-cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt 
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr
        alt_type@(PrimAlt tycon) alts
   = do	{ tmp_reg <- bindNewToTemp bndr
 	; cm_lit <- cgLit lit
@@ -120,7 +119,7 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr
        alt_type@(PrimAlt tycon) alts
   = do	{ -- Careful! we can't just bind the default binder to the same thing
 	  -- as the scrutinee, since it might be a stack location, and having
@@ -137,7 +136,7 @@ Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
 cgCase (StgOpApp op@(StgPrimOp primop) args _) 
-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts
   | not (primOpOutOfLine primop)
   = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
 \end{code}
@@ -152,7 +151,7 @@ right here, just like an inline primop.
 
 \begin{code}
 cgCase (StgOpApp op@(StgFCallOp fcall _) args _) 
-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts
   | unsafe_foreign_call
   = ASSERT( isSingleton alts )
     do	--  *must* be an unboxed tuple alt.
@@ -177,7 +176,7 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 cgCase (StgApp fun args)
-	live_in_whole_case live_in_alts bndr srt alt_type alts
+	live_in_whole_case live_in_alts bndr alt_type alts
   = do	{ fun_info <- getCgIdInfo fun
 	; arg_amodes <- getArgAmodes args
 
@@ -195,7 +194,7 @@ cgCase (StgApp fun args)
 	    <- forkEval alts_eob_info 
 			(allocStackTop retAddrSizeW >> nopC)
 			(do { deAllocStackTop retAddrSizeW
-			    ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+			    ; cgEvalAlts maybe_cc_slot bndr alt_type alts })
 
 	; setEndOfBlockInfo scrut_eob_info
 			    (performTailCall fun_info arg_amodes save_assts) }
@@ -215,7 +214,7 @@ deAllocStackTop call is doing above.
 Finally, here is the general case.
 
 \begin{code}
-cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
+cgCase expr live_in_whole_case live_in_alts bndr alt_type alts
   = do	{	-- Figure out what volatile variables to save
 	  nukeDeadBindings live_in_whole_case
     
@@ -232,7 +231,7 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
 				; allocStackTop retAddrSizeW   -- space for retn address 
 				; nopC })
 			   (do	{ deAllocStackTop retAddrSizeW
-				; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+				; cgEvalAlts maybe_cc_slot bndr alt_type alts })
 
 	; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
     }
@@ -355,14 +354,13 @@ is some evaluation to be done.
 \begin{code}
 cgEvalAlts :: Maybe VirtualSpOffset	-- Offset of cost-centre to be restored, if any
 	   -> Id
-	   -> SRT			-- SRT for the continuation
 	   -> AltType
 	   -> [StgAlt]
 	   -> FCode Sequel	-- Any addr modes inside are guaranteed
 				-- to be a label so that we can duplicate it 
 				-- without risk of duplicating code
 
-cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts
   = do	{ let   rep = tyConCgRep tycon
 		reg = dataReturnConvPrim rep	-- Bottom for voidRep
 
@@ -374,10 +372,10 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
 		; restoreCurrentCostCentre cc_slot True
 		; cgPrimAlts GCMayHappen alt_type reg alts }
 
-	; lbl <- emitReturnTarget (idName bndr) abs_c srt
+	; lbl <- emitReturnTarget (idName bndr) abs_c
 	; returnFC (CaseAlts lbl Nothing bndr) }
 
-cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
+cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]
   =	-- Unboxed tuple case
 	-- By now, the simplifier should have have turned it
 	-- into 	case e of (# a,b #) -> e
@@ -396,10 +394,10 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
 			-- and finally the code for the alternative
 		; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
 				     (cgExpr rhs) }
-	; lbl <- emitReturnTarget (idName bndr) abs_c srt
+	; lbl <- emitReturnTarget (idName bndr) abs_c
 	; returnFC (CaseAlts lbl Nothing bndr) }
 
-cgEvalAlts cc_slot bndr srt alt_type alts
+cgEvalAlts cc_slot bndr alt_type alts
   = 	-- Algebraic and polymorphic case
     do	{	-- Bind the default binder
 	  bindNewToReg bndr nodeReg (mkLFArgument bndr)
@@ -416,7 +414,7 @@ cgEvalAlts cc_slot bndr srt alt_type alts
 	; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
 
 	; (lbl, branches) <- emitAlgReturnTarget (idName bndr) 
-				alts mb_deflt srt fam_sz
+				alts mb_deflt fam_sz
 
 	; returnFC (CaseAlts lbl branches bndr) }
   where
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index fd851157d7..2c72860a29 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -61,17 +61,16 @@ They should have no free variables.
 cgTopRhsClosure :: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
-		-> SRT
 		-> UpdateFlag
 		-> [Id]		-- Args
 		-> StgExpr
 		-> FCode (Id, CgIdInfo)
 
-cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+cgTopRhsClosure id ccs binder_info upd_flag args body = do
   {	-- LAY OUT THE OBJECT
     let name = idName id
   ; lf_info  <- mkClosureLFInfo id TopLevel [] upd_flag args
-  ; srt_info <- getSRTInfo name srt
+  ; srt_info <- getSRTInfo
   ; mod_name <- getModuleName
   ; let descr         = closureDescription mod_name name
 	closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
@@ -136,14 +135,13 @@ Here's the general case.
 cgRhsClosure	:: Id
 		-> CostCentreStack	-- Optional cost centre annotation
 		-> StgBinderInfo
-		-> SRT
 		-> [Id]			-- Free vars
 		-> UpdateFlag
 		-> [Id]			-- Args
 		-> StgExpr
 		-> FCode (Id, CgIdInfo)
 
-cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
   { 	-- LAY OUT THE OBJECT
 	-- If the binder is itself a free variable, then don't store
 	-- it in the closure.  Instead, just bind it to Node on entry.
@@ -161,7 +159,7 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
 
   ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
   ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
-  ; srt_info <- getSRTInfo name srt
+  ; srt_info <- getSRTInfo
   ; mod_name <- getModuleName
   ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
 	(tot_wds, ptr_wds, bind_details) 
diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs
index 43f69906e6..a71493a28b 100644
--- a/compiler/codeGen/CgExpr.lhs
+++ b/compiler/codeGen/CgExpr.lhs
@@ -203,7 +203,7 @@ module, @CgCase@.
 \begin{code}
 
 cgExpr (StgCase expr live_vars save_vars bndr srt alt_type alts)
-  = cgCase expr live_vars save_vars bndr srt alt_type alts
+  = setSRT srt $ cgCase expr live_vars save_vars bndr alt_type alts
 \end{code}
 
 
@@ -293,7 +293,7 @@ cgRhs name (StgRhsCon maybe_cc con args)
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
   = do this_pkg <- getThisPackage
-       mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body
+       setSRT srt $ mkRhsClosure this_pkg name cc bi fvs upd_flag args body
 \end{code}
 
 mkRhsClosure looks for two special forms of the right-hand side:
@@ -316,12 +316,12 @@ form:
 
 
 \begin{code}
-mkRhsClosure	this_pkg bndr cc bi srt
+mkRhsClosure	this_pkg bndr cc bi
 		[the_fv]   		-- Just one free var
 		upd_flag		-- Updatable thunk
 		[]			-- A thunk
 		body@(StgCase (StgApp scrutinee [{-no args-}])
-		      _ _ _ _   -- ignore uniq, etc.
+		      _ _ _ srt   -- ignore uniq, etc.
 		      (AlgAlt tycon)
 		      [(DataAlt con, params, use_mask,
 			    (StgApp selectee [{-no args-}]))])
@@ -334,7 +334,7 @@ mkRhsClosure	this_pkg bndr cc bi srt
     -- other constructors in the datatype.  It's still ok to make a selector
     -- thunk in this case, because we *know* which constructor the scrutinee
     -- will evaluate to.
-    cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
+    setSRT srt $ cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv]
   where
     lf_info 		  = mkSelectorLFInfo bndr offset_into_int
 				 (isUpdatable upd_flag)
@@ -362,7 +362,7 @@ We only generate an Ap thunk if all the free variables are pointers,
 for semi-obvious reasons.
 
 \begin{code}
-mkRhsClosure 	this_pkg bndr cc bi srt
+mkRhsClosure 	this_pkg bndr cc bi
 		fvs
 		upd_flag
 		[]			-- No args; a thunk
@@ -387,8 +387,8 @@ mkRhsClosure 	this_pkg bndr cc bi srt
 The default case
 ~~~~~~~~~~~~~~~~
 \begin{code}
-mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body
-  = cgRhsClosure bndr cc bi srt fvs upd_flag args body
+mkRhsClosure this_pkg bndr cc bi fvs upd_flag args body
+  = cgRhsClosure bndr cc bi fvs upd_flag args body
 \end{code}
 
 
@@ -434,7 +434,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
     -- case upd_flag of
     --     Updatable -> panic "cgLetNoEscapeRhs"	-- Nothing to update!
     --     other     -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
-    cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
+    setSRT srt $ cgLetNoEscapeClosure binder cc bi full_live_in_rhss rhs_eob_info
 	maybe_cc_slot rec args body
 
 -- For a constructor RHS we want to generate a single chunk of code which
@@ -442,7 +442,7 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 -- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
 cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
     	    	 (StgRhsCon cc con args)
-  = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
+  = setSRT NoSRT $ cgLetNoEscapeClosure binder cc noBinderInfo{-safe-}
 			 full_live_in_rhss rhs_eob_info maybe_cc_slot rec
 	[] 	--No args; the binder is data structure, not a function
 	(StgConApp con args)
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 48015fa45a..b2ca5b166a 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -32,6 +32,7 @@ import CmmUtils
 import MachOp
 import SMRep
 import ForeignCall
+import ClosureInfo
 import Constants
 import StaticFlags
 import Outputable
@@ -76,8 +77,9 @@ emitForeignCall
 
 emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
   = do vols <- getVolatileRegs live
+       srt <- getSRTInfo
        emitForeignCall' safety results
-		(CmmForeignCall cmm_target cconv) call_args (Just vols)
+		(CmmForeignCall cmm_target cconv) call_args (Just vols) srt
   where
       (call_args, cmm_target)
 	= case target of
@@ -96,7 +98,7 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
 	-- ToDo: this might not be correct for 64-bit API
       arg_size rep = max (machRepByteWidth rep) wORD_SIZE
 
-emitForeignCall results (DNCall _) args live
+emitForeignCall _ (DNCall _) _ _
   = panic "emitForeignCall: DNCall"
 
 
@@ -107,13 +109,14 @@ emitForeignCall'
 	-> CmmCallTarget	-- the op
 	-> [(CmmExpr,MachHint)] -- arguments
 	-> Maybe [GlobalReg]	-- live vars, in case we need to save them
+        -> C_SRT                -- the SRT of the calls continuation
 	-> Code
-emitForeignCall' safety results target args vols 
+emitForeignCall' safety results target args vols srt
   | not (playSafe safety) = do
     temp_args <- load_args_into_temps args
     let (caller_save, caller_load) = callerSaveVolatileRegs vols
     stmtsC caller_save
-    stmtC (CmmCall target results temp_args)
+    stmtC (CmmCall target results temp_args srt)
     stmtsC caller_load
 
   | otherwise = do
@@ -126,15 +129,17 @@ emitForeignCall' safety results target args vols
     let (caller_save, caller_load) = callerSaveVolatileRegs vols
     emitSaveThreadState
     stmtsC caller_save
+    -- Using the same SRT for each of these is a little bit conservative
+    -- but it should work for now.
     stmtC (CmmCall (CmmForeignCall suspendThread CCallConv) 
 			[ (id,PtrHint) ]
 			[ (CmmReg (CmmGlobal BaseReg), PtrHint) ] 
-			)
-    stmtC (CmmCall temp_target results temp_args)
+			srt)
+    stmtC (CmmCall temp_target results temp_args srt)
     stmtC (CmmCall (CmmForeignCall resumeThread CCallConv) 
 			[ (new_base, PtrHint) ]
 			[ (CmmReg (CmmLocal id), PtrHint) ]
-			)
+			srt)
     -- Assign the result to BaseReg: we
     -- might now have a different Capability!
     stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs
index e457e4c944..caf68cd154 100644
--- a/compiler/codeGen/CgHpc.hs
+++ b/compiler/codeGen/CgHpc.hs
@@ -17,6 +17,7 @@ import CgUtils
 import CgMonad
 import CgForeignCall
 import ForeignCall
+import ClosureInfo
 import FastString
 import HscTypes
 import Char
@@ -70,6 +71,7 @@ initHpc this_mod (HpcInfo tickCount hashNo)
                , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,PtrHint)
                ]
                (Just [])
+               C_SRT -- No SRT b/c we PlayRisky
        }
   where
        mod_alloc = mkFastString "hs_hpc_module"
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index d3b54a2f65..4220b47210 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -10,7 +10,6 @@ module CgInfoTbls (
 	emitClosureCodeAndInfoTable,
 	emitInfoTableAndCode,
 	dataConTagZ,
-	getSRTInfo,
 	emitReturnTarget, emitAlgReturnTarget,
 	emitReturnInstr,
 	mkRetInfoTable,
@@ -187,12 +186,11 @@ mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry
 emitReturnTarget
    :: Name
    -> CgStmts			-- The direct-return code (if any)
-   -> SRT
    -> FCode CLabel
-emitReturnTarget name stmts srt
+emitReturnTarget name stmts
   = do	{ live_slots <- getLiveStackSlots
 	; liveness   <- buildContLiveness name live_slots
-	; srt_info   <- getSRTInfo name srt
+	; srt_info   <- getSRTInfo
 
 	; let
 	      cl_type | isBigLiveness liveness = rET_BIG
@@ -231,15 +229,14 @@ emitAlgReturnTarget
 	:: Name				-- Just for its unique
 	-> [(ConTagZ, CgStmts)]		-- Tagged branches
 	-> Maybe CgStmts		-- Default branch (if any)
-	-> SRT				-- Continuation's SRT
 	-> Int                          -- family size
 	-> FCode (CLabel, SemiTaggingStuff)
 
-emitAlgReturnTarget name branches mb_deflt srt fam_sz
+emitAlgReturnTarget name branches mb_deflt fam_sz
   = do  { blks <- getCgStmts $
 		    emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
 		-- NB: tag_expr is zero-based
-	; lbl <- emitReturnTarget name blks srt 
+	; lbl <- emitReturnTarget name blks
 	; return (lbl, Nothing) }
 		-- Nothing: the internal branches in the switch don't have
 		-- global labels, so we can't use them at the 'call site'
@@ -425,29 +422,6 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks
 --
 -------------------------------------------------------------------------
 
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT.  The label is passed down to
--- the nested bindings via the monad.
-
-getSRTInfo :: Name -> SRT -> FCode C_SRT
-getSRTInfo id NoSRT = return NoC_SRT
-getSRTInfo id (SRT off len bmp)
-  | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
-  = do	{ srt_lbl <- getSRTLabel
-	; let srt_desc_lbl = mkSRTDescLabel id
-	; emitRODataLits srt_desc_lbl
-		   ( cmmLabelOffW srt_lbl off
-		   : mkWordCLit (fromIntegral len)
-		   : map mkWordCLit bmp)
-	; return (C_SRT srt_desc_lbl 0 srt_escape) }
-
-  | otherwise 
-  = do	{ srt_lbl <- getSRTLabel
-	; return (C_SRT srt_lbl off (fromIntegral (head bmp))) }
-		-- The fromIntegral converts to StgHalfWord
-
-srt_escape = (-1) :: StgHalfWord
-
 srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
 srtLabelAndLength NoC_SRT _		
   = (zeroCLit, 0)
diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs
index 99705f6de6..3913a99ef0 100644
--- a/compiler/codeGen/CgLetNoEscape.lhs
+++ b/compiler/codeGen/CgLetNoEscape.lhs
@@ -136,7 +136,6 @@ cgLetNoEscapeClosure
 	:: Id			-- binder
 	-> CostCentreStack   	-- NB: *** NOT USED *** ToDo (WDP 94/06)
 	-> StgBinderInfo	-- NB: ditto
-	-> SRT
 	-> StgLiveVars		-- variables live in RHS, including the binders
 				-- themselves in the case of a recursive group
 	-> EndOfBlockInfo       -- where are we going to?
@@ -149,7 +148,7 @@ cgLetNoEscapeClosure
 -- ToDo: deal with the cost-centre issues
 
 cgLetNoEscapeClosure 
-	bndr cc binder_info srt full_live_in_rhss 
+	bndr cc binder_info full_live_in_rhss 
 	rhs_eob_info cc_slot rec args body
   = let
 	arity   = length args
@@ -168,7 +167,7 @@ cgLetNoEscapeClosure
 
 			-- Ignore the label that comes back from
 			-- mkRetDirectTarget.  It must be conjured up elswhere
-		    ; emitReturnTarget (idName bndr) abs_c srt
+		    ; emitReturnTarget (idName bndr) abs_c
 		    ; return () })
 
 	; returnFC (bndr, letNoEscapeIdInfo bndr vSp lf_info) }
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 61b358a6ba..ca08e06582 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -32,6 +32,7 @@ module CgMonad (
 	EndOfBlockInfo(..),
 	setEndOfBlockInfo, getEndOfBlockInfo,
 
+	setSRT, getSRT,
 	setSRTLabel, getSRTLabel, 
 	setTickyCtrLabel, getTickyCtrLabel,
 
@@ -65,6 +66,7 @@ import PackageConfig
 import Cmm
 import CmmUtils
 import CLabel
+import StgSyn (SRT)
 import SMRep
 import Module
 import Id
@@ -98,7 +100,8 @@ data CgInfoDownwards	-- information only passed *downwards* by the monad
 	cgd_dflags  :: DynFlags,
 	cgd_mod     :: Module,		-- Module being compiled
 	cgd_statics :: CgBindings,	-- [Id -> info] : static environment
-	cgd_srt     :: CLabel,		-- label of the current SRT
+	cgd_srt_lbl :: CLabel,		-- label of the current SRT
+        cgd_srt     :: SRT,		-- the current SRT
 	cgd_ticky   :: CLabel,		-- current destination for ticky counts
 	cgd_eob     :: EndOfBlockInfo	-- Info for stuff to do at end of basic block:
   }
@@ -108,6 +111,7 @@ initCgInfoDown dflags mod
   = MkCgInfoDown {	cgd_dflags  = dflags,
 			cgd_mod     = mod,
 			cgd_statics = emptyVarEnv,
+			cgd_srt_lbl = error "initC: srt_lbl",
 			cgd_srt     = error "initC: srt",
 			cgd_ticky   = mkTopTickyCtrLabel,
 			cgd_eob     = initEobInfo }
@@ -828,12 +832,21 @@ getEndOfBlockInfo = do
 
 getSRTLabel :: FCode CLabel	-- Used only by cgPanic
 getSRTLabel = do info  <- getInfoDown
-		 return (cgd_srt info)
+		 return (cgd_srt_lbl info)
 
 setSRTLabel :: CLabel -> FCode a -> FCode a
 setSRTLabel srt_lbl code
   = do  info <- getInfoDown
-	withInfoDown code (info { cgd_srt = srt_lbl})
+	withInfoDown code (info { cgd_srt_lbl = srt_lbl})
+
+getSRT :: FCode SRT
+getSRT = do info <- getInfoDown
+            return (cgd_srt info)
+
+setSRT :: SRT -> FCode a -> FCode a
+setSRT srt code
+  = do info <- getInfoDown
+       withInfoDown code (info { cgd_srt = srt})
 
 -- ----------------------------------------------------------------------------
 -- Get/set the current ticky counter label
diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs
index 17ecfa0856..01279b453d 100644
--- a/compiler/codeGen/CgPrimOp.hs
+++ b/compiler/codeGen/CgPrimOp.hs
@@ -13,6 +13,7 @@ module CgPrimOp (
 #include "HsVersions.h"
 
 import ForeignCall
+import ClosureInfo
 import StgSyn
 import CgForeignCall
 import CgBindery
@@ -122,6 +123,7 @@ emitPrimOp [res] ParOp [arg] live
     	(CmmForeignCall newspark CCallConv) 
 	[(CmmReg (CmmGlobal BaseReg), PtrHint), (arg,PtrHint)] 
 	(Just vols)
+        NoC_SRT -- No SRT b/c we do PlayRisky
   where
 	newspark = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("newSpark")))
 
@@ -138,6 +140,7 @@ emitPrimOp [] WriteMutVarOp [mutv,var] live
 			 CCallConv)
 		[(CmmReg (CmmGlobal BaseReg), PtrHint), (mutv,PtrHint)]
 		(Just vols)
+                NoC_SRT -- No SRT b/c we do PlayRisky
 
 --  #define sizzeofByteArrayzh(r,a) \
 --     r = (((StgArrWords *)(a))->words * sizeof(W_))
@@ -342,6 +345,7 @@ emitPrimOp [res] op args live
 	   (CmmPrim prim) 
 	   [(a,NoHint) | a<-args]  -- ToDo: hints?
 	   (Just vols)
+           NoC_SRT -- No SRT b/c we do PlayRisky
 
    | Just mop <- translateOp op
    = let stmt = CmmAssign (CmmLocal res) (CmmMachOp mop args) in
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a4d2338e52..26857d386c 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -29,7 +29,9 @@ module CgUtils (
 	mkWordCLit,
 	mkStringCLit, mkByteStringCLit,
 	packHalfWordsCLit,
-	blankWord
+	blankWord,
+
+	getSRTInfo
   ) where
 
 #include "HsVersions.h"
@@ -45,6 +47,8 @@ import CLabel
 import CmmUtils
 import MachOp
 import ForeignCall
+import ClosureInfo
+import StgSyn (SRT(..))
 import Literal
 import Digraph
 import ListSetOps
@@ -284,8 +288,9 @@ emitRtsCall'
    -> Maybe [GlobalReg]
    -> Code
 emitRtsCall' res fun args vols = do
+    srt <- getSRTInfo
     stmtsC caller_save
-    stmtC (CmmCall target res args)
+    stmtC (CmmCall target res args srt)
     stmtsC caller_load
   where
     (caller_save, caller_load) = callerSaveVolatileRegs vols
@@ -705,3 +710,38 @@ possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 
 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 possiblySameLoc l1 rep1 l2	   rep2 = True	-- Conservative
+
+-------------------------------------------------------------------------
+--
+--	Static Reference Tables
+--
+-------------------------------------------------------------------------
+
+-- There is just one SRT for each top level binding; all the nested
+-- bindings use sub-sections of this SRT.  The label is passed down to
+-- the nested bindings via the monad.
+
+getSRTInfo :: FCode C_SRT
+getSRTInfo = do
+  srt_lbl <- getSRTLabel
+  srt <- getSRT
+  case srt of
+    -- TODO: Should we panic in this case?
+    -- Someone obviously thinks there should be an SRT
+    NoSRT -> return NoC_SRT
+    SRT off len bmp
+      | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+      -> do id <- newUnique
+            let srt_desc_lbl = mkLargeSRTLabel id
+	    emitRODataLits srt_desc_lbl
+             ( cmmLabelOffW srt_lbl off
+	       : mkWordCLit (fromIntegral len)
+	       : map mkWordCLit bmp)
+	    return (C_SRT srt_desc_lbl 0 srt_escape)
+
+    SRT off len bmp
+      | otherwise 
+      -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+		-- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index 27aed3a70e..ad26b2ec7c 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -127,6 +127,10 @@ data C_SRT = NoC_SRT
 needsSRT :: C_SRT -> Bool
 needsSRT NoC_SRT       = False
 needsSRT (C_SRT _ _ _) = True
+
+instance Outputable C_SRT where
+  ppr (NoC_SRT) = ptext SLIT("_no_srt_")
+  ppr (C_SRT label off bitmap) = parens (ppr label <> comma <> ppr off <> comma <> text (show bitmap))
 \end{code}
 
 %************************************************************************
diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs
index 13e9c4a59c..4c7f570ff4 100644
--- a/compiler/codeGen/CodeGen.lhs
+++ b/compiler/codeGen/CodeGen.lhs
@@ -323,8 +323,9 @@ cgTopRhs bndr (StgRhsCon cc con args)
 
 cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body)
   = ASSERT(null fvs)    -- There should be no free variables
-    setSRTLabel (mkSRTLabel (idName bndr)) $ 
-    forkStatics (cgTopRhsClosure bndr cc bi srt upd_flag args body)
+    setSRTLabel (mkSRTLabel (idName bndr)) $
+    setSRT srt $
+    forkStatics (cgTopRhsClosure bndr cc bi upd_flag args body)
 \end{code}