compiler/cmm/CmmBuildInfoTables.hs

   1 {-# LANGUAGE BangPatterns, CPP, GADTs #-}
   2
   3 module CmmBuildInfoTables
   4     ( CAFSet, CAFEnv, cafAnal
   5     , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
   6 where
   7
   8 #include "HsVersions.h"
   9
  10 import GhcPrelude hiding (succ)
  11
  12 import Hoopl.Block
  13 import Hoopl.Graph
  14 import Hoopl.Label
  15 import Hoopl.Collections
  16 import Hoopl.Dataflow
  17 import Digraph
  18 import Bitmap
  19 import CLabel
  20 import PprCmmDecl ()
  21 import Cmm
  22 import CmmUtils
  23 import CmmInfo
  24 import Data.List
  25 import DynFlags
  26 import Maybes
  27 import Outputable
  28 import SMRep
  29 import UniqSupply
  30 import Util
  31
  32 import PprCmm()
  33 import Data.Map (Map)
  34 import qualified Data.Map as Map
  35 import Data.Set (Set)
  36 import qualified Data.Set as Set
  37 import Control.Monad
  38
  39 foldSet :: (a -> b -> b) -> b -> Set a -> b
  40 foldSet = Set.foldr
  41
  42 -----------------------------------------------------------------------
  43 -- SRTs
  44
  45 {- EXAMPLE
  46
  47 f = \x. ... g ...
  48   where
  49     g = \y. ... h ... c1 ...
  50     h = \z. ... c2 ...
  51
  52 c1 & c2 are CAFs
  53
  54 g and h are local functions, but they have no static closures.  When
  55 we generate code for f, we start with a CmmGroup of four CmmDecls:
  56
  57    [ f_closure, f_entry, g_entry, h_entry ]
  58
  59 we process each CmmDecl separately in cpsTop, giving us a list of
  60 CmmDecls. e.g. for f_entry, we might end up with
  61
  62    [ f_entry, f1_ret, f2_proc ]
  63
  64 where f1_ret is a return point, and f2_proc is a proc-point.  We have
  65 a CAFSet for each of these CmmDecls, let's suppose they are
  66
  67    [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
  68    [ g_entry{h_closure, c1_closure} ]
  69    [ h_entry{c2_closure} ]
  70
  71 Now, note that we cannot use g_closure and h_closure in an SRT,
  72 because there are no static closures corresponding to these functions.
  73 So we have to flatten out the structure, replacing g_closure and
  74 h_closure with their contents:
  75
  76    [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
  77    [ g_entry{c2_closure, c1_closure} ]
  78    [ h_entry{c2_closure} ]
  79
  80 This is what flattenCAFSets is doing.
  81
  82 -}
  83
  84 -----------------------------------------------------------------------
  85 -- Finding the CAFs used by a procedure
  86
  87 type CAFSet = Set CLabel
  88 type CAFEnv = LabelMap CAFSet
  89
  90 cafLattice :: DataflowLattice CAFSet
  91 cafLattice = DataflowLattice Set.empty add
  92   where
  93     add (OldFact old) (NewFact new) =
  94         let !new' = old `Set.union` new
  95         in changedIf (Set.size new' > Set.size old) new'
  96
  97 cafTransfers :: TransferFun CAFSet
  98 cafTransfers (BlockCC eNode middle xNode) fBase =
  99     let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
 100         !result = foldNodesBwdOO cafsInNode middle joined
 101     in mapSingleton (entryLabel eNode) result
 102
 103 cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
 104 cafsInNode node set = foldExpDeep addCaf node set
 105   where
 106     addCaf expr !set =
 107         case expr of
 108             CmmLit (CmmLabel c) -> add c set
 109             CmmLit (CmmLabelOff c _) -> add c set
 110             CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
 111             _ -> set
 112     add l s | hasCAF l  = Set.insert (toClosureLbl l) s
 113             | otherwise = s
 114
 115 -- | An analysis to find live CAFs.
 116 cafAnal :: CmmGraph -> CAFEnv
 117 cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
 118
 119 -----------------------------------------------------------------------
 120 -- Building the SRTs
 121
 122 -- Description of the SRT for a given module.
 123 -- Note that this SRT may grow as we greedily add new CAFs to it.
 124 data TopSRT = TopSRT { lbl      :: CLabel
 125                      , next_elt :: Int -- the next entry in the table
 126                      , rev_elts :: [CLabel]
 127                      , elt_map  :: Map CLabel Int }
 128                         -- map: CLabel -> its last entry in the table
 129 instance Outputable TopSRT where
 130   ppr (TopSRT lbl next elts eltmap) =
 131     text "TopSRT:" <+> ppr lbl
 132                    <+> ppr next
 133                    <+> ppr elts
 134                    <+> ppr eltmap
 135
 136 emptySRT :: MonadUnique m => m TopSRT
 137 emptySRT =
 138   do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
 139      return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
 140
 141 isEmptySRT :: TopSRT -> Bool
 142 isEmptySRT srt = null (rev_elts srt)
 143
 144 cafMember :: TopSRT -> CLabel -> Bool
 145 cafMember srt lbl = Map.member lbl (elt_map srt)
 146
 147 cafOffset :: TopSRT -> CLabel -> Maybe Int
 148 cafOffset srt lbl = Map.lookup lbl (elt_map srt)
 149
 150 addCAF :: CLabel -> TopSRT -> TopSRT
 151 addCAF caf srt =
 152   srt { next_elt = last + 1
 153       , rev_elts = caf : rev_elts srt
 154       , elt_map  = Map.insert caf last (elt_map srt) }
 155     where last  = next_elt srt
 156
 157 srtToData :: TopSRT -> CmmGroup
 158 srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
 159     where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
 160           sec = Section RelocatableReadOnlyData (lbl srt)
 161
 162 -- Once we have found the CAFs, we need to do two things:
 163 -- 1. Build a table of all the CAFs used in the procedure.
 164 -- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
 165 --
 166 -- When building the local view of the SRT, we first make sure that all the CAFs are
 167 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
 168 -- we make sure they're all close enough to the bottom of the table that the
 169 -- bitmap will be able to cover all of them.
 170 buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
 171 buildSRT dflags topSRT cafs =
 172   do let
 173          -- For each label referring to a function f without a static closure,
 174          -- replace it with the CAFs that are reachable from f.
 175          sub_srt topSRT localCafs =
 176            let cafs = Set.elems localCafs
 177                mkSRT topSRT =
 178                  do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
 179                     return (topSRT, localSRTs)
 180            in if cafs `lengthExceeds` maxBmpSize dflags then
 181                 mkSRT (foldl add_if_missing topSRT cafs)
 182               else -- make sure all the cafs are near the bottom of the srt
 183                 mkSRT (add_if_too_far topSRT cafs)
 184          add_if_missing srt caf =
 185            if cafMember srt caf then srt else addCAF caf srt
 186          -- If a CAF is more than maxBmpSize entries from the young end of the
 187          -- SRT, then we add it to the SRT again.
 188          -- (Note: Not in the SRT => infinitely far.)
 189          add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
 190            add srt (sortBy farthestFst cafs)
 191              where
 192                farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
 193                                    (Nothing, Nothing) -> EQ
 194                                    (Nothing, Just _)  -> LT
 195                                    (Just _,  Nothing) -> GT
 196                                    (Just d, Just d')  -> compare d' d
 197                add srt [] = srt
 198                add srt@(TopSRT {next_elt = next}) (caf : rst) =
 199                  case cafOffset srt caf of
 200                    Just ix -> if next - ix > maxBmpSize dflags then
 201                                 add (addCAF caf srt) rst
 202                               else srt
 203                    Nothing -> add (addCAF caf srt) rst
 204      (topSRT, subSRTs) <- sub_srt topSRT cafs
 205      let (sub_tbls, blockSRTs) = subSRTs
 206      return (topSRT, sub_tbls, blockSRTs)
 207
 208 -- Construct an SRT bitmap.
 209 -- Adapted from simpleStg/SRT.hs, which expects Id's.
 210 procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
 211                 UniqSM (Maybe CmmDecl, C_SRT)
 212 procpointSRT _ _ _ [] =
 213  return (Nothing, NoC_SRT)
 214 procpointSRT dflags top_srt top_table entries =
 215  do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
 216     return (top, srt)
 217   where
 218     ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
 219     sorted_ints = sort ints
 220     offset = head sorted_ints
 221     bitmap_entries = map (subtract offset) sorted_ints
 222     len = GhcPrelude.last bitmap_entries + 1
 223     bitmap = intsToBitmap dflags len bitmap_entries
 224
 225 maxBmpSize :: DynFlags -> Int
 226 maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
 227
 228 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
 229 to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
 230 to_SRT dflags top_srt off len bmp
 231   | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
 232   = do id <- getUniqueM
 233        let srt_desc_lbl = mkLargeSRTLabel id
 234            section = Section RelocatableReadOnlyData srt_desc_lbl
 235            tbl = CmmData section $
 236                    Statics srt_desc_lbl $ map CmmStaticLit
 237                      ( cmmLabelOffW dflags top_srt off
 238                      : mkWordCLit dflags (fromIntegral len)
 239                      : map (mkStgWordCLit dflags) bmp)
 240        return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
 241   | otherwise
 242   = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
 243         -- The fromIntegral converts to StgHalfWord
 244
 245 -- Gather CAF info for a procedure, but only if the procedure
 246 -- doesn't have a static closure.
 247 -- (If it has a static closure, it will already have an SRT to
 248 --  keep its CAFs live.)
 249 -- Any procedure referring to a non-static CAF c must keep live
 250 -- any CAF that is reachable from c.
 251 localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
 252 localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
 253 localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
 254   case topInfoTable proc of
 255     Just (CmmInfoTable { cit_rep = rep })
 256       | not (isStaticRep rep) && not (isStackRep rep)
 257       -> (cafs, Just (toClosureLbl top_l))
 258     _other -> (cafs, Nothing)
 259   where
 260     cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
 261
 262 -- Once we have the local CAF sets for some (possibly) mutually
 263 -- recursive functions, we can create an environment mapping
 264 -- each function to its set of CAFs. Note that a CAF may
 265 -- be a reference to a function. If that function f does not have
 266 -- a static closure, then we need to refer specifically
 267 -- to the set of CAFs used by f. Of course, the set of CAFs
 268 -- used by f must be included in the local CAF sets that are input to
 269 -- this function. To minimize lookup time later, we return
 270 -- the environment with every reference to f replaced by its set of CAFs.
 271 -- To do this replacement efficiently, we gather strongly connected
 272 -- components, then we sort the components in topological order.
 273 mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
 274 mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
 275   where
 276         addToTop env (AcyclicSCC (l, cafset)) =
 277           Map.insert l (flatten env cafset) env
 278         addToTop env (CyclicSCC nodes) =
 279           let (lbls, cafsets) = unzip nodes
 280               cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
 281           in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
 282
 283         g = stronglyConnCompFromEdgedVerticesOrd
 284               [ DigraphNode (l,cafs) l (Set.elems cafs)
 285               | (cafs, Just l) <- localCAFs ]
 286
 287 flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
 288 flatten env cafset = foldSet (lookup env) Set.empty cafset
 289   where
 290       lookup env caf cafset' =
 291           case Map.lookup caf env of
 292              Just cafs -> foldSet Set.insert cafset' cafs
 293              Nothing   -> Set.insert caf cafset'
 294
 295 bundle :: Map CLabel CAFSet
 296        -> (CAFEnv, CmmDecl)
 297        -> (CAFSet, Maybe CLabel)
 298        -> (LabelMap CAFSet, CmmDecl)
 299 bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
 300   = ( mapMapWithKey get_cafs (info_tbls infos), decl )
 301  where
 302   entry = g_entry g
 303
 304   entry_cafs
 305     | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
 306     | otherwise        = flatten flatmap closure_cafs
 307
 308   get_cafs l _
 309     | l == entry = entry_cafs
 310     | Just info <- mapLookup l env = flatten flatmap info
 311     | otherwise  = Set.empty
 312     -- the label might not be in the env if the code corresponding to
 313     -- this info table was optimised away (perhaps because it was
 314     -- unreachable).  In this case it doesn't matter what SRT we
 315     -- infer, since the info table will not appear in the generated
 316     -- code.  See #9329.
 317
 318 bundle _flatmap (_, decl) _
 319   = ( mapEmpty, decl )
 320
 321
 322 flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
 323 flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
 324    where
 325      zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
 326      localCAFs = unzipWith localCAFInfo zipped
 327      flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
 328
 329 doSRTs :: DynFlags
 330        -> TopSRT
 331        -> [(CAFEnv, [CmmDecl])]
 332        -> IO (TopSRT, [CmmDecl])
 333
 334 doSRTs dflags topSRT tops
 335   = do
 336      let caf_decls = flattenCAFSets tops
 337      us <- mkSplitUniqSupply 'u'
 338      let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
 339      return (topSRT', reverse gs' {- Note [reverse gs] -})
 340   where
 341     setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
 342        (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
 343        let decl' = updInfoSRTs srt_env decl
 344        return (topSRT, decl': srt_tables ++ rst)
 345     setSRT (topSRT, rst) (_, decl) =
 346       return (topSRT, decl : rst)
 347
 348 buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
 349           -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
 350 buildSRTs dflags top_srt caf_map
 351   = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
 352   where
 353   doOne (top_srt, decls, srt_env) (l, cafs)
 354     = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
 355          return ( top_srt, maybeToList mb_decl ++ decls
 356                 , mapInsert l srt srt_env )
 357
 358 {-
 359 - In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
 360 - The one corresponding to g_entry is the closure info table, the
 361   rest are continuations.
 362 - Each one needs an SRT.
 363 - We get the CAFSet for each one from the CAFEnv
 364 - flatten gives us
 365     [(LabelMap CAFSet, CmmDecl)]
 366 -
 367 -}
 368
 369
 370 {- Note [reverse gs]
 371
 372    It is important to keep the code blocks in the same order,
 373    otherwise binary sizes get slightly bigger.  I'm not completely
 374    sure why this is, perhaps the assembler generates bigger jump
 375    instructions for forward refs.  --SDM
 376 -}
 377
 378 updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl
 379 updInfoSRTs srt_env (CmmProc top_info top_l live g) =
 380   CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
 381   where updInfoTbl l info_tbl
 382              = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
 383 updInfoSRTs _ t = t