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