summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/cmm/CLabel.hs55
-rw-r--r--compiler/cmm/Cmm.hs14
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs913
-rw-r--r--compiler/cmm/CmmInfo.hs9
-rw-r--r--compiler/cmm/CmmParse.y12
-rw-r--r--compiler/cmm/CmmPipeline.hs21
-rw-r--r--compiler/cmm/Hoopl/Dataflow.hs6
-rw-r--r--compiler/cmm/PprCmm.hs2
-rw-r--r--compiler/cmm/PprCmmDecl.hs17
-rw-r--r--compiler/codeGen/StgCmmClosure.hs10
-rw-r--r--compiler/main/HscMain.hs20
-rw-r--r--compiler/stgSyn/CoreToStg.hs9
-rw-r--r--includes/rts/storage/ClosureMacros.h2
-rw-r--r--includes/rts/storage/InfoTables.h53
-rw-r--r--includes/stg/MiscClosures.h16
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc8
-rw-r--r--rts/RtsAPI.c2
-rw-r--r--rts/RtsSymbols.c16
-rw-r--r--rts/StgMiscClosures.cmm55
-rw-r--r--rts/sm/Evac.c4
-rw-r--r--rts/sm/Scav.c109
-rw-r--r--testsuite/tests/regalloc/regalloc_unit_tests.hs2
22 files changed, 817 insertions, 538 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]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
index be1569ba8e..2b78ab44b8 100644
--- a/includes/rts/storage/ClosureMacros.h
+++ b/includes/rts/storage/ClosureMacros.h
@@ -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;
}
/* -----------------------------------------------------------------------------
diff --git a/includes/rts/storage/InfoTables.h b/includes/rts/storage/InfoTables.h
index c621e5e749..0e25e14c8e 100644
--- a/includes/rts/storage/InfoTables.h
+++ b/includes/rts/storage/InfoTables.h
@@ -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
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 1fbfab9fbe..758ec1f51e 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -153,6 +153,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 */
diff --git a/libraries/ghci/GHCi/InfoTable.hsc b/libraries/ghci/GHCi/InfoTable.hsc
index d650e246ba..d5e50c2dff 100644
--- a/libraries/ghci/GHCi/InfoTable.hsc
+++ b/libraries/ghci/GHCi/InfoTable.hsc
@@ -57,7 +57,11 @@ peekItbl a0 = do
ptrs' <- (#peek StgInfoTable, layout.payload.ptrs) a0
nptrs' <- (#peek StgInfoTable, layout.payload.nptrs) a0
tipe' <- (#peek StgInfoTable, type) a0
+#if __GLASGOW_HASKELL__ > 804
+ srtlen' <- (#peek StgInfoTable, has_srt) a0
+#else
srtlen' <- (#peek StgInfoTable, srt_bitmap) a0
+#endif
return StgInfoTable
{ entry = entry'
, ptrs = ptrs'
@@ -393,7 +397,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 (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
diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c
index 533c0c41d4..8946f9d840 100644
--- a/rts/RtsAPI.c
+++ b/rts/RtsAPI.c
@@ -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;
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index aa95660945..4952f013f7 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -776,6 +776,22 @@
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) \
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index 9fd5fb8b88..c307293cce 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -518,7 +518,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.
diff --git a/rts/sm/Evac.c b/rts/sm/Evac.c
index 06648c3de9..198c37d5a9 100644
--- a/rts/sm/Evac.c
+++ b/rts/sm/Evac.c
@@ -536,13 +536,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;
diff --git a/rts/sm/Scav.c b/rts/sm/Scav.c
index 8b4c80e7e2..1bee05221a 100644
--- a/rts/sm/Scav.c
+++ b/rts/sm/Scav.c
@@ -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);
}
}
@@ -1979,8 +1888,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: {
diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs
index 9a9a640d5d..66aa51a050 100644
--- a/testsuite/tests/regalloc/regalloc_unit_tests.hs
+++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs
@@ -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)
View Lorry Controller Status