CmmBuildInfoTables.hs 12.6 KB
Newer Older
1
{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
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
Ian Lynagh's avatar
Ian Lynagh committed
10 11
-- If this module lives on I'd like to get rid of the -XNoMonoLocalBinds
-- flag 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, localCAFInfo, mkTopCAFInfo
17
    , setInfoTableSRT
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
18
    , TopSRT, emptySRT, srtToData
19
    , bundleCAFs
Simon Marlow's avatar
Simon Marlow committed
20
    , cafTransfers )
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
21 22 23 24
where

#include "HsVersions.h"

25 26 27 28
-- These should not be imported here!
import StgCmmForeign
import StgCmmUtils

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
29 30 31
import Constants
import Digraph
import qualified Prelude as P
32
import Prelude hiding (succ)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
33 34 35 36 37
import Util (sortLe)

import BlockId
import Bitmap
import CLabel
38
import Cmm
39
import CmmUtils
40
import Module
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
41 42 43
import FastString
import ForeignCall
import IdInfo
Ian Lynagh's avatar
Ian Lynagh committed
44
import Data.List
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
45
import Maybes
46
import MkGraph as M
Ian Lynagh's avatar
Ian Lynagh committed
47
import Control.Monad
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
48
import Name
49
import OptimizationFuel
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
50
import Outputable
51
import Platform
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
52 53
import SMRep
import UniqSupply
54

Simon Marlow's avatar
Simon Marlow committed
55
import Hoopl
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
56

57 58
import Data.Map (Map)
import qualified Data.Map as Map
59 60
import Data.Set (Set)
import qualified Data.Set as Set
61 62
import qualified FiniteMap as Map

63 64 65 66 67 68
#if __GLASGOW_HASKELL__ < 704
foldSet = Set.fold
#else
foldSet = Set.foldr
#endif

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
----------------------------------------------------------------
-- 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).


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

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

-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
93 94 95
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')
96

97 98
cafTransfers :: Platform -> BwdTransfer CmmNode CAFSet
cafTransfers platform = mkBTransfer3 first middle last
99
  where first  _ live = live
100 101
        middle m live = foldExpDeep addCaf m live
        last   l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
102 103 104 105 106
        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
107
        add l s = if hasCAF l then Set.insert (toClosureLbl platform l) s
108
                              else s
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
109

110
cafAnal :: Platform -> CmmGraph -> CAFEnv
111
cafAnal platform g
Simon Marlow's avatar
Simon Marlow committed
112
    = dataflowAnalBwd g [] $ analBwd cafLattice (cafTransfers platform)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
113 114 115 116 117 118 119 120 121

-----------------------------------------------------------------------
-- 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]
122
                     , elt_map  :: Map CLabel Int }
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
123
                        -- map: CLabel -> its last entry in the table
124 125 126 127 128 129
instance PlatformOutputable TopSRT where
  pprPlatform platform (TopSRT lbl next elts eltmap) =
    text "TopSRT:" <+> pprPlatform platform lbl
                   <+> ppr next
                   <+> pprPlatform platform elts
                   <+> pprPlatform platform eltmap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
130 131 132 133

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

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

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

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

Simon Peyton Jones's avatar
Simon Peyton Jones committed
149
srtToData :: TopSRT -> CmmGroup
150
srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
151 152 153 154 155 156 157 158 159 160
    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.
161
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
162
             FuelUniqSM (TopSRT, Maybe CmmDecl, C_SRT)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
163
buildSRTs topSRT topCAFMap cafs =
164 165 166
  do let liftCAF lbl z = -- get CAFs for functions without static closures
           case Map.lookup lbl topCAFMap of Just cafs -> z `Set.union` cafs
                                            Nothing   -> Set.insert lbl z
167 168
         -- 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
169
         sub_srt topSRT localCafs =
170
           let cafs = Set.elems (foldSet liftCAF Set.empty localCafs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
171 172 173
               mkSRT topSRT =
                 do localSRTs <- procpointSRT (lbl topSRT) (elt_map topSRT) cafs
                    return (topSRT, localSRTs)
174
           in if length cafs > maxBmpSize then
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
175 176 177 178 179 180 181 182 183 184 185
                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
186
               farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
                                   (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.
204
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
205
                FuelUniqSM (Maybe CmmDecl, C_SRT)
206
procpointSRT _ _ [] =
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
207 208 209 210 211
 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
212
    ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
213 214 215 216 217 218 219 220 221 222
    sorted_ints = sortLe (<=) ints
    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.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
223
to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmDecl, C_SRT)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
224 225 226 227 228
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 $
229
                   Statics srt_desc_lbl $ map CmmStaticLit
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
230 231 232 233 234 235 236 237 238 239 240 241
                     ( 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.)
242
-- Any procedure referring to a non-static CAF c must keep live
243
-- any CAF that is reachable from c.
244 245 246
localCAFInfo :: Platform -> CAFEnv -> CmmDecl -> Maybe (CLabel, CAFSet)
localCAFInfo _        _      (CmmData _ _) = Nothing
localCAFInfo platform cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
247
  case info_tbl top_info of
248 249
    CmmInfoTable { cit_rep = rep } 
      | not (isStaticRep rep) 
250
      -> Just (toClosureLbl platform top_l,
251
               expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
252 253 254 255 256 257 258 259 260 261 262 263 264
    _ -> Nothing

-- 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.
265 266
mkTopCAFInfo :: [(CLabel, CAFSet)] -> Map CLabel CAFSet
mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
267
  where addToTop env (AcyclicSCC (l, cafset)) =
268
          Map.insert l (flatten env cafset) env
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
269 270
        addToTop env (CyclicSCC nodes) =
          let (lbls, cafsets) = unzip nodes
271
              cafset  = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
272
          in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
273
        flatten env cafset = foldSet (lookup env) Set.empty cafset
274
        lookup env caf cafset' =
275
          case Map.lookup caf env of Just cafs -> foldSet add cafset' cafs
276 277
                                     Nothing -> add caf cafset'
        add caf cafset' = Set.insert caf cafset'
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
278
        g = stronglyConnCompFromEdgedVertices
279
              (map (\n@(l, cafs) -> (n, l, Set.elems cafs)) localCAFs)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
280

281
-- Bundle the CAFs used at a procpoint.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
282
bundleCAFs :: CAFEnv -> CmmDecl -> (CAFSet, CmmDecl)
283 284
bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
  (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
285
bundleCAFs _ t = (Set.empty, t)
286

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
287
-- Construct the SRTs for the given procedure.
Simon Peyton Jones's avatar
Simon Peyton Jones committed
288 289
setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmDecl) ->
                   FuelUniqSM (TopSRT, [CmmDecl])
290
setInfoTableSRT topCAFMap topSRT (cafs, t) =
291 292
  setSRT cafs topCAFMap topSRT t

293
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
Simon Peyton Jones's avatar
Simon Peyton Jones committed
294
          CmmDecl -> FuelUniqSM (TopSRT, [CmmDecl])
295 296
setSRT cafs topCAFMap topSRT t =
  do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
297 298
     let t' = updInfo id (const srt) t
     case cafTable of
299
       Just tbl -> return (topSRT, [t', tbl])
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
300 301
       Nothing  -> return (topSRT, [t'])

302 303
type StackLayout = Liveness

Simon Peyton Jones's avatar
Simon Peyton Jones committed
304
updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmDecl -> CmmDecl
305 306 307 308 309
updInfo toVars toSrt (CmmProc top_info top_l g) =
  CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
updInfo _ _ t = t

updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
310 311 312 313 314
updInfoTbl toVars toSrt info_tbl@(CmmInfoTable {})
  = info_tbl { cit_srt = toSrt (cit_srt info_tbl)
             , cit_rep = case cit_rep info_tbl of
                           StackRep ls -> StackRep (toVars ls)
                           other       -> other }
315
updInfoTbl _ _ t@CmmNonInfoTable = t