CmmBuildInfoTables.hs 14 KB
Newer Older
1
{-# LANGUAGE CPP, GADTs #-}
2

Jan Stolarek's avatar
Jan Stolarek committed
3
-- See Note [Deprecations in Hoopl] in Hoopl module
4
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
5
module CmmBuildInfoTables
6
    ( CAFSet, CAFEnv, cafAnal
7
    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
8
where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
9 10 11

#include "HsVersions.h"

12
import Hoopl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
13 14 15 16
import Digraph
import BlockId
import Bitmap
import CLabel
Simon Marlow's avatar
Simon Marlow committed
17
import PprCmmDecl ()
18
import Cmm
19
import CmmUtils
Simon Marlow's avatar
Simon Marlow committed
20
import CmmInfo
Ian Lynagh's avatar
Ian Lynagh committed
21
import Data.List
22
import DynFlags
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23 24 25 26
import Maybes
import Outputable
import SMRep
import UniqSupply
27
import Util
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
28

Simon Peyton Jones's avatar
Simon Peyton Jones committed
29
import PprCmm()
30 31
import Data.Map (Map)
import qualified Data.Map as Map
32 33
import Data.Set (Set)
import qualified Data.Set as Set
34
import Control.Monad
35

Simon Marlow's avatar
Simon Marlow committed
36 37 38
import qualified Prelude as P
import Prelude hiding (succ)

Simon Marlow's avatar
Simon Marlow committed
39
foldSet :: (a -> b -> b) -> b -> Set a -> b
40 41
foldSet = Set.foldr

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
42 43 44
-----------------------------------------------------------------------
-- SRTs

45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
{- EXAMPLE

f = \x. ... g ...
  where
    g = \y. ... h ... c1 ...
    h = \z. ... c2 ...

c1 & c2 are CAFs

g and h are local functions, but they have no static closures.  When
we generate code for f, we start with a CmmGroup of four CmmDecls:

   [ f_closure, f_entry, g_entry, h_entry ]

we process each CmmDecl separately in cpsTop, giving us a list of
CmmDecls. e.g. for f_entry, we might end up with

   [ f_entry, f1_ret, f2_proc ]

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} ]
   [ 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} ]

80
This is what flattenCAFSets is doing.
81 82

-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
83 84 85 86

-----------------------------------------------------------------------
-- Finding the CAFs used by a procedure

87
type CAFSet = Set CLabel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
88 89 90 91
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
92 93 94
cafLattice = DataflowLattice "live cafs" Set.empty add
  where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
                                              new' -> (changeIf $ Set.size new' > Set.size old, new')
95

96 97
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
98
  where first  _ live = live
99 100
        middle m live = foldExpDeep addCaf m live
        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
101 102 103 104 105
        addCaf e set = case e of
               CmmLit (CmmLabel c)              -> add c set
               CmmLit (CmmLabelOff c _)         -> add c set
               CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
               _ -> set
106
        add l s = if hasCAF l then Set.insert (toClosureLbl l) s
107
                              else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
108

Simon Marlow's avatar
Simon Marlow committed
109
cafAnal :: CmmGraph -> CAFEnv
110
cafAnal g = dataflowAnalBwd g [] cafLattice cafTransfers
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
111 112 113 114 115 116 117 118 119

-----------------------------------------------------------------------
-- 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 :: Int -- the next entry in the table
                     , rev_elts :: [CLabel]
120
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
121
                        -- map: CLabel -> its last entry in the table
Ian Lynagh's avatar
Ian Lynagh committed
122 123 124
instance Outputable TopSRT where
  ppr (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> ppr lbl
125
                   <+> ppr next
Ian Lynagh's avatar
Ian Lynagh committed
126 127
                   <+> ppr elts
                   <+> ppr eltmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
128

129 130 131
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
132
     return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
133

134 135 136
isEmptySRT :: TopSRT -> Bool
isEmptySRT srt = null (rev_elts srt)

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
137
cafMember :: TopSRT -> CLabel -> Bool
138
cafMember srt lbl = Map.member lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
139 140

cafOffset :: TopSRT -> CLabel -> Maybe Int
141
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
142 143 144 145 146

addCAF :: CLabel -> TopSRT -> TopSRT
addCAF caf srt =
  srt { next_elt = last + 1
      , rev_elts = caf : rev_elts srt
147
      , elt_map  = Map.insert caf last (elt_map srt) }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
148 149
    where last  = next_elt srt

Simon Peyton Jones's avatar
Simon Peyton Jones committed
150
srtToData :: TopSRT -> CmmGroup
151
srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
152
    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
153
          sec = Section RelocatableReadOnlyData (lbl srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
154 155 156 157 158

-- 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.
--
159
-- When building the local view of the SRT, we first make sure that all the CAFs are
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
160 161 162
-- 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.
163 164
buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT dflags topSRT cafs =
165
  do let
166 167
         -- For each label referring to a function f without a static closure,
         -- replace it with the CAFs that are reachable from f.
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
168
         sub_srt topSRT localCafs =
169
           let cafs = Set.elems localCafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
170
               mkSRT topSRT =
171
                 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
172
                    return (topSRT, localSRTs)
173
           in if length cafs > maxBmpSize dflags then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
174 175 176 177 178 179 180 181 182 183 184
                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
185
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
186 187 188 189 190 191 192
                                   (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
193
                   Just ix -> if next - ix > maxBmpSize dflags then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
194 195 196 197 198 199 200 201
                                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.
202
-- Adapted from simpleStg/SRT.hs, which expects Id's.
203
procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
204
                UniqSM (Maybe CmmDecl, C_SRT)
205
procpointSRT _ _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
206
 return (Nothing, NoC_SRT)
207 208
procpointSRT dflags top_srt top_table entries =
 do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
209 210
    return (top, srt)
  where
211
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
Ian Lynagh's avatar
Ian Lynagh committed
212
    sorted_ints = sort ints
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
213 214 215
    offset = head sorted_ints
    bitmap_entries = map (subtract offset) sorted_ints
    len = P.last bitmap_entries + 1
216
    bitmap = intsToBitmap dflags len bitmap_entries
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
217

218 219
maxBmpSize :: DynFlags -> Int
maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
220 221

-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
222 223
to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT dflags top_srt off len bmp
Simon Marlow's avatar
Simon Marlow committed
224
  | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
225 226
  = do id <- getUniqueM
       let srt_desc_lbl = mkLargeSRTLabel id
227 228
           section = Section RelocatableReadOnlyData srt_desc_lbl
           tbl = CmmData section $
229
                   Statics srt_desc_lbl $ map CmmStaticLit
230
                     ( cmmLabelOffW dflags top_srt off
231 232
                     : mkWordCLit dflags (fromIntegral len)
                     : map (mkStgWordCLit dflags) bmp)
Simon Marlow's avatar
Simon Marlow committed
233
       return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
234
  | otherwise
235
  = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
236
        -- The fromIntegral converts to StgHalfWord
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
237 238 239 240 241

-- 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.)
242
-- Any procedure referring to a non-static CAF c must keep live
243
-- any CAF that is reachable from c.
244 245
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
246
localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
247
  case topInfoTable proc of
248 249
    Just (CmmInfoTable { cit_rep = rep })
      | not (isStaticRep rep) && not (isStackRep rep)
250 251 252 253
      -> (cafs, Just (toClosureLbl top_l))
    _other -> (cafs, Nothing)
  where
    cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
254 255 256 257 258 259 260 261 262 263 264 265

-- 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.
266
mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
267
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
268 269
  where
        addToTop env (AcyclicSCC (l, cafset)) =
270
          Map.insert l (flatten env cafset) env
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
271 272
        addToTop env (CyclicSCC nodes) =
          let (lbls, cafsets) = unzip nodes
273
              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
274
          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
275

niteria's avatar
niteria committed
276
        g = stronglyConnCompFromEdgedVerticesOrd
277 278 279 280 281 282 283 284 285 286 287 288 289
              [ ((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)
290
       -> (BlockEnv CAFSet, CmmDecl)
291
bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
292 293 294 295 296 297 298 299 300 301
  = ( mapMapWithKey get_cafs (info_tbls infos), decl )
 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
302 303 304 305 306 307 308
    | 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.
309

Simon Marlow's avatar
Simon Marlow committed
310
bundle _flatmap (_, decl) _
311
  = ( mapEmpty, decl )
312

313 314

flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
315 316
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
   where
317
     zipped    = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
318 319 320
     localCAFs = unzipWith localCAFInfo zipped
     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs

321 322
doSRTs :: DynFlags
       -> TopSRT
323 324 325
       -> [(CAFEnv, [CmmDecl])]
       -> IO (TopSRT, [CmmDecl])

326
doSRTs dflags topSRT tops
327 328 329 330 331 332
  = 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
333
    setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
334
       (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
335 336
       let decl' = updInfoSRTs srt_env decl
       return (topSRT, decl': srt_tables ++ rst)
337 338 339
    setSRT (topSRT, rst) (_, decl) =
      return (topSRT, decl : rst)

340
buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
341
          -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
342
buildSRTs dflags top_srt caf_map
343 344 345
  = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
  where
  doOne (top_srt, decls, srt_env) (l, cafs)
346
    = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
347 348 349 350 351 352 353 354 355 356 357 358 359 360 361
         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
    [(BlockEnv CAFSet, CmmDecl)]
-
-}


362 363 364 365 366 367 368 369
{- Note [reverse gs]

   It is important to keep the code blocks in the same order,
   otherwise binary sizes get slightly bigger.  I'm not completely
   sure why this is, perhaps the assembler generates bigger jump
   instructions for forward refs.  --SDM
-}

370
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
371 372
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
373 374 375
  where updInfoTbl l info_tbl
             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t