CmmBuildInfoTables.hs 13.4 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
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
35
import IdInfo
Ian Lynagh's avatar
Ian Lynagh committed
36
import Data.List
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
37 38 39 40 41
import Maybes
import Name
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 56 57 58 59 60 61 62 63 64 65 66 67
----------------------------------------------------------------
-- Building InfoTables


-----------------------------------------------------------------------
-- SRTs

-- WE NEED AN EXAMPLE HERE.
-- IN PARTICULAR, WE NEED TO POINT OUT THE DISTINCTION BETWEEN
-- FUNCTIONS WITH STATIC CLOSURES AND THOSE THAT MUST BE CONSTRUCTED
-- DYNAMICALLY (AND HENCE CAN'T BE REFERENCED IN AN SRT).
-- IN THE LATTER CASE, WE HAVE TO TAKE ALL THE CAFs REFERENCED BY
-- THE CLOSURE AND INLINE THEM INTO ANY SRT THAT MAY MENTION THE CLOSURE.
-- (I.E. TAKE THE TRANSITIVE CLOSURE, but only for non-static closures).

68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
{- 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} ]

This is what mkTopCAFInfo is doing.

-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
106 107 108 109

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

110
type CAFSet = Set CLabel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
111 112 113 114
type CAFEnv = BlockEnv CAFSet

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
115 116 117
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')
118

119 120
cafTransfers :: BwdTransfer CmmNode CAFSet
cafTransfers = mkBTransfer3 first middle last
121
  where first  _ live = live
122 123
        middle m live = foldExpDeep addCaf m live
        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
124 125 126 127 128
        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
129
        add l s = if hasCAF l then Set.insert (toClosureLbl l) s
130
                              else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
131

Simon Marlow's avatar
Simon Marlow committed
132
cafAnal :: CmmGraph -> CAFEnv
133
cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
134 135 136 137 138 139 140 141 142

-----------------------------------------------------------------------
-- 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]
143
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
144
                        -- map: CLabel -> its last entry in the table
Ian Lynagh's avatar
Ian Lynagh committed
145 146 147
instance Outputable TopSRT where
  ppr (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> ppr lbl
148
                   <+> ppr next
Ian Lynagh's avatar
Ian Lynagh committed
149 150
                   <+> ppr elts
                   <+> ppr eltmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
151 152 153 154

emptySRT :: MonadUnique m => m TopSRT
emptySRT =
  do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") NoCafRefs
155
     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
156 157

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

cafOffset :: TopSRT -> CLabel -> Maybe Int
161
cafOffset srt lbl = Map.lookup lbl (elt_map srt)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
162 163 164 165 166

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
170
srtToData :: TopSRT -> CmmGroup
171
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
172 173 174 175 176 177 178 179 180 181
    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.
182 183 184
buildSRTs :: TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
buildSRTs topSRT cafs =
  do let
185 186
         -- 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
187
         sub_srt topSRT localCafs =
188
           let cafs = Set.elems localCafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
189 190 191
               mkSRT topSRT =
                 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                    return (topSRT, localSRTs)
192
           in if length cafs > maxBmpSize then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
193 194 195 196 197 198 199 200 201 202 203
                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
204
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221
                                   (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 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.lhs, which expects Id's.
222
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
223
                UniqSM (Maybe CmmDecl, C_SRT)
224
procpointSRT _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
225 226 227 228 229
 return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
 do (top, srt) <- bitmap `seq` to_SRT top_srt offset len bitmap
    return (top, srt)
  where
230
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
Ian Lynagh's avatar
Ian Lynagh committed
231
    sorted_ints = sort ints
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
232 233 234 235 236 237 238 239 240
    offset = head sorted_ints
    bitmap_entries = map (subtract offset) sorted_ints
    len = P.last bitmap_entries + 1
    bitmap = intsToBitmap len bitmap_entries

maxBmpSize :: Int
maxBmpSize = widthInBits wordWidth `div` 2

-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
241
to_SRT :: CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
242 243 244 245 246
to_SRT top_srt off len bmp
  | len > maxBmpSize || bmp == [fromIntegral srt_escape]
  = do id <- getUniqueM
       let srt_desc_lbl = mkLargeSRTLabel id
           tbl = CmmData RelocatableReadOnlyData $
247
                   Statics srt_desc_lbl $ map CmmStaticLit
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
248 249 250 251 252 253 254 255 256 257 258 259
                     ( cmmLabelOffW top_srt off
                     : mkWordCLit (fromIntegral len)
                     : map mkWordCLit bmp)
       return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
  | otherwise
  = return (Nothing, C_SRT top_srt off (fromIntegral (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.)
260
-- Any procedure referring to a non-static CAF c must keep live
261
-- any CAF that is reachable from c.
262 263
localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
264
localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
265
  case info_tbl top_info of
266 267 268 269 270
    CmmInfoTable { cit_rep = rep } | not (isStaticRep rep)
      -> (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
271 272 273 274 275 276 277 278 279 280 281 282

-- 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.
283
mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
284
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
285 286
  where
        addToTop env (AcyclicSCC (l, cafset)) =
287
          Map.insert l (flatten env cafset) env
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
288 289
        addToTop env (CyclicSCC nodes) =
          let (lbls, cafsets) = unzip nodes
290
              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
291
          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
292

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
293
        g = stronglyConnCompFromEdgedVertices
294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356
              [ ((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)
       -> (CAFSet, CmmDecl)
bundle flatmap (_, decl) (cafs, Nothing)
  = (flatten flatmap cafs, decl)
bundle flatmap (_, decl) (_, Just l)
  = (expectJust "bundle" $ Map.lookup l flatmap, decl)

flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(CAFSet, CmmDecl)]
flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
   where
     zipped    = [(e,d) | (e,ds) <- cpsdecls, d <- ds ]
     localCAFs = unzipWith localCAFInfo zipped
     flatmap   = mkTopCAFInfo localCAFs -- transitive closure of localCAFs

doSRTs :: TopSRT
       -> [(CAFEnv, [CmmDecl])]
       -> IO (TopSRT, [CmmDecl])

doSRTs 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) (cafs, decl@(CmmProc{})) = do
       (topSRT, cafTable, srt) <- buildSRTs topSRT cafs
       let decl' = updInfo (const srt) decl
       case cafTable of
         Just tbl -> return (topSRT, decl': tbl : rst)
         Nothing  -> return (topSRT, decl' : rst)
    setSRT (topSRT, rst) (_, decl) =
      return (topSRT, decl : rst)

{- 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
-}

updInfo :: (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
updInfo toSrt (CmmProc top_info top_l g) =
  CmmProc (top_info {info_tbl = updInfoTbl toSrt (info_tbl top_info)}) top_l g
updInfo _ t = t

updInfoTbl :: (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
updInfoTbl toSrt info_tbl@(CmmInfoTable {})
  = info_tbl { cit_srt = toSrt (cit_srt info_tbl) }
updInfoTbl _ t@CmmNonInfoTable = t