New codegen: do not split proc-points when using the NCG

Proc-point splitting is only required by backends that do not support
having proc-points within a code block (that is, everything except the
native backend, i.e. LLVM and C).

Not doing proc-point splitting saves some compilation time, and might
produce slightly better code in some cases.

29 files changed, 452 insertions, 316 deletions

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 315e582878..2dedee0d52 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -14,7 +14,7 @@ module Cmm (
      CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
    
      -- * Info Tables
-     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..),
+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
      ClosureTypeInfo(..), 
      C_SRT(..), needsSRT,
      ProfilingInfo(..), ConstrDescription, 
@@ -96,17 +96,23 @@ type CmmBwdRewrite f = BwdRewrite UniqSM CmmNode f
 --     Info Tables
 -----------------------------------------------------------------------------
 
-data CmmTopInfo   = TopInfo { info_tbl :: CmmInfoTable
+data CmmTopInfo   = TopInfo { info_tbls  :: BlockEnv CmmInfoTable
                             , stack_info :: CmmStackInfo }
 
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTable (CmmProc infos _ g) = mapLookup (g_entry g) (info_tbls infos)
+topInfoTable _                   = Nothing
+
 data CmmStackInfo
    = StackInfo {
        arg_space :: ByteOff,
                -- number of bytes of arguments on the stack on entry to the
                -- the proc.  This is filled in by StgCmm.codeGen, and used
                -- by the stack allocator later.
-       updfr_space :: Maybe ByteOff     -- XXX: comment?
-   }
+       updfr_space :: Maybe ByteOff
+               -- XXX: this never contains anything useful, but it should.
+               -- See comment in CmmLayoutStack.
+  }
 
 -- | Info table as a haskell data type
 data CmmInfoTable
@@ -116,7 +122,6 @@ data CmmInfoTable
       cit_prof :: ProfilingInfo,
       cit_srt  :: C_SRT
     }
-  | CmmNonInfoTable   -- Procedure doesn't need an info table
 
 data ProfilingInfo
   = NoProfilingInfo
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 285fe8fa33..a916db1b7d 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -50,21 +50,9 @@ import Control.Monad
 foldSet :: (a -> b -> b) -> b -> Set a -> b
 foldSet = Set.foldr
 
-----------------------------------------------------------------
--- Building InfoTables
-
-
 -----------------------------------------------------------------------
 -- SRTs
 
--- WE NEED AN EXAMPLE HERE.
--- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
--- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
--- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
--- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
--- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
--- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).
-
 {- EXAMPLE
 
 f = \x. ... g ...
@@ -100,7 +88,7 @@ h_closure with their contents:
    [ g_entry{c2_closure, c1_closure} ]
    [ h_entry{c2_closure} ]
 
-This is what mkTopCAFInfo is doing.
+This is what flattenCAFSets is doing.
 
 -}
 
@@ -179,8 +167,8 @@ srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
 -- we make sure they're all close enough to the bottom of the table that the
 -- bitmap will be able to cover all of them.
-buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
-buildSRTs topSRT cafs =
+buildSRT :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
+buildSRT topSRT cafs =
   do let
          -- For each label referring to a function f without a static closure,
          -- replace it with the CAFs that are reachable from f.
@@ -261,9 +249,9 @@ to_SRT top_srt off len bmp
 -- any CAF that is reachable from c.
 localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
 localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
-localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
-  case info_tbl top_info of
-    CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
+localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
+  case topInfoTable proc of
+    Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
       -> (cafs, Just (toClosureLbl top_l))
     _other -> (cafs, Nothing)
   where
@@ -304,16 +292,30 @@ flatten env cafset = foldSet (lookup env) Set.empty cafset
 bundle :: Map CLabel CAFSet
        -> (CAFEnv, CmmDecl)
        -> (CAFSet, Maybe CLabel)
-       -> (CAFSet, CmmDecl)
-bundle flatmap (_, decl) (cafs, Nothing)
-  = (flatten flatmap cafs, decl)
-bundle flatmap (_, decl) (_, Just l)
-  = (expectJust "bundle" $ Map.lookup l flatmap, decl)
+       -> (BlockEnv CAFSet, CmmDecl)
+bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
+  = ( mapMapWithKey get_cafs (info_tbls infos), decl )
+ where
+  entry = g_entry g
+
+  entry_cafs
+    | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
+    | otherwise        = flatten flatmap closure_cafs
+
+  get_cafs l _
+    | l == entry = entry_cafs
+    | otherwise  = if not (mapMember l env)
+                      then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
+                      else flatten flatmap $ expectJust "bundle" $ mapLookup l env
+
+bundle flatmap (_, decl) _
+  = ( mapEmpty, decl )
 
-flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
+
+flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
 flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
    where
-     zipped    = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
+     zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
      localCAFs = unzipWith localCAFInfo zipped
      flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
 
@@ -328,15 +330,35 @@ doSRTs topSRT tops
      let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
      return (topSRT', reverse gs' {- Note [reverse gs] -})
   where
-    setSRT (topSRT, rst) (cafs, decl@(CmmProc{})) = do
-       (topSRT, cafTable, srt) <- buildSRTs topSRT cafs
-       let decl' = updInfo (const srt) decl
-       case cafTable of
-         Just tbl -> return (topSRT, decl': tbl : rst)
-         Nothing  -> return (topSRT, decl' : rst)
+    setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
+       (topSRT, srt_tables, srt_env) <- buildSRTs topSRT caf_map
+       let decl' = updInfoSRTs srt_env decl
+       return (topSRT, decl': srt_tables ++ rst)
     setSRT (topSRT, rst) (_, decl) =
       return (topSRT, decl : rst)
 
+buildSRTs :: TopSRT -> BlockEnv CAFSet
+          -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
+buildSRTs top_srt caf_map
+  = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
+  where
+  doOne (top_srt, decls, srt_env) (l, cafs)
+    = do (top_srt, mb_decl, srt) <- buildSRT top_srt cafs
+         return ( top_srt, maybeToList mb_decl ++ decls
+                , mapInsert l srt srt_env )
+
+{-
+- In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
+- The one corresponding to g_entry is the closure info table, the
+  rest are continuations.
+- Each one needs an SRT.
+- We get the CAFSet for each one from the CAFEnv
+- flatten gives us
+    [(BlockEnv CAFSet, CmmDecl)]
+-
+-}
+
+
 {- Note [reverse gs]
 
    It is important to keep the code blocks in the same order,
@@ -345,12 +367,9 @@ doSRTs topSRT tops
    instructions for forward refs.  --SDM
 -}
 
-updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
-updInfo toSrt (CmmProc top_info top_l g) =
-  CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g
-updInfo _ t = t
-
-updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
-updInfoTbl toSrt info_tbl@(CmmInfoTable {})
-  = info_tbl { cit_srt = toSrt (cit_srt info_tbl) }
-updInfoTbl _ t@CmmNonInfoTable = t
+updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
+updInfoSRTs srt_env (CmmProc top_info top_l g) =
+  CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
+  where updInfoTbl l info_tbl
+             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
+updInfoSRTs _ t = t
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index f9fa68062e..f504f46575 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -25,14 +25,21 @@ import Prelude hiding (succ, unzip, zip)
 -----------------------------------------------------------------------------
 
 cmmCfgOpts :: CmmGraph -> CmmGraph
-cmmCfgOpts = removeUnreachableBlocks . blockConcat
+cmmCfgOpts g = removeUnreachableBlocks $ fst (blockConcat g)
 
 cmmCfgOptsProc :: CmmDecl -> CmmDecl
-cmmCfgOptsProc = optProc cmmCfgOpts
+cmmCfgOptsProc (CmmProc info lbl g) = CmmProc info' lbl (removeUnreachableBlocks g')
+    where (g', env) = blockConcat g
+          info' = info{ info_tbls = new_info_tbls }
+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))
 
-optProc :: (g -> g) -> GenCmmDecl d h g -> GenCmmDecl d h g
-optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
-optProc _   top                  = top
+          upd_info (k,info)
+             | Just k' <- mapLookup k env
+             = (k', info{ cit_lbl = infoTblLbl k' })
+             | otherwise
+             = (k,info)
+
+cmmCfgOptsProc top = top
 
 
 -----------------------------------------------------------------------------
@@ -41,7 +48,7 @@ optProc _   top                  = top
 --
 -----------------------------------------------------------------------------
 
--- This optimisation does two things:
+-- This optimisation does three things:
 --   - If a block finishes with an unconditional branch, then we may
 --     be able to concatenate the block it points to and remove the
 --     branch.  We do this either if the destination block is small
@@ -52,6 +59,10 @@ optProc _   top                  = top
 --     goto, then we can shortcut the destination, making the
 --     continuation block the destination of the goto.
 --
+--   - removes any unreachable blocks from the graph.  This is a side
+--     effect of starting with a postorder DFS traversal of the graph
+--
+
 -- Both transformations are improved by working from the end of the
 -- graph towards the beginning, because we may be able to perform many
 -- shortcuts in one go.
@@ -77,9 +88,9 @@ optProc _   top                  = top
 -- which labels we have renamed and apply the mapping at the end
 -- with replaceLabels.
 
-blockConcat  :: CmmGraph -> CmmGraph
+blockConcat  :: CmmGraph -> (CmmGraph, BlockEnv BlockId)
 blockConcat g@CmmGraph { g_entry = entry_id }
-  = replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
   where
      -- we might be able to shortcut the entry BlockId itself
      new_entry
@@ -90,9 +101,12 @@ blockConcat g@CmmGraph { g_entry = entry_id }
        = entry_id
 
      blocks = postorderDfs g
+     blockmap = foldr addBlock emptyBody blocks
+      -- the initial blockmap is constructed from the postorderDfs result,
+      -- so that we automatically throw away unreachable blocks.
 
      (new_blocks, shortcut_map) =
-           foldr maybe_concat (toBlockMap g, mapEmpty) blocks
+           foldr maybe_concat (blockmap, mapEmpty) blocks
 
      maybe_concat :: CmmBlock
                   -> (BlockEnv CmmBlock, BlockEnv BlockId)
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index 2fa8c6a13f..cd838821b3 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -19,7 +19,7 @@ import Outputable
 
 cmmOfZgraph :: CmmGroup -> Old.CmmGroup
 cmmOfZgraph tops = map mapTop tops
-  where mapTop (CmmProc h l g) = CmmProc (info_tbl h) l (ofZgraph g)
+  where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
         mapTop (CmmData s ds) = CmmData s ds
 
 data ValueDirection = Arguments | Results
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 3970f249d3..7bdaf5aaca 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -21,6 +21,7 @@ import SMRep
 import Bitmap
 import Stream (Stream)
 import qualified Stream
+import Hoopl
 
 import Maybes
 import Constants
@@ -90,17 +91,63 @@ mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
 mkInfoTable _ (CmmData sec dat) 
   = return [CmmData sec dat]
 
-mkInfoTable dflags (CmmProc info entry_label blocks)
-  | CmmNonInfoTable <- info   -- Code without an info table.  Easy.
-  = return [CmmProc Nothing entry_label blocks]
-                               
-  | CmmInfoTable { cit_lbl = info_lbl } <- info
-  = do { (top_decls, info_cts) <- mkInfoTableContents dflags info Nothing
-       ; return (top_decls  ++
-                 mkInfoTableAndCode info_lbl info_cts
-                                    entry_label blocks) }
-  | otherwise = panic "mkInfoTable"
-                  -- Patern match overlap check not clever enough
+mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
+  --
+  -- in the non-tables-next-to-code case, procs can have at most a
+  -- single info table associated with the entry label of the proc.
+  --
+  | not tablesNextToCode
+  = case topInfoTable proc of   --  must be at most one
+      -- no info table
+      Nothing ->
+         return [CmmProc mapEmpty entry_lbl blocks]
+
+      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
+        (top_decls, (std_info, extra_bits)) <-
+             mkInfoTableContents dflags info Nothing
+        let
+          rel_std_info   = map (makeRelativeRefTo info_lbl) std_info
+          rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
+        --
+        case blocks of
+          ListGraph [] ->
+              -- No code; only the info table is significant
+              -- Use a zero place-holder in place of the
+              -- entry-label in the info table
+              return (top_decls ++
+                      [mkRODataLits info_lbl (zeroCLit : rel_std_info ++
+                                                         rel_extra_bits)])
+          _nonempty ->
+             -- Separately emit info table (with the function entry
+             -- point as first entry) and the entry code
+             return (top_decls ++
+                     [CmmProc mapEmpty entry_lbl blocks,
+                      mkDataLits Data info_lbl
+                         (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+
+  --
+  -- With tables-next-to-code, we can have many info tables,
+  -- associated with some of the BlockIds of the proc.  For each info
+  -- table we need to turn it into CmmStatics, and collect any new
+  -- CmmDecls that arise from doing so.
+  --
+  | otherwise
+  = do
+    (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
+    return (concat top_declss ++
+            [CmmProc (mapFromList raw_infos) entry_lbl blocks])
+
+  where
+   do_one_info (lbl,itbl) = do
+     (top_decls, (std_info, extra_bits)) <-
+         mkInfoTableContents dflags itbl Nothing
+     let
+        info_lbl = cit_lbl itbl
+        rel_std_info   = map (makeRelativeRefTo info_lbl) std_info
+        rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
+     --
+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
+                              reverse rel_extra_bits ++ rel_std_info))
 
 -----------------------------------------------------
 type InfoTableContents = ( [CmmLit]	     -- The standard part
@@ -207,36 +254,6 @@ mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)
 --   * the code
 -- and lays them out in memory, producing a list of RawCmmDecl
 
--- The value of tablesNextToCode determines the relative positioning
--- of the extra bits and the standard info table, and whether the
--- former is reversed or not.  It also decides whether pointers in the
--- info table should be expressed as offsets relative to the info
--- pointer or not (see "Position Independent Code" below.
-
-mkInfoTableAndCode :: CLabel             -- Info table label
-                   -> InfoTableContents
-                   -> CLabel     	 -- Entry label
-                   -> ListGraph CmmStmt  -- Entry code
-                   -> [RawCmmDecl]
-mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
-  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
-  = [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
-                     reverse rel_extra_bits ++ rel_std_info)
-             entry_lbl blocks]
-
-  | ListGraph [] <- blocks -- No code; only the info table is significant
-  =		-- Use a zero place-holder in place of the 
-		-- entry-label in the info table
-    [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
-
-  | otherwise	-- Separately emit info table (with the function entry 
-  =		-- point as first entry) and the entry code 
-    [CmmProc Nothing entry_lbl blocks,
-     mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]
-  where
-    rel_std_info   = map (makeRelativeRefTo info_lbl) std_info
-    rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits
-
 -------------------------------------------------------------------------
 --
 --	Position independent code
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 7dc1210392..7fa0b4aa55 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -820,18 +820,17 @@ elimStackStores stackmap stackmaps area_off nodes
 
 
 setInfoTableStackMap :: BlockEnv StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap stackmaps
-    (CmmProc top_info@TopInfo{..} l g@CmmGraph{g_entry = eid})
-  = CmmProc top_info{ info_tbl = fix_info info_tbl } l g
+setInfoTableStackMap stackmaps (CmmProc top_info@TopInfo{..} l g)
+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l g
   where
-    fix_info info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
-       info_tbl { cit_rep = StackRep (get_liveness eid) }
-    fix_info other = other
+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
+       info_tbl { cit_rep = StackRep (get_liveness lbl) }
+    fix_info _ other = other
 
     get_liveness :: BlockId -> Liveness
     get_liveness lbl
       = case mapLookup lbl stackmaps of
-          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl)
+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
           Just sm -> stackMapToLiveness sm
 
 setInfoTableStackMap _ d = d
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 8ff04cfa7b..2e3da5ca98 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -22,6 +22,7 @@ import CmmNode (wrapRecExp)
 import CmmUtils
 import DynFlags
 import StaticFlags
+import CLabel
 
 import UniqFM
 import Unique
@@ -667,11 +668,12 @@ exactLog2 x_
 -}
 
 cmmLoopifyForC :: RawCmmDecl -> RawCmmDecl
-cmmLoopifyForC p@(CmmProc Nothing _ _) = p  -- only if there's an info table, ignore case alts
-cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
+-- XXX: revisit if we actually want to do this
+-- cmmLoopifyForC p@(CmmProc Nothing _ _) = p  -- only if there's an info table, ignore case alts
+cmmLoopifyForC (CmmProc infos entry_lbl
                  (ListGraph blocks@(BasicBlock top_id _ : _))) =
 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
-  CmmProc (Just info) entry_lbl (ListGraph blocks')
+  CmmProc infos entry_lbl (ListGraph blocks')
   where blocks' = [ BasicBlock id (map do_stmt stmts)
                   | BasicBlock id stmts <- blocks ]
 
@@ -679,7 +681,7 @@ cmmLoopifyForC (CmmProc (Just info@(Statics info_lbl _)) entry_lbl
                 = CmmBranch top_id
         do_stmt stmt = stmt
 
-        jump_lbl | tablesNextToCode = info_lbl
+        jump_lbl | tablesNextToCode = toInfoLbl entry_lbl
                  | otherwise        = entry_lbl
 
 cmmLoopifyForC top = top
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 0d1c788113..f14aa9c987 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -255,7 +255,7 @@ cmmproc :: { ExtCode }
                                         $4;
                                         return formals }
 			blks <- code (cgStmtsToBlocks stmts)
-                        code (emitProc CmmNonInfoTable (mkCmmCodeLabel pkg $1) formals blks) }
+                        code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
 
 info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 9aac09f29f..211e8ccc9e 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -10,6 +10,7 @@ module CmmPipeline (
 ) where
 
 import Cmm
+import CmmUtils
 import CmmLint
 import CmmBuildInfoTables
 import CmmCommonBlockElim
@@ -25,6 +26,7 @@ import ErrUtils
 import HscTypes
 import Control.Monad
 import Outputable
+import StaticFlags
 
 -----------------------------------------------------------------------------
 -- | Top level driver for C-- pipeline
@@ -65,57 +67,84 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        -- elimCommonBlocks
 
        ----------- Proc points -------------------
-       let callPPs = {-# SCC "callProcPoints" #-} callProcPoints g
-       procPoints <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
-                     minimalProcPointSet (targetPlatform dflags) callPPs g
+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+       proc_points <-
+          if splitting_proc_points
+             then {-# SCC "minimalProcPointSet" #-} runUniqSM $
+                  minimalProcPointSet (targetPlatform dflags) call_pps g
+             else
+                  return call_pps
+
+       let noncall_pps = proc_points `setDifference` call_pps
+       when (not (setNull noncall_pps)) $
+         pprTrace "Non-call proc points: " (ppr noncall_pps) $ return ()
 
        ----------- Layout the stack and manifest Sp ---------------
        -- (also does: removeDeadAssignments, and lowerSafeForeignCalls)
        (g, stackmaps) <- {-# SCC "layoutStack" #-}
-                         runUniqSM $ cmmLayoutStack dflags procPoints entry_off g
+                         runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
        dump Opt_D_dump_cmmz_sp "Layout Stack" g
 
-       g <- if optLevel dflags >= 99
+       ----------- Sink and inline assignments -------------------
+       g <- if dopt Opt_CmmSink dflags
                then do g <- {-# SCC "sink" #-} return (cmmSink g)
                        dump Opt_D_dump_cmmz_rewrite "Sink assignments" g
-                       g <- {-# SCC "inline" #-} return (cmmPeepholeInline g)
-                       dump Opt_D_dump_cmmz_rewrite "Peephole inline" g
                        return g
                else return g
 
---       ----------- Sink and inline assignments -------------------
---       g <- {-# SCC "rewriteAssignments" #-} runOptimization $
---            rewriteAssignments platform g
---       dump Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g
-
-       ------------- Split into separate procedures ------------
-       procPointMap  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
-                        procPointAnalysis procPoints g
-       dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" procPointMap
-       gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
-             splitAtProcPoints l callPPs procPoints procPointMap (CmmProc h l g)
-       dumps Opt_D_dump_cmmz_split "Post splitting" gs
-
        ------------- CAF analysis ------------------------------
        let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
 
-       ------------- Populate info tables with stack info ------
-       gs <- {-# SCC "setInfoTableStackMap" #-}
-             return $ map (setInfoTableStackMap stackmaps) gs
-       dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
-
-       ----------- Control-flow optimisations -----------------
-       gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
-       dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
-
-       return (cafEnv, gs)
+       if splitting_proc_points
+          then do
+            ------------- Split into separate procedures ------------
+            pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
+                             procPointAnalysis proc_points g
+            dumpWith dflags Opt_D_dump_cmmz_procmap "procpoint map" pp_map
+            gs <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
+                  splitAtProcPoints l call_pps proc_points pp_map (CmmProc h l g)
+            dumps Opt_D_dump_cmmz_split "Post splitting" gs
+     
+            ------------- Populate info tables with stack info ------
+            gs <- {-# SCC "setInfoTableStackMap" #-}
+                  return $ map (setInfoTableStackMap stackmaps) gs
+            dumps Opt_D_dump_cmmz_info "after setInfoTableStackMap" gs
+     
+            ----------- Control-flow optimisations ---------------
+            gs <- {-# SCC "cmmCfgOpts(2)" #-} return $ map cmmCfgOptsProc gs
+            dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
+
+            return (cafEnv, gs)
+
+          else do
+            -- attach info tables to return points
+            g <- return $ attachContInfoTables call_pps (CmmProc h l g)
+
+            ------------- Populate info tables with stack info ------
+            g <- {-# SCC "setInfoTableStackMap" #-}
+                  return $ setInfoTableStackMap stackmaps g
+            dump' Opt_D_dump_cmmz_info "after setInfoTableStackMap" g
+     
+            ----------- Control-flow optimisations ---------------
+            g <- {-# SCC "cmmCfgOpts(2)" #-} return $ cmmCfgOptsProc g
+            dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
+
+            return (cafEnv, [g])
 
   where dflags = hsc_dflags hsc_env
         dump = dumpGraph dflags
+        dump' = dumpWith dflags
 
         dumps flag name
            = mapM_ (dumpWith dflags flag name)
 
+        -- we don't need to split proc points for the NCG, unless
+        -- tablesNextToCode is off.  The latter is because we have no
+        -- label to put on info tables for basic blocks that are not
+        -- the entry point.
+        splitting_proc_points = hscTarget dflags /= HscAsm
+                             || not tablesNextToCode
+
 runUniqSM :: UniqSM a -> IO a
 runUniqSM m = do
   us <- mkSplitUniqSupply 'u'
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index ebe40d9c9e..58f2e54ffa 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -5,6 +5,7 @@ module CmmProcPoint
     ( ProcPointSet, Status(..)
     , callProcPoints, minimalProcPointSet
     , splitAtProcPoints, procPointAnalysis
+    , attachContInfoTables
     )
 where
 
@@ -209,7 +210,7 @@ extendPPSet platform g blocks procPoints =
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      CmmDecl -> UniqSM [CmmDecl]
 splitAtProcPoints entry_label callPPs procPoints procMap
-                  (CmmProc (TopInfo {info_tbl=info_tbl})
+                  (CmmProc (TopInfo {info_tbls = info_tbls})
                            top_l g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
      let addBlock b graphEnv =
@@ -234,10 +235,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      --    the proc point is a callPP)
      -- Due to common blockification, we may overestimate the set of procpoints.
      let add_label map pp = Map.insert pp lbls map
-           where lbls | pp == entry = (entry_label, Just entry_info_lbl)
+           where lbls | pp == entry = (entry_label, Just (toInfoLbl entry_label))
                       | otherwise   = (blockLbl pp, guard (setMember pp callPPs) >> 
                                                     Just (infoTblLbl pp))
-                 entry_info_lbl = cit_lbl info_tbl
          procLabels = foldl add_label Map.empty
                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
      -- In each new graph, add blocks jumping off to the new procedures,
@@ -278,13 +278,13 @@ splitAtProcPoints entry_label callPPs procPoints procMap
      let to_proc (bid, g) = case expectJust "pp label" $ Map.lookup bid procLabels of
              (lbl, Just info_lbl)
                | bid == entry
-               -> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
+               -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
                           top_l (replacePPIds g)
                | otherwise
-               -> CmmProc (TopInfo {info_tbl=mkEmptyContInfoTable info_lbl, stack_info=stack_info})
+               -> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info})
                           lbl (replacePPIds g)
              (lbl, Nothing)
-               -> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
+               -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
                           lbl (replacePPIds g)
             where
              stack_info = StackInfo 0 Nothing -- panic "No StackInfo"
@@ -335,6 +335,20 @@ replaceBranches env cmmg
             -- until the lookup returns Nothing, at which point we
             -- return the last BlockId
 
+-- --------------------------------------------------------------
+-- Not splitting proc points: add info tables for continuations
+
+attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl
+attachContInfoTables call_proc_points (CmmProc top_info top_l g)
+ = CmmProc top_info{info_tbls = info_tbls'} top_l g
+ where
+   info_tbls' = mapUnion (info_tbls top_info) $
+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))
+                            | l <- setElems call_proc_points
+                            , l /= g_entry g ]
+attachContInfoTables _ other_decl
+ = other_decl
+
 ----------------------------------------------------------------
 
 {-
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index aa83afbf8d..05aa5fb811 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -9,7 +9,7 @@
 module OldCmm (
         CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
         ListGraph(..),
-        CmmInfoTable(..), ClosureTypeInfo(..),
+        CmmInfoTable(..), ClosureTypeInfo(..), topInfoTable,
         CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
 
         cmmMapGraph, cmmTopMapGraph,
@@ -64,16 +64,18 @@ import ForeignCall
 -- across a whole compilation unit.
 newtype ListGraph i = ListGraph [GenBasicBlock i]
 
+type CmmInfoTables = BlockEnv CmmInfoTable
+
 -- | Cmm with the info table as a data type
-type CmmGroup = GenCmmGroup CmmStatics CmmInfoTable (ListGraph CmmStmt)
-type CmmDecl = GenCmmDecl CmmStatics CmmInfoTable (ListGraph CmmStmt)
+type CmmGroup = GenCmmGroup CmmStatics CmmInfoTables (ListGraph CmmStmt)
+type CmmDecl = GenCmmDecl CmmStatics CmmInfoTables (ListGraph CmmStmt)
 
 -- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
 -- table label. If we are building without tables-next-to-code there will be no statics
 --
 -- INVARIANT: if there is an info table, it has at least one CmmStatic
-type RawCmmGroup = GenCmmGroup CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt)
-type RawCmmDecl = GenCmmDecl CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt)
+type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt)
+type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt)
 
 
 -- A basic block containing a single label, at the beginning.
@@ -99,6 +101,14 @@ blockStmts (BasicBlock _ stmts) = stmts
 mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
 mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
 
+-- | Returns the info table associated with the CmmDecl's entry point,
+-- if any.
+topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
+topInfoTable (CmmProc infos _ (ListGraph (b:_)))
+  = mapLookup (blockId b) infos
+topInfoTable _
+  = Nothing
+
 ----------------------------------------------------------------
 --   graph maps
 ----------------------------------------------------------------
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index b9e36782d4..dd71ac655e 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -82,8 +82,8 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
 -- top level procs
 --
 pprTop :: RawCmmDecl -> SDoc
-pprTop (CmmProc mb_info clbl (ListGraph blocks)) =
-    (case mb_info of
+pprTop proc@(CmmProc _ clbl (ListGraph blocks)) =
+    (case topInfoTable proc of
        Nothing -> empty
        Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                             pprWordArray info_clbl info_dat) $$
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 132f291540..58866979f8 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -100,7 +100,7 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
   ptext (sLit "updfr_space: ") <> ppr updfr_space
 
 pprTopInfo :: CmmTopInfo -> SDoc
-pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
   vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
         ptext (sLit "stack_info: ") <> ppr stack_info]
 
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 85caebd353..ab320b4100 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -114,8 +114,6 @@ pprTop (CmmData section ds) =
 -- Info tables.
 
 pprInfoTable :: CmmInfoTable -> SDoc
-pprInfoTable CmmNonInfoTable
-  = empty
 pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
                            , cit_prof = prof_info
                            , cit_srt = _srt })
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 80b3b06ce3..133d78d371 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -366,5 +366,5 @@ emitInfoTableAndCode
 	-> Code
 
 emitInfoTableAndCode entry_ret_lbl info args blocks
-  = emitProc info entry_ret_lbl args blocks
+  = emitProc (Just info) entry_ret_lbl args blocks
 
diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs
index 71da9e9ae0..f776af3b3b 100644
--- a/compiler/codeGen/CgMonad.lhs
+++ b/compiler/codeGen/CgMonad.lhs
@@ -709,11 +709,16 @@ emitDecl decl = do
     state <- getState
     setState $ state { cgs_tops = cgs_tops state `snocOL` decl }
 
-emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
-emitProc info lbl [] blocks = do
-    let proc_block = CmmProc info lbl (ListGraph blocks)
+emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code
+emitProc mb_info lbl [] blocks = do
+    let proc_block = CmmProc infos lbl (ListGraph blocks)
     state <- getState
     setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block }
+  where
+    infos = case (blocks,mb_info) of
+                (b:_, Just info) -> mapSingleton (blockId b) info
+                _other           -> mapEmpty
+
 emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
 
 -- Emit a procedure whose body is the specified code; no info table
@@ -721,7 +726,7 @@ emitSimpleProc :: CLabel -> Code -> Code
 emitSimpleProc lbl code = do
     stmts <- getCgStmts code
     blks <- cgStmtsToBlocks stmts
-    emitProc CmmNonInfoTable lbl [] blks
+    emitProc Nothing lbl [] blks
 
 -- Get all the CmmTops (there should be no stmts)
 -- Return a single Cmm which may be split from other Cmms by
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 2bec4208a1..55307216c3 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -470,7 +470,7 @@ mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
            jump = mkDirectJump (mkLblExpr fast_lbl)
                                (map (CmmReg . CmmLocal) arg_regs)
                                initUpdFrameOff
-       emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
+       emitProcWithConvention Slow Nothing slow_lbl arg_regs jump
   | otherwise = return ()
 
 -----------------------------------------
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 73b3d1639e..7a9c8414ee 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -934,5 +934,3 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
   | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
-staticClosureNeedsLink _ _ = False
-
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 0e9cebfea4..5bcb67f82b 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -542,7 +542,7 @@ emitClosureAndInfoTable ::
 emitClosureAndInfoTable info_tbl conv args body
   = do { blks <- getCode body
        ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)
-       ; emitProcWithConvention conv info_tbl entry_lbl args blks
+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks
        }
 
 -----------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 602bdebcad..d1732ed2b7 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -66,6 +66,7 @@ module StgCmmMonad (
 import Cmm
 import StgCmmClosure
 import DynFlags
+import Hoopl
 import MkGraph
 import BlockId
 import CLabel
@@ -639,23 +640,30 @@ emitDecl decl
 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
 
-emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] ->
-                          CmmAGraph -> FCode ()
-emitProcWithConvention conv info lbl args blocks
+emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
+                       -> [CmmFormal] -> CmmAGraph -> FCode ()
+emitProcWithConvention conv mb_info lbl args blocks
   = do  { us <- newUniqSupply
         ; let (offset, entry) = mkCallEntry conv args
               blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
         ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
-              proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks
+              tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
+              proc_block = CmmProc tinfo lbl blks
+
+              infos | Just info <- mb_info
+                    = mapSingleton (g_entry blks) info
+                    | otherwise
+                    = mapEmpty
+
         ; state <- getState
         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
-emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
+emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
 emitProc = emitProcWithConvention NativeNodeCall
 
 emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
 emitSimpleProc lbl code = 
-  emitProc CmmNonInfoTable lbl [] code
+  emitProc Nothing lbl [] code
 
 getCmm :: FCode () -> FCode CmmGroup
 -- Get all the CmmTops (there should be no stmts)
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 5c2e420545..a4c48058bb 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -41,8 +41,8 @@ llvmCodeGen dflags h us cmms
         (cdata,env) = {-# SCC "llvm_split" #-}
                       foldr split ([], initLlvmEnv dflags) cmm
         split (CmmData s d' ) (d,e) = ((s,d'):d,e)
-        split (CmmProc i l _) (d,e) =
-            let lbl = strCLabel_llvm env $ case i of
+        split p@(CmmProc _ l _) (d,e) =
+            let lbl = strCLabel_llvm env $ case topInfoTable p of
                         Nothing                   -> l
                         Just (Statics info_lbl _) -> info_lbl
                 env' = funInsert lbl llvmFunTy e
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 79a0c00543..2a2104dac1 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -37,9 +37,10 @@ type LlvmStatements = OrdList LlvmStatement
 -- | Top-level of the LLVM proc Code generator
 --
 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do
+genLlvmProc env proc0@(CmmProc _ lbl (ListGraph blocks)) = do
     (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
-    let proc = CmmProc info lbl (ListGraph lmblocks)
+    let info = topInfoTable proc0
+        proc = CmmProc info lbl (ListGraph lmblocks)
     return (env', proc:lmdata)
 
 genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 787f067182..a351746948 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -279,6 +279,7 @@ data DynFlag
    | Opt_LlvmTBAA                       -- Use LLVM TBAA infastructure for improving AA (hidden flag)
    | Opt_RegLiveness                    -- Use the STG Reg liveness information (hidden flag)
    | Opt_IrrefutableTuples
+   | Opt_CmmSink
 
    -- Interface files
    | Opt_IgnoreInterfacePragmas
@@ -2039,6 +2040,7 @@ fFlags = [
   ( "llvm-tbaa",                        Opt_LlvmTBAA, nop), -- hidden flag
   ( "regs-liveness",                    Opt_RegLiveness, nop), -- hidden flag
   ( "irrefutable-tuples",               Opt_IrrefutableTuples, nop ),
+  ( "cmm-sink",                         Opt_CmmSink, nop ),
   ( "gen-manifest",                     Opt_GenManifest, nop ),
   ( "embed-manifest",                   Opt_EmbedManifest, nop ),
   ( "ext-core",                         Opt_EmitExternalCore, nop ),
@@ -2311,6 +2313,7 @@ optLevelFlags
     , ([2],     Opt_RegsGraph)
     , ([0,1,2], Opt_LlvmTBAA)
     , ([0,1,2], Opt_RegLiveness)
+    , ([1,2],   Opt_CmmSink)
 
 --     , ([2],     Opt_StaticArgumentTransformation)
 -- Max writes: I think it's probably best not to enable SAT with -O2 for the
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 7c314ae84b..656af96b0e 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -56,7 +56,6 @@ import OldPprCmm
 import CLabel
 
 import UniqFM
-import Unique           ( Unique, getUnique )
 import UniqSupply
 import DynFlags
 import Util
@@ -270,7 +269,7 @@ nativeCodeGen' dflags ncgImpl h us cmms
                 | dopt Opt_SplitObjs dflags = split_marker : tops
                 | otherwise                 = tops
 
-        split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph [])
+        split_marker = CmmProc mapEmpty mkSplitMarkerLabel (ListGraph [])
 
 
 cmmNativeGenStream :: (Outputable statics, Outputable instr, Instruction instr)
@@ -599,7 +598,7 @@ sequenceTop
 
 sequenceTop _       top@(CmmData _ _) = top
 sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
-  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks)
+  CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks info blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -613,12 +612,13 @@ sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) =
 
 sequenceBlocks
         :: Instruction instr
-        => [NatBasicBlock instr]
+        => BlockEnv i
+        -> [NatBasicBlock instr]
         -> [NatBasicBlock instr]
 
-sequenceBlocks [] = []
-sequenceBlocks (entry:blocks) =
-  seqBlocks (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
+sequenceBlocks _ [] = []
+sequenceBlocks infos (entry:blocks) =
+  seqBlocks infos (mkNode entry : reverse (flattenSCCs (sccBlocks blocks)))
   -- the first block is the entry point ==> it must remain at the start.
 
 
@@ -626,8 +626,8 @@ sccBlocks
         :: Instruction instr
         => [NatBasicBlock instr]
         -> [SCC ( NatBasicBlock instr
-                , Unique
-                , [Unique])]
+                , BlockId
+                , [BlockId])]
 
 sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 
@@ -635,30 +635,32 @@ sccBlocks blocks = stronglyConnCompFromEdgedVerticesR (map mkNode blocks)
 -- the block, and only if it has a single destination.
 getOutEdges
         :: Instruction instr
-        => [instr] -> [Unique]
+        => [instr] -> [BlockId]
 
 getOutEdges instrs
         = case jumpDestsOfInstr (last instrs) of
-                [one] -> [getUnique one]
+                [one] -> [one]
                 _many -> []
 
 mkNode :: (Instruction t)
        => GenBasicBlock t
-       -> (GenBasicBlock t, Unique, [Unique])
-mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs)
-
-seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1]
-seqBlocks [] = []
-seqBlocks ((block,_,[]) : rest)
-  = block : seqBlocks rest
-seqBlocks ((block@(BasicBlock id instrs),_,[next]) : rest)
-  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks rest'
-  | otherwise       = block : seqBlocks rest'
+       -> (GenBasicBlock t, BlockId, [BlockId])
+mkNode block@(BasicBlock id instrs) = (block, id, getOutEdges instrs)
+
+seqBlocks :: BlockEnv i -> [(GenBasicBlock t1, BlockId, [BlockId])]
+                        -> [GenBasicBlock t1]
+seqBlocks _ [] = []
+seqBlocks infos ((block,_,[]) : rest)
+  = block : seqBlocks infos rest
+seqBlocks infos ((block@(BasicBlock id instrs),_,[next]) : rest)
+  | can_fallthrough = BasicBlock id (init instrs) : seqBlocks infos rest'
+  | otherwise       = block : seqBlocks infos rest'
   where
-        (can_fallthrough, rest') = reorder next [] rest
+        can_fallthrough = not (mapMember next infos) && can_reorder
+        (can_reorder, rest') = reorder next [] rest
           -- TODO: we should do a better job for cycles; try to maximise the
           -- fallthroughs within a loop.
-seqBlocks _ = panic "AsmCodegen:seqBlocks"
+seqBlocks _ _ = panic "AsmCodegen:seqBlocks"
 
 reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)])
 reorder  _ accum [] = (False, reverse accum)
@@ -733,8 +735,8 @@ shortcutBranches dflags ncgImpl tops
     mapping = foldr plusUFM emptyUFM mappings
 
 build_mapping :: NcgImpl statics instr jumpDest
-              -> GenCmmDecl d t (ListGraph instr)
-              -> (GenCmmDecl d t (ListGraph instr), UniqFM jumpDest)
+              -> GenCmmDecl d (BlockEnv t) (ListGraph instr)
+              -> (GenCmmDecl d (BlockEnv t) (ListGraph instr), UniqFM jumpDest)
 build_mapping _ top@(CmmData _ _) = (top, emptyUFM)
 build_mapping _ (CmmProc info lbl (ListGraph []))
   = (CmmProc info lbl (ListGraph []), emptyUFM)
@@ -750,13 +752,17 @@ build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks)))
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just jd <- canShortcut ncgImpl insn,
           Just dest <- getJumpDestBlockId ncgImpl jd,
+          not (has_info id),
           (setMember dest s) || dest == id -- loop checks
         = (s, shortcut_blocks, b : others)
     split (s, shortcut_blocks, others) (BasicBlock id [insn])
-        | Just dest <- canShortcut ncgImpl insn
+        | Just dest <- canShortcut ncgImpl insn,
+          not (has_info id)
         = (setInsert id s, (id,dest) : shortcut_blocks, others)
     split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
 
+    -- do not eliminate blocks that have an info table
+    has_info l = mapMember l info
 
     -- build a mapping from BlockId to JumpDest for shorting branches
     mapping = foldl add emptyUFM shortcut_blocks
diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs
index 0d4161f843..b67ff9d40f 100644
--- a/compiler/nativeGen/Instruction.hs
+++ b/compiler/nativeGen/Instruction.hs
@@ -39,13 +39,13 @@ noUsage  = RU [] []
 type NatCmm instr
         = GenCmmGroup
                 CmmStatics
-                (Maybe CmmStatics)
+                (BlockEnv CmmStatics)
                 (ListGraph instr)
 
 type NatCmmDecl statics instr
         = GenCmmDecl
                 statics
-                (Maybe CmmStatics)
+                (BlockEnv CmmStatics)
                 (ListGraph instr)
 
 
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 1b49a495f5..55cc6d2a0d 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -50,42 +50,43 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph []))
-    = pprLabel lbl
-
- -- special case for code without an info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks)
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- from the entry code to a label on the _top_ of of the info table,
-         -- so that the linker will not think it is unreferenced and dead-strip
-         -- it. That's why the label is called a DeadStripPreventer (_dsp).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty)
+pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map pprBasicBlock blocks)
+
+    Just (Statics info_lbl info) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionHeader Text $$
+      (
+           (if platformHasSubsectionsViaSymbols platform
+            then ppr (mkDeadStripPreventer info_lbl) <> char ':'
+            else empty) $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+      ) $$
+      vcat (map pprBasicBlock blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- from the entry code to a label on the _top_ of of the info table,
+             -- so that the linker will not think it is unreferenced and dead-strip
+             -- it. That's why the label is called a DeadStripPreventer (_dsp).
+                      text "\t.long "
+                  <+> ppr info_lbl
+                  <+> char '-'
+                  <+> ppr (mkDeadStripPreventer info_lbl)
+             else empty)
 
 
 pprBasicBlock :: NatBasicBlock Instr -> SDoc
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 5ceee3e242..fc585d9438 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -160,7 +160,7 @@ data Liveness
 -- | Stash regs live on entry to each basic block in the info part of the cmm code.
 data LiveInfo
         = LiveInfo
-                (Maybe CmmStatics)                      -- cmm info table static stuff
+                (BlockEnv CmmStatics)                   -- cmm info table static stuff
                 (Maybe BlockId)                         -- id of the first block
                 (Maybe (BlockMap RegSet))               -- argument locals live on entry to this block
                 (Map BlockId (Set Int))                 -- stack slots live on entry to this block
@@ -215,7 +215,7 @@ instance Outputable instr
 
 instance Outputable LiveInfo where
     ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry)
-        =  (maybe empty (ppr) mb_static)
+        =  (ppr mb_static)
         $$ text "# firstId          = " <> ppr firstId
         $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry
         $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 91a2b894c5..8a5761990e 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -52,41 +52,43 @@ pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
-
- -- special case for code without info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks)
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- from the entry code to a label on the _top_ of of the info table,
-         -- so that the linker will not think it is unreferenced and dead-strip
-         -- it. That's why the label is called a DeadStripPreventer (_dsp).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty)
+pprNatCmmDecl proc@(CmmProc _ lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map pprBasicBlock blocks)
+
+    Just (Statics info_lbl info) ->
+      sdocWithPlatform $ \platform ->
+      pprSectionHeader Text $$
+      (
+           (if platformHasSubsectionsViaSymbols platform
+            then pprCLabel (mkDeadStripPreventer info_lbl) <> char ':'
+            else empty) $$
+           vcat (map pprData info) $$
+           pprLabel info_lbl
+      ) $$
+      vcat (map pprBasicBlock blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- from the entry code to a label on the _top_ of of the info table,
+             -- so that the linker will not think it is unreferenced and dead-strip
+             -- it. That's why the label is called a DeadStripPreventer (_dsp).
+                      text "\t.long "
+                  <+> pprCLabel info_lbl
+                  <+> char '-'
+                  <+> pprCLabel (mkDeadStripPreventer info_lbl)
+             else empty)
 
 
 pprBasicBlock :: NatBasicBlock Instr -> SDoc
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index e844376806..c935eb8ab0 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -32,6 +32,7 @@ import Reg
 import PprBase
 
 
+import BlockId
 import BasicTypes       (Alignment)
 import OldCmm
 import CLabel
@@ -51,43 +52,40 @@ pprNatCmmDecl :: NatCmmDecl (Alignment, CmmStatics) Instr -> SDoc
 pprNatCmmDecl (CmmData section dats) =
   pprSectionHeader section $$ pprDatas dats
 
- -- special case for split markers:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl
-
- -- special case for code without info table:
-pprNatCmmDecl (CmmProc Nothing lbl (ListGraph blocks)) =
-  pprSectionHeader Text $$
-  pprLabel lbl $$ -- blocks guaranteed not null, so label needed
-  vcat (map pprBasicBlock blocks) $$
-  pprSizeDecl lbl
-
-pprNatCmmDecl (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) =
-  sdocWithPlatform $ \platform ->
-  pprSectionHeader Text $$
-  (
-       (if platformHasSubsectionsViaSymbols platform
-        then ppr (mkDeadStripPreventer info_lbl) <> char ':'
-        else empty) $$
-       vcat (map pprData info) $$
-       pprLabel info_lbl
-  ) $$
-  vcat (map pprBasicBlock blocks) $$
-     -- above: Even the first block gets a label, because with branch-chain
-     -- elimination, it might be the target of a goto.
-        (if platformHasSubsectionsViaSymbols platform
-         then
-         -- If we are using the .subsections_via_symbols directive
-         -- (available on recent versions of Darwin),
-         -- we have to make sure that there is some kind of reference
-         -- from the entry code to a label on the _top_ of of the info table,
-         -- so that the linker will not think it is unreferenced and dead-strip
-         -- it. That's why the label is called a DeadStripPreventer (_dsp).
-                  text "\t.long "
-              <+> ppr info_lbl
-              <+> char '-'
-              <+> ppr (mkDeadStripPreventer info_lbl)
-         else empty) $$
-  pprSizeDecl info_lbl
+pprNatCmmDecl proc@(CmmProc top_info lbl (ListGraph blocks)) =
+  case topInfoTable proc of
+    Nothing ->
+       case blocks of
+         []     -> -- special case for split markers:
+           pprLabel lbl
+         blocks -> -- special case for code without info table:
+           pprSectionHeader Text $$
+           pprLabel lbl $$ -- blocks guaranteed not null, so label needed
+           vcat (map (pprBasicBlock top_info) blocks) $$
+           pprSizeDecl lbl
+
+    Just (Statics info_lbl info) ->
+      sdocWithPlatform $ \platform ->
+      (if platformHasSubsectionsViaSymbols platform
+          then pprCLabel (mkDeadStripPreventer info_lbl) <> char ':'
+          else empty) $$
+      vcat (map (pprBasicBlock top_info) blocks) $$
+         -- above: Even the first block gets a label, because with branch-chain
+         -- elimination, it might be the target of a goto.
+            (if platformHasSubsectionsViaSymbols platform
+             then
+             -- If we are using the .subsections_via_symbols directive
+             -- (available on recent versions of Darwin),
+             -- we have to make sure that there is some kind of reference
+             -- from the entry code to a label on the _top_ of of the info table,
+             -- so that the linker will not think it is unreferenced and dead-strip
+             -- it. That's why the label is called a DeadStripPreventer (_dsp).
+                      text "\t.long "
+                  <+> pprCLabel info_lbl
+                  <+> char '-'
+                  <+> pprCLabel (mkDeadStripPreventer info_lbl)
+             else empty) $$
+      pprSizeDecl info_lbl
 
 -- | Output the ELF .size directive.
 pprSizeDecl :: CLabel -> SDoc
@@ -98,11 +96,18 @@ pprSizeDecl lbl
      <> ptext (sLit ", .-") <> ppr lbl
    else empty
 
-pprBasicBlock :: NatBasicBlock Instr -> SDoc
-pprBasicBlock (BasicBlock blockid instrs) =
-  pprLabel (mkAsmTempLabel (getUnique blockid)) $$
-  vcat (map pprInstr instrs)
-
+pprBasicBlock :: BlockEnv CmmStatics -> NatBasicBlock Instr -> SDoc
+pprBasicBlock info_env (BasicBlock blockid instrs)
+  = maybe_infotable $$
+    pprLabel (mkAsmTempLabel (getUnique blockid)) $$
+    vcat (map pprInstr instrs)
+  where
+    maybe_infotable = case mapLookup blockid info_env of
+       Nothing   -> empty
+       Just (Statics info_lbl info) ->
+           pprSectionHeader Text $$
+           vcat (map pprData info) $$
+           pprLabel platform info_lbl
 
 pprDatas :: (Alignment, CmmStatics) -> SDoc
 pprDatas (align, (Statics lbl dats))