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