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