af3a092a938be33648c902086614ed050b86ccd9
[ghc.git] / compiler / cmm / CmmBuildInfoTables.hs
1 {-# LANGUAGE BangPatterns, CPP, GADTs #-}
2
3 module CmmBuildInfoTables
4 ( CAFSet, CAFEnv, cafAnal
5 , doSRTs, TopSRT, emptySRT, isEmptySRT, srtToData )
6 where
7
8 #include "HsVersions.h"
9
10 import Hoopl
11 import Digraph
12 import Bitmap
13 import CLabel
14 import PprCmmDecl ()
15 import Cmm
16 import CmmUtils
17 import CmmInfo
18 import Data.List
19 import DynFlags
20 import Maybes
21 import Outputable
22 import SMRep
23 import UniqSupply
24 import Util
25
26 import PprCmm()
27 import Data.Map (Map)
28 import qualified Data.Map as Map
29 import Data.Set (Set)
30 import qualified Data.Set as Set
31 import Control.Monad
32
33 import qualified Prelude as P
34 import Prelude hiding (succ)
35
36 foldSet :: (a -> b -> b) -> b -> Set a -> b
37 foldSet = Set.foldr
38
39 -----------------------------------------------------------------------
40 -- SRTs
41
42 {- EXAMPLE
43
44 f = \x. ... g ...
45 where
46 g = \y. ... h ... c1 ...
47 h = \z. ... c2 ...
48
49 c1 & c2 are CAFs
50
51 g and h are local functions, but they have no static closures. When
52 we generate code for f, we start with a CmmGroup of four CmmDecls:
53
54 [ f_closure, f_entry, g_entry, h_entry ]
55
56 we process each CmmDecl separately in cpsTop, giving us a list of
57 CmmDecls. e.g. for f_entry, we might end up with
58
59 [ f_entry, f1_ret, f2_proc ]
60
61 where f1_ret is a return point, and f2_proc is a proc-point. We have
62 a CAFSet for each of these CmmDecls, let's suppose they are
63
64 [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
65 [ g_entry{h_closure, c1_closure} ]
66 [ h_entry{c2_closure} ]
67
68 Now, note that we cannot use g_closure and h_closure in an SRT,
69 because there are no static closures corresponding to these functions.
70 So we have to flatten out the structure, replacing g_closure and
71 h_closure with their contents:
72
73 [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
74 [ g_entry{c2_closure, c1_closure} ]
75 [ h_entry{c2_closure} ]
76
77 This is what flattenCAFSets is doing.
78
79 -}
80
81 -----------------------------------------------------------------------
82 -- Finding the CAFs used by a procedure
83
84 type CAFSet = Set CLabel
85 type CAFEnv = LabelMap CAFSet
86
87 cafLattice :: DataflowLattice CAFSet
88 cafLattice = DataflowLattice Set.empty add
89 where
90 add (OldFact old) (NewFact new) =
91 let !new' = old `Set.union` new
92 in changedIf (Set.size new' > Set.size old) new'
93
94 cafTransfers :: TransferFun CAFSet
95 cafTransfers (BlockCC eNode middle xNode) fBase =
96 let joined = cafsInNode xNode $! joinOutFacts cafLattice xNode fBase
97 !result = foldNodesBwdOO cafsInNode middle joined
98 in mapSingleton (entryLabel eNode) result
99
100 cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
101 cafsInNode node set = foldExpDeep addCaf node set
102 where
103 addCaf expr !set =
104 case expr of
105 CmmLit (CmmLabel c) -> add c set
106 CmmLit (CmmLabelOff c _) -> add c set
107 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $! add c2 set
108 _ -> set
109 add l s | hasCAF l = Set.insert (toClosureLbl l) s
110 | otherwise = s
111
112 -- | An analysis to find live CAFs.
113 cafAnal :: CmmGraph -> CAFEnv
114 cafAnal cmmGraph = analyzeCmmBwd cafLattice cafTransfers cmmGraph mapEmpty
115
116 -----------------------------------------------------------------------
117 -- Building the SRTs
118
119 -- Description of the SRT for a given module.
120 -- Note that this SRT may grow as we greedily add new CAFs to it.
121 data TopSRT = TopSRT { lbl :: CLabel
122 , next_elt :: Int -- the next entry in the table
123 , rev_elts :: [CLabel]
124 , elt_map :: Map CLabel Int }
125 -- map: CLabel -> its last entry in the table
126 instance Outputable TopSRT where
127 ppr (TopSRT lbl next elts eltmap) =
128 text "TopSRT:" <+> ppr lbl
129 <+> ppr next
130 <+> ppr elts
131 <+> ppr eltmap
132
133 emptySRT :: MonadUnique m => m TopSRT
134 emptySRT =
135 do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
136 return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
137
138 isEmptySRT :: TopSRT -> Bool
139 isEmptySRT srt = null (rev_elts srt)
140
141 cafMember :: TopSRT -> CLabel -> Bool
142 cafMember srt lbl = Map.member lbl (elt_map srt)
143
144 cafOffset :: TopSRT -> CLabel -> Maybe Int
145 cafOffset srt lbl = Map.lookup lbl (elt_map srt)
146
147 addCAF :: CLabel -> TopSRT -> TopSRT
148 addCAF caf srt =
149 srt { next_elt = last + 1
150 , rev_elts = caf : rev_elts srt
151 , elt_map = Map.insert caf last (elt_map srt) }
152 where last = next_elt srt
153
154 srtToData :: TopSRT -> CmmGroup
155 srtToData srt = [CmmData sec (Statics (lbl srt) tbl)]
156 where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
157 sec = Section RelocatableReadOnlyData (lbl srt)
158
159 -- Once we have found the CAFs, we need to do two things:
160 -- 1. Build a table of all the CAFs used in the procedure.
161 -- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint.
162 --
163 -- When building the local view of the SRT, we first make sure that all the CAFs are
164 -- in the SRT. Then, if the number of CAFs is small enough to fit in a bitmap,
165 -- we make sure they're all close enough to the bottom of the table that the
166 -- bitmap will be able to cover all of them.
167 buildSRT :: DynFlags -> TopSRT -> CAFSet -> UniqSM (TopSRT, Maybe CmmDecl, C_SRT)
168 buildSRT dflags topSRT cafs =
169 do let
170 -- For each label referring to a function f without a static closure,
171 -- replace it with the CAFs that are reachable from f.
172 sub_srt topSRT localCafs =
173 let cafs = Set.elems localCafs
174 mkSRT topSRT =
175 do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
176 return (topSRT, localSRTs)
177 in if length cafs > maxBmpSize dflags then
178 mkSRT (foldl add_if_missing topSRT cafs)
179 else -- make sure all the cafs are near the bottom of the srt
180 mkSRT (add_if_too_far topSRT cafs)
181 add_if_missing srt caf =
182 if cafMember srt caf then srt else addCAF caf srt
183 -- If a CAF is more than maxBmpSize entries from the young end of the
184 -- SRT, then we add it to the SRT again.
185 -- (Note: Not in the SRT => infinitely far.)
186 add_if_too_far srt@(TopSRT {elt_map = m}) cafs =
187 add srt (sortBy farthestFst cafs)
188 where
189 farthestFst x y = case (Map.lookup x m, Map.lookup y m) of
190 (Nothing, Nothing) -> EQ
191 (Nothing, Just _) -> LT
192 (Just _, Nothing) -> GT
193 (Just d, Just d') -> compare d' d
194 add srt [] = srt
195 add srt@(TopSRT {next_elt = next}) (caf : rst) =
196 case cafOffset srt caf of
197 Just ix -> if next - ix > maxBmpSize dflags then
198 add (addCAF caf srt) rst
199 else srt
200 Nothing -> add (addCAF caf srt) rst
201 (topSRT, subSRTs) <- sub_srt topSRT cafs
202 let (sub_tbls, blockSRTs) = subSRTs
203 return (topSRT, sub_tbls, blockSRTs)
204
205 -- Construct an SRT bitmap.
206 -- Adapted from simpleStg/SRT.hs, which expects Id's.
207 procpointSRT :: DynFlags -> CLabel -> Map CLabel Int -> [CLabel] ->
208 UniqSM (Maybe CmmDecl, C_SRT)
209 procpointSRT _ _ _ [] =
210 return (Nothing, NoC_SRT)
211 procpointSRT dflags top_srt top_table entries =
212 do (top, srt) <- bitmap `seq` to_SRT dflags top_srt offset len bitmap
213 return (top, srt)
214 where
215 ints = map (expectJust "constructSRT" . flip Map.lookup top_table) entries
216 sorted_ints = sort ints
217 offset = head sorted_ints
218 bitmap_entries = map (subtract offset) sorted_ints
219 len = P.last bitmap_entries + 1
220 bitmap = intsToBitmap dflags len bitmap_entries
221
222 maxBmpSize :: DynFlags -> Int
223 maxBmpSize dflags = widthInBits (wordWidth dflags) `div` 2
224
225 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
226 to_SRT :: DynFlags -> CLabel -> Int -> Int -> Bitmap -> UniqSM (Maybe CmmDecl, C_SRT)
227 to_SRT dflags top_srt off len bmp
228 | len > maxBmpSize dflags || bmp == [toStgWord dflags (fromStgHalfWord (srtEscape dflags))]
229 = do id <- getUniqueM
230 let srt_desc_lbl = mkLargeSRTLabel id
231 section = Section RelocatableReadOnlyData srt_desc_lbl
232 tbl = CmmData section $
233 Statics srt_desc_lbl $ map CmmStaticLit
234 ( cmmLabelOffW dflags top_srt off
235 : mkWordCLit dflags (fromIntegral len)
236 : map (mkStgWordCLit dflags) bmp)
237 return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
238 | otherwise
239 = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
240 -- The fromIntegral converts to StgHalfWord
241
242 -- Gather CAF info for a procedure, but only if the procedure
243 -- doesn't have a static closure.
244 -- (If it has a static closure, it will already have an SRT to
245 -- keep its CAFs live.)
246 -- Any procedure referring to a non-static CAF c must keep live
247 -- any CAF that is reachable from c.
248 localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
249 localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
250 localCAFInfo cafEnv proc@(CmmProc _ top_l _ (CmmGraph {g_entry=entry})) =
251 case topInfoTable proc of
252 Just (CmmInfoTable { cit_rep = rep })
253 | not (isStaticRep rep) && not (isStackRep rep)
254 -> (cafs, Just (toClosureLbl top_l))
255 _other -> (cafs, Nothing)
256 where
257 cafs = expectJust "maybeBindCAFs" $ mapLookup entry cafEnv
258
259 -- Once we have the local CAF sets for some (possibly) mutually
260 -- recursive functions, we can create an environment mapping
261 -- each function to its set of CAFs. Note that a CAF may
262 -- be a reference to a function. If that function f does not have
263 -- a static closure, then we need to refer specifically
264 -- to the set of CAFs used by f. Of course, the set of CAFs
265 -- used by f must be included in the local CAF sets that are input to
266 -- this function. To minimize lookup time later, we return
267 -- the environment with every reference to f replaced by its set of CAFs.
268 -- To do this replacement efficiently, we gather strongly connected
269 -- components, then we sort the components in topological order.
270 mkTopCAFInfo :: [(CAFSet, Maybe CLabel)] -> Map CLabel CAFSet
271 mkTopCAFInfo localCAFs = foldl addToTop Map.empty g
272 where
273 addToTop env (AcyclicSCC (l, cafset)) =
274 Map.insert l (flatten env cafset) env
275 addToTop env (CyclicSCC nodes) =
276 let (lbls, cafsets) = unzip nodes
277 cafset = foldr Set.delete (foldl Set.union Set.empty cafsets) lbls
278 in foldl (\env l -> Map.insert l (flatten env cafset) env) env lbls
279
280 g = stronglyConnCompFromEdgedVerticesOrd
281 [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
282
283 flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
284 flatten env cafset = foldSet (lookup env) Set.empty cafset
285 where
286 lookup env caf cafset' =
287 case Map.lookup caf env of
288 Just cafs -> foldSet Set.insert cafset' cafs
289 Nothing -> Set.insert caf cafset'
290
291 bundle :: Map CLabel CAFSet
292 -> (CAFEnv, CmmDecl)
293 -> (CAFSet, Maybe CLabel)
294 -> (LabelMap CAFSet, CmmDecl)
295 bundle flatmap (env, decl@(CmmProc infos _lbl _ g)) (closure_cafs, mb_lbl)
296 = ( mapMapWithKey get_cafs (info_tbls infos), decl )
297 where
298 entry = g_entry g
299
300 entry_cafs
301 | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
302 | otherwise = flatten flatmap closure_cafs
303
304 get_cafs l _
305 | l == entry = entry_cafs
306 | Just info <- mapLookup l env = flatten flatmap info
307 | otherwise = Set.empty
308 -- the label might not be in the env if the code corresponding to
309 -- this info table was optimised away (perhaps because it was
310 -- unreachable). In this case it doesn't matter what SRT we
311 -- infer, since the info table will not appear in the generated
312 -- code. See #9329.
313
314 bundle _flatmap (_, decl) _
315 = ( mapEmpty, decl )
316
317
318 flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(LabelMap CAFSet, CmmDecl)]
319 flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
320 where
321 zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
322 localCAFs = unzipWith localCAFInfo zipped
323 flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
324
325 doSRTs :: DynFlags
326 -> TopSRT
327 -> [(CAFEnv, [CmmDecl])]
328 -> IO (TopSRT, [CmmDecl])
329
330 doSRTs dflags topSRT tops
331 = do
332 let caf_decls = flattenCAFSets tops
333 us <- mkSplitUniqSupply 'u'
334 let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
335 return (topSRT', reverse gs' {- Note [reverse gs] -})
336 where
337 setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
338 (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
339 let decl' = updInfoSRTs srt_env decl
340 return (topSRT, decl': srt_tables ++ rst)
341 setSRT (topSRT, rst) (_, decl) =
342 return (topSRT, decl : rst)
343
344 buildSRTs :: DynFlags -> TopSRT -> LabelMap CAFSet
345 -> UniqSM (TopSRT, [CmmDecl], LabelMap C_SRT)
346 buildSRTs dflags top_srt caf_map
347 = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
348 where
349 doOne (top_srt, decls, srt_env) (l, cafs)
350 = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
351 return ( top_srt, maybeToList mb_decl ++ decls
352 , mapInsert l srt srt_env )
353
354 {-
355 - In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
356 - The one corresponding to g_entry is the closure info table, the
357 rest are continuations.
358 - Each one needs an SRT.
359 - We get the CAFSet for each one from the CAFEnv
360 - flatten gives us
361 [(LabelMap CAFSet, CmmDecl)]
362 -
363 -}
364
365
366 {- Note [reverse gs]
367
368 It is important to keep the code blocks in the same order,
369 otherwise binary sizes get slightly bigger. I'm not completely
370 sure why this is, perhaps the assembler generates bigger jump
371 instructions for forward refs. --SDM
372 -}
373
374 updInfoSRTs :: LabelMap C_SRT -> CmmDecl -> CmmDecl
375 updInfoSRTs srt_env (CmmProc top_info top_l live g) =
376 CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l live g
377 where updInfoTbl l info_tbl
378 = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
379 updInfoSRTs _ t = t