An overhaul of the SRT representation

Summary:
- Previously we would hvae a single big table of pointers per module,
  with a set of bitmaps to reference entries within it. The new
  representation is identical to a static constructor, which is much
  simpler for the GC to traverse, and we get to remove the complicated
  bitmap-traversal code from the GC.

- Rewrite all the code to generate SRTs in CmmBuildInfoTables, and
  document it much better (see Note [SRTs]). This has been something
  I've wanted to do since we moved to the new code generator, I
  finally had the opportunity to finish it while on a transatlantic
  flight recently :)

There are a series of 4 diffs:

1. D4632 (this one), which does the bulk of the changes

2. D4633 which adds support for smaller `CmmLabelDiffOff` constants

3. D4634 which takes advantage of D4632 and D4633 to save a word in
   info tables that have an SRT on x86_64. This is where most of the
   binary size improvement comes from.

4. D4637 which makes a further optimisation to merge some SRTs with
   static FUN closures.  This adds some complexity and the benefits
   are fairly modest, so it's not clear yet whether we should do this.

Results (after (3), on x86_64)

- GHC itself (staticaly linked) is 5.2% smaller

- -1.7% binary sizes in nofib, -2.9% module sizes. Full nofib results: P176

- I measured the overhead of traversing all the static objects in a
  major GC in GHC itself by doing `replicateM_ 1000 performGC` as the
  first thing in `Main.main`.  The new version was 5-10% faster, but
  the results did vary quite a bit.

- I'm not sure if there's a compile-time difference, the results are
  too unreliable.

Test Plan: validate

Reviewers: bgamari, michalt, niteria, simonpj, erikd, osa1

Subscribers: thomie, carter

Differential Revision: https://phabricator.haskell.org/D4632

12 files changed, 693 insertions, 395 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index a37ce7e87f..38efd12cf5 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -14,12 +14,11 @@ module CLabel (
         pprDebugCLabel,
 
         mkClosureLabel,
-        mkTopSRTLabel,
+        mkSRTLabel,
         mkInfoTableLabel,
         mkEntryLabel,
         mkRednCountsLabel,
         mkConInfoTableLabel,
-        mkLargeSRTLabel,
         mkApEntryLabel,
         mkApInfoTableLabel,
         mkClosureTableLabel,
@@ -54,6 +53,7 @@ module CLabel (
         mkSMAP_DIRTY_infoLabel,
         mkBadAlignmentLabel,
         mkArrWords_infoLabel,
+        mkSRTInfoLabel,
 
         mkTopTickyCtrLabel,
         mkCAFBlackHoleInfoTableLabel,
@@ -250,10 +250,7 @@ data CLabel
   | HpcTicksLabel Module
 
   -- | Static reference table
-  | SRTLabel !Unique
-
-  -- | Label of an StgLargeSRT
-  | LargeSRTLabel
+  | SRTLabel
         {-# UNPACK #-} !Unique
 
   -- | A bitmap (function or case return)
@@ -303,8 +300,6 @@ instance Ord CLabel where
     compare a1 a2
   compare (SRTLabel u1) (SRTLabel u2) =
     nonDetCmpUnique u1 u2
-  compare (LargeSRTLabel u1) (LargeSRTLabel u2) =
-    nonDetCmpUnique u1 u2
   compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =
     nonDetCmpUnique u1 u2
   compare IdLabel{} _ = LT
@@ -337,8 +332,6 @@ instance Ord CLabel where
   compare _ HpcTicksLabel{} = GT
   compare SRTLabel{} _ = LT
   compare _ SRTLabel{} = GT
-  compare LargeSRTLabel{} _ = LT
-  compare _ LargeSRTLabel{} = GT
 
 -- | Record where a foreign label is stored.
 data ForeignLabelSource
@@ -387,9 +380,6 @@ pprDebugCLabel lbl
 
 data IdLabelInfo
   = Closure             -- ^ Label for closure
-  | SRT                 -- ^ Static reference table (TODO: could be removed
-                        -- with the old code generator, but might be needed
-                        -- when we implement the New SRT Plan)
   | InfoTable           -- ^ Info tables for closures; always read-only
   | Entry               -- ^ Entry point
   | Slow                -- ^ Slow entry point
@@ -459,8 +449,8 @@ data DynamicLinkerLabelInfo
 -- Constructing IdLabels
 -- These are always local:
 
-mkTopSRTLabel     :: Unique -> CLabel
-mkTopSRTLabel u = SRTLabel u
+mkSRTLabel     :: Unique -> CLabel
+mkSRTLabel u = SRTLabel u
 
 mkRednCountsLabel :: Name -> CLabel
 mkRednCountsLabel       name    =
@@ -517,6 +507,29 @@ mkSMAP_FROZEN0_infoLabel        = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_P
 mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
 mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry
 
+mkSRTInfoLabel :: Int -> CLabel
+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo
+ where
+   lbl =
+     case n of
+       1 -> fsLit "stg_SRT_1"
+       2 -> fsLit "stg_SRT_2"
+       3 -> fsLit "stg_SRT_3"
+       4 -> fsLit "stg_SRT_4"
+       5 -> fsLit "stg_SRT_5"
+       6 -> fsLit "stg_SRT_6"
+       7 -> fsLit "stg_SRT_7"
+       8 -> fsLit "stg_SRT_8"
+       9 -> fsLit "stg_SRT_9"
+       10 -> fsLit "stg_SRT_10"
+       11 -> fsLit "stg_SRT_11"
+       12 -> fsLit "stg_SRT_12"
+       13 -> fsLit "stg_SRT_13"
+       14 -> fsLit "stg_SRT_14"
+       15 -> fsLit "stg_SRT_15"
+       16 -> fsLit "stg_SRT_16"
+       _ -> panic "mkSRTInfoLabel"
+
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
   mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
@@ -602,7 +615,6 @@ isSomeRODataLabel (IdLabel _ _ InfoTable) = True
 isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True
 isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True
 -- static reference tables defined in haskell (.hs)
-isSomeRODataLabel (IdLabel _ _ SRT) = True
 isSomeRODataLabel (SRTLabel _) = True
 -- info table defined in cmm (.cmm)
 isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True
@@ -615,9 +627,7 @@ foreignLabelStdcallInfo _lbl = Nothing
 
 
 -- Constructing Large*Labels
-mkLargeSRTLabel :: Unique -> CLabel
 mkBitmapLabel   :: Unique -> CLabel
-mkLargeSRTLabel uniq            = LargeSRTLabel uniq
 mkBitmapLabel   uniq            = LargeBitmapLabel uniq
 
 -- Constructing Cost Center Labels
@@ -675,8 +685,6 @@ mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")
 -- Convert between different kinds of label
 
 toClosureLbl :: CLabel -> CLabel
-toClosureLbl (IdLabel n _ BlockInfoTable)
-  = pprPanic "toClosureLbl: BlockInfoTable" (ppr n)
 toClosureLbl (IdLabel n c _) = IdLabel n c Closure
 toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
 toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
@@ -745,7 +753,6 @@ needsCDecl :: CLabel -> Bool
   -- don't bother declaring Bitmap labels, we always make sure
   -- they are defined before use.
 needsCDecl (SRTLabel _)                 = True
-needsCDecl (LargeSRTLabel _)            = False
 needsCDecl (LargeBitmapLabel _)         = False
 needsCDecl (IdLabel _ _ _)              = True
 needsCDecl (LocalBlockLabel _)          = True
@@ -892,12 +899,10 @@ externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
 externallyVisibleCLabel (HpcTicksLabel _)       = True
 externallyVisibleCLabel (LargeBitmapLabel _)    = False
 externallyVisibleCLabel (SRTLabel _)            = False
-externallyVisibleCLabel (LargeSRTLabel _)       = False
 externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"
 externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"
 
 externallyVisibleIdLabel :: IdLabelInfo -> Bool
-externallyVisibleIdLabel SRT             = False
 externallyVisibleIdLabel LocalInfoTable  = False
 externallyVisibleIdLabel LocalEntry      = False
 externallyVisibleIdLabel BlockInfoTable  = False
@@ -953,7 +958,6 @@ labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?
 labelType PicBaseLabel                          = DataLabel
 labelType (DeadStripPreventer _)                = DataLabel
 labelType (HpcTicksLabel _)                     = DataLabel
-labelType (LargeSRTLabel _)                     = DataLabel
 labelType (LargeBitmapLabel _)                  = DataLabel
 
 idInfoLabelType :: IdLabelInfo -> CLabelType
@@ -1042,7 +1046,6 @@ internal names. <type> is one of the following:
 
          info                   Info table
          srt                    Static reference table
-         srtd                   Static reference table descriptor
          entry                  Entry code (function, closure)
          slow                   Slow entry code (if any)
          ret                    Direct return address
@@ -1181,7 +1184,6 @@ pprCLbl (StringLitLabel u)
 pprCLbl (SRTLabel u)
   = pprUniqueAlways u <> pp_cSEP <> text "srt"
 
-pprCLbl (LargeSRTLabel u)  = pprUniqueAlways u <> pp_cSEP <> text "srtd"
 pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUniqueAlways u <> pp_cSEP <> text "btm"
 -- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
 -- until that gets resolved we'll just force them to start
@@ -1274,7 +1276,6 @@ ppIdFlavor :: IdLabelInfo -> SDoc
 ppIdFlavor x = pp_cSEP <>
                (case x of
                        Closure          -> text "closure"
-                       SRT              -> text "srt"
                        InfoTable        -> text "info"
                        LocalInfoTable   -> text "info"
                        Entry            -> text "entry"
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 50d48afb38..f059a7b3a8 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -18,7 +18,6 @@ module Cmm (
      -- * Info Tables
      CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
      ClosureTypeInfo(..),
-     C_SRT(..), needsSRT,
      ProfilingInfo(..), ConstrDescription,
 
      -- * Statements, expressions and types
@@ -138,24 +137,13 @@ data CmmInfoTable
       cit_lbl  :: CLabel, -- Info table label
       cit_rep  :: SMRep,
       cit_prof :: ProfilingInfo,
-      cit_srt  :: C_SRT
+      cit_srt  :: Maybe CLabel   -- empty, or a closure address
     }
 
 data ProfilingInfo
   = NoProfilingInfo
   | ProfilingInfo [Word8] [Word8] -- closure_type, closure_desc
 
--- C_SRT is what StgSyn.SRT gets translated to...
--- we add a label for the table, and expect only the 'offset/length' form
-
-data C_SRT = NoC_SRT
-           | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-}
-           deriving (Eq)
-
-needsSRT :: C_SRT -> Bool
-needsSRT NoC_SRT       = False
-needsSRT (C_SRT _ _ _) = True
-
 -----------------------------------------------------------------------------
 --              Static Data
 -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index ae192e504c..226d3a1138 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,46 +1,123 @@
-{-# LANGUAGE BangPatterns, GADTs #-}
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+    GeneralizedNewtypeDeriving, NondecreasingIndentation #-}
 
 module CmmBuildInfoTables
-    ( CAFSet, CAFEnv, cafAnal
-    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
-where
+  ( CAFSet, CAFEnv, cafAnal
+  , doSRTs, ModuleSRTInfo, emptySRT
+  ) where
 
 import GhcPrelude hiding (succ)
 
+import BlockId
 import Hoopl.Block
 import Hoopl.Graph
 import Hoopl.Label
 import Hoopl.Collections
 import Hoopl.Dataflow
+import Module
 import Digraph
-import Bitmap
 import CLabel
 import PprCmmDecl ()
 import Cmm
 import CmmUtils
-import CmmInfo
-import Data.List
 import DynFlags
 import Maybes
 import Outputable
 import SMRep
 import UniqSupply
-import Util
+import CostCentre
+import StgCmmHeap
 
 import PprCmm()
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Data.Tuple
 import Control.Monad
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
 
-foldSet :: (a -> b -> b) -> b -> Set a -> b
-foldSet = Set.foldr
 
------------------------------------------------------------------------
--- SRTs
+{- Note [SRTs]
 
-{- EXAMPLE
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+|      |     +-----+---+---+---+
+|   -------->|SRT_2| | | | | 0 |
+|------|     +-----+-|-+-|-+---+
+|      |             |   |
+| code |             |   |
+|      |             v   v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor.  There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | |   | | | 0 |
++-----+-|-+- -+-|-+---+
+        |       |
+        v       v
+              +----+---+---+---+
+              |SRT2| | | | | 0 |
+              +----+-|-+-|-+---+
+                     |   |
+                     |   |
+                     v   v
+
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The following things have SRTs:
+
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
+
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+(but see TODO below, we can improve this)
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable       +------+
+  info->f.srt_offset  |  ------------> offset to SRT object
+StgStdInfoTable       +------+
+  info->layout.ptrs   | ...  |
+  info->layout.nptrs  | ...  |
+  info->srt           |  1   |
+  info->type          | ...  |
+                      |------|
+
+
+EXAMPLE
+^^^^^^^
 
 f = \x. ... g ...
   where
@@ -62,29 +139,219 @@ CmmDecls. e.g. for f_entry, we might end up with
 where f1_ret is a return point, and f2_proc is a proc-point.  We have
 a CAFSet for each of these CmmDecls, let's suppose they are
 
-   [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
-   [ g_entry{h_closure, c1_closure} ]
+   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+   [ g_entry{h_info, c1_closure} ]
    [ h_entry{c2_closure} ]
 
-Now, note that we cannot use g_closure and h_closure in an SRT,
-because there are no static closures corresponding to these functions.
-So we have to flatten out the structure, replacing g_closure and
-h_closure with their contents:
-
-   [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
-   [ g_entry{c2_closure, c1_closure} ]
-   [ h_entry{c2_closure} ]
-
-This is what flattenCAFSets is doing.
+Next, we make an SRT for each of these functions:
+
+  f_srt : [g_info]
+  g_srt : [h_info, c1_closure]
+  h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+  f_srt : [g_srt]
+  g_srt : [h_srt, c1_closure]
+  h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element.  So, since h_srt == c2_closure, we have
+
+  f_srt : [g_srt]
+  g_srt : [c2_closure, c1_closure]
+  h_srt : [c2_closure]
+
+and the only SRT closure we generate is
+
+  g_srt = SRT_2 [c2_closure, c1_closure]
+
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations.  Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Shortcut] we never create an SRT with a single entry, instead
+   we replace all references to the singleton SRT with a reference
+   to its element.  This includes references from info tables.
+
+   i.e. instead of
+
+    +------+
+    | info |
+    |      |     +-----+---+---+
+    |   -------->|SRT_1| | | 0 |
+    |------|     +-----+-|-+---+
+    |      |             |
+    | code |             |
+    |      |             v
+                      closure
+
+   we can point directly to the closure:
+
+    +------+
+    | info |
+    |      |
+    |   -------->closure
+    |------|
+    |      |
+    | code |
+    |      |
+
+
+   The exception to this is when we're doing dynamic linking. In that
+   case, if the closure is not locally defined then we can't point to
+   it directly from the info table, because this is the text section
+   which cannot contain runtime relocations. In this case we skip this
+   optimisation and generate the singleton SRT, becase SRTs are in the
+   data section and *can* have relocatable references.
+
+2. [FUN] If an SRT refers to a top-level function (a FUN_STATIC), then
+   we can shortcut the reference to point directly to the function's
+   SRT instead.
+
+   i.e. instead of
+
+   +---+---+---
+   |SRT| | |
+   +---+-|-+---
+         |
+         v
+       +---+---+
+       | | | 0 |
+       +-|-+---+
+         |
+         |      +------+
+         |      | info |
+         |      |      |     +-----+---+---+
+         |      |   -------->|SRT_1| | | 0 |
+         `----->|------|     +-----+-|-+---+
+                |      |             |
+                | code |             |
+                |      |             v
+                                  closure
+
+   we can generate
+
+   +---+---+---
+   |SRT| | |
+   +---+-|-+---
+         `----------------------,
+                                |
+       +---+---+                |
+       | | | 0 |                |
+       +-|-+---+                |
+         |                      |
+         |      +------+        |
+         |      | info |        v
+         |      |      |     +-----+---+---+
+         |      |   -------->|SRT_1| | | 0 |
+         `----->|------|     +-----+-|-+---+
+                |      |             |
+                | code |             |
+                |      |             v
+                                  closure
+
+   This is quicker for the garbage collector to traverse, and avoids
+   setting the static link field on the function's closure.
+
+   Of course we can only do this if we know what the function's SRT
+   is. Due to [Shortcut] the function's SRT can be an arbitrary
+   closure, so this optimisation only applies within a module.
+
+   Note: we can *not* do this optimisation for top-level thunks
+   (CAFs), because we want the SRT to point directly to the
+   CAF. Otherwise the SRT would keep the CAF's static references alive
+   even after the CAF had been evaluated!
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+   refers to C (perhaps transitively), then we can omit the reference
+   to C from A.
+
+
+As an alternative to [FUN]: we could merge the FUN's SRT with the FUN
+object itself.
+
+TODO: make info->srt be an offset to the SRT, or zero if none (save
+one word per info table that has an SRT)
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Shortcut] C = A.
 
 -}
 
------------------------------------------------------------------------
--- Finding the CAFs used by a procedure
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+--   - _closure labels for static functions or CAFs
+--   - _info labels for dynamic functions, thunks, or continuations
+--   - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl.  Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+  deriving (Eq,Ord,Outputable)
 
-type CAFSet = Set CLabel
+type CAFSet = Set CAFLabel
 type CAFEnv = LabelMap CAFSet
 
+mkCAFLabel :: CLabel -> CAFLabel
+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
+
+-- This is a label that we can put in an SRT.  It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+  deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+-- |
+-- For each code block:
+--   - collect the references reachable from this code block to FUN,
+--     THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+  :: LabelSet   -- The blocks representing continuations, ie. those
+                -- that will get RET info tables.  These labels will
+                -- get their own SRTs, so we don't aggregate CAFs from
+                -- references to these labels, we just use the label.
+  -> CLabel     -- The top label of the proc
+  -> CmmGraph
+  -> CAFEnv
+cafAnal contLbls topLbl cmmGraph =
+  analyzeCmmBwd cafLattice
+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
 cafLattice :: DataflowLattice CAFSet
 cafLattice = DataflowLattice Set.empty add
   where
@@ -92,279 +359,329 @@ cafLattice = DataflowLattice Set.empty add
         let !new' = old `Set.union` new
         in changedIf (Set.size new' > Set.size old) new'
 
-cafTransfers :: TransferFun CAFSet
-cafTransfers (BlockCC eNode middle xNode) fBase =
-    let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
+
+cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers contLbls entry topLbl
+  (BlockCC eNode middle xNode) fBase =
+    let joined = cafsInNode xNode $! live'
         !result = foldNodesBwdOO cafsInNode middle joined
+
+        facts = mapMaybe successorFact (successors xNode)
+        live' = joinFacts cafLattice facts
+
+        successorFact s
+          -- If this is a loop back to the entry, we can refer to the
+          -- entry label.
+          | s == entry = Just (add topLbl Set.empty)
+          -- If this is a continuation, we want to refer to the
+          -- SRT for the continuation's info table
+          | s `setMember` contLbls
+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
+          -- Otherwise, takes the CAF references from the destination
+          | otherwise
+          = lookupFact s fBase
+
+        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+        cafsInNode node set = foldExpDeep addCaf node set
+
+        addCaf expr !set =
+          case expr of
+              CmmLit (CmmLabel c) -> add c set
+              CmmLit (CmmLabelOff c _) -> add c set
+              CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
+              _ -> set
+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s
+                | otherwise = s
+
     in mapSingleton (entryLabel eNode) result
 
-cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
-cafsInNode node set = foldExpDeep addCaf node set
-  where
-    addCaf expr !set =
-        case expr of
-            CmmLit (CmmLabel c) -> add c set
-            CmmLit (CmmLabelOff c _) -> add c set
-            CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
-            _ -> set
-    add l s | hasCAF l  = Set.insert (toClosureLbl l) s
-            | otherwise = s
-
--- | An analysis to find live CAFs.
-cafAnal :: CmmGraph -> CAFEnv
-cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
-
------------------------------------------------------------------------
--- Building the SRTs
-
--- Description of the SRT for a given module.
--- Note that this SRT may grow as we greedily add new CAFs to it.
-data TopSRT = TopSRT
-  { lbl      :: CLabel
-  , next_elt :: {-# UNPACK #-} !Int -- the next entry in the table
-  , rev_elts :: [CLabel]
-  , elt_map  :: !(Map CLabel Int) -- CLabel -> its last entry in the table
+
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+  { thisModule :: Module
+    -- ^ Current module being compiled. Required for calling labelDynamic.
+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+    -- ^ previous SRTs we've emitted, so we can de-duplicate.
+    -- Used to implement the [Common] optimisation.
+  , flatSRTs :: Map SRTEntry (Set SRTEntry)
+    -- ^ The reverse mapping, so that we can remove redundant
+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
+    -- points to [c,d], we can omit c and emit [a,b].
+    -- Used to implement the [Filter] optimisation.
   }
+instance Outputable ModuleSRTInfo where
+  ppr ModuleSRTInfo{..} =
+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
 
-instance Outputable TopSRT where
-  ppr (TopSRT lbl next elts eltmap) =
-    text "TopSRT:" <+> ppr lbl
-                   <+> ppr next
-                   <+> ppr elts
-                   <+> ppr eltmap
-
-emptySRT :: MonadUnique m => m TopSRT
-emptySRT =
-  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
-     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
-
-isEmptySRT :: TopSRT -> Bool
-isEmptySRT srt = null (rev_elts srt)
-
-cafMember :: TopSRT -> CLabel -> Bool
-cafMember srt lbl = Map.member lbl (elt_map srt)
-
-cafOffset :: TopSRT -> CLabel -> Maybe Int
-cafOffset srt lbl = Map.lookup lbl (elt_map srt)
-
-addCAF :: CLabel -> TopSRT -> TopSRT
-addCAF caf srt =
-  srt { next_elt = last + 1
-      , rev_elts = caf : rev_elts srt
-      , elt_map  = Map.insert caf last (elt_map srt) }
-    where last  = next_elt srt
-
-srtToData :: TopSRT -> CmmGroup
-srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
-    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-          sec = Section RelocatableReadOnlyData (lbl srt)
-
--- Once we have found the CAFs, we need to do two things:
--- 1. Build a table of all the CAFs used in the procedure.
--- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
---
--- When building the local view of the SRT, we first make sure that all the CAFs are
--- 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.
-buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
-buildSRT dflags 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.
-         sub_srt topSRT localCafs =
-           let cafs = Set.elems localCafs
-               mkSRT topSRT =
-                 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
-                    return (topSRT, localSRTs)
-           in if cafs `lengthExceeds` maxBmpSize dflags then
-                mkSRT (foldl' add_if_missing topSRT cafs)
-              else -- make sure all the cafs are near the bottom of the srt
-                mkSRT (add_if_too_far topSRT cafs)
-         add_if_missing srt caf =
-           if cafMember srt caf then srt else addCAF caf srt
-         -- If a CAF is more than maxBmpSize entries from the young end of the
-         -- SRT, then we add it to the SRT again.
-         -- (Note: Not in the SRT => infinitely far.)
-         add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
-           add srt (sortBy farthestFst cafs)
-             where
-               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
-                                   (Nothing, Nothing) -> EQ
-                                   (Nothing, Just _)  -> LT
-                                   (Just _,  Nothing) -> GT
-                                   (Just d, Just d')  -> compare d' d
-               add srt [] = srt
-               add srt@(TopSRT {next_elt = next}) (caf : rst) =
-                 case cafOffset srt caf of
-                   Just ix -> if next - ix > maxBmpSize dflags then
-                                add (addCAF caf srt) rst
-                              else srt
-                   Nothing -> add (addCAF caf srt) rst
-     (topSRT, subSRTs) <- sub_srt topSRT cafs
-     let (sub_tbls, blockSRTs) = subSRTs
-     return (topSRT, sub_tbls, blockSRTs)
-
--- Construct an SRT bitmap.
--- Adapted from simpleStg/SRT.hs, which expects Id's.
-procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
-                UniqSM (Maybe CmmDecl, C_SRT)
-procpointSRT _ _ _ [] =
- return (Nothing, NoC_SRT)
-procpointSRT dflags top_srt top_table entries =
- do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
-    return (top, srt)
-  where
-    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
-    sorted_ints = sort ints
-    offset = head sorted_ints
-    bitmap_entries = map (subtract offset) sorted_ints
-    len = GhcPrelude.last bitmap_entries + 1
-    bitmap = intsToBitmap dflags len bitmap_entries
-
-maxBmpSize :: DynFlags -> Int
-maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
-
--- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
-to_SRT dflags top_srt off len bmp
-  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
-  = do id <- getUniqueM
-       let srt_desc_lbl = mkLargeSRTLabel id
-           section = Section RelocatableReadOnlyData srt_desc_lbl
-           tbl = CmmData section $
-                   Statics srt_desc_lbl $ map CmmStaticLit
-                     ( cmmLabelOffW dflags top_srt off
-                     : mkWordCLit dflags (fromIntegral len)
-                     : map (mkStgWordCLit dflags) bmp)
-       return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
-  | otherwise
-  = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
-        -- The fromIntegral converts to StgHalfWord
-
--- Gather CAF info for a procedure, but only if the procedure
--- doesn't have a static closure.
--- (If it has a static closure, it will already have an SRT to
---  keep its CAFs live.)
--- Any procedure referring to a non-static CAF c must keep live
--- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
-localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
-localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
-  case topInfoTable proc of
-    Just (CmmInfoTable { cit_rep = rep })
-      | not (isStaticRep rep) && not (isStackRep rep)
-      -> (cafs, Just (toClosureLbl top_l))
-    _other -> (cafs, Nothing)
-  where
-    cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
-
--- Once we have the local CAF sets for some (possibly) mutually
--- recursive functions, we can create an environment mapping
--- each function to its set of CAFs. Note that a CAF may
--- be a reference to a function. If that function f does not have
--- a static closure, then we need to refer specifically
--- to the set of CAFs used by f. Of course, the set of CAFs
--- used by f must be included in the local CAF sets that are input to
--- this function. To minimize lookup time later, we return
--- the environment with every reference to f replaced by its set of CAFs.
--- To do this replacement efficiently, we gather strongly connected
--- components, then we sort the components in topological order.
-mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
-mkTopCAFInfo localCAFs = foldl' addToTop Map.empty g
-  where
-        addToTop !env (AcyclicSCC (l, cafset)) =
-          Map.insert l (flatten env cafset) env
-        addToTop !env (CyclicSCC nodes) =
-          let (lbls, cafsets) = unzip nodes
-              cafset = Set.unions cafsets `Set.difference` Set.fromList lbls
-          in foldl' (\env l -> Map.insert l (flatten env cafset) env) env lbls
-
-        g = stronglyConnCompFromEdgedVerticesOrd
-              [ DigraphNode (l,cafs) l (Set.elems cafs)
-              | (cafs, Just l) <- localCAFs ]
-
-flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
-flatten env cafset = foldSet (lookup env) Set.empty cafset
-  where
-      lookup env caf cafset' =
-          case Map.lookup caf env of
-             Just cafs -> foldSet Set.insert cafset' cafs
-             Nothing   -> Set.insert caf cafset'
-
-bundle :: Map CLabel CAFSet
-       -> (CAFEnv, CmmDecl)
-       -> (CAFSet, Maybe CLabel)
-       -> (LabelMap CAFSet, CmmDecl)
-bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
-  = ( mapMapWithKey get_cafs (info_tbls infos), decl )
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+  ModuleSRTInfo
+    { thisModule = mod
+    , dedupSRTs = Map.empty
+    , flatSRTs = Map.empty }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+  table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT.  We need to make a
+  label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
+
+-}
+
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+--   where the label is
+--   - the info label for a continuation or dynamic closure
+--   - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
+getLabelledBlocks (CmmData _ _) = []
+getLabelledBlocks (CmmProc top_info _ _ _) =
+  [ (blockId, mkCAFLabel (cit_lbl info))
+  | (blockId, info) <- mapToList (info_tbls top_info)
+  , let rep = cit_rep info
+  , not (isStaticRep rep) || not (isThunkRep rep)
+  ]
+
+
+-- | Get (Label,CLabel) pairs for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+--  - we never resolve a reference to a CAF to the contents of its SRT, since
+--    the point of SRTs is to keep CAFs alive.
+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+--    instead we generate their SRTs after everything else, so that we can
+--    resolve references in the CAF's SRT.
+getCAFs :: CmmDecl -> [(Label, CAFLabel)]
+getCAFs (CmmData _ _) = []
+getCAFs (CmmProc top_info topLbl _ g)
+  | Just info <- mapLookup (g_entry g) (info_tbls top_info)
+  , let rep = cit_rep info
+  , isStaticRep rep && isThunkRep rep = [(g_entry g, mkCAFLabel topLbl)]
+  | otherwise = []
+
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order.  This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs.
+depAnalSRTs
+  :: CAFEnv
+  -> [CmmDecl]
+  -> [SCC (Label, CAFLabel, Set CAFLabel)]
+
+depAnalSRTs cafEnv decls =
+  srtTrace "depAnalSRTs" (ppr blockToLabel $$ ppr (graph ++ cafSCCs)) $
+  (graph ++ cafSCCs)
  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
-    | Just info <- mapLookup l env = flatten flatmap info
-    | otherwise  = Set.empty
-    -- the label might not be in the env if the code corresponding to
-    -- this info table was optimised away (perhaps because it was
-    -- unreachable).  In this case it doesn't matter what SRT we
-    -- infer, since the info table will not appear in the generated
-    -- code.  See #9329.
-
-bundle _flatmap (_, decl) _
-  = ( mapEmpty, decl )
-
-
-flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
-flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
-   where
-     zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
-     localCAFs = unzipWith localCAFInfo zipped
-     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
-
-doSRTs :: DynFlags
-       -> TopSRT
-       -> [(CAFEnv, [CmmDecl])]
-       -> IO (TopSRT, [CmmDecl])
-
-doSRTs dflags topSRT tops
-  = do
-     let caf_decls = flattenCAFSets tops
-     us <- mkSplitUniqSupply 'u'
-     let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
-     return (topSRT', reverse gs' {- Note [reverse gs] -})
-  where
-    setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
-       (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
-       let decl' = updInfoSRTs srt_env decl
-       return (topSRT, decl': srt_tables ++ rst)
-    setSRT (topSRT, rst) (_, decl) =
-      return (topSRT, decl : rst)
-
-buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
-          -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
-buildSRTs dflags top_srt caf_map
-  = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
+  cafs = concatMap getCAFs decls
+  cafSCCs = [ AcyclicSCC (blockid, lbl, cafs)
+            | (blockid, lbl) <- cafs
+            , Just cafs <- [mapLookup blockid cafEnv] ]
+  labelledBlocks = concatMap getLabelledBlocks decls
+  blockToLabel :: LabelMap CAFLabel
+  blockToLabel = mapFromList (cafs ++ labelledBlocks)
+  labelToBlock = Map.fromList (map swap labelledBlocks)
+  graph = stronglyConnCompFromEdgedVerticesOrd
+             [ let cafs' = Set.delete lbl cafs in
+               DigraphNode (l,lbl,cafs') l
+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+             | (l, lbl) <- labelledBlocks
+             , Just cafs <- [mapLookup l cafEnv] ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+--   - closures with singleton SRTs resolve to their single entry
+--   - closures with larger SRTs map to the label for that SRT
+--   - CAFs must not map to anything!
+--   - if a labels maps to Nothing, we found that this label's SRT
+--     is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF srtMap lbl@(CAFLabel l) =
+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
+
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+  :: DynFlags
+  -> ModuleSRTInfo
+  -> [(CAFEnv, [CmmDecl])]
+  -> IO (ModuleSRTInfo, [CmmDecl])
+
+doSRTs dflags topSRT tops = do
+  us <- mkSplitUniqSupply 'u'
+
+  -- Ignore the original grouping of decls, and combine all the
+  -- CAFEnvs into a single CAFEnv.
+  let (cafEnvs, declss) = unzip tops
+      cafEnv = mapUnions cafEnvs
+      decls = concat declss
+
+  -- Put the decls in dependency order. Why? So that we can implement
+  -- [Shortcut] and [Filter].  If we need to refer to an SRT that has
+  -- a single entry, we use the entry itself, which means that we
+  -- don't need to generate the singleton SRT in the first place.  But
+  -- to do this we need to process blocks before things that depend on
+  -- them.
+  let sccs = depAnalSRTs cafEnv decls
+
+  -- On each strongly-connected group of decls, construct the SRT
+  -- closures and the SRT fields for info tables.
+  let (((declss, pairs), _srtMap), topSRT') =
+        initUs_ us $
+        flip runStateT topSRT $
+        flip runStateT Map.empty $
+        mapAndUnzipM (doSCC dflags) sccs
+
+  -- Next, update the info tables with the SRTs
+  let decls' = map (updInfoSRTs (mapFromList (concat pairs))) decls
+
+  return (topSRT', concat declss ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+  :: DynFlags
+  -> SCC (Label, CAFLabel, Set CAFLabel)
+  -> StateT SRTMap
+        (StateT ModuleSRTInfo UniqSM)
+        ( [CmmDecl]           -- generated SRTs
+        , [(Label, CLabel)] -- SRT fields for info tables
+        )
+
+doSCC dflags  (AcyclicSCC (l, cafLbl, cafs)) =
+  oneSRT dflags [l] [cafLbl] cafs
+
+doSCC dflags (CyclicSCC nodes) = do
+  -- build a single SRT for the whole cycle
+  let (blockids, lbls, cafsets) = unzip3 nodes
+      cafs = Set.unions cafsets `Set.difference` Set.fromList lbls
+  oneSRT dflags blockids lbls cafs
+
+
+-- | Build an SRT for a set of blocks
+oneSRT
+  :: DynFlags
+  -> [Label]                    -- blocks in this set
+  -> [CAFLabel]                 -- labels for those blocks
+  -> Set CAFLabel               -- SRT for this set
+  -> StateT SRTMap
+       (StateT ModuleSRTInfo UniqSM)
+       ( [CmmDecl]                    -- SRT objects we built
+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
+       )
+
+oneSRT dflags blockids lbls cafs = do
+  srtMap <- get
+  topSRT <- lift get
+  let
+    -- First resolve all the CAFLabels to SRTEntries
+    -- implements the [Shortcut] optimisation.
+    resolved =
+       Set.fromList $
+       catMaybes (map (resolveCAF srtMap) (Set.toList cafs))
+
+    -- The set of all SRTEntries in SRTs that we refer to from here.
+    allBelow =
+      Set.unions [ lbls | caf <- Set.toList resolved
+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+    -- Remove SRTEntries that are also in an SRT that we refer to.
+    -- Implements the [Filter] optimisation.
+    filtered = Set.difference resolved allBelow
+
+  srtTrace "oneSRT:"
+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
+
+  let
+    updateSRTMap srtEntry = do
+      let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
+      put (Map.union newSRTMap srtMap)
+
+  case Set.toList filtered of
+    [] -> do
+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
+      updateSRTMap Nothing
+      return ([], [])
+
+    [one@(SRTEntry lbl)]
+      | not (labelDynamic dflags (thisModule topSRT) lbl) -> do
+        updateSRTMap (Just one)
+        return ([], [(l, lbl) | l <- blockids])
+
+    cafList ->
+      -- Check whether an SRT with the same entries has been emitted already.
+      -- Implements the [Common] optimisation.
+      case Map.lookup filtered (dedupSRTs topSRT) of
+        Just srtEntry@(SRTEntry srtLbl)  -> do
+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
+          updateSRTMap (Just srtEntry)
+          return ([], [(l, srtLbl) | l <- blockids])
+        Nothing -> do
+          -- No duplicates: we have to build a new SRT object
+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
+          (decls, srtEntry) <- lift . lift $ buildSRTChain dflags cafList
+          updateSRTMap (Just srtEntry)
+          let allBelowThis = Set.union allBelow filtered
+              oldFlatSRTs = flatSRTs topSRT
+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+          lift (put (topSRT { dedupSRTs = newDedupSRTs
+                            , flatSRTs = newFlatSRTs }))
+          let SRTEntry lbl = srtEntry
+          return (decls, [(l, lbl) | l <- blockids])
+
+
+-- | build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+   :: DynFlags
+   -> [SRTEntry]
+   -> UniqSM
+        ( [CmmDecl]    -- The SRT object(s)
+        , SRTEntry     -- label to use in the info table
+        )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain dflags cafSet =
+  case splitAt mAX_SRT_SIZE cafSet of
+    (these, []) -> do
+      (decl,lbl) <- buildSRT dflags these
+      return ([decl], lbl)
+    (these,those) -> do
+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+      return (decl:rest, lbl)
   where
-  doOne (top_srt, decls, srt_env) (l, cafs)
-    = do (top_srt, mb_decl, srt) <- buildSRT dflags 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
-    [(LabelMap CAFSet, CmmDecl)]
--
--}
+    mAX_SRT_SIZE = 16
+
+
+buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
+buildSRT dflags refs = do
+  id <- getUniqueM
+  let
+    lbl = mkSRTLabel id
+    srt_n_info = mkSRTInfoLabel (length refs)
+    fields =
+      mkStaticClosure dflags srt_n_info dontCareCCS
+        [ CmmLabel lbl | SRTEntry lbl <- refs ]
+        [] -- no padding
+        [mkIntCLit dflags 0] -- link field
+        [] -- no saved info
+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
 
 
 {- Note [reverse gs]
@@ -375,9 +692,13 @@ buildSRTs dflags top_srt caf_map
    instructions for forward refs.  --SDM
 -}
 
-updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl
+updInfoSRTs :: LabelMap CLabel -> CmmDecl -> CmmDecl
 updInfoSRTs srt_env (CmmProc top_info top_l live g) =
   CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
   where updInfoTbl l info_tbl
-             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
+             = info_tbl { cit_srt = mapLookup l srt_env }
 updInfoSRTs _ t = t
+
+
+srtTrace :: String -> SDoc -> b -> b
+srtTrace _ _ b = b
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 4eb045a881..20e8858ba8 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -62,7 +62,7 @@ mkEmptyContInfoTable info_lbl
   = CmmInfoTable { cit_lbl  = info_lbl
                  , cit_rep  = mkStackRep []
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing }
 
 cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
             -> IO (Stream IO RawCmmGroup ())
@@ -255,12 +255,11 @@ packIntsCLit dflags a b = packHalfWordsCLit dflags
 
 
 mkSRTLit :: DynFlags
-         -> C_SRT
+         -> Maybe CLabel
          -> ([CmmLit],    -- srt_label, if any
              StgHalfWord) -- srt_bitmap
-mkSRTLit dflags NoC_SRT                = ([], toStgHalfWord dflags 0)
-mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
-
+mkSRTLit dflags Nothing    = ([], toStgHalfWord dflags 0)
+mkSRTLit dflags (Just lbl) = ([CmmLabel lbl], toStgHalfWord dflags 1)
 
 -------------------------------------------------------------------------
 --
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index cf660d274f..1bdf0e6a7e 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -472,7 +472,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               []) }
         
         | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
@@ -488,7 +488,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               []) }
                 -- we leave most of the fields zero here.  This is only used
                 -- to generate the BCO info table in the RTS at the moment.
@@ -506,7 +506,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               []) }
 
                      -- If profiling is on, this string gets duplicated,
@@ -523,7 +523,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmEntryLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
@@ -534,7 +534,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmRetLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               []) }
 
         | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
@@ -549,7 +549,7 @@ info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
                       return (mkCmmRetLabel pkg $3,
                               Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
                                            , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
+                                           , cit_prof = prof, cit_srt = Nothing },
                               live) }
 
 body    :: { CmmParse () }
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 4d109a4086..77598a4b09 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -32,21 +32,22 @@ import Platform
 -- | Top level driver for C-- pipeline
 -----------------------------------------------------------------------------
 
-cmmPipeline  :: HscEnv -- Compilation env including
-                       -- dynamic flags: -dcmm-lint -ddump-cmm-cps
-             -> TopSRT     -- SRT table and accumulating list of compiled procs
-             -> CmmGroup             -- Input C-- with Procedures
-             -> IO (TopSRT, CmmGroup) -- Output CPS transformed C--
-
-cmmPipeline hsc_env topSRT prog =
+cmmPipeline
+ :: HscEnv -- Compilation env including
+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps
+ -> ModuleSRTInfo        -- Info about SRTs generated so far
+ -> CmmGroup             -- Input C-- with Procedures
+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
+
+cmmPipeline hsc_env srtInfo prog =
   do let dflags = hsc_dflags hsc_env
 
      tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
 
-     (topSRT, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags topSRT tops
+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
      dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
 
-     return (topSRT, cmms)
+     return (srtInfo, cmms)
 
 
 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
@@ -105,7 +106,7 @@ cpsTop hsc_env proc =
                      Opt_D_dump_cmm_sink "Sink assignments"
 
        ------------- CAF analysis ----------------------------------------------
-       let cafEnv = {-# SCC "cafAnal" #-} cafAnal g
+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
        dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
 
        g <- if splitting_proc_points
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/cmm/Hoopl/Dataflow.hs
index 2538b70ee3..85a7d5f3c9 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/cmm/Hoopl/Dataflow.hs
@@ -30,6 +30,7 @@ module Hoopl.Dataflow
   , rewriteCmmBwd
   , changedIf
   , joinOutFacts
+  , joinFacts
   )
 where
 
@@ -374,6 +375,11 @@ joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts
         , isJust fact
         ]
 
+joinFacts :: DataflowLattice f -> [f] -> f
+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts
+  where
+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)
+
 -- | Returns the joined facts for each label.
 mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f
 mkFactBase lattice = foldl' add mapEmpty
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index c9a6003aaf..51deb8cb12 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -108,7 +108,7 @@ pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
 
 pprTopInfo :: CmmTopInfo -> SDoc
 pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
-  vcat [text "info_tbl: " <> ppr info_tbl,
+  vcat [text "info_tbls: " <> ppr info_tbl,
         text "stack_info: " <> ppr stack_info]
 
 ----------------------------------------------------------
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs
index 9dd2332b67..c4ee6fd068 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/cmm/PprCmmDecl.hs
@@ -115,18 +115,15 @@ pprTop (CmmData section ds) =
 pprInfoTable :: CmmInfoTable -> SDoc
 pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
                            , cit_prof = prof_info
-                           , cit_srt = _srt })
-  = vcat [ text "label:" <+> ppr lbl
-         , text "rep:" <> ppr rep
+                           , cit_srt = srt })
+  = vcat [ text "label: " <> ppr lbl
+         , text "rep: " <> ppr rep
          , case prof_info of
              NoProfilingInfo -> empty
-             ProfilingInfo ct cd -> vcat [ text "type:" <+> pprWord8String ct
-                                         , text "desc: " <> pprWord8String cd ] ]
-
-instance Outputable C_SRT where
-  ppr NoC_SRT = text "_no_srt_"
-  ppr (C_SRT label off bitmap)
-      = parens (ppr label <> comma <> ppr off <> comma <> ppr bitmap)
+             ProfilingInfo ct cd ->
+               vcat [ text "type: " <> pprWord8String ct
+                    , text "desc: " <> pprWord8String cd ]
+         , text "srt: " <> ppr srt ]
 
 instance Outputable ForeignHint where
   ppr NoHint     = empty
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 1da1f707a2..d58e9f6f88 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -755,7 +755,7 @@ mkCmmInfo ClosureInfo {..}
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing }
 
 --------------------------------------
 --        Building ClosureInfos
@@ -1040,7 +1040,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = sm_rep
                 , cit_prof = prof
-                , cit_srt  = NoC_SRT }
+                , cit_srt  = Nothing }
  where
    name = dataConName data_con
    info_lbl = mkConInfoTableLabel name NoCafRefs
@@ -1063,14 +1063,14 @@ cafBlackHoleInfoTable
   = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel
                  , cit_rep  = blackHoleRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing }
 
 indStaticInfoTable :: CmmInfoTable
 indStaticInfoTable
   = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel
                  , cit_rep  = indStaticRep
                  , cit_prof = NoProfilingInfo
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing }
 
 staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- A static closure needs a link field to aid the GC when traversing
@@ -1081,4 +1081,4 @@ staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool
 -- of the SRT.
 staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }
   | isConRep smrep         = not (isStaticNoCafCon smrep)
-  | otherwise              = has_srt -- needsSRT (cit_srt info_tbl)
+  | otherwise              = has_srt
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 223886a1fc..9012025ece 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1397,15 +1397,13 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        us <- mkSplitUniqSupply 'S'
-        let initTopSRT = initUs_ us emptySRT
         dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
-        (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
-        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         let -- Make up a module name to give the NCG. We can't pass bottom here
             -- lest we reproduce #11784.
             mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
             cmm_mod = mkModule (thisPackage dflags) mod_name
+        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
              rawCmms
         return ()
@@ -1456,21 +1454,17 @@ doCodeGen hsc_env this_mod data_tycons
         osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
         = {-# SCC "cmmPipeline" #-}
           let run_pipeline us cmmgroup = do
-                let (topSRT', us') = initUs us emptySRT
-                (topSRT, cmmgroup) <- cmmPipeline hsc_env topSRT' cmmgroup
-                let srt | isEmptySRT topSRT = []
-                        | otherwise         = srtToData topSRT
-                return (us', srt ++ cmmgroup)
+                (_topSRT, cmmgroup) <-
+                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup
+                return (us, cmmgroup)
 
           in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
                 return ()
 
       | otherwise
         = {-# SCC "cmmPipeline" #-}
-          let initTopSRT = initUs_ us emptySRT
-              run_pipeline = cmmPipeline hsc_env
-          in do topSRT <- Stream.mapAccumL run_pipeline initTopSRT ppr_stream1
-                Stream.yield (srtToData topSRT)
+          let run_pipeline = cmmPipeline hsc_env
+          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
 
     let
         dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 3ee3ba5cc4..e2ed3953ae 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -131,15 +131,6 @@ import Control.Monad (liftM, ap)
 --
 -- The CafInfo has already been calculated during the CoreTidy pass.
 --
--- During CoreToStg, we then pin onto each binding and case expression, a
--- list of Ids which represents the "live" CAFs at that point.  The meaning
--- of "live" here is the same as for live variables, see above (which is
--- why it's convenient to collect CAF information here rather than elsewhere).
---
--- The later SRT pass takes these lists of Ids and uses them to construct
--- the actual nested SRTs, and replaces the lists of Ids with (offset,length)
--- pairs.
-
 -- Note [What is a non-escaping let]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --