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

11 files changed, 50 insertions, 35 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)