Merge FUN_STATIC closure with its SRT
[ghc.git] / compiler / cmm / CmmBuildInfoTables.hs
1 {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
2 GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
3
4 module CmmBuildInfoTables
5 ( CAFSet, CAFEnv, cafAnal
6 , doSRTs, ModuleSRTInfo, emptySRT
7 ) where
8
9 import GhcPrelude hiding (succ)
10
11 import Id
12 import BlockId
13 import Hoopl.Block
14 import Hoopl.Graph
15 import Hoopl.Label
16 import Hoopl.Collections
17 import Hoopl.Dataflow
18 import Module
19 import Digraph
20 import CLabel
21 import PprCmmDecl ()
22 import Cmm
23 import CmmUtils
24 import DynFlags
25 import Maybes
26 import Outputable
27 import SMRep
28 import UniqSupply
29 import CostCentre
30 import StgCmmHeap
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 Data.Tuple
38 import Control.Monad.Trans.State
39 import Control.Monad.Trans.Class
40
41
42 {- Note [SRTs]
43
44 SRTs are the mechanism by which the garbage collector can determine
45 the live CAFs in the program.
46
47 Representation
48 ^^^^^^^^^^^^^^
49
50 +------+
51 | info |
52 | | +-----+---+---+---+
53 | -------->|SRT_2| | | | | 0 |
54 |------| +-----+-|-+-|-+---+
55 | | | |
56 | code | | |
57 | | v v
58
59 An SRT is simply an object in the program's data segment. It has the
60 same representation as a static constructor. There are 16
61 pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
62 representing SRT objects with 1-16 pointers, respectively.
63
64 The entries of an SRT object point to static closures, which are either
65 - FUN_STATIC, THUNK_STATIC or CONSTR
66 - Another SRT (actually just a CONSTR)
67
68 The final field of the SRT is the static link field, used by the
69 garbage collector to chain together static closures that it visits and
70 to determine whether a static closure has been visited or not. (see
71 Note [STATIC_LINK fields])
72
73 By traversing the transitive closure of an SRT, the GC will reach all
74 of the CAFs that are reachable from the code associated with this SRT.
75
76 If we need to create an SRT with more than 16 entries, we build a
77 chain of SRT objects with all but the last having 16 entries.
78
79 +-----+---+- -+---+---+
80 |SRT16| | | | | | 0 |
81 +-----+-|-+- -+-|-+---+
82 | |
83 v v
84 +----+---+---+---+
85 |SRT2| | | | | 0 |
86 +----+-|-+-|-+---+
87 | |
88 | |
89 v v
90
91 Referring to an SRT from the info table
92 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
93
94 The following things have SRTs:
95
96 - Static functions (FUN)
97 - Static thunks (THUNK), ie. CAFs
98 - Continuations (RET_SMALL, etc.)
99
100 In each case, the info table points to the SRT.
101
102 - info->srt is zero if there's no SRT, otherwise:
103 - info->srt == 1 and info->f.srt_offset points to the SRT
104
105 e.g. for a FUN with an SRT:
106
107 StgFunInfoTable +------+
108 info->f.srt_offset | ------------> offset to SRT object
109 StgStdInfoTable +------+
110 info->layout.ptrs | ... |
111 info->layout.nptrs | ... |
112 info->srt | 1 |
113 info->type | ... |
114 |------|
115
116 On x86_64, we optimise the info table representation further. The
117 offset to the SRT can be stored in 32 bits (all code lives within a
118 2GB region in x86_64's small memory model), so we can save a word in
119 the info table by storing the srt_offset in the srt field, which is
120 half a word.
121
122 On x86_64 with TABLES_NEXT_TO_CODE:
123
124 - info->srt is zero if there's no SRT, otherwise:
125 - info->srt is an offset from the info pointer to the SRT object
126
127 StgStdInfoTable +------+
128 info->layout.ptrs | |
129 info->layout.nptrs | |
130 info->srt | ------------> offset to SRT object
131 |------|
132
133
134 EXAMPLE
135 ^^^^^^^
136
137 f = \x. ... g ...
138 where
139 g = \y. ... h ... c1 ...
140 h = \z. ... c2 ...
141
142 c1 & c2 are CAFs
143
144 g and h are local functions, but they have no static closures. When
145 we generate code for f, we start with a CmmGroup of four CmmDecls:
146
147 [ f_closure, f_entry, g_entry, h_entry ]
148
149 we process each CmmDecl separately in cpsTop, giving us a list of
150 CmmDecls. e.g. for f_entry, we might end up with
151
152 [ f_entry, f1_ret, f2_proc ]
153
154 where f1_ret is a return point, and f2_proc is a proc-point. We have
155 a CAFSet for each of these CmmDecls, let's suppose they are
156
157 [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
158 [ g_entry{h_info, c1_closure} ]
159 [ h_entry{c2_closure} ]
160
161 Next, we make an SRT for each of these functions:
162
163 f_srt : [g_info]
164 g_srt : [h_info, c1_closure]
165 h_srt : [c2_closure]
166
167 Now, for g_info and h_info, we want to refer to the SRTs for g and h
168 respectively, which we'll label g_srt and h_srt:
169
170 f_srt : [g_srt]
171 g_srt : [h_srt, c1_closure]
172 h_srt : [c2_closure]
173
174 Now, when an SRT has a single entry, we don't actually generate an SRT
175 closure for it, instead we just replace references to it with its
176 single element. So, since h_srt == c2_closure, we have
177
178 f_srt : [g_srt]
179 g_srt : [c2_closure, c1_closure]
180 h_srt : [c2_closure]
181
182 and the only SRT closure we generate is
183
184 g_srt = SRT_2 [c2_closure, c1_closure]
185
186
187 Optimisations
188 ^^^^^^^^^^^^^
189
190 To reduce the code size overhead and the cost of traversing SRTs in
191 the GC, we want to simplify SRTs where possible. We therefore apply
192 the following optimisations. Each has a [keyword]; search for the
193 keyword in the code below to see where the optimisation is
194 implemented.
195
196 1. [Shortcut] we never create an SRT with a single entry, instead
197 we replace all references to the singleton SRT with a reference
198 to its element. This includes references from info tables.
199
200 i.e. instead of
201
202 +------+
203 | info |
204 | | +-----+---+---+
205 | -------->|SRT_1| | | 0 |
206 |------| +-----+-|-+---+
207 | | |
208 | code | |
209 | | v
210 closure
211
212 we can point directly to the closure:
213
214 +------+
215 | info |
216 | |
217 | -------->closure
218 |------|
219 | |
220 | code |
221 | |
222
223
224 The exception to this is when we're doing dynamic linking. In that
225 case, if the closure is not locally defined then we can't point to
226 it directly from the info table, because this is the text section
227 which cannot contain runtime relocations. In this case we skip this
228 optimisation and generate the singleton SRT, becase SRTs are in the
229 data section and *can* have relocatable references.
230
231 2. [FUN] A static function closure can also be an SRT, we simply put
232 the SRT entries as fields in the static closure. This makes a lot
233 of sense: the static references are just like the free variables of
234 the FUN closure.
235
236 i.e. instead of
237
238 f_closure:
239 +-----+---+
240 | | | 0 |
241 +- |--+---+
242 | +------+
243 | | info | f_srt:
244 | | | +-----+---+---+---+
245 | | -------->|SRT_2| | | | + 0 |
246 `----------->|------| +-----+-|-+-|-+---+
247 | | | |
248 | code | | |
249 | | v v
250
251
252 We can generate:
253
254 f_closure:
255 +-----+---+---+---+
256 | | | | | | | 0 |
257 +- |--+-|-+-|-+---+
258 | | | +------+
259 | v v | info |
260 | | |
261 | | 0 |
262 `----------->|------|
263 | |
264 | code |
265 | |
266
267
268 (note: we can't do this for THUNKs, because the thunk gets
269 overwritten when it is entered, so we wouldn't be able to share
270 this SRT with other info tables that want to refer to it (see
271 [Common] below). FUNs are immutable so don't have this problem.)
272
273 3. [Common] Identical SRTs can be commoned up.
274
275 4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
276 refers to C (perhaps transitively), then we can omit the reference
277 to C from A.
278
279
280 Note that there are many other optimisations that we could do, but
281 aren't implemented. In general, we could omit any reference from an
282 SRT if everything reachable from it is also reachable from the other
283 fields in the SRT. Our [Filter] optimisation is a special case of
284 this.
285
286 Another opportunity we don't exploit is this:
287
288 A = {X,Y,Z}
289 B = {Y,Z}
290 C = {X,B}
291
292 Here we could use C = {A} and therefore [Shortcut] C = A.
293 -}
294
295 -- ---------------------------------------------------------------------
296 -- Label types
297
298 -- Labels that come from cafAnal can be:
299 -- - _closure labels for static functions or CAFs
300 -- - _info labels for dynamic functions, thunks, or continuations
301 -- - _entry labels for functions or thunks
302 --
303 -- Meanwhile the labels on top-level blocks are _entry labels.
304 --
305 -- To put everything in the same namespace we convert all labels to
306 -- closure labels using toClosureLbl. Note that some of these
307 -- labels will not actually exist; that's ok because we're going to
308 -- map them to SRTEntry later, which ranges over labels that do exist.
309 --
310 newtype CAFLabel = CAFLabel CLabel
311 deriving (Eq,Ord,Outputable)
312
313 type CAFSet = Set CAFLabel
314 type CAFEnv = LabelMap CAFSet
315
316 mkCAFLabel :: CLabel -> CAFLabel
317 mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)
318
319 -- This is a label that we can put in an SRT. It *must* be a closure label,
320 -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
321 newtype SRTEntry = SRTEntry CLabel
322 deriving (Eq, Ord, Outputable)
323
324 -- ---------------------------------------------------------------------
325 -- CAF analysis
326
327 -- |
328 -- For each code block:
329 -- - collect the references reachable from this code block to FUN,
330 -- THUNK or RET labels for which hasCAF == True
331 --
332 -- This gives us a `CAFEnv`: a mapping from code block to sets of labels
333 --
334 cafAnal
335 :: LabelSet -- The blocks representing continuations, ie. those
336 -- that will get RET info tables. These labels will
337 -- get their own SRTs, so we don't aggregate CAFs from
338 -- references to these labels, we just use the label.
339 -> CLabel -- The top label of the proc
340 -> CmmGraph
341 -> CAFEnv
342 cafAnal contLbls topLbl cmmGraph =
343 analyzeCmmBwd cafLattice
344 (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
345
346
347 cafLattice :: DataflowLattice CAFSet
348 cafLattice = DataflowLattice Set.empty add
349 where
350 add (OldFact old) (NewFact new) =
351 let !new' = old `Set.union` new
352 in changedIf (Set.size new' > Set.size old) new'
353
354
355 cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
356 cafTransfers contLbls entry topLbl
357 (BlockCC eNode middle xNode) fBase =
358 let joined = cafsInNode xNode $! live'
359 !result = foldNodesBwdOO cafsInNode middle joined
360
361 facts = mapMaybe successorFact (successors xNode)
362 live' = joinFacts cafLattice facts
363
364 successorFact s
365 -- If this is a loop back to the entry, we can refer to the
366 -- entry label.
367 | s == entry = Just (add topLbl Set.empty)
368 -- If this is a continuation, we want to refer to the
369 -- SRT for the continuation's info table
370 | s `setMember` contLbls
371 = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))
372 -- Otherwise, takes the CAF references from the destination
373 | otherwise
374 = lookupFact s fBase
375
376 cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
377 cafsInNode node set = foldExpDeep addCaf node set
378
379 addCaf expr !set =
380 case expr of
381 CmmLit (CmmLabel c) -> add c set
382 CmmLit (CmmLabelOff c _) -> add c set
383 CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set
384 _ -> set
385 add l s | hasCAF l = Set.insert (mkCAFLabel l) s
386 | otherwise = s
387
388 in mapSingleton (entryLabel eNode) result
389
390
391 -- -----------------------------------------------------------------------------
392 -- ModuleSRTInfo
393
394 data ModuleSRTInfo = ModuleSRTInfo
395 { thisModule :: Module
396 -- ^ Current module being compiled. Required for calling labelDynamic.
397 , dedupSRTs :: Map (Set SRTEntry) SRTEntry
398 -- ^ previous SRTs we've emitted, so we can de-duplicate.
399 -- Used to implement the [Common] optimisation.
400 , flatSRTs :: Map SRTEntry (Set SRTEntry)
401 -- ^ The reverse mapping, so that we can remove redundant
402 -- entries. e.g. if we have an SRT [a,b,c], and we know that b
403 -- points to [c,d], we can omit c and emit [a,b].
404 -- Used to implement the [Filter] optimisation.
405 }
406 instance Outputable ModuleSRTInfo where
407 ppr ModuleSRTInfo{..} =
408 text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
409
410 emptySRT :: Module -> ModuleSRTInfo
411 emptySRT mod =
412 ModuleSRTInfo
413 { thisModule = mod
414 , dedupSRTs = Map.empty
415 , flatSRTs = Map.empty }
416
417 -- -----------------------------------------------------------------------------
418 -- Constructing SRTs
419
420 {- Implementation notes
421
422 - In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
423
424 - The entry in info_tbls corresponding to g_entry is the closure info
425 table, the rest are continuations.
426
427 - Each entry in info_tbls possibly needs an SRT. We need to make a
428 label for each of these.
429
430 - We get the CAFSet for each entry from the CAFEnv
431
432 -}
433
434 -- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
435 -- where the label is
436 -- - the info label for a continuation or dynamic closure
437 -- - the closure label for a top-level function (not a CAF)
438 getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
439 getLabelledBlocks (CmmData _ _) = []
440 getLabelledBlocks (CmmProc top_info _ _ _) =
441 [ (blockId, mkCAFLabel (cit_lbl info))
442 | (blockId, info) <- mapToList (info_tbls top_info)
443 , let rep = cit_rep info
444 , not (isStaticRep rep) || not (isThunkRep rep)
445 ]
446
447
448 -- | Get (Label,CLabel) pairs for each block that represents a CAF.
449 -- These are treated differently from other labelled blocks:
450 -- - we never resolve a reference to a CAF to the contents of its SRT, since
451 -- the point of SRTs is to keep CAFs alive.
452 -- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
453 -- instead we generate their SRTs after everything else, so that we can
454 -- resolve references in the CAF's SRT.
455 getCAFs :: CmmDecl -> [(Label, CAFLabel)]
456 getCAFs (CmmData _ _) = []
457 getCAFs (CmmProc top_info topLbl _ g)
458 | Just info <- mapLookup (g_entry g) (info_tbls top_info)
459 , let rep = cit_rep info
460 , isStaticRep rep && isThunkRep rep = [(g_entry g, mkCAFLabel topLbl)]
461 | otherwise = []
462
463 -- | Get the list of blocks that correspond to the entry points for
464 -- FUN_STATIC closures. These are the blocks for which if we have an
465 -- SRT we can merge it with the static closure. [FUN]
466 getStaticFuns :: CmmDecl -> [(BlockId, CLabel)]
467 getStaticFuns (CmmData _ _) = []
468 getStaticFuns (CmmProc top_info _ _ g)
469 | Just info <- mapLookup (g_entry g) (info_tbls top_info)
470 , let rep = cit_rep info
471 , Just (id, _) <- cit_clo info
472 , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
473 , isStaticRep rep && isFunRep rep = [(g_entry g, lbl)]
474 | otherwise = []
475
476
477 -- | Put the labelled blocks that we will be annotating with SRTs into
478 -- dependency order. This is so that we can process them one at a
479 -- time, resolving references to earlier blocks to point to their
480 -- SRTs.
481 depAnalSRTs
482 :: CAFEnv
483 -> [CmmDecl]
484 -> [SCC (Label, CAFLabel, Set CAFLabel)]
485
486 depAnalSRTs cafEnv decls =
487 srtTrace "depAnalSRTs" (ppr blockToLabel $$ ppr (graph ++ cafSCCs)) $
488 (graph ++ cafSCCs)
489 where
490 cafs = concatMap getCAFs decls
491 cafSCCs = [ AcyclicSCC (blockid, lbl, cafs)
492 | (blockid, lbl) <- cafs
493 , Just cafs <- [mapLookup blockid cafEnv] ]
494 labelledBlocks = concatMap getLabelledBlocks decls
495 blockToLabel :: LabelMap CAFLabel
496 blockToLabel = mapFromList (cafs ++ labelledBlocks)
497 labelToBlock = Map.fromList (map swap labelledBlocks)
498 graph = stronglyConnCompFromEdgedVerticesOrd
499 [ let cafs' = Set.delete lbl cafs in
500 DigraphNode (l,lbl,cafs') l
501 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
502 | (l, lbl) <- labelledBlocks
503 , Just cafs <- [mapLookup l cafEnv] ]
504
505
506 -- | Maps labels from 'cafAnal' to the final CLabel that will appear
507 -- in the SRT.
508 -- - closures with singleton SRTs resolve to their single entry
509 -- - closures with larger SRTs map to the label for that SRT
510 -- - CAFs must not map to anything!
511 -- - if a labels maps to Nothing, we found that this label's SRT
512 -- is empty, so we don't need to refer to it from other SRTs.
513 type SRTMap = Map CAFLabel (Maybe SRTEntry)
514
515 -- | resolve a CAFLabel to its SRTEntry using the SRTMap
516 resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
517 resolveCAF srtMap lbl@(CAFLabel l) =
518 Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
519
520
521 -- | Attach SRTs to all info tables in the CmmDecls, and add SRT
522 -- declarations to the ModuleSRTInfo.
523 --
524 doSRTs
525 :: DynFlags
526 -> ModuleSRTInfo
527 -> [(CAFEnv, [CmmDecl])]
528 -> IO (ModuleSRTInfo, [CmmDecl])
529
530 doSRTs dflags topSRT tops = do
531 us <- mkSplitUniqSupply 'u'
532
533 -- Ignore the original grouping of decls, and combine all the
534 -- CAFEnvs into a single CAFEnv.
535 let (cafEnvs, declss) = unzip tops
536 cafEnv = mapUnions cafEnvs
537 decls = concat declss
538 staticFuns = mapFromList (concatMap getStaticFuns decls)
539
540 -- Put the decls in dependency order. Why? So that we can implement
541 -- [Shortcut] and [Filter]. If we need to refer to an SRT that has
542 -- a single entry, we use the entry itself, which means that we
543 -- don't need to generate the singleton SRT in the first place. But
544 -- to do this we need to process blocks before things that depend on
545 -- them.
546 let sccs = depAnalSRTs cafEnv decls
547
548 -- On each strongly-connected group of decls, construct the SRT
549 -- closures and the SRT fields for info tables.
550 let ((result, _srtMap), topSRT') =
551 initUs_ us $
552 flip runStateT topSRT $
553 flip runStateT Map.empty $
554 mapM (doSCC dflags staticFuns) sccs
555
556 (declss, pairs, funSRTs) = unzip3 result
557
558 -- Next, update the info tables with the SRTs
559 let
560 srtFieldMap = mapFromList (concat pairs)
561 funSRTMap = mapFromList (concat funSRTs)
562 decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
563
564 return (topSRT', concat declss ++ decls')
565
566
567 -- | Build the SRT for a strongly-connected component of blocks
568 doSCC
569 :: DynFlags
570 -> LabelMap CLabel -- which blocks are static function entry points
571 -> SCC (Label, CAFLabel, Set CAFLabel)
572 -> StateT SRTMap
573 (StateT ModuleSRTInfo UniqSM)
574 ( [CmmDecl] -- generated SRTs
575 , [(Label, CLabel)] -- SRT fields for info tables
576 , [(Label, [SRTEntry])] -- SRTs to attach to static functions
577 )
578
579 doSCC dflags staticFuns (AcyclicSCC (l, cafLbl, cafs)) =
580 oneSRT dflags staticFuns [l] [cafLbl] cafs
581
582 doSCC dflags staticFuns (CyclicSCC nodes) = do
583 -- build a single SRT for the whole cycle
584 let (blockids, lbls, cafsets) = unzip3 nodes
585 cafs = Set.unions cafsets `Set.difference` Set.fromList lbls
586 oneSRT dflags staticFuns blockids lbls cafs
587
588
589 -- | Build an SRT for a set of blocks
590 oneSRT
591 :: DynFlags
592 -> LabelMap CLabel -- which blocks are static function entry points
593 -> [Label] -- blocks in this set
594 -> [CAFLabel] -- labels for those blocks
595 -> Set CAFLabel -- SRT for this set
596 -> StateT SRTMap
597 (StateT ModuleSRTInfo UniqSM)
598 ( [CmmDecl] -- SRT objects we built
599 , [(Label, CLabel)] -- SRT fields for these blocks' itbls
600 , [(Label, [SRTEntry])] -- SRTs to attach to static functions
601 )
602
603 oneSRT dflags staticFuns blockids lbls cafs = do
604 srtMap <- get
605 topSRT <- lift get
606 let
607 -- First resolve all the CAFLabels to SRTEntries
608 -- implements the [Shortcut] optimisation.
609 resolved =
610 Set.fromList $
611 catMaybes (map (resolveCAF srtMap) (Set.toList cafs))
612
613 -- The set of all SRTEntries in SRTs that we refer to from here.
614 allBelow =
615 Set.unions [ lbls | caf <- Set.toList resolved
616 , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
617
618 -- Remove SRTEntries that are also in an SRT that we refer to.
619 -- Implements the [Filter] optimisation.
620 filtered = Set.difference resolved allBelow
621
622 srtTrace "oneSRT:"
623 (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()
624
625 let
626 updateSRTMap srtEntry = do
627 let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
628 put (Map.union newSRTMap srtMap)
629
630 case Set.toList filtered of
631 [] -> do
632 srtTrace "oneSRT: empty" (ppr lbls) $ return ()
633 updateSRTMap Nothing
634 return ([], [], [])
635
636 [one@(SRTEntry lbl)]
637 | not (labelDynamic dflags (thisModule topSRT) lbl) -> do
638 updateSRTMap (Just one)
639 return ([], map (,lbl) blockids, [])
640
641 cafList ->
642 -- Check whether an SRT with the same entries has been emitted already.
643 -- Implements the [Common] optimisation.
644 case Map.lookup filtered (dedupSRTs topSRT) of
645 Just srtEntry@(SRTEntry srtLbl) -> do
646 srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
647 updateSRTMap (Just srtEntry)
648 return ([], map (,srtLbl) blockids, [])
649 Nothing -> do
650 -- No duplicates: we have to build a new SRT object
651 srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
652 let
653 -- Can we merge this SRT with a FUN_STATIC closure?
654 maybeFunClosure = listToMaybe
655 [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ]
656 (decls, funSRTs, srtEntry) <-
657 case maybeFunClosure of
658 Just (fun,block) ->
659 return ( [], [(block, cafList)], SRTEntry fun )
660 Nothing -> do
661 (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
662 return (decls, [], entry)
663 updateSRTMap (Just srtEntry)
664 let allBelowThis = Set.union allBelow filtered
665 oldFlatSRTs = flatSRTs topSRT
666 newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
667 newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
668 lift (put (topSRT { dedupSRTs = newDedupSRTs
669 , flatSRTs = newFlatSRTs }))
670 let SRTEntry lbl = srtEntry
671 return (decls, map (,lbl) blockids, funSRTs)
672
673
674 -- | build a static SRT object (or a chain of objects) from a list of
675 -- SRTEntries.
676 buildSRTChain
677 :: DynFlags
678 -> [SRTEntry]
679 -> UniqSM
680 ( [CmmDecl] -- The SRT object(s)
681 , SRTEntry -- label to use in the info table
682 )
683 buildSRTChain _ [] = panic "buildSRT: empty"
684 buildSRTChain dflags cafSet =
685 case splitAt mAX_SRT_SIZE cafSet of
686 (these, []) -> do
687 (decl,lbl) <- buildSRT dflags these
688 return ([decl], lbl)
689 (these,those) -> do
690 (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
691 (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
692 return (decl:rest, lbl)
693 where
694 mAX_SRT_SIZE = 16
695
696
697 buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
698 buildSRT dflags refs = do
699 id <- getUniqueM
700 let
701 lbl = mkSRTLabel id
702 srt_n_info = mkSRTInfoLabel (length refs)
703 fields =
704 mkStaticClosure dflags srt_n_info dontCareCCS
705 [ CmmLabel lbl | SRTEntry lbl <- refs ]
706 [] -- no padding
707 [mkIntCLit dflags 0] -- link field
708 [] -- no saved info
709 return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
710
711
712 -- | Update info tables with references to their SRTs. Also generate
713 -- static closures, splicing in SRT fields as necessary.
714 updInfoSRTs
715 :: DynFlags
716 -> LabelMap CLabel -- SRT labels for each block
717 -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures
718 -> CmmDecl
719 -> [CmmDecl]
720
721 updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
722 | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
723 | otherwise = [ proc ]
724 where
725 proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
726 newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
727 updInfoTbl l info_tbl
728 | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
729 | otherwise = info_tbl { cit_srt = mapLookup l srt_env }
730
731 -- Generate static closures [FUN]. Note that this also generates
732 -- static closures for thunks (CAFs), because it's easier to treat
733 -- them uniformly in the code generator.
734 maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
735 maybeStaticClosure
736 | Just info_tbl@CmmInfoTable{..} <-
737 mapLookup (g_entry g) (info_tbls top_info)
738 , Just (id, ccs) <- cit_clo
739 , isStaticRep cit_rep =
740 let
741 (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
742 Nothing ->
743 -- if we don't add SRT entries to this closure, then we
744 -- want to set the srt field in its info table as usual
745 (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
746 Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
747 (info_tbl { cit_rep = new_rep }, res)
748 where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
749 fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
750 srtEntries
751 new_rep = case cit_rep of
752 HeapRep sta ptrs nptrs ty ->
753 HeapRep sta (ptrs + length srtEntries) nptrs ty
754 _other -> panic "maybeStaticFun"
755 lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
756 in
757 Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
758 | otherwise = Nothing
759
760 updInfoSRTs _ _ _ t = [t]
761
762
763 srtTrace :: String -> SDoc -> b -> b
764 -- srtTrace = pprTrace
765 srtTrace _ _ b = b