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

25 files changed, 173 insertions, 119 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index f5d325b9f1..0918cc8cef 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -11,7 +11,6 @@ module CLabel (
 
 	mkClosureLabel,
 	mkSRTLabel,
-	mkSRTDescLabel,
 	mkInfoTableLabel,
 	mkEntryLabel,
 	mkSlowEntryLabel,
@@ -20,6 +19,7 @@ module CLabel (
 	mkRednCountsLabel,
 	mkConInfoTableLabel,
 	mkStaticInfoTableLabel,
+	mkLargeSRTLabel,
 	mkApEntryLabel,
 	mkApInfoTableLabel,
 	mkClosureTableLabel,
@@ -210,12 +210,14 @@ data CLabel
   | HpcTicksLabel Module       -- Per-module table of tick locations
   | HpcModuleNameLabel         -- Per-module name of the module for Hpc
 
+  | LargeSRTLabel           -- Label of an StgLargeSRT
+        {-# UNPACK #-} !Unique
+
   deriving (Eq, Ord)
 
 data IdLabelInfo
   = Closure		-- Label for closure
   | SRT                 -- Static reference table
-  | SRTDesc             -- Static reference table descriptor
   | InfoTable		-- Info tables for closures; always read-only
   | Entry		-- entry point
   | Slow		-- slow entry point
@@ -287,7 +289,6 @@ data DynamicLinkerLabelInfo
 
 -- These are always local:
 mkSRTLabel		name 	= IdLabel name  SRT
-mkSRTDescLabel		name 	= IdLabel name  SRTDesc
 mkSlowEntryLabel      	name 	= IdLabel name  Slow
 mkBitmapLabel   	name 	= IdLabel name  Bitmap
 mkRednCountsLabel     	name 	= IdLabel name  RednCounts
@@ -333,6 +334,7 @@ mkStaticConEntryLabel this_pkg name
   | isDllName this_pkg name = DynIdLabel    name StaticConEntry
   | otherwise             = IdLabel name StaticConEntry
 
+mkLargeSRTLabel	uniq 	= LargeSRTLabel uniq
 
 mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
 mkReturnInfoLabel uniq		= CaseLabel uniq CaseReturnInfo
@@ -467,7 +469,7 @@ needsCDecl :: CLabel -> Bool
   -- don't bother declaring SRT & Bitmap labels, we always make sure
   -- they are defined before use.
 needsCDecl (IdLabel _ SRT)		= False
-needsCDecl (IdLabel _ SRTDesc)		= False
+needsCDecl (LargeSRTLabel _)		= False
 needsCDecl (IdLabel _ Bitmap)		= False
 needsCDecl (IdLabel _ _)		= True
 needsCDecl (DynIdLabel _ _)		= True
@@ -697,6 +699,8 @@ pprCLbl (CaseLabel u (CaseAlt tag))
 pprCLbl (CaseLabel u CaseDefault)
   = hcat [pprUnique u, ptext SLIT("_dflt")]
 
+pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
+
 pprCLbl (RtsLabel (RtsCode str))   = ptext str
 pprCLbl (RtsLabel (RtsData str))   = ptext str
 pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
@@ -791,7 +795,6 @@ ppIdFlavor x = pp_cSEP <>
 	       (case x of
 		       Closure	    	-> ptext SLIT("closure")
 		       SRT		-> ptext SLIT("srt")
-		       SRTDesc		-> ptext SLIT("srtd")
 		       InfoTable    	-> ptext SLIT("info")
 		       Entry	    	-> ptext SLIT("entry")
 		       Slow	    	-> ptext SLIT("slow")
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index cae1633366..7ec5ad0796 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -28,6 +28,7 @@ module Cmm (
 import MachOp
 import CLabel
 import ForeignCall
+import ClosureInfo
 import Unique
 import UniqFM
 import FastString
@@ -116,6 +117,7 @@ data CmmStmt
      CmmCallTarget
      CmmHintFormals		 -- zero or more results
      CmmActuals			 -- zero or more arguments
+     C_SRT			 -- SRT for the continuation of the call
 
   | CmmBranch BlockId             -- branch to another BB in this fn
 
diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
index 1d07631755..60cb3e5ae7 100644
--- a/compiler/cmm/CmmBrokenBlock.hs
+++ b/compiler/cmm/CmmBrokenBlock.hs
@@ -12,6 +12,8 @@ module CmmBrokenBlock (
 import Cmm
 import CLabel
 
+import ClosureInfo
+
 import Maybes
 import Panic
 import Unique
@@ -50,6 +52,7 @@ data BlockEntryInfo
 
   | ContinuationEntry 		-- ^ Return point of a function call
       CmmFormals                -- ^ return values (argument to continuation)
+      C_SRT                     -- ^ SRT for the continuation's info table
 
   | ControlEntry		-- ^ Any other kind of block.
                                 -- Only entered due to control flow.
@@ -136,13 +139,13 @@ breakBlock uniques (BasicBlock ident stmts) entry =
                 block = do_call current_id entry accum_stmts exits next_id
                                 target results arguments
              -}
-            (CmmCall target results arguments:stmts) -> block : rest
+            (CmmCall target results arguments srt:stmts) -> block : rest
               where
                 next_id = BlockId $ head uniques
                 block = do_call current_id entry accum_stmts exits next_id
                                 target results arguments
                 rest = breakBlock' (tail uniques) next_id
-                                   (ContinuationEntry (map fst results)) [] [] stmts
+                                   (ContinuationEntry (map fst results) srt) [] [] stmts
             (s:stmts) ->
                 breakBlock' uniques current_id entry
                             (cond_branch_target s++exits)
@@ -171,7 +174,7 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
             FinalJump target arguments -> [CmmJump target arguments]
             FinalSwitch expr targets -> [CmmSwitch expr targets]
             FinalCall branch_target call_target results arguments ->
-                [CmmCall call_target results arguments,
+                [CmmCall call_target results arguments (panic "needed SRT from cmmBlockFromBrokenBlock"),
                  CmmBranch branch_target]
 
 -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 9a9f8a9fb2..42dfdced36 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -209,7 +209,7 @@ gatherBlocksIntoContinuation proc_points blocks start =
                  _ -> mkReturnPtLabel $ getUnique start
       params = case start_block_entry of
                  FunctionEntry _ args -> args
-                 ContinuationEntry args -> args
+                 ContinuationEntry args _ -> args
                  ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
 
 --------------------------------------------------------------------------------
@@ -256,7 +256,7 @@ continuationToProc formats (Continuation is_entry info label formals blocks) =
                        ControlEntry -> []
                        FunctionEntry _ formals -> -- TODO: gc_stack_check
                            function_entry formals curr_format
-                       ContinuationEntry formals ->
+                       ContinuationEntry formals _ ->
                            function_entry formals curr_format
             postfix = case exit of
                         FinalBranch next -> [CmmBranch next]
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 0812347c06..fd4a99cbe3 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -117,7 +117,7 @@ lintCmmStmt (CmmStore l r) = do
   lintCmmExpr l
   lintCmmExpr r
   return ()
-lintCmmStmt (CmmCall _target _res args) = mapM_ (lintCmmExpr.fst) args
+lintCmmStmt (CmmCall _target _res args _) = mapM_ (lintCmmExpr.fst) args
 lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> checkCond e >> return ()
 lintCmmStmt (CmmSwitch e _branches) = do
   erep <- lintCmmExpr e
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index 40d7b7c82e..bee3c65b07 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/cmm/CmmLive.hs
@@ -170,7 +170,7 @@ cmmStmtLive _ (CmmAssign reg expr) =
               (CmmGlobal _) -> id
 cmmStmtLive _ (CmmStore expr1 expr2) =
     cmmExprLive expr2 . cmmExprLive expr1
-cmmStmtLive _ (CmmCall target results arguments) =
+cmmStmtLive _ (CmmCall target results arguments _) =
     target_liveness .
     foldr ((.) . cmmExprLive) id (map fst arguments) .
     addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index aa0c821809..76ed78eb8d 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -140,7 +140,7 @@ lookForInline u expr (stmt:stmts)
 getStmtUses :: CmmStmt -> UniqFM Int
 getStmtUses (CmmAssign _ e) = getExprUses e
 getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
-getStmtUses (CmmCall target _ es)
+getStmtUses (CmmCall target _ es _)
    = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
    where uses (CmmForeignCall e _) = getExprUses e
 	 uses _ = emptyUFM
@@ -161,8 +161,8 @@ getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
-inlineStmt u a (CmmCall target regs es)
-   = CmmCall (infn target) regs es'
+inlineStmt u a (CmmCall target regs es srt)
+   = CmmCall (infn target) regs es' srt
    where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
 	 infn (CmmPrim p) = CmmPrim p
 	 es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 567dd606ad..dda1ca246b 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -267,10 +267,11 @@ stmt	:: { ExtCode }
 --		{ do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
 	| type '[' expr ']' '=' expr ';'
 		{ doStore $1 $3 $6 }
+-- TODO: add real SRT to parsed Cmm
 	| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
-		{% foreignCall $3 $1 $4 $6 $8 }
+		{% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
 	| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
-		{% primCall $1 $4 $6 $8 }
+		{% primCall $1 $4 $6 $8 NoC_SRT }
 	-- stmt-level macros, stealing syntax from ordinary C-- function calls.
 	-- Perhaps we ought to use the %%-form?
 	| NAME '(' exprs0 ')' ';'
@@ -818,8 +819,10 @@ foreignCall
 	-> [ExtFCode (CmmFormal,MachHint)]
 	-> ExtFCode CmmExpr
 	-> [ExtFCode (CmmExpr,MachHint)]
-	-> Maybe [GlobalReg] -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols
+	-> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+foreignCall conv_string results_code expr_code args_code vols srt
   = do  convention <- case conv_string of
           "C" -> return CCallConv
           "C--" -> return CmmCallConv
@@ -829,20 +832,22 @@ foreignCall conv_string results_code expr_code args_code vols
 	  expr <- expr_code
 	  args <- sequence args_code
           code (emitForeignCall' PlayRisky results 
-                 (CmmForeignCall expr convention) args vols) where
+                 (CmmForeignCall expr convention) args vols srt) where
 
 primCall
 	:: [ExtFCode (CmmFormal,MachHint)]
 	-> FastString
 	-> [ExtFCode (CmmExpr,MachHint)]
-	-> Maybe [GlobalReg] -> P ExtCode
-primCall results_code name args_code vols
+	-> Maybe [GlobalReg]
+        -> C_SRT
+        -> P ExtCode
+primCall results_code name args_code vols srt
   = case lookupUFM callishMachOps name of
 	Nothing -> fail ("unknown primitive " ++ unpackFS name)
 	Just p  -> return $ do
 		results <- sequence results_code
 		args <- sequence args_code
-        	code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
+        	code (emitForeignCall' PlayRisky results (CmmPrim p) args vols srt)
 
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 729f4242be..65b08166c5 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -47,7 +47,7 @@ calculateProcPoints blocks = calculateProcPoints' init_proc_points blocks
       always_proc_point BrokenBlock {
                               brokenBlockEntry = FunctionEntry _ _ } = True
       always_proc_point BrokenBlock {
-                              brokenBlockEntry = ContinuationEntry _ } = True
+                              brokenBlockEntry = ContinuationEntry _ _ } = True
       always_proc_point _ = False
 
 calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index bda191cb5f..817e82bfef 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -28,6 +28,7 @@ import Cmm
 import CLabel
 import MachOp
 import ForeignCall
+import ClosureInfo
 
 -- Utils
 import DynFlags
@@ -198,11 +199,11 @@ pprStmt stmt = case stmt of
 	where
 	  rep = cmmExprRep src
 
-    CmmCall (CmmForeignCall fn cconv) results args ->
+    CmmCall (CmmForeignCall fn cconv) results args srt ->
 	-- Controversial: leave this out for now.
 	-- pprUndef fn $$
 
-	pprCall ppr_fn cconv results args
+	pprCall ppr_fn cconv results args srt
 	where
     	ppr_fn = case fn of
 		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
@@ -219,8 +220,8 @@ pprStmt stmt = case stmt of
 	   ptext SLIT("#undef") <+> pprCLabel lbl
 	pprUndef _ = empty
 
-    CmmCall (CmmPrim op) results args ->
-	pprCall ppr_fn CCallConv results args
+    CmmCall (CmmPrim op) results args srt ->
+	pprCall ppr_fn CCallConv results args srt
 	where
     	ppr_fn = pprCallishMachOp_for_C op
 
@@ -718,10 +719,10 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
 -- -----------------------------------------------------------------------------
 -- Foreign Calls
 
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
 	-> SDoc
 
-pprCall ppr_fn cconv results args
+pprCall ppr_fn cconv results args _
   | not (is_cish cconv)
   = panic "pprCall: unknown calling convention"
 
@@ -839,7 +840,7 @@ te_Lit _ = return ()
 te_Stmt :: CmmStmt -> TE ()
 te_Stmt (CmmAssign r e)		= te_Reg r >> te_Expr e
 te_Stmt (CmmStore l r)		= te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es)	= mapM_ (te_temp.fst) rs >>
+te_Stmt (CmmCall _ rs es _)	= mapM_ (te_temp.fst) rs >>
 				  mapM_ (te_Expr.fst) es
 te_Stmt (CmmCondBranch e _)	= te_Expr e
 te_Stmt (CmmSwitch e _)		= te_Expr e
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index ee8f0f3040..3253915c21 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -150,20 +150,21 @@ pprStmt stmt = case stmt of
 
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
-    CmmCall (CmmForeignCall fn cconv) results args ->
+    CmmCall (CmmForeignCall fn cconv) results args srt ->
         hcat [ ptext SLIT("call"), space, 
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
                (if null results
                     then empty
-                    else brackets( commafy $ map ppr results)), semi ]
+                    else brackets( commafy $ map ppr results)),
+               brackets (ppr srt), semi ]
         where
             target (CmmLit lit) = pprLit lit
             target fn'          = parens (ppr fn')
 
-    CmmCall (CmmPrim op) results args ->
+    CmmCall (CmmPrim op) results args srt ->
         pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
-                        results args)
+                        results args srt)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 
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}
 
 
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 585ea8bf9f..b3ca8447b7 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -536,7 +536,7 @@ cmmStmtConFold stmt
            -> do addr' <- cmmExprConFold JumpReference addr
                  return $ CmmJump addr' regs
 
-	CmmCall target regs args
+	CmmCall target regs args srt
 	   -> do target' <- case target of
 			      CmmForeignCall e conv -> do
 			        e' <- cmmExprConFold CallReference e
@@ -545,7 +545,7 @@ cmmStmtConFold stmt
                  args' <- mapM (\(arg, hint) -> do
                                   arg' <- cmmExprConFold DataReference arg
                                   return (arg', hint)) args
-	         return $ CmmCall target' regs args'
+	         return $ CmmCall target' regs args' srt
 
         CmmCondBranch test dest
            -> do test' <- cmmExprConFold DataReference test
diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index 792bbcecfa..dc79d95ce5 100644
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -29,6 +29,7 @@ import PprCmm		( pprExpr )
 import Cmm
 import MachOp
 import CLabel
+import ClosureInfo	( C_SRT(..) )
 
 -- The rest:
 import StaticFlags	( opt_PIC )
@@ -119,7 +120,7 @@ stmtToInstrs stmt = case stmt of
       | otherwise	 -> assignMem_IntCode kind addr src
 	where kind = cmmExprRep src
 
-    CmmCall target result_regs args
+    CmmCall target result_regs args _
        -> genCCall target result_regs args
 
     CmmBranch id	  -> genBranch id
@@ -3181,13 +3182,13 @@ outOfLineFloatOp mop res args
         
       if localRegRep res == F64
         then
-          stmtToInstrs (CmmCall target [(res,FloatHint)] args)  
+          stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT)
         else do
           uq <- getUniqueNat
           let 
             tmp = LocalReg uq F64 KindNonPtr
           -- in
-          code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args)
+          code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT)
           code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
           return (code1 `appOL` code2)
   where