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.

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

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

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)

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

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

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

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

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 ')'

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'

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})