CmmBuildInfoTables.hs 14.2 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
    ( CAFSet, CAFEnv, cafAnal
17
    , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
18
where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
19 20 21

#include "HsVersions.h"

22
import Hoopl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23 24 25 26
import Digraph
import BlockId
import Bitmap
import CLabel
Simon Marlow's avatar
Simon Marlow committed
27
import PprCmmDecl ()
28
import Cmm
29
import CmmUtils
Simon Marlow's avatar
Simon Marlow committed
30
import CmmInfo
Ian Lynagh's avatar
Ian Lynagh committed
31
import Data.List
32
import DynFlags
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
33 34 35 36
import Maybes
import Outputable
import SMRep
import UniqSupply
37
import Util
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
38

39 40
import Data.Map (Map)
import qualified Data.Map as Map
41 42
import Data.Set (Set)
import qualified Data.Set as Set
43
import Control.Monad
44

Simon Marlow's avatar
Simon Marlow committed
45 46 47
import qualified Prelude as P
import Prelude hiding (succ)

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
51 52 53
-----------------------------------------------------------------------
-- SRTs

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 80 81 82 83 84 85 86 87 88
{- 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} ]

89
This is what flattenCAFSets is doing.
90 91

-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
92 93 94 95

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

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

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

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

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

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

138 139 140
emptySRT :: MonadUnique m => m TopSRT
emptySRT =
  do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
141
     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
142

143 144 145
isEmptySRT :: TopSRT -> Bool
isEmptySRT srt = null (rev_elts srt)

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

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

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

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

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

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

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

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
282
        g = stronglyConnCompFromEdgedVertices
283 284 285 286 287 288 289 290 291 292 293 294 295
              [ ((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)
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311
       -> (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
312
bundle _flatmap (_, decl) _
313
  = ( mapEmpty, decl )
314

315 316

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

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

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

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


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

372 373 374 375 376 377
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