CmmBuildInfoTables.hs 14.1 KB
Newer Older
1
{-# LANGUAGE GADTs, NoMonoLocalBinds #-}
Ian Lynagh's avatar
Ian Lynagh committed
2 3 4 5 6 7 8
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

9
-- Norman likes local bindings
10 11
-- If this module lives on I'd like to get rid of the NoMonoLocalBinds
-- extension in due course
12

Ian Lynagh's avatar
Ian Lynagh committed
13
-- Todo: remove -fno-warn-warnings-deprecations
14
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
15
module CmmBuildInfoTables
16 17 18
    ( CAFSet, CAFEnv, cafAnal
    , doSRTs, TopSRT, emptySRT, srtToData )
where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
19 20 21

#include "HsVersions.h"

22 23
-- These should not be imported here!
import StgCmmUtils
24
import Hoopl
25

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
26 27
import Digraph
import qualified Prelude as P
28
import Prelude hiding (succ)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
29 30 31 32

import BlockId
import Bitmap
import CLabel
33
import Cmm
34
import CmmUtils
Ian Lynagh's avatar
Ian Lynagh committed
35
import Data.List
36
import DynFlags
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
37
import Maybes
38
import Module
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
39 40 41
import Outputable
import SMRep
import UniqSupply
42
import Util
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
43

44 45
import Data.Map (Map)
import qualified Data.Map as Map
46 47
import Data.Set (Set)
import qualified Data.Set as Set
48
import Control.Monad
49

Simon Marlow's avatar
Simon Marlow committed
50
foldSet :: (a -> b -> b) -> b -> Set a -> b
51 52
foldSet = Set.foldr

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
53 54 55
-----------------------------------------------------------------------
-- SRTs

56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90
{- 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} ]

91
This is what flattenCAFSets is doing.
92 93

-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
94 95 96 97

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

98
type CAFSet = Set CLabel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
99 100 101 102
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
103 104 105
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')
106

107 108
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
109
  where first  _ live = live
110 111
        middle m live = foldExpDeep addCaf m live
        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
112 113 114 115 116
        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
117
        add l s = if hasCAF l then Set.insert (toClosureLbl l) s
118
                              else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
119

Simon Marlow's avatar
Simon Marlow committed
120
cafAnal :: CmmGraph -> CAFEnv
121
cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
122 123 124 125 126 127 128 129 130

-----------------------------------------------------------------------
-- 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]
131
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
132
                        -- map: CLabel -> its last entry in the table
Ian Lynagh's avatar
Ian Lynagh committed
133 134 135
instance Outputable TopSRT where
  ppr (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> ppr lbl
136
                   <+> ppr next
Ian Lynagh's avatar
Ian Lynagh committed
137 138
                   <+> ppr elts
                   <+> ppr eltmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
139

140 141 142
emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
emptySRT mb_mod =
  do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
143
     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
144 145

cafMember :: TopSRT -> CLabel -> Bool
146
cafMember srt lbl = Map.member lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
147 148

cafOffset :: TopSRT -> CLabel -> Maybe Int
149
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
150 151 152 153 154

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
158
srtToData :: TopSRT -> CmmGroup
159
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
160 161 162 163 164 165 166 167 168 169
    where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts 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.
170 171
buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRT dflags topSRT cafs =
172
  do let
173 174
         -- 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
175
         sub_srt topSRT localCafs =
176
           let cafs = Set.elems localCafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
177
               mkSRT topSRT =
178
                 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
179
                    return (topSRT, localSRTs)
180
           in if length cafs > maxBmpSize dflags then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
181 182 183 184 185 186 187 188 189 190 191
                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
192
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
193 194 195 196 197 198 199
                                   (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
200
                   Just ix -> if next - ix > maxBmpSize dflags then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
201 202 203 204 205 206 207 208 209
                                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.lhs, which expects Id's.
210
procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
211
                UniqSM (Maybe CmmDecl, C_SRT)
212
procpointSRT _ _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
213
 return (Nothing, NoC_SRT)
214 215
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
216 217
    return (top, srt)
  where
218
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
Ian Lynagh's avatar
Ian Lynagh committed
219
    sorted_ints = sort ints
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
220 221 222
    offset = head sorted_ints
    bitmap_entries = map (subtract offset) sorted_ints
    len = P.last bitmap_entries + 1
223
    bitmap = intsToBitmap dflags len bitmap_entries
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
224

225 226
maxBmpSize :: DynFlags -> Int
maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
227 228

-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
229 230
to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
to_SRT dflags top_srt off len bmp
231
  | len > maxBmpSize dflags || bmp == [fromInteger (fromStgHalfWord (srt_escape dflags))]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
232 233 234
  = do id <- getUniqueM
       let srt_desc_lbl = mkLargeSRTLabel id
           tbl = CmmData RelocatableReadOnlyData $
235
                   Statics srt_desc_lbl $ map CmmStaticLit
236
                     ( cmmLabelOffW dflags top_srt off
237 238
                     : mkWordCLit dflags (fromIntegral len)
                     : map (mkWordCLit dflags) bmp)
239
       return (Just tbl, C_SRT srt_desc_lbl 0 (srt_escape dflags))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
240
  | otherwise
241
  = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (toInteger (head bmp))))
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
242 243 244 245 246 247
	-- 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.)
248
-- Any procedure referring to a non-static CAF c must keep live
249
-- any CAF that is reachable from c.
250 251
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
252 253 254
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
  case topInfoTable proc of
    Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
255 256 257 258
      -> (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
259 260 261 262 263 264 265 266 267 268 269 270

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
281
        g = stronglyConnCompFromEdgedVertices
282 283 284 285 286 287 288 289 290 291 292 293 294
              [ ((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)
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310
       -> (BlockEnv CAFSet, CmmDecl)
bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
  = ( 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
    | otherwise  = if not (mapMember l env)
                      then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
                      else flatten flatmap $ expectJust "bundle" $ mapLookup l env

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

314 315

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

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

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

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


363 364 365 366 367 368 369 370
{- 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
-}

371 372 373 374 375 376
updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
updInfoSRTs srt_env (CmmProc top_info top_l g) =
  CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
  where updInfoTbl l info_tbl
             = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
updInfoSRTs _ t = t