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