30e0addbdcc75fc32ddbe4fac01f504298f76f86
[ghc.git] / compiler / cmm / CmmBuildInfoTables.hs
1 {-# LANGUAGE GADTs, NoMonoLocalBinds #-}
2 {-# OPTIONS -fno-warn-tabs #-}
3 -- The above warning supression flag is a temporary kludge.
4 -- While working on this module you are encouraged to remove it and
5 -- detab the module (please do the detabbing in a separate patch). See
6 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
7 -- for details
8
9 -- Norman likes local bindings
10 -- If this module lives on I'd like to get rid of the NoMonoLocalBinds
11 -- extension in due course
12
13 -- Todo: remove -fno-warn-warnings-deprecations
14 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
15 module CmmBuildInfoTables
16 ( CAFSet, CAFEnv, cafAnal
17 , doSRTs, TopSRT, emptySRT, srtToData )
18 where
19
20 #include "HsVersions.h"
21
22 -- These should not be imported here!
23 import StgCmmUtils
24 import Hoopl
25
26 import Digraph
27 import qualified Prelude as P
28 import Prelude hiding (succ)
29
30 import BlockId
31 import Bitmap
32 import CLabel
33 import Cmm
34 import CmmUtils
35 import Data.List
36 import DynFlags
37 import Maybes
38 import Module
39 import Outputable
40 import SMRep
41 import UniqSupply
42 import Util
43
44 import Data.Map (Map)
45 import qualified Data.Map as Map
46 import Data.Set (Set)
47 import qualified Data.Set as Set
48 import Control.Monad
49
50 foldSet :: (a -> b -> b) -> b -> Set a -> b
51 foldSet = Set.foldr
52
53 -----------------------------------------------------------------------
54 -- SRTs
55
56 {- EXAMPLE
57
58 f = \x. ... g ...
59 where
60 g = \y. ... h ... c1 ...
61 h = \z. ... c2 ...
62
63 c1 & c2 are CAFs
64
65 g and h are local functions, but they have no static closures. When
66 we generate code for f, we start with a CmmGroup of four CmmDecls:
67
68 [ f_closure, f_entry, g_entry, h_entry ]
69
70 we process each CmmDecl separately in cpsTop, giving us a list of
71 CmmDecls. e.g. for f_entry, we might end up with
72
73 [ f_entry, f1_ret, f2_proc ]
74
75 where f1_ret is a return point, and f2_proc is a proc-point. We have
76 a CAFSet for each of these CmmDecls, let's suppose they are
77
78 [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
79 [ g_entry{h_closure, c1_closure} ]
80 [ h_entry{c2_closure} ]
81
82 Now, note that we cannot use g_closure and h_closure in an SRT,
83 because there are no static closures corresponding to these functions.
84 So we have to flatten out the structure, replacing g_closure and
85 h_closure with their contents:
86
87 [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
88 [ g_entry{c2_closure, c1_closure} ]
89 [ h_entry{c2_closure} ]
90
91 This is what flattenCAFSets is doing.
92
93 -}
94
95 -----------------------------------------------------------------------
96 -- Finding the CAFs used by a procedure
97
98 type CAFSet = Set CLabel
99 type CAFEnv = BlockEnv CAFSet
100
101 -- First, an analysis to find live CAFs.
102 cafLattice :: DataflowLattice CAFSet
103 cafLattice = DataflowLattice "live cafs" Set.empty add
104 where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
105 new' -> (changeIf $ Set.size new' > Set.size old, new')
106
107 cafTransfers :: BwdTransfer CmmNode CAFSet
108 cafTransfers = mkBTransfer3 first middle last
109 where first _ live = live
110 middle m live = foldExpDeep addCaf m live
111 last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
112 addCaf e set = case e of
113 CmmLit (CmmLabel c) -> add c set
114 CmmLit (CmmLabelOff c _) -> add c set
115 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
116 _ -> set
117 add l s = if hasCAF l then Set.insert (toClosureLbl l) s
118 else s
119
120 cafAnal :: CmmGraph -> CAFEnv
121 cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
122
123 -----------------------------------------------------------------------
124 -- Building the SRTs
125
126 -- Description of the SRT for a given module.
127 -- Note that this SRT may grow as we greedily add new CAFs to it.
128 data TopSRT = TopSRT { lbl :: CLabel
129 , next_elt :: Int -- the next entry in the table
130 , rev_elts :: [CLabel]
131 , elt_map :: Map CLabel Int }
132 -- map: CLabel -> its last entry in the table
133 instance Outputable TopSRT where
134 ppr (TopSRT lbl next elts eltmap) =
135 text "TopSRT:" <+> ppr lbl
136 <+> ppr next
137 <+> ppr elts
138 <+> ppr eltmap
139
140 emptySRT :: MonadUnique m => Maybe Module -> m TopSRT
141 emptySRT mb_mod =
142 do top_lbl <- getUniqueM >>= \ u -> return $ mkModSRTLabel mb_mod u
143 return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
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 RelocatableReadOnlyData (Statics (lbl srt) tbl)]
160 where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts 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 length cafs > 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.lhs, 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 = P.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 == [fromIntegral srt_escape]
232 = do id <- getUniqueM
233 let srt_desc_lbl = mkLargeSRTLabel id
234 tbl = CmmData RelocatableReadOnlyData $
235 Statics srt_desc_lbl $ map CmmStaticLit
236 ( cmmLabelOffW dflags top_srt off
237 : mkWordCLit dflags (fromIntegral len)
238 : map (mkWordCLit dflags) bmp)
239 return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape)
240 | otherwise
241 = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp)))
242 -- The fromIntegral converts to StgHalfWord
243
244 -- Gather CAF info for a procedure, but only if the procedure
245 -- doesn't have a static closure.
246 -- (If it has a static closure, it will already have an SRT to
247 -- keep its CAFs live.)
248 -- Any procedure referring to a non-static CAF c must keep live
249 -- any CAF that is reachable from c.
250 localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
251 localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
252 localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
253 case topInfoTable proc of
254 Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep 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 = stronglyConnCompFromEdgedVertices
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 | otherwise = if not (mapMember l env)
308 then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
309 else flatten flatmap $ expectJust "bundle" $ mapLookup l env
310
311 bundle _flatmap (_, decl) _
312 = ( mapEmpty, decl )
313
314
315 flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
316 flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
317 where
318 zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
319 localCAFs = unzipWith localCAFInfo zipped
320 flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
321
322 doSRTs :: DynFlags
323 -> TopSRT
324 -> [(CAFEnv, [CmmDecl])]
325 -> IO (TopSRT, [CmmDecl])
326
327 doSRTs dflags topSRT tops
328 = do
329 let caf_decls = flattenCAFSets tops
330 us <- mkSplitUniqSupply 'u'
331 let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
332 return (topSRT', reverse gs' {- Note [reverse gs] -})
333 where
334 setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
335 (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
336 let decl' = updInfoSRTs srt_env decl
337 return (topSRT, decl': srt_tables ++ rst)
338 setSRT (topSRT, rst) (_, decl) =
339 return (topSRT, decl : rst)
340
341 buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
342 -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
343 buildSRTs dflags top_srt caf_map
344 = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
345 where
346 doOne (top_srt, decls, srt_env) (l, cafs)
347 = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
348 return ( top_srt, maybeToList mb_decl ++ decls
349 , mapInsert l srt srt_env )
350
351 {-
352 - In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
353 - The one corresponding to g_entry is the closure info table, the
354 rest are continuations.
355 - Each one needs an SRT.
356 - We get the CAFSet for each one from the CAFEnv
357 - flatten gives us
358 [(BlockEnv CAFSet, CmmDecl)]
359 -
360 -}
361
362
363 {- Note [reverse gs]
364
365 It is important to keep the code blocks in the same order,
366 otherwise binary sizes get slightly bigger. I'm not completely
367 sure why this is, perhaps the assembler generates bigger jump
368 instructions for forward refs. --SDM
369 -}
370
371 updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
372 updInfoSRTs srt_env (CmmProc top_info top_l g) =
373 CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
374 where updInfoTbl l info_tbl
375 = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
376 updInfoSRTs _ t = t