Implemented and fixed bugs in CmmInfo handling

compiler/cmm/CLabel.hs

@@ -521,6 +521,8 @@ externallyVisibleCLabel (CCS_Label _)	   = True
 externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)   = True
 externallyVisibleCLabel HpcModuleNameLabel      = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeSRTLabel _) = False
 
 -- -----------------------------------------------------------------------------
 -- Finding the "type" of a CLabel 
@@ -702,7 +704,11 @@ pprCLbl (CaseLabel u CaseDefault)
   = hcat [pprUnique u, ptext SLIT("_dflt")]
 
 pprCLbl (LargeSRTLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
-pprCLbl (LargeBitmapLabel u)  = pprUnique u <> pp_cSEP <> ptext SLIT("btm")
+pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext SLIT("btm")
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assmbly code.
+        
 
 pprCLbl (RtsLabel (RtsCode str))   = ptext str
 pprCLbl (RtsLabel (RtsData str))   = ptext str

compiler/cmm/Cmm.hs

@@ -9,9 +9,10 @@
 module Cmm ( 
 	GenCmm(..), Cmm, RawCmm,
 	GenCmmTop(..), CmmTop, RawCmmTop,
-	CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),
+	CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
 	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
 	CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
+        CmmSafety(..),
 	CmmCallTarget(..),
 	CmmStatic(..), Section(..),
 	CmmExpr(..), cmmExprRep, 
@@ -133,12 +134,14 @@ data ClosureTypeInfo
 -- TODO: These types may need refinement
 data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
 type ClosureTypeTag = StgHalfWord
-type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
+type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
 type ConstrTag = StgHalfWord
 type ConstrDescription = CmmLit
 type FunType = StgHalfWord
 type FunArity = StgHalfWord
-type SlowEntry = CLabel
+type SlowEntry = CmmLit
+  -- ^We would like this to be a CLabel but
+  -- for now the parser sets this to zero on an INFO_TABLE_FUN.
 type SelectorOffset = StgWord
 
 -----------------------------------------------------------------------------
@@ -161,7 +164,7 @@ data CmmStmt
      CmmCallTarget
      CmmHintFormals		 -- zero or more results
      CmmActuals			 -- zero or more arguments
-     C_SRT			 -- SRT for the continuation of the call
+     CmmSafety			 -- whether to build a continuation
 
   | CmmBranch BlockId             -- branch to another BB in this fn
 
@@ -184,6 +187,7 @@ type CmmActuals = [(CmmActual,MachHint)]
 type CmmFormal = LocalReg
 type CmmHintFormals = [(CmmFormal,MachHint)]
 type CmmFormals = [CmmFormal]
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT
 
 {-
 Discussion

compiler/cmm/CmmCPS.hs

@@ -70,9 +70,9 @@ cmmCPS dflags abstractC = do
   return continuationC
 
 stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
-make_gc_block block_id fun_label formals srt = BasicBlock block_id stmts
+make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
     where
-      stmts = [CmmCall stg_gc_gen_target [] [] srt,
+      stmts = [CmmCall stg_gc_gen_target [] [] safety,
                CmmJump fun_expr actuals]
       stg_gc_gen_target =
           CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
@@ -85,10 +85,10 @@ force_gc_block old_info block_id fun_label formals blocks =
       CmmInfo _ (Just _) _ _ -> (old_info, [])
       CmmNonInfo Nothing
           -> (CmmNonInfo (Just block_id),
-              [make_gc_block block_id fun_label formals NoC_SRT])
+              [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)])
       CmmInfo prof Nothing type_tag type_info
         -> (CmmInfo prof (Just block_id) type_tag type_info,
-            [make_gc_block block_id fun_label formals srt])
+            [make_gc_block block_id fun_label formals (CmmSafe srt)])
            where
              srt = case type_info of
                      ConstrInfo _ _ _ -> NoC_SRT
@@ -361,9 +361,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
       -- TODO prof: this is the same as the current implementation
       -- but I think it could be improved
       prof = ProfilingInfo zeroCLit zeroCLit
-      tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
-            then rET_BIG
-            else rET_SMALL
+      tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed
       format = maybe unknown_block id $ lookup label formats
       unknown_block = panic "unknown BlockId in applyStackFormat"
 

compiler/cmm/CmmInfo.hs

 module CmmInfo (
+  cmmToRawCmm,
   mkInfoTable
 ) where
 
@@ -6,30 +7,81 @@ module CmmInfo (
 
 import Cmm
 import CmmUtils
+import PprCmm
 
 import CLabel
+import MachOp
 
 import Bitmap
 import ClosureInfo
 import CgInfoTbls
 import CgCallConv
 import CgUtils
+import SMRep
 
 import Constants
 import StaticFlags
+import DynFlags
 import Unique
+import UniqSupply
 import Panic
 
 import Data.Bits
 
+cmmToRawCmm :: [Cmm] -> IO [RawCmm]
+cmmToRawCmm cmm = do
+  info_tbl_uniques <- mkSplitUniqSupply 'i'
+  return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
+    where
+      raw_cmm uniq_supply (Cmm procs) =
+          Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+--	<reversed variable part>
+--	<normal forward StgInfoTable, but without 
+--		an entry point at the front>
+--	<code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+--	<entry label>
+--	<normal forward rest of StgInfoTable>
+--	<forward variable part>
+--
+--	See includes/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+--			<srt slot>
+--			<standard info table>
+--  	ret-addr -->	<entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+--	ret-addr -->	<ptr to entry code>
+--			<standard info table>
+--			<srt slot>
+--
+--  * The SRT slot is only there if there is SRT info to record
+
 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
 mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
     case info of
+      -- | Code without an info table.  Easy.
       CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
+
+      -- | A function entry point.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
-              (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
-          mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
+              (FunInfo (ptrs, nptrs) srt fun_type fun_arity
+                       pap_bitmap slow_entry) ->
+          mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
+                             arguments blocks
           where
             fun_extra_bits =
                [packHalfWordsCLit fun_type fun_arity] ++
@@ -37,71 +89,74 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
                case pap_bitmap of
                  ArgGen liveness ->
                      [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
-                      makeRelativeRefTo info_label (CmmLabel slow_entry)]
+                      makeRelativeRefTo info_label slow_entry]
                  _ -> []
             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
             info_label = entryLblToInfoLbl entry_label
-            (srt_label, srt_bitmap) =
-                case srt of
-                  NoC_SRT -> ([], 0)
-                  (C_SRT lbl off bitmap) ->
-                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
-                       bitmap)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A constructor.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ConstrInfo (ptrs, nptrs) con_tag descr) ->
-          mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info [con_name] entry_label
+                             arguments blocks
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
             info_label = entryLblToInfoLbl entry_label
             con_name = makeRelativeRefTo info_label descr
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A thunk.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ThunkInfo (ptrs, nptrs) srt) ->
-          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info srt_label entry_label
+                             arguments blocks
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
             info_label = entryLblToInfoLbl entry_label
-            (srt_label, srt_bitmap) =
-                case srt of
-                  NoC_SRT -> ([], 0)
-                  (C_SRT lbl off bitmap) ->
-                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
-                       bitmap)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
             layout = packHalfWordsCLit ptrs nptrs
 
+      -- | A selector thunk.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
               (ThunkSelectorInfo offset srt) ->
-          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info srt_label entry_label
+                             arguments blocks
           where
             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
             info_label = entryLblToInfoLbl entry_label
-            (srt_label, srt_bitmap) =
-                case srt of
-                  NoC_SRT -> ([], 0)
-                  (C_SRT lbl off bitmap) ->
-                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
-                       bitmap)
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
+      -- A continuation/return-point.
       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
           liveness_data ++
-          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+          mkInfoTableAndCode info_label std_info srt_label entry_label
+                             arguments blocks
           where
-            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
+            std_info = mkStdInfoTable ty_prof cl_prof maybe_big_type_tag srt_bitmap
+                                      (makeRelativeRefTo info_label liveness_lit)
             info_label = entryLblToInfoLbl entry_label
-            (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
-            (srt_label, srt_bitmap) =
-                case srt of
-                  NoC_SRT -> ([], 0)
-                  (C_SRT lbl off bitmap) ->
-                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
-                       bitmap)
+            (liveness_lit, liveness_data, liveness_tag) =
+                mkLiveness uniq stack_layout
+            maybe_big_type_tag = if type_tag == rET_SMALL
+                                 then liveness_tag
+                                 else type_tag
+            (srt_label, srt_bitmap) = mkSRTLit info_label srt
 
+-- Handle the differences between tables-next-to-code
+-- and not tables-next-to-code
+mkInfoTableAndCode :: CLabel
+                   -> [CmmLit]
+                   -> [CmmLit]
+                   -> CLabel
+                   -> CmmFormals
+                   -> [CmmBasicBlock]
+                   -> [RawCmmTop]
 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
   | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
-  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
+  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
+             entry_lbl args blocks]
 
   | null blocks -- No actual code; only the info table is significant
   =		-- Use a zero place-holder in place of the 
@@ -113,27 +168,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
     [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
      CmmProc [] entry_lbl args blocks]
 
+mkSRTLit :: CLabel
+         -> C_SRT
+         -> ([CmmLit],    -- srt_label
+             StgHalfWord) -- srt_bitmap
+mkSRTLit info_label NoC_SRT = ([], 0)
+mkSRTLit info_label (C_SRT lbl off bitmap) =
+    ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
+
+-------------------------------------------------------------------------
+--
+--		Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+--	- pointer variables (bound in the environment)
+-- 	- non-pointer variables (bound in the environment)
+-- 	- free slots (recorded in the stack free list)
+-- 	- non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
 -- TODO: refactor to use utility functions
-mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
-mkLiveness uniq live
-  = if length live > mAX_SMALL_BITMAP_SIZE
-    then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
-    else (mkWordCLit small_liveness, []) -- fits in one word
+-- TODO: combine with CgCallConv.mkLiveness (see comment there)
+mkLiveness :: Unique
+           -> [Maybe LocalReg]
+           -> (CmmLit,           -- ^ The bitmap (literal value or label)
+               [RawCmmTop],      -- ^ Large bitmap CmmData if needed
+               ClosureTypeTag)   -- ^ rET_SMALL or rET_BIG
+mkLiveness uniq live =
+  if length bits > mAX_SMALL_BITMAP_SIZE
+    -- does not fit in one word
+    then (CmmLabel big_liveness, [data_lits], rET_BIG)
+    -- fits in one word
+    else (mkWordCLit small_liveness, [], rET_SMALL)
   where
-    size = length live
+    mkBits [] = []
+    mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
+        sizeW = case reg of
+                  Nothing -> 1
+                  Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE
+        bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
 
-    bits = mkBitmap (map is_non_ptr live)
     is_non_ptr Nothing = True
-    is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
-    is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
+    is_non_ptr (Just reg) =
+        case localRegGCFollow reg of
+          KindNonPtr -> True
+          KindPtr -> False
 
-    big_liveness = mkBitmapLabel uniq
-    data_lits = mkRODataLits big_liveness lits
-    lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
-  
-    small_liveness =
-        fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
-    small_bits = case bits of 
+    bits :: [Bool]
+    bits = mkBits live
+
+    bitmap :: Bitmap
+    bitmap = mkBitmap bits
+
+    small_bitmap = case bitmap of 
 		   []  -> 0
 		   [b] -> fromIntegral b
 		   _   -> panic "mkLiveness"
+    small_liveness =
+        fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
+
+    big_liveness = mkBitmapLabel uniq
+    lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
+    data_lits = mkRODataLits big_liveness lits
+
+-------------------------------------------------------------------------
+--
+--	Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table.  This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+   :: CmmLit		-- closure type descr (profiling)
+   -> CmmLit		-- closure descr (profiling)
+   -> StgHalfWord	-- closure type
+   -> StgHalfWord	-- SRT length
+   -> CmmLit		-- layout field
+   -> [CmmLit]
+
+mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
+ = 	-- Parallel revertible-black hole field
+    prof_info
+	-- Ticky info (none at present)
+	-- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where  
+    prof_info 
+	| opt_SccProfilingOn = [type_descr, closure_descr]
+	| otherwise	     = []
+
+    type_lit = packHalfWordsCLit cl_type srt_len

compiler/cmm/CmmParse.y

@@ -231,7 +231,9 @@ info	:: { ExtFCode (CLabel, CmmInfo) }
 		{ do prof <- profilingInfo $11 $13
 		     return (mkRtsInfoLabelFS $3,
 			CmmInfo prof Nothing (fromIntegral $9)
-				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
+				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
+				 (ArgSpec 0)
+				 zeroCLit)) }
 		-- we leave most of the fields zero here.  This is only used
 		-- to generate the BCO info table in the RTS at the moment.
 	
@@ -258,7 +260,7 @@ info	:: { ExtFCode (CLabel, CmmInfo) }
 			CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
 				(ContInfo [] NoC_SRT)) }
 
-	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
+	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
 		-- closure type, live regs
 		{ do live <- sequence (map (liftM Just) $7)
 		     return (mkRtsInfoLabelFS $3,
@@ -792,48 +794,6 @@ forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
   code (forkCgStmts stmts)
 
-retInfo name size live_bits cl_type = do
-  let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
-      info_lbl = mkRtsRetInfoLabelFS name
-      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
-				(fromIntegral cl_type)
-  return (info_lbl, info1, info2)
-
-stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
-  basicInfo name (packHalfWordsCLit ptrs nptrs) 
-	srt_bitmap cl_type desc_str ty_str
-
-conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
-  (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) 
-                	srt_bitmap cl_type desc_str ty_str
-  desc_lit <- code $ mkStringCLit desc_str
-  let desc_field = makeRelativeRefTo lbl desc_lit
-  return (lbl, info1, [desc_field])
-
-basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
-  let info_lbl = mkRtsInfoLabelFS name
-  lit1 <- if opt_SccProfilingOn 
-		   then code $ do lit <- mkStringCLit desc_str
-                                  return (makeRelativeRefTo info_lbl lit)
-		   else return (mkIntCLit 0)
-  lit2 <- if opt_SccProfilingOn 
-		   then code $ do lit <- mkStringCLit ty_str
-                                  return (makeRelativeRefTo info_lbl lit)
-		   else return (mkIntCLit 0)
-  let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
-			(fromIntegral srt_bitmap)
-			layout
-  return (info_lbl, info1, [])
-
-funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
-  (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
-			 cl_type desc_str ty_str 
-  let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
-		-- we leave most of the fields zero here.  This is only used
-		-- to generate the BCO info table in the RTS at the moment.
-  return (label,info1,info2)
- where
-   zero = mkIntCLit 0
 
 profilingInfo desc_str ty_str = do
   lit1 <- if opt_SccProfilingOn 
@@ -907,6 +867,7 @@ emitRetUT args = do
   emitStmts stmts
   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+  -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 
 -- -----------------------------------------------------------------------------
 -- If-then-else and boolean expressions

compiler/cmm/PprC.hs

@@ -199,11 +199,11 @@ pprStmt stmt = case stmt of
 	where
 	  rep = cmmExprRep src
 
-    CmmCall (CmmForeignCall fn cconv) results args srt ->
+    CmmCall (CmmForeignCall fn cconv) results args safety ->
 	-- Controversial: leave this out for now.
 	-- pprUndef fn $$
 
-	pprCall ppr_fn cconv results args srt
+	pprCall ppr_fn cconv results args safety
 	where
     	ppr_fn = case fn of
 		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
@@ -220,8 +220,8 @@ pprStmt stmt = case stmt of
 	   ptext SLIT("#undef") <+> pprCLabel lbl
 	pprUndef _ = empty
 
-    CmmCall (CmmPrim op) results args srt ->
-	pprCall ppr_fn CCallConv results args srt
+    CmmCall (CmmPrim op) results args safety ->
+	pprCall ppr_fn CCallConv results args safety
 	where
     	ppr_fn = pprCallishMachOp_for_C op
 
@@ -719,7 +719,7 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
 -- -----------------------------------------------------------------------------
 -- Foreign Calls
 
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
 	-> SDoc
 
 pprCall ppr_fn cconv results args _

compiler/cmm/PprCmm.hs

@@ -117,7 +117,10 @@ pprTop (CmmData section ds) =
     (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
     $$ rbrace
 
-
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+  ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
+  ppr (CmmSafe srt) = ppr srt
 
 -- --------------------------------------------------------------------------
 -- Info tables. The current pretty printer needs refinement
@@ -128,13 +131,15 @@ pprTop (CmmData section ds) =
 -- and were labelled with the procedure name ++ "_info".
 pprInfo (CmmNonInfo gc_target) =
     ptext SLIT("gc_target: ") <>
-          maybe (ptext SLIT("<none>")) pprBlockId gc_target
+          ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
+          -- ^ gc_target is currently unused and wired to a panic
 pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
                  gc_target tag info) =
     vcat [ptext SLIT("type: ") <> pprLit closure_type,
           ptext SLIT("desc: ") <> pprLit closure_desc,
           ptext SLIT("gc_target: ") <>
-                maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+                ptext SLIT("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+                -- ^ gc_target is currently unused and wired to a panic
           ptext SLIT("tag: ") <> integer (toInteger tag),
           pprTypeInfo info]
 
@@ -192,7 +197,7 @@ pprStmt stmt = case stmt of
 
     -- call "ccall" foo(x, y)[r1, r2];
     -- ToDo ppr volatile
-    CmmCall (CmmForeignCall fn cconv) results args srt ->
+    CmmCall (CmmForeignCall fn cconv) results args safety ->
         hcat [ if null results
                   then empty
                   else parens (commafy $ map ppr results) <>
@@ -200,14 +205,14 @@ pprStmt stmt = case stmt of
                ptext SLIT("call"), space, 
                doubleQuotes(ppr cconv), space,
                target fn, parens  ( commafy $ map ppr args ),
-               brackets (ppr srt), semi ]
+               brackets (ppr safety), semi ]
         where
             target (CmmLit lit) = pprLit lit
             target fn'          = parens (ppr fn')
 
-    CmmCall (CmmPrim op) results args srt ->
+    CmmCall (CmmPrim op) results args safety ->
         pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
-                        results args srt)
+                        results args safety)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 

compiler/codeGen/CgBindery.lhs

@@ -19,6 +19,7 @@ module CgBindery (
 	nukeVolatileBinds,
 	nukeDeadBindings,
 	getLiveStackSlots,
+        getLiveStackBindings,
 
 	bindArgsToStack,  rebindToStack,
 	bindNewToNode, bindNewToReg, bindArgsToRegs,
@@ -494,3 +495,14 @@ getLiveStackSlots
 				   cg_rep = rep } <- varEnvElts binds, 
 		        isFollowableArg rep] }
 \end{code}
+
+\begin{code}
+getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
+getLiveStackBindings
+  = do { binds <- getBinds
+       ; return [(off, bind) |
+                 bind <- varEnvElts binds,
+                 CgIdInfo { cg_stb = VirStkLoc off,
+                            cg_rep = rep} <- [bind],
+                 isFollowableArg rep] }
+\end{code}

compiler/codeGen/CgCallConv.hs

@@ -15,7 +15,7 @@ module CgCallConv (
 	mkArgDescr, argDescrType,
 
 	-- Liveness