diff options
Diffstat (limited to 'compiler/cmm/CmmBuildInfoTables.hs')
-rw-r--r-- | compiler/cmm/CmmBuildInfoTables.hs | 913 |
1 files changed, 617 insertions, 296 deletions
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 |