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