Revert "Revert "An overhaul of the SRT representation""
authorBen Gamari <ben@smart-cactus.org>
Tue, 18 Sep 2018 15:45:21 +0000 (11:45 -0400)
committerBen Gamari <ben@smart-cactus.org>
Tue, 18 Sep 2018 15:45:21 +0000 (11:45 -0400)
This reverts commit ceffd7fe3f310cb30fec870f768e8047af309d99.

23 files changed:
compiler/cmm/CLabel.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmPipeline.hs
compiler/cmm/Hoopl/Dataflow.hs
compiler/cmm/PprCmm.hs
compiler/cmm/PprCmmDecl.hs
compiler/codeGen/StgCmmClosure.hs
compiler/main/HscMain.hs
compiler/stgSyn/CoreToStg.hs
includes/rts/storage/ClosureMacros.h
includes/rts/storage/InfoTables.h
includes/stg/MiscClosures.h
libraries/ghc-heap/GHC/Exts/Heap/InfoTable.hsc
libraries/ghc-heap/GHC/Exts/Heap/InfoTableProf.hsc
rts/RtsAPI.c
rts/RtsSymbols.c
rts/StgMiscClosures.cmm
rts/sm/Evac.c
rts/sm/Scav.c
testsuite/tests/regalloc/regalloc_unit_tests.hs

index a7b7812..472bd3c 100644 (file)
@@ -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    =
@@ -518,6 +508,29 @@ mkSMAP_FROZEN_DIRTY_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,9 +615,6 @@ isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True
 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
 isSomeRODataLabel _lbl = False
@@ -616,9 +626,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
@@ -676,8 +684,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)
@@ -746,7 +752,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
@@ -893,12 +898,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
@@ -954,7 +957,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
@@ -1043,7 +1045,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
@@ -1182,7 +1183,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
@@ -1275,7 +1275,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"
index 50d48af..f059a7b 100644 (file)
@@ -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
 -----------------------------------------------------------------------------
index f01a219..498fded 100644 (file)
-{-# 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
index a652382..ea79232 100644 (file)
@@ -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)
 
 -------------------------------------------------------------------------
 --
index f8e507d..140d79a 100644 (file)
@@ -470,7 +470,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 ')'
@@ -486,7 +486,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.
@@ -504,7 +504,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,
@@ -521,7 +521,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 ')'
@@ -532,7 +532,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 ')'
@@ -547,7 +547,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 () }
index 4d109a4..77598a4 100644 (file)
@@ -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
index 2538b70..85a7d5f 100644 (file)
@@ -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
index 9198373..90f26e4 100644 (file)
@@ -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]
 
 ----------------------------------------------------------
index 9dd2332..c4ee6fd 100644 (file)
@@ -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
index 4c991c9..39d4362 100644 (file)
@@ -750,7 +750,7 @@ mkCmmInfo ClosureInfo {..}
   = CmmInfoTable { cit_lbl  = closureInfoLabel
                  , cit_rep  = closureSMRep
                  , cit_prof = closureProf
-                 , cit_srt  = NoC_SRT }
+                 , cit_srt  = Nothing }
 
 --------------------------------------
 --        Building ClosureInfos
@@ -1035,7 +1035,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
@@ -1058,14 +1058,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
@@ -1076,4 +1076,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
index 2e85ed2..a8a33bf 100644 (file)
@@ -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
index 120cfd5..fdd8d5b 100644 (file)
@@ -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]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 --
index c0aebe9..a99eab3 100644 (file)
@@ -109,7 +109,7 @@ INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)
 
 INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)
 {
-    return get_itbl(con)->srt_bitmap;
+    return get_itbl(con)->has_srt;
 }
 
 /* -----------------------------------------------------------------------------
index c621e5e..0e25e14 100644 (file)
@@ -124,31 +124,6 @@ typedef struct {
   StgWord bitmap[];
 } StgLargeBitmap;
 
-/* -----------------------------------------------------------------------------
-   SRTs  (Static Reference Tables)
-
-   These tables are used to keep track of the static objects referred
-   to by the code for a closure or stack frame, so that we can follow
-   static data references from code and thus accurately
-   garbage-collect CAFs.
-   -------------------------------------------------------------------------- */
-
-/* An SRT is just an array of closure pointers: */
-typedef StgClosure* StgSRT[];
-
-/*
- * Each info table refers to some subset of the closure pointers in an
- * SRT.  It does this using a pair of an StgSRT pointer and a
- * half-word bitmap.  If the half-word bitmap isn't large enough, then
- * we fall back to a large SRT, including an unbounded bitmap.  If the
- * half-word bitmap is set to all ones (0xffff), then the StgSRT
- * pointer instead points to an StgLargeSRT:
- */
-typedef struct StgLargeSRT_ {
-    StgSRT *srt;
-    StgLargeBitmap l;
-} StgLargeSRT;
-
 /* ----------------------------------------------------------------------------
    Info Tables
    ------------------------------------------------------------------------- */
@@ -194,11 +169,11 @@ typedef struct StgInfoTable_ {
     StgClosureInfo  layout;     /* closure layout info (one word) */
 
     StgHalfWord     type;       /* closure type */
-    StgHalfWord     srt_bitmap;
+    StgHalfWord     has_srt;
        /* In a CONSTR:
             - the constructor tag
           In a FUN/THUNK
-            - a bitmap of SRT entries
+            - non-zero if there is an SRT
        */
 
 #if defined(TABLES_NEXT_TO_CODE)
@@ -217,7 +192,7 @@ typedef struct StgInfoTable_ {
       and bitmap fields may be left out (they are at the end, so omitting
       them doesn't affect the layout).
 
-   -  If srt_bitmap (in the std info table part) is zero, then the srt
+   -  If has_srt (in the std info table part) is zero, then the srt
       field needn't be set.  This only applies if the slow_apply and
       bitmap fields have also been omitted.
    -------------------------------------------------------------------------- */
@@ -239,7 +214,7 @@ typedef struct StgFunInfoExtraRev_ {
         StgWord bitmap;
         OFFSET_FIELD(bitmap_offset);    /* arg ptr/nonptr bitmap */
     } b;
-    OFFSET_FIELD(srt_offset);   /* pointer to the SRT table */
+    OFFSET_FIELD(srt_offset);   /* pointer to the SRT closure */
     StgHalfWord    fun_type;    /* function type */
     StgHalfWord    arity;       /* function arity */
 } StgFunInfoExtraRev;
@@ -247,7 +222,7 @@ typedef struct StgFunInfoExtraRev_ {
 typedef struct StgFunInfoExtraFwd_ {
     StgHalfWord    fun_type;    /* function type */
     StgHalfWord    arity;       /* function arity */
-    StgSRT         *srt;        /* pointer to the SRT table */
+    StgClosure    *srt;         /* pointer to the SRT closure */
     union { /* union for compat. with TABLES_NEXT_TO_CODE version */
         StgWord        bitmap;  /* arg ptr/nonptr bitmap */
     } b;
@@ -273,16 +248,16 @@ extern const StgWord stg_arg_bitmaps[];
 
 /*
  * When info tables are laid out backwards, we can omit the SRT
- * pointer iff srt_bitmap is zero.
+ * pointer iff has_srt is zero.
  */
 
 typedef struct {
 #if defined(TABLES_NEXT_TO_CODE)
-    OFFSET_FIELD(srt_offset);   /* offset to the SRT table */
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
     StgInfoTable i;
 #else
     StgInfoTable i;
-    StgSRT      *srt;   /* pointer to the SRT table */
+    StgClosure  *srt;           /* pointer to the SRT closure */
 #endif
 } StgRetInfoTable;
 
@@ -292,7 +267,7 @@ typedef struct {
 
 /*
  * When info tables are laid out backwards, we can omit the SRT
- * pointer iff srt_bitmap is zero.
+ * pointer iff has_srt is zero.
  */
 
 typedef struct StgThunkInfoTable_ {
@@ -300,9 +275,9 @@ typedef struct StgThunkInfoTable_ {
     StgInfoTable i;
 #endif
 #if defined(TABLES_NEXT_TO_CODE)
-    OFFSET_FIELD(srt_offset);   /* offset to the SRT table */
+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */
 #else
-    StgSRT         *srt;        /* pointer to the SRT table */
+    StgClosure  *srt;           /* pointer to the SRT closure */
 #endif
 #if defined(TABLES_NEXT_TO_CODE)
     StgInfoTable i;
@@ -340,7 +315,8 @@ typedef struct StgConInfoTable_ {
  * info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)
  */
 #if defined(TABLES_NEXT_TO_CODE)
-#define GET_SRT(info) ((StgSRT*) (((StgWord) ((info)+1)) + (info)->srt_offset))
+#define GET_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->srt_offset))
 #else
 #define GET_SRT(info) ((info)->srt)
 #endif
@@ -361,7 +337,8 @@ typedef struct StgConInfoTable_ {
  * info must be a StgFunInfoTable*
  */
 #if defined(TABLES_NEXT_TO_CODE)
-#define GET_FUN_SRT(info) ((StgSRT*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))
+#define GET_FUN_SRT(info) \
+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))
 #else
 #define GET_FUN_SRT(info) ((info)->f.srt)
 #endif
index f26fe59..98363b3 100644 (file)
@@ -150,6 +150,22 @@ RTS_ENTRY(stg_END_STM_CHUNK_LIST);
 RTS_ENTRY(stg_NO_TREC);
 RTS_ENTRY(stg_COMPACT_NFDATA_CLEAN);
 RTS_ENTRY(stg_COMPACT_NFDATA_DIRTY);
+RTS_ENTRY(stg_SRT_1);
+RTS_ENTRY(stg_SRT_2);
+RTS_ENTRY(stg_SRT_3);
+RTS_ENTRY(stg_SRT_4);
+RTS_ENTRY(stg_SRT_5);
+RTS_ENTRY(stg_SRT_6);
+RTS_ENTRY(stg_SRT_7);
+RTS_ENTRY(stg_SRT_8);
+RTS_ENTRY(stg_SRT_9);
+RTS_ENTRY(stg_SRT_10);
+RTS_ENTRY(stg_SRT_11);
+RTS_ENTRY(stg_SRT_12);
+RTS_ENTRY(stg_SRT_13);
+RTS_ENTRY(stg_SRT_14);
+RTS_ENTRY(stg_SRT_15);
+RTS_ENTRY(stg_SRT_16);
 
 /* closures */
 
index 547a871..b77e162 100644 (file)
@@ -37,7 +37,11 @@ peekItbl a0 = do
   ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
   nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
   tipe'   <- (#peek struct StgInfoTable_, type) ptr
+#if __GLASGOW_HASKELL__ > 804
+  srtlen' <- (#peek struct StgInfoTable_, has_srt) a0
+#else
   srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr
+#endif
   return StgInfoTable
     { entry  = entry'
     , ptrs   = ptrs'
@@ -55,7 +59,11 @@ pokeItbl a0 itbl = do
   (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
   (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
   (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
+#if __GLASGOW_HASKELL__ > 804
+  (#poke StgInfoTable, has_srt) a0 (srtlen itbl)
+#else
   (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)
+#endif
 #if defined(TABLES_NEXT_TO_CODE)
   let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
   case code itbl of
index c250026..cf244f5 100644 (file)
@@ -34,7 +34,11 @@ peekItbl a0 = do
   ptrs'   <- (#peek struct StgInfoTable_, layout.payload.ptrs) ptr
   nptrs'  <- (#peek struct StgInfoTable_, layout.payload.nptrs) ptr
   tipe'   <- (#peek struct StgInfoTable_, type) ptr
+#if __GLASGOW_HASKELL__ > 804
+  srtlen' <- (#peek struct StgInfoTable_, has_srt) a0
+#else
   srtlen' <- (#peek struct StgInfoTable_, srt_bitmap) ptr
+#endif
   return StgInfoTable
     { entry  = entry'
     , ptrs   = ptrs'
@@ -52,7 +56,11 @@ pokeItbl a0 itbl = do
   (#poke StgInfoTable, layout.payload.ptrs) a0 (ptrs itbl)
   (#poke StgInfoTable, layout.payload.nptrs) a0 (nptrs itbl)
   (#poke StgInfoTable, type) a0 (fromEnum (tipe itbl))
+#if __GLASGOW_HASKELL__ > 804
+  (#poke StgInfoTable, has_srt) a0 (srtlen itbl)
+#else
   (#poke StgInfoTable, srt_bitmap) a0 (srtlen itbl)
+#endif
 #if defined(TABLES_NEXT_TO_CODE)
   let code_offset = a0 `plusPtr` (#offset StgInfoTable, code)
   case code itbl of
index 533c0c4..8946f9d 100644 (file)
@@ -367,7 +367,7 @@ rts_getBool (HaskellObj p)
     const StgInfoTable *info;
 
     info = get_itbl((const StgClosure *)UNTAG_CONST_CLOSURE(p));
-    if (info->srt_bitmap == 0) { // srt_bitmap is the constructor tag
+    if (info->has_srt == 0) { // has_srt is the constructor tag
         return 0;
     } else {
         return 1;
index 875a891..87fa98d 100644 (file)
       SymI_HasProto(stg_MUT_VAR_CLEAN_info)                             \
       SymI_HasProto(stg_MUT_VAR_DIRTY_info)                             \
       SymI_HasProto(stg_WEAK_info)                                      \
+      SymI_HasProto(stg_SRT_1_info)                                     \
+      SymI_HasProto(stg_SRT_2_info)                                     \
+      SymI_HasProto(stg_SRT_3_info)                                     \
+      SymI_HasProto(stg_SRT_4_info)                                     \
+      SymI_HasProto(stg_SRT_5_info)                                     \
+      SymI_HasProto(stg_SRT_6_info)                                     \
+      SymI_HasProto(stg_SRT_7_info)                                     \
+      SymI_HasProto(stg_SRT_8_info)                                     \
+      SymI_HasProto(stg_SRT_9_info)                                     \
+      SymI_HasProto(stg_SRT_10_info)                                    \
+      SymI_HasProto(stg_SRT_11_info)                                    \
+      SymI_HasProto(stg_SRT_12_info)                                    \
+      SymI_HasProto(stg_SRT_13_info)                                    \
+      SymI_HasProto(stg_SRT_14_info)                                    \
+      SymI_HasProto(stg_SRT_15_info)                                    \
+      SymI_HasProto(stg_SRT_16_info)                                    \
       SymI_HasProto(stg_ap_v_info)                                      \
       SymI_HasProto(stg_ap_f_info)                                      \
       SymI_HasProto(stg_ap_d_info)                                      \
index d3a232b..e645442 100644 (file)
@@ -507,7 +507,60 @@ CLOSURE(stg_END_STM_CHUNK_LIST_closure,stg_END_STM_CHUNK_LIST);
 CLOSURE(stg_NO_TREC_closure,stg_NO_TREC);
 
 /* ----------------------------------------------------------------------------
-   Messages
+   SRTs
+
+   See Note [SRTs] in compiler/cmm/CmmBuildInfoTable.hs
+   ------------------------------------------------------------------------- */
+
+INFO_TABLE_CONSTR(stg_SRT_1, 1, 0, 0, CONSTR, "SRT_1", "SRT_1")
+{ foreign "C" barf("SRT_1 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_2, 2, 0, 0, CONSTR, "SRT_2", "SRT_2")
+{ foreign "C" barf("SRT_2 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_3, 3, 0, 0, CONSTR, "SRT_3", "SRT_3")
+{ foreign "C" barf("SRT_3 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_4, 4, 0, 0, CONSTR, "SRT_4", "SRT_4")
+{ foreign "C" barf("SRT_4 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_5, 5, 0, 0, CONSTR, "SRT_5", "SRT_5")
+{ foreign "C" barf("SRT_5 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_6, 6, 0, 0, CONSTR, "SRT_6", "SRT_6")
+{ foreign "C" barf("SRT_6 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_7, 7, 0, 0, CONSTR, "SRT_7", "SRT_7")
+{ foreign "C" barf("SRT_7 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_8, 8, 0, 0, CONSTR, "SRT_8", "SRT_8")
+{ foreign "C" barf("SRT_8 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_9, 9, 0, 0, CONSTR, "SRT_9", "SRT_9")
+{ foreign "C" barf("SRT_9 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_10, 10, 0, 0, CONSTR, "SRT_10", "SRT_10")
+{ foreign "C" barf("SRT_10 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_11, 11, 0, 0, CONSTR, "SRT_11", "SRT_11")
+{ foreign "C" barf("SRT_11 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_12, 12, 0, 0, CONSTR, "SRT_12", "SRT_12")
+{ foreign "C" barf("SRT_12 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_13, 13, 0, 0, CONSTR, "SRT_13", "SRT_13")
+{ foreign "C" barf("SRT_13 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_14, 14, 0, 0, CONSTR, "SRT_14", "SRT_14")
+{ foreign "C" barf("SRT_14 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_15, 15, 0, 0, CONSTR, "SRT_15", "SRT_15")
+{ foreign "C" barf("SRT_15 object entered!") never returns; }
+
+INFO_TABLE_CONSTR(stg_SRT_16, 16, 0, 0, CONSTR, "SRT_16", "SRT_16")
+{ foreign "C" barf("SRT_16 object entered!") never returns; }
+
+/* ---------------------------------------------------------------------------   Messages
    ------------------------------------------------------------------------- */
 
 // PRIM rather than CONSTR, because PRIM objects cannot be duplicated by the GC.
index ec88ace..839859a 100644 (file)
@@ -522,13 +522,13 @@ loop:
       switch (info->type) {
 
       case THUNK_STATIC:
-          if (info->srt_bitmap != 0) {
+          if (info->has_srt != 0) {
               evacuate_static_object(THUNK_STATIC_LINK((StgClosure *)q), q);
           }
           return;
 
       case FUN_STATIC:
-          if (info->srt_bitmap != 0) {
+          if (info->has_srt != 0) {
               evacuate_static_object(FUN_STATIC_LINK((StgClosure *)q), q);
           }
           return;
index 55c941d..eef16b1 100644 (file)
@@ -329,105 +329,17 @@ scavenge_AP (StgAP *ap)
    Scavenge SRTs
    -------------------------------------------------------------------------- */
 
-/* Similar to scavenge_large_bitmap(), but we don't write back the
- * pointers we get back from evacuate().
- */
-static void
-scavenge_large_srt_bitmap( StgLargeSRT *large_srt )
-{
-    uint32_t i, j, size;
-    StgWord bitmap;
-    StgClosure **p;
-
-    size   = (uint32_t)large_srt->l.size;
-    p      = (StgClosure **)large_srt->srt;
-
-    for (i = 0; i < size / BITS_IN(W_); i++) {
-        bitmap = large_srt->l.bitmap[i];
-        // skip zero words: bitmaps can be very sparse, and this helps
-        // performance a lot in some cases.
-        if (bitmap != 0) {
-            for (j = 0; j < BITS_IN(W_); j++) {
-                if ((bitmap & 1) != 0) {
-                    evacuate(p);
-                }
-                p++;
-                bitmap = bitmap >> 1;
-            }
-        } else {
-            p += BITS_IN(W_);
-        }
-    }
-    if (size % BITS_IN(W_) != 0) {
-        bitmap = large_srt->l.bitmap[i];
-        for (j = 0; j < size % BITS_IN(W_); j++) {
-            if ((bitmap & 1) != 0) {
-                evacuate(p);
-            }
-            p++;
-            bitmap = bitmap >> 1;
-        }
-    }
-}
-
-/* evacuate the SRT.  If srt_bitmap is zero, then there isn't an
- * srt field in the info table.  That's ok, because we'll
- * never dereference it.
- */
-STATIC_INLINE GNUC_ATTR_HOT void
-scavenge_srt (StgClosure **srt, uint32_t srt_bitmap)
-{
-  uint32_t bitmap;
-  StgClosure **p;
-
-  bitmap = srt_bitmap;
-  p = srt;
-
-  if (bitmap == (StgHalfWord)(-1)) {
-      scavenge_large_srt_bitmap( (StgLargeSRT *)srt );
-      return;
-  }
-
-  while (bitmap != 0) {
-      if ((bitmap & 1) != 0) {
-#if defined(COMPILING_WINDOWS_DLL)
-          // Special-case to handle references to closures hiding out in DLLs, since
-          // double indirections required to get at those. The code generator knows
-          // which is which when generating the SRT, so it stores the (indirect)
-          // reference to the DLL closure in the table by first adding one to it.
-          // We check for this here, and undo the addition before evacuating it.
-          //
-          // If the SRT entry hasn't got bit 0 set, the SRT entry points to a
-          // closure that's fixed at link-time, and no extra magic is required.
-          if ( (W_)(*srt) & 0x1 ) {
-              evacuate( (StgClosure**) ((W_) (*srt) & ~0x1));
-          } else {
-              evacuate(p);
-          }
-#else
-          evacuate(p);
-#endif
-      }
-      p++;
-      bitmap = bitmap >> 1;
-  }
-}
-
-
 STATIC_INLINE GNUC_ATTR_HOT void
 scavenge_thunk_srt(const StgInfoTable *info)
 {
     StgThunkInfoTable *thunk_info;
-    uint32_t bitmap;
 
     if (!major_gc) return;
 
     thunk_info = itbl_to_thunk_itbl(info);
-    bitmap = thunk_info->i.srt_bitmap;
-    if (bitmap) {
-        // don't read srt_offset if bitmap==0, because it doesn't exist
-        // and so the memory might not be readable.
-        scavenge_srt((StgClosure **)GET_SRT(thunk_info), bitmap);
+    if (thunk_info->i.has_srt) {
+        StgClosure *srt = (StgClosure*)GET_SRT(thunk_info);
+        evacuate(&srt);
     }
 }
 
@@ -435,16 +347,13 @@ STATIC_INLINE GNUC_ATTR_HOT void
 scavenge_fun_srt(const StgInfoTable *info)
 {
     StgFunInfoTable *fun_info;
-    uint32_t bitmap;
 
     if (!major_gc) return;
 
     fun_info = itbl_to_fun_itbl(info);
-    bitmap = fun_info->i.srt_bitmap;
-    if (bitmap) {
-        // don't read srt_offset if bitmap==0, because it doesn't exist
-        // and so the memory might not be readable.
-        scavenge_srt((StgClosure **)GET_FUN_SRT(fun_info), bitmap);
+    if (fun_info->i.has_srt) {
+        StgClosure *srt = (StgClosure*)GET_FUN_SRT(fun_info);
+        evacuate(&srt);
     }
 }
 
@@ -1964,8 +1873,10 @@ scavenge_stack(StgPtr p, StgPtr stack_end)
         p = scavenge_small_bitmap(p, size, bitmap);
 
     follow_srt:
-        if (major_gc)
-            scavenge_srt((StgClosure **)GET_SRT(info), info->i.srt_bitmap);
+        if (major_gc && info->i.has_srt) {
+            StgClosure *srt = (StgClosure*)GET_SRT(info);
+            evacuate(&srt);
+        }
         continue;
 
     case RET_BCO: {
index 9a9a640..66aa51a 100644 (file)
@@ -112,7 +112,7 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do
     -- print parser errors or warnings
     mapM_ (printBagOfErrors dflags) [warningMsgs, errorMsgs]
 
-    let initTopSRT = initUs_ usa emptySRT
+    let initTopSRT = emptySRT thisMod
     cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fromJust parsedCmm
 
     rawCmms <- cmmToRawCmm dflags (Stream.yield cmmGroup)