Produce new-style Cmm from the Cmm parser
[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, isEmptySRT, srtToData )
18 where
19
20 #include "HsVersions.h"
21
22 import Hoopl
23 import Digraph
24 import BlockId
25 import Bitmap
26 import CLabel
27 import PprCmmDecl ()
28 import Cmm
29 import CmmUtils
30 import CmmInfo
31 import Data.List
32 import DynFlags
33 import Maybes
34 import Outputable
35 import SMRep
36 import UniqSupply
37 import Util
38
39 import Data.Map (Map)
40 import qualified Data.Map as Map
41 import Data.Set (Set)
42 import qualified Data.Set as Set
43 import Control.Monad
44
45 import qualified Prelude as P
46 import Prelude hiding (succ)
47
48 foldSet :: (a -> b -> b) -> b -> Set a -> b
49 foldSet = Set.foldr
50
51 -----------------------------------------------------------------------
52 -- SRTs
53
54 {- EXAMPLE
55
56 f = \x. ... g ...
57 where
58 g = \y. ... h ... c1 ...
59 h = \z. ... c2 ...
60
61 c1 & c2 are CAFs
62
63 g and h are local functions, but they have no static closures. When
64 we generate code for f, we start with a CmmGroup of four CmmDecls:
65
66 [ f_closure, f_entry, g_entry, h_entry ]
67
68 we process each CmmDecl separately in cpsTop, giving us a list of
69 CmmDecls. e.g. for f_entry, we might end up with
70
71 [ f_entry, f1_ret, f2_proc ]
72
73 where f1_ret is a return point, and f2_proc is a proc-point. We have
74 a CAFSet for each of these CmmDecls, let's suppose they are
75
76 [ f_entry{g_closure}, f1_ret{g_closure}, f2_proc{} ]
77 [ g_entry{h_closure, c1_closure} ]
78 [ h_entry{c2_closure} ]
79
80 Now, note that we cannot use g_closure and h_closure in an SRT,
81 because there are no static closures corresponding to these functions.
82 So we have to flatten out the structure, replacing g_closure and
83 h_closure with their contents:
84
85 [ f_entry{c2_closure, c1_closure}, f1_ret{c2_closure,c1_closure}, f2_proc{} ]
86 [ g_entry{c2_closure, c1_closure} ]
87 [ h_entry{c2_closure} ]
88
89 This is what flattenCAFSets is doing.
90
91 -}
92
93 -----------------------------------------------------------------------
94 -- Finding the CAFs used by a procedure
95
96 type CAFSet = Set CLabel
97 type CAFEnv = BlockEnv CAFSet
98
99 -- First, an analysis to find live CAFs.
100 cafLattice :: DataflowLattice CAFSet
101 cafLattice = DataflowLattice "live cafs" Set.empty add
102 where add _ (OldFact old) (NewFact new) = case old `Set.union` new of
103 new' -> (changeIf $ Set.size new' > Set.size old, new')
104
105 cafTransfers :: BwdTransfer CmmNode CAFSet
106 cafTransfers = mkBTransfer3 first middle last
107 where first _ live = live
108 middle m live = foldExpDeep addCaf m live
109 last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
110 addCaf e set = case e of
111 CmmLit (CmmLabel c) -> add c set
112 CmmLit (CmmLabelOff c _) -> add c set
113 CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set
114 _ -> set
115 add l s = if hasCAF l then Set.insert (toClosureLbl l) s
116 else s
117
118 cafAnal :: CmmGraph -> CAFEnv
119 cafAnal g = dataflowAnalBwd g [] $ analBwd cafLattice cafTransfers
120
121 -----------------------------------------------------------------------
122 -- Building the SRTs
123
124 -- Description of the SRT for a given module.
125 -- Note that this SRT may grow as we greedily add new CAFs to it.
126 data TopSRT = TopSRT { lbl :: CLabel
127 , next_elt :: Int -- the next entry in the table
128 , rev_elts :: [CLabel]
129 , elt_map :: Map CLabel Int }
130 -- map: CLabel -> its last entry in the table
131 instance Outputable TopSRT where
132 ppr (TopSRT lbl next elts eltmap) =
133 text "TopSRT:" <+> ppr lbl
134 <+> ppr next
135 <+> ppr elts
136 <+> ppr eltmap
137
138 emptySRT :: MonadUnique m => m TopSRT
139 emptySRT =
140 do top_lbl <- getUniqueM >>= \ u -> return $ mkTopSRTLabel u
141 return TopSRT { lbl = top_lbl, next_elt = 0, rev_elts = [], elt_map = Map.empty }
142
143 isEmptySRT :: TopSRT -> Bool
144 isEmptySRT srt = null (rev_elts srt)
145
146 cafMember :: TopSRT -> CLabel -> Bool
147 cafMember srt lbl = Map.member lbl (elt_map srt)
148
149 cafOffset :: TopSRT -> CLabel -> Maybe Int
150 cafOffset srt lbl = Map.lookup lbl (elt_map srt)
151
152 addCAF :: CLabel -> TopSRT -> TopSRT
153 addCAF caf srt =
154 srt { next_elt = last + 1
155 , rev_elts = caf : rev_elts srt
156 , elt_map = Map.insert caf last (elt_map srt) }
157 where last = next_elt srt
158
159 srtToData :: TopSRT -> CmmGroup
160 srtToData srt = [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)]
161 where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts 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 length cafs > 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.lhs, 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 tbl = CmmData RelocatableReadOnlyData $
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 = stronglyConnCompFromEdgedVertices
284 [ ((l,cafs), l, Set.elems cafs) | (cafs, Just l) <- localCAFs ]
285
286 flatten :: Map CLabel CAFSet -> CAFSet -> CAFSet
287 flatten env cafset = foldSet (lookup env) Set.empty cafset
288 where
289 lookup env caf cafset' =
290 case Map.lookup caf env of
291 Just cafs -> foldSet Set.insert cafset' cafs
292 Nothing -> Set.insert caf cafset'
293
294 bundle :: Map CLabel CAFSet
295 -> (CAFEnv, CmmDecl)
296 -> (CAFSet, Maybe CLabel)
297 -> (BlockEnv CAFSet, CmmDecl)
298 bundle flatmap (env, decl@(CmmProc infos lbl g)) (closure_cafs, mb_lbl)
299 = ( mapMapWithKey get_cafs (info_tbls infos), decl )
300 where
301 entry = g_entry g
302
303 entry_cafs
304 | Just l <- mb_lbl = expectJust "bundle" $ Map.lookup l flatmap
305 | otherwise = flatten flatmap closure_cafs
306
307 get_cafs l _
308 | l == entry = entry_cafs
309 | otherwise = if not (mapMember l env)
310 then pprPanic "bundle" (ppr l <+> ppr lbl <+> ppr (info_tbls infos))
311 else flatten flatmap $ expectJust "bundle" $ mapLookup l env
312
313 bundle _flatmap (_, decl) _
314 = ( mapEmpty, decl )
315
316
317 flattenCAFSets :: [(CAFEnv, [CmmDecl])] -> [(BlockEnv CAFSet, CmmDecl)]
318 flattenCAFSets cpsdecls = zipWith (bundle flatmap) zipped localCAFs
319 where
320 zipped = [ (env,decl) | (env,decls) <- cpsdecls, decl <- decls ]
321 localCAFs = unzipWith localCAFInfo zipped
322 flatmap = mkTopCAFInfo localCAFs -- transitive closure of localCAFs
323
324 doSRTs :: DynFlags
325 -> TopSRT
326 -> [(CAFEnv, [CmmDecl])]
327 -> IO (TopSRT, [CmmDecl])
328
329 doSRTs dflags topSRT tops
330 = do
331 let caf_decls = flattenCAFSets tops
332 us <- mkSplitUniqSupply 'u'
333 let (topSRT', gs') = initUs_ us $ foldM setSRT (topSRT, []) caf_decls
334 return (topSRT', reverse gs' {- Note [reverse gs] -})
335 where
336 setSRT (topSRT, rst) (caf_map, decl@(CmmProc{})) = do
337 (topSRT, srt_tables, srt_env) <- buildSRTs dflags topSRT caf_map
338 let decl' = updInfoSRTs srt_env decl
339 return (topSRT, decl': srt_tables ++ rst)
340 setSRT (topSRT, rst) (_, decl) =
341 return (topSRT, decl : rst)
342
343 buildSRTs :: DynFlags -> TopSRT -> BlockEnv CAFSet
344 -> UniqSM (TopSRT, [CmmDecl], BlockEnv C_SRT)
345 buildSRTs dflags top_srt caf_map
346 = foldM doOne (top_srt, [], mapEmpty) (mapToList caf_map)
347 where
348 doOne (top_srt, decls, srt_env) (l, cafs)
349 = do (top_srt, mb_decl, srt) <- buildSRT dflags top_srt cafs
350 return ( top_srt, maybeToList mb_decl ++ decls
351 , mapInsert l srt srt_env )
352
353 {-
354 - In each CmmDecl there is a mapping from BlockId -> CmmInfoTable
355 - The one corresponding to g_entry is the closure info table, the
356 rest are continuations.
357 - Each one needs an SRT.
358 - We get the CAFSet for each one from the CAFEnv
359 - flatten gives us
360 [(BlockEnv CAFSet, CmmDecl)]
361 -
362 -}
363
364
365 {- Note [reverse gs]
366
367 It is important to keep the code blocks in the same order,
368 otherwise binary sizes get slightly bigger. I'm not completely
369 sure why this is, perhaps the assembler generates bigger jump
370 instructions for forward refs. --SDM
371 -}
372
373 updInfoSRTs :: BlockEnv C_SRT -> CmmDecl -> CmmDecl
374 updInfoSRTs srt_env (CmmProc top_info top_l g) =
375 CmmProc (top_info {info_tbls = mapMapWithKey updInfoTbl (info_tbls top_info)}) top_l g
376 where updInfoTbl l info_tbl
377 = info_tbl { cit_srt = expectJust "updInfo" $ mapLookup l srt_env }
378 updInfoSRTs _ t = t