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