never executed always true always false
1 {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
2 GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
3 ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
4 {-# LANGUAGE MultiParamTypeClasses #-}
5 {-# LANGUAGE FlexibleInstances #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE DerivingStrategies #-}
8 {-# LANGUAGE FlexibleContexts #-}
9 {-# LANGUAGE UndecidableInstances #-}
10
11
12 module GHC.Cmm.Info.Build
13 ( CAFSet, CAFEnv, cafAnal, cafAnalData
14 , doSRTs, ModuleSRTInfo (..), emptySRT
15 , SRTMap, srtMapNonCAFs
16 ) where
17
18 import GHC.Prelude hiding (succ)
19
20 import GHC.Platform
21 import GHC.Platform.Profile
22
23 import GHC.Types.Id
24 import GHC.Types.Id.Info
25 import GHC.Cmm.BlockId
26 import GHC.Cmm.Dataflow.Block
27 import GHC.Cmm.Dataflow.Graph
28 import GHC.Cmm.Dataflow.Label
29 import GHC.Cmm.Dataflow.Collections
30 import GHC.Cmm.Dataflow
31 import GHC.Unit.Module
32 import GHC.Data.Graph.Directed
33 import GHC.Cmm.CLabel
34 import GHC.Cmm
35 import GHC.Cmm.Utils
36 import GHC.Driver.Session
37 import GHC.Data.Maybe
38 import GHC.Utils.Outputable
39 import GHC.Utils.Panic
40 import GHC.Runtime.Heap.Layout
41 import GHC.Types.Unique.Supply
42 import GHC.Types.CostCentre
43 import GHC.StgToCmm.Heap
44 import GHC.Driver.Config.CmmToAsm
45
46 import Control.Monad
47 import Data.Map.Strict (Map)
48 import qualified Data.Map.Strict as Map
49 import Data.Set (Set)
50 import qualified Data.Set as Set
51 import Control.Monad.Trans.State
52 import Control.Monad.Trans.Class
53 import Data.List (unzip4)
54
55 import GHC.Types.Name.Set
56
57 {- Note [SRTs]
58
59 SRTs are the mechanism by which the garbage collector can determine
60 the live CAFs in the program.
61
62 Representation
63 ^^^^^^^^^^^^^^
64
65 +------+
66 | info |
67 | | +-----+---+---+---+
68 | -------->|SRT_2| | | | | 0 |
69 |------| +-----+-|-+-|-+---+
70 | | | |
71 | code | | |
72 | | v v
73
74 An SRT is simply an object in the program's data segment. It has the
75 same representation as a static constructor. There are 16
76 pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
77 representing SRT objects with 1-16 pointers, respectively.
78
79 The entries of an SRT object point to static closures, which are either
80 - FUN_STATIC, THUNK_STATIC or CONSTR
81 - Another SRT (actually just a CONSTR)
82
83 The final field of the SRT is the static link field, used by the
84 garbage collector to chain together static closures that it visits and
85 to determine whether a static closure has been visited or not. (see
86 Note [STATIC_LINK fields])
87
88 By traversing the transitive closure of an SRT, the GC will reach all
89 of the CAFs that are reachable from the code associated with this SRT.
90
91 If we need to create an SRT with more than 16 entries, we build a
92 chain of SRT objects with all but the last having 16 entries.
93
94 +-----+---+- -+---+---+
95 |SRT16| | | | | | 0 |
96 +-----+-|-+- -+-|-+---+
97 | |
98 v v
99 +----+---+---+---+
100 |SRT2| | | | | 0 |
101 +----+-|-+-|-+---+
102 | |
103 | |
104 v v
105
106 Referring to an SRT from the info table
107 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
108
109 The following things have SRTs:
110
111 - Static functions (FUN)
112 - Static thunks (THUNK), ie. CAFs
113 - Continuations (RET_SMALL, etc.)
114
115 In each case, the info table points to the SRT.
116
117 - info->srt is zero if there's no SRT, otherwise:
118 - info->srt == 1 and info->f.srt_offset points to the SRT
119
120 e.g. for a FUN with an SRT:
121
122 StgFunInfoTable +------+
123 info->f.srt_offset | ------------> offset to SRT object
124 StgStdInfoTable +------+
125 info->layout.ptrs | ... |
126 info->layout.nptrs | ... |
127 info->srt | 1 |
128 info->type | ... |
129 |------|
130
131 On x86_64, we optimise the info table representation further. The
132 offset to the SRT can be stored in 32 bits (all code lives within a
133 2GB region in x86_64's small memory model), so we can save a word in
134 the info table by storing the srt_offset in the srt field, which is
135 half a word.
136
137 On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
138
139 - info->srt is zero if there's no SRT, otherwise:
140 - info->srt is an offset from the info pointer to the SRT object
141
142 StgStdInfoTable +------+
143 info->layout.ptrs | |
144 info->layout.nptrs | |
145 info->srt | ------------> offset to SRT object
146 |------|
147
148
149 EXAMPLE
150 ^^^^^^^
151
152 f = \x. ... g ...
153 where
154 g = \y. ... h ... c1 ...
155 h = \z. ... c2 ...
156
157 c1 & c2 are CAFs
158
159 g and h are local functions, but they have no static closures. When
160 we generate code for f, we start with a CmmGroup of four CmmDecls:
161
162 [ f_closure, f_entry, g_entry, h_entry ]
163
164 we process each CmmDecl separately in cpsTop, giving us a list of
165 CmmDecls. e.g. for f_entry, we might end up with
166
167 [ f_entry, f1_ret, f2_proc ]
168
169 where f1_ret is a return point, and f2_proc is a proc-point. We have
170 a CAFSet for each of these CmmDecls, let's suppose they are
171
172 [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
173 [ g_entry{h_info, c1_closure} ]
174 [ h_entry{c2_closure} ]
175
176 Next, we make an SRT for each of these functions:
177
178 f_srt : [g_info]
179 g_srt : [h_info, c1_closure]
180 h_srt : [c2_closure]
181
182 Now, for g_info and h_info, we want to refer to the SRTs for g and h
183 respectively, which we'll label g_srt and h_srt:
184
185 f_srt : [g_srt]
186 g_srt : [h_srt, c1_closure]
187 h_srt : [c2_closure]
188
189 Now, when an SRT has a single entry, we don't actually generate an SRT
190 closure for it, instead we just replace references to it with its
191 single element. So, since h_srt == c2_closure, we have
192
193 f_srt : [g_srt]
194 g_srt : [c2_closure, c1_closure]
195 h_srt : [c2_closure]
196
197 and the only SRT closure we generate is
198
199 g_srt = SRT_2 [c2_closure, c1_closure]
200
201 Algorithm
202 ^^^^^^^^^
203
204 0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}
205 Maps closures to their SRT entries (i.e. how they appear in a SRT payload)
206
207 1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG
208 after code-generation.
209
210 2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might
211 be multiple CmmDecls in the result, due to proc-point splitting.
212
213 3. In cpsTop, *before* proc-point splitting, when we still have a single
214 CmmDecl, we do cafAnal for procs:
215
216 * cafAnal performs a backwards analysis on the code blocks
217
218 * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel),
219 representing all the CAFLabels reachable from this label.
220
221 * A label is added to the set if it refers to a FUN, THUNK, or RET,
222 and its CafInfo /= NoCafRefs.
223 (NB. all CafInfo for Ids in the current module should be initialised to
224 MayHaveCafRefs)
225
226 * The result is CAFEnv = LabelMap CAFSet
227
228 (Why *before* proc-point splitting? Because the analysis needs to propagate
229 information across branches, and proc-point splitting turns branches into
230 CmmCalls to top-level CmmDecls. The analysis would fail to find all the
231 references to CAFFY labels if we did it after proc-point splitting.)
232
233 For static data, cafAnalData simply returns set of all labels that refer to a
234 FUN, THUNK, and RET whose CafInfos /= NoCafRefs.
235
236 4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl)
237 for static data. So after `mapM cpsTop decls` we have
238 [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)]
239
240 5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl])
241
242 6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets)
243
244 7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel
245
246 8. For each SCC in dependency order
247 - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC
248 - Apply CAFEnv to each label and concat the result :: [CAFLabel]
249 - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get
250 srt :: [SRTEntry]
251 - Make a label for this SRT, call it l
252 - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the
253 group to the SRT (see Note [Invalid optimisation: shortcutting])
254 - Add to srtMap: lbls -> if null srt then Nothing else Just l
255
256 9. At the end, for every top-level binding x, if srtMap x == Nothing, then the
257 binding is non-CAFFY, otherwise it is CAFFY.
258
259 Optimisations
260 ^^^^^^^^^^^^^
261
262 To reduce the code size overhead and the cost of traversing SRTs in
263 the GC, we want to simplify SRTs where possible. We therefore apply
264 the following optimisations. Each has a [keyword]; search for the
265 keyword in the code below to see where the optimisation is
266 implemented.
267
268 1. [Inline] we never create an SRT with a single entry, instead we
269 point to the single entry directly from the info table.
270
271 i.e. instead of
272
273 +------+
274 | info |
275 | | +-----+---+---+
276 | -------->|SRT_1| | | 0 |
277 |------| +-----+-|-+---+
278 | | |
279 | code | |
280 | | v
281 C
282
283 we can point directly to the closure:
284
285 +------+
286 | info |
287 | |
288 | -------->C
289 |------|
290 | |
291 | code |
292 | |
293
294
295 Furthermore, the SRT for any code that refers to this info table
296 can point directly to C.
297
298 The exception to this is when we're doing dynamic linking. In that
299 case, if the closure is not locally defined then we can't point to
300 it directly from the info table, because this is the text section
301 which cannot contain runtime relocations. In this case we skip this
302 optimisation and generate the singleton SRT, because SRTs are in the
303 data section and *can* have relocatable references.
304
305 2. [FUN] A static function closure can also be an SRT, we simply put
306 the SRT entries as fields in the static closure. This makes a lot
307 of sense: the static references are just like the free variables of
308 the FUN closure.
309
310 i.e. instead of
311
312 f_closure:
313 +-----+---+
314 | | | 0 |
315 +- |--+---+
316 | +------+
317 | | info | f_srt:
318 | | | +-----+---+---+---+
319 | | -------->|SRT_2| | | | + 0 |
320 `----------->|------| +-----+-|-+-|-+---+
321 | | | |
322 | code | | |
323 | | v v
324
325
326 We can generate:
327
328 f_closure:
329 +-----+---+---+---+
330 | | | | | | | 0 |
331 +- |--+-|-+-|-+---+
332 | | | +------+
333 | v v | info |
334 | | |
335 | | 0 |
336 `----------->|------|
337 | |
338 | code |
339 | |
340
341
342 (note: we can't do this for THUNKs, because the thunk gets
343 overwritten when it is entered, so we wouldn't be able to share
344 this SRT with other info tables that want to refer to it (see
345 [Common] below). FUNs are immutable so don't have this problem.)
346
347 3. [Common] Identical SRTs can be commoned up.
348
349 4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
350 refers to C (perhaps transitively), then we can omit the reference
351 to C from A.
352
353
354 Note that there are many other optimisations that we could do, but
355 aren't implemented. In general, we could omit any reference from an
356 SRT if everything reachable from it is also reachable from the other
357 fields in the SRT. Our [Filter] optimisation is a special case of
358 this.
359
360 Another opportunity we don't exploit is this:
361
362 A = {X,Y,Z}
363 B = {Y,Z}
364 C = {X,B}
365
366 Here we could use C = {A} and therefore [Inline] C = A.
367 -}
368
369 -- ---------------------------------------------------------------------
370 {- Note [Invalid optimisation: shortcutting]
371
372 You might think that if we have something like
373
374 A's SRT = {B}
375 B's SRT = {X}
376
377 that we could replace the reference to B in A's SRT with X.
378
379 A's SRT = {X}
380 B's SRT = {X}
381
382 and thereby perhaps save a little work at runtime, because we don't
383 have to visit B.
384
385 But this is NOT valid.
386
387 Consider these cases:
388
389 0. B can't be a constructor, because constructors don't have SRTs
390
391 1. B is a CAF. This is the easy one. Obviously we want A's SRT to
392 point to B, so that it keeps B alive.
393
394 2. B is a function. This is the tricky one. The reason we can't
395 shortcut in this case is that we aren't allowed to resurrect static
396 objects.
397
398 == How does this cause a problem? ==
399
400 The particular case that cropped up when we tried this was #15544.
401 - A is a thunk
402 - B is a static function
403 - X is a CAF
404 - suppose we GC when A is alive, and B is not otherwise reachable.
405 - B is "collected", meaning that it doesn't make it onto the static
406 objects list during this GC, but nothing bad happens yet.
407 - Next, suppose we enter A, and then call B. (remember that A refers to B)
408 At the entry point to B, we GC. This puts B on the stack, as part of the
409 RET_FUN stack frame that gets pushed when we GC at a function entry point.
410 - This GC will now reach B
411 - But because B was previous "collected", it breaks the assumption
412 that static objects are never resurrected. See Note [STATIC_LINK
413 fields] in rts/sm/Storage.h for why this is bad.
414 - In practice, the GC thinks that B has already been visited, and so
415 doesn't visit X, and catastrophe ensues.
416
417 == Isn't this caused by the RET_FUN business? ==
418
419 Maybe, but could you prove that RET_FUN is the only way that
420 resurrection can occur?
421
422 So, no shortcutting.
423
424 Note [Ticky labels in SRT analysis]
425 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
426
427 Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered
428 non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing`
429 (meaning they're not CAFFY).
430
431 However when building with -ticky we generate ticky CLabels using the function's
432 `Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky
433 build we get two IdLabels using the name `sat_s1rQ`:
434
435 - For the function itself: IdLabel sat_s1rQ ... Entry
436 - For the ticky counter: IdLabel sat_s1rQ ... RednCounts
437
438 In these cases we really want to use the function definition for the SRT
439 analysis of this Name, because that's what we export for this Name -- ticky
440 counters are not exported. So we ignore ticky counters in SRT analysis (which
441 are never CAFFY and never exported).
442
443 Not doing this caused #17947 where we analysed the function first mapped the
444 name to CAFFY. We then saw the ticky constructor, and because it has the same
445 Name as the function and is not CAFFY we overrode the CafInfo of the name as
446 non-CAFFY.
447 -}
448
449 -- ---------------------------------------------------------------------
450 -- Label types
451
452 -- Labels that come from cafAnal can be:
453 -- - _closure labels for static functions or CAFs
454 -- - _info labels for dynamic functions, thunks, or continuations
455 -- - _entry labels for functions or thunks
456 --
457 -- Meanwhile the labels on top-level blocks are _entry labels.
458 --
459 -- To put everything in the same namespace we convert all labels to
460 -- closure labels using toClosureLbl. Note that some of these
461 -- labels will not actually exist; that's ok because we're going to
462 -- map them to SRTEntry later, which ranges over labels that do exist.
463 --
464 newtype CAFLabel = CAFLabel CLabel
465 deriving (Eq,Ord)
466
467 deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel
468
469 type CAFSet = Set CAFLabel
470 type CAFEnv = LabelMap CAFSet
471
472 mkCAFLabel :: Platform -> CLabel -> CAFLabel
473 mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)
474
475 -- This is a label that we can put in an SRT. It *must* be a closure label,
476 -- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
477 newtype SRTEntry = SRTEntry CLabel
478 deriving (Eq, Ord)
479
480 deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry
481
482
483 -- ---------------------------------------------------------------------
484 -- CAF analysis
485
486 addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
487 addCafLabel platform l s
488 | Just _ <- hasHaskellName l
489 , let caf_label = mkCAFLabel platform l
490 -- For imported Ids hasCAF will have accurate CafInfo
491 -- Locals are initialized as CAFFY. We turn labels with empty SRTs into
492 -- non-CAFFYs in doSRTs
493 , hasCAF l
494 = Set.insert caf_label s
495 | otherwise
496 = s
497
498 cafAnalData
499 :: Platform
500 -> CmmStatics
501 -> CAFSet
502 cafAnalData platform st = case st of
503 CmmStaticsRaw _lbl _data -> Set.empty
504 CmmStatics _lbl _itbl _ccs payload ->
505 foldl' analyzeStatic Set.empty payload
506 where
507 analyzeStatic s lit =
508 case lit of
509 CmmLabel c -> addCafLabel platform c s
510 CmmLabelOff c _ -> addCafLabel platform c s
511 CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s
512 _ -> s
513
514 -- |
515 -- For each code block:
516 -- - collect the references reachable from this code block to FUN,
517 -- THUNK or RET labels for which hasCAF == True
518 --
519 -- This gives us a `CAFEnv`: a mapping from code block to sets of labels
520 --
521 cafAnal
522 :: Platform
523 -> LabelSet -- The blocks representing continuations, ie. those
524 -- that will get RET info tables. These labels will
525 -- get their own SRTs, so we don't aggregate CAFs from
526 -- references to these labels, we just use the label.
527 -> CLabel -- The top label of the proc
528 -> CmmGraph
529 -> CAFEnv
530 cafAnal platform contLbls topLbl cmmGraph =
531 analyzeCmmBwd cafLattice
532 (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
533
534
535 cafLattice :: DataflowLattice CAFSet
536 cafLattice = DataflowLattice Set.empty add
537 where
538 add (OldFact old) (NewFact new) =
539 let !new' = old `Set.union` new
540 in changedIf (Set.size new' > Set.size old) new'
541
542
543 cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
544 cafTransfers platform contLbls entry topLbl
545 block@(BlockCC eNode middle xNode) fBase =
546 let joined :: CAFSet
547 joined = cafsInNode xNode $! live'
548
549 result :: CAFSet
550 !result = foldNodesBwdOO cafsInNode middle joined
551
552 facts :: [Set CAFLabel]
553 facts = mapMaybe successorFact (successors xNode)
554
555 live' :: CAFSet
556 live' = joinFacts cafLattice facts
557
558 successorFact :: Label -> Maybe (Set CAFLabel)
559 successorFact s
560 -- If this is a loop back to the entry, we can refer to the
561 -- entry label.
562 | s == entry = Just (addCafLabel platform topLbl Set.empty)
563 -- If this is a continuation, we want to refer to the
564 -- SRT for the continuation's info table
565 | s `setMember` contLbls
566 = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))
567 -- Otherwise, takes the CAF references from the destination
568 | otherwise
569 = lookupFact s fBase
570
571 cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
572 cafsInNode node set = foldExpDeep addCafExpr node set
573
574 addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
575 addCafExpr expr !set =
576 case expr of
577 CmmLit (CmmLabel c) ->
578 addCafLabel platform c set
579 CmmLit (CmmLabelOff c _) ->
580 addCafLabel platform c set
581 CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
582 addCafLabel platform c1 $! addCafLabel platform c2 set
583 _ ->
584 set
585 in
586 srtTrace "cafTransfers" (text "block:" <+> pdoc platform block $$
587 text "contLbls:" <+> ppr contLbls $$
588 text "entry:" <+> ppr entry $$
589 text "topLbl:" <+> pdoc platform topLbl $$
590 text "cafs in exit:" <+> pdoc platform joined $$
591 text "result:" <+> pdoc platform result) $
592 mapSingleton (entryLabel eNode) result
593
594
595 -- -----------------------------------------------------------------------------
596 -- ModuleSRTInfo
597
598 data ModuleSRTInfo = ModuleSRTInfo
599 { thisModule :: Module
600 -- ^ Current module being compiled. Required for calling labelDynamic.
601 , dedupSRTs :: Map (Set SRTEntry) SRTEntry
602 -- ^ previous SRTs we've emitted, so we can de-duplicate.
603 -- Used to implement the [Common] optimisation.
604 , flatSRTs :: Map SRTEntry (Set SRTEntry)
605 -- ^ The reverse mapping, so that we can remove redundant
606 -- entries. e.g. if we have an SRT [a,b,c], and we know that b
607 -- points to [c,d], we can omit c and emit [a,b].
608 -- Used to implement the [Filter] optimisation.
609 , moduleSRTMap :: SRTMap
610 }
611
612 instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where
613 pdoc env ModuleSRTInfo{..} =
614 text "ModuleSRTInfo {" $$
615 (nest 4 $ text "dedupSRTs =" <+> pdoc env dedupSRTs $$
616 text "flatSRTs =" <+> pdoc env flatSRTs $$
617 text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}'
618
619 emptySRT :: Module -> ModuleSRTInfo
620 emptySRT mod =
621 ModuleSRTInfo
622 { thisModule = mod
623 , dedupSRTs = Map.empty
624 , flatSRTs = Map.empty
625 , moduleSRTMap = Map.empty
626 }
627
628 -- -----------------------------------------------------------------------------
629 -- Constructing SRTs
630
631 {- Implementation notes
632
633 - In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
634
635 - The entry in info_tbls corresponding to g_entry is the closure info
636 table, the rest are continuations.
637
638 - Each entry in info_tbls possibly needs an SRT. We need to make a
639 label for each of these.
640
641 - We get the CAFSet for each entry from the CAFEnv
642
643 -}
644
645 data SomeLabel
646 = BlockLabel !Label
647 | DeclLabel CLabel
648 deriving (Eq, Ord)
649
650 instance OutputableP env CLabel => OutputableP env SomeLabel where
651 pdoc env = \case
652 BlockLabel l -> text "b:" <+> pdoc env l
653 DeclLabel l -> text "s:" <+> pdoc env l
654
655 getBlockLabel :: SomeLabel -> Maybe Label
656 getBlockLabel (BlockLabel l) = Just l
657 getBlockLabel (DeclLabel _) = Nothing
658
659 getBlockLabels :: [SomeLabel] -> [Label]
660 getBlockLabels = mapMaybe getBlockLabel
661
662 -- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
663 -- where the label is
664 -- - the info label for a continuation or dynamic closure
665 -- - the closure label for a top-level function (not a CAF)
666 getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
667 getLabelledBlocks platform decl = case decl of
668 CmmData _ (CmmStaticsRaw _ _) -> []
669 CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]
670 CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)
671 | (blockId, info) <- mapToList (info_tbls top_info)
672 , let rep = cit_rep info
673 , not (isStaticRep rep) || not (isThunkRep rep)
674 , let !caf_lbl = mkCAFLabel platform (cit_lbl info)
675 ]
676
677 -- | Put the labelled blocks that we will be annotating with SRTs into
678 -- dependency order. This is so that we can process them one at a
679 -- time, resolving references to earlier blocks to point to their
680 -- SRTs. CAFs themselves are not included here; see getCAFs below.
681 depAnalSRTs
682 :: Platform
683 -> CAFEnv
684 -> Map CLabel CAFSet -- CAFEnv for statics
685 -> [CmmDecl]
686 -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
687 depAnalSRTs platform cafEnv cafEnv_static decls =
688 srtTrace "depAnalSRTs" (text "decls:" <+> pdoc platform decls $$
689 text "nodes:" <+> pdoc platform (map node_payload nodes) $$
690 text "graph:" <+> pdoc platform graph) graph
691 where
692 labelledBlocks :: [(SomeLabel, CAFLabel)]
693 labelledBlocks = concatMap (getLabelledBlocks platform) decls
694 labelToBlock :: Map CAFLabel SomeLabel
695 labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
696
697 nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
698 nodes = [ DigraphNode (l,lbl,cafs') l
699 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
700 | (l, lbl) <- labelledBlocks
701 , Just (cafs :: Set CAFLabel) <-
702 [case l of
703 BlockLabel l -> mapLookup l cafEnv
704 DeclLabel cl -> Map.lookup cl cafEnv_static]
705 , let cafs' = Set.delete lbl cafs
706 ]
707
708 graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
709 graph = stronglyConnCompFromEdgedVerticesOrd nodes
710
711 -- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
712 -- These are treated differently from other labelled blocks:
713 -- - we never shortcut a reference to a CAF to the contents of its
714 -- SRT, since the point of SRTs is to keep CAFs alive.
715 -- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
716 -- instead we generate their SRTs after everything else.
717 getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
718 getCAFs platform cafEnv decls =
719 [ (g_entry g, mkCAFLabel platform topLbl, cafs)
720 | CmmProc top_info topLbl _ g <- decls
721 , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
722 , let rep = cit_rep info
723 , isStaticRep rep && isThunkRep rep
724 , Just cafs <- [mapLookup (g_entry g) cafEnv]
725 ]
726
727
728 -- | Get the list of blocks that correspond to the entry points for
729 -- FUN_STATIC closures. These are the blocks for which if we have an
730 -- SRT we can merge it with the static closure. [FUN]
731 getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
732 getStaticFuns decls =
733 [ (g_entry g, lbl)
734 | CmmProc top_info _ _ g <- decls
735 , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
736 , Just (id, _) <- [cit_clo info]
737 , let rep = cit_rep info
738 , isStaticRep rep && isFunRep rep
739 , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
740 ]
741
742
743 -- | Maps labels from 'cafAnal' to the final CLabel that will appear
744 -- in the SRT.
745 -- - closures with singleton SRTs resolve to their single entry
746 -- - closures with larger SRTs map to the label for that SRT
747 -- - CAFs must not map to anything!
748 -- - if a labels maps to Nothing, we found that this label's SRT
749 -- is empty, so we don't need to refer to it from other SRTs.
750 type SRTMap = Map CAFLabel (Maybe SRTEntry)
751
752
753 -- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
754 -- module. Any 'Name's not in the set are CAFFY.
755 srtMapNonCAFs :: SRTMap -> NonCaffySet
756 srtMapNonCAFs srtMap =
757 NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
758 where
759 get_name (CAFLabel l, Nothing) = hasHaskellName l
760 get_name (_l, Just _srt_entry) = Nothing
761
762 -- | resolve a CAFLabel to its SRTEntry using the SRTMap
763 resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
764 resolveCAF platform srtMap lbl@(CAFLabel l) =
765 srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret
766 where
767 ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap
768
769 -- | Attach SRTs to all info tables in the CmmDecls, and add SRT
770 -- declarations to the ModuleSRTInfo.
771 --
772 doSRTs
773 :: DynFlags
774 -> ModuleSRTInfo
775 -> [(CAFEnv, [CmmDecl])]
776 -> [(CAFSet, CmmDecl)]
777 -> IO (ModuleSRTInfo, [CmmDeclSRTs])
778
779 doSRTs dflags moduleSRTInfo procs data_ = do
780 us <- mkSplitUniqSupply 'u'
781
782 let profile = targetProfile dflags
783
784 -- Ignore the original grouping of decls, and combine all the
785 -- CAFEnvs into a single CAFEnv.
786 let static_data_env :: Map CLabel CAFSet
787 static_data_env =
788 Map.fromList $
789 flip map data_ $
790 \(set, decl) ->
791 case decl of
792 CmmProc{} ->
793 pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
794 CmmData _ static ->
795 case static of
796 CmmStatics lbl _ _ _ -> (lbl, set)
797 CmmStaticsRaw lbl _ -> (lbl, set)
798
799 static_data :: Set CLabel
800 static_data = Map.keysSet static_data_env
801
802 (proc_envs, procss) = unzip procs
803 cafEnv = mapUnions proc_envs
804 decls = map snd data_ ++ concat procss
805 staticFuns = mapFromList (getStaticFuns decls)
806
807 platform = targetPlatform dflags
808
809 -- Put the decls in dependency order. Why? So that we can implement
810 -- [Inline] and [Filter]. If we need to refer to an SRT that has
811 -- a single entry, we use the entry itself, which means that we
812 -- don't need to generate the singleton SRT in the first place. But
813 -- to do this we need to process blocks before things that depend on
814 -- them.
815 let
816 sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
817 sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
818
819 cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
820 cafsWithSRTs = getCAFs platform cafEnv decls
821
822 srtTraceM "doSRTs" (text "data:" <+> pdoc platform data_ $$
823 text "procs:" <+> pdoc platform procs $$
824 text "static_data_env:" <+> pdoc platform static_data_env $$
825 text "sccs:" <+> pdoc platform sccs $$
826 text "cafsWithSRTs:" <+> pdoc platform cafsWithSRTs)
827
828 -- On each strongly-connected group of decls, construct the SRT
829 -- closures and the SRT fields for info tables.
830 let result ::
831 [ ( [CmmDeclSRTs] -- generated SRTs
832 , [(Label, CLabel)] -- SRT fields for info tables
833 , [(Label, [SRTEntry])] -- SRTs to attach to static functions
834 , Bool -- Whether the group has CAF references
835 ) ]
836
837 (result, moduleSRTInfo') =
838 initUs_ us $
839 flip runStateT moduleSRTInfo $ do
840 nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs
841 cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
842 oneSRT dflags staticFuns [BlockLabel l] [cafLbl]
843 True{-is a CAF-} cafs static_data
844 return (nonCAFs ++ cAFs)
845
846 (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
847 srt_decls = concat srt_declss
848
849 -- Next, update the info tables with the SRTs
850 let
851 srtFieldMap = mapFromList (concat pairs)
852 funSRTMap = mapFromList (concat funSRTs)
853 has_caf_refs' = or has_caf_refs
854 decls' =
855 concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls
856
857 -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are
858 -- not analysed in oneSRT so we never add entries for them to the SRTMap.
859 let srtMap_w_raws =
860 foldl' (\(srtMap :: SRTMap) (_, decl) ->
861 case decl of
862 CmmData _ CmmStatics{} ->
863 -- already updated by oneSRT
864 srtMap
865 CmmData _ (CmmStaticsRaw lbl _)
866 | isIdLabel lbl && not (isTickyLabel lbl) ->
867 -- Raw data are not analysed by oneSRT and they can't
868 -- be CAFFY.
869 -- See Note [Ticky labels in SRT analysis] above for
870 -- why we exclude ticky labels here.
871 Map.insert (mkCAFLabel platform lbl) Nothing srtMap
872 | otherwise ->
873 -- Not an IdLabel, ignore
874 srtMap
875 CmmProc{} ->
876 pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
877 (moduleSRTMap moduleSRTInfo') data_
878
879 return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
880
881
882 -- | Build the SRT for a strongly-connected component of blocks
883 doSCC
884 :: DynFlags
885 -> LabelMap CLabel -- which blocks are static function entry points
886 -> Set CLabel -- static data
887 -> SCC (SomeLabel, CAFLabel, Set CAFLabel)
888 -> StateT ModuleSRTInfo UniqSM
889 ( [CmmDeclSRTs] -- generated SRTs
890 , [(Label, CLabel)] -- SRT fields for info tables
891 , [(Label, [SRTEntry])] -- SRTs to attach to static functions
892 , Bool -- Whether the group has CAF references
893 )
894
895 doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =
896 oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data
897
898 doSCC dflags staticFuns static_data (CyclicSCC nodes) = do
899 -- build a single SRT for the whole cycle, see Note [recursive SRTs]
900 let (lbls, caf_lbls, cafsets) = unzip3 nodes
901 cafs = Set.unions cafsets
902 oneSRT dflags staticFuns lbls caf_lbls False cafs static_data
903
904
905 {- Note [recursive SRTs]
906
907 If the dependency analyser has found us a recursive group of
908 declarations, then we build a single SRT for the whole group, on the
909 grounds that everything in the group is reachable from everything
910 else, so we lose nothing by having a single SRT.
911
912 However, there are a couple of wrinkles to be aware of.
913
914 * The Set CAFLabel for this SRT will contain labels in the group
915 itself. The SRTMap will therefore not contain entries for these labels
916 yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
917 can just remove recursive references from the Set CAFLabel before
918 generating the SRT - the SRT will still contain all the CAFLabels that
919 we need to refer to from this group's SRT.
920
921 * That is, EXCEPT for static function closures. For the same reason
922 described in Note [Invalid optimisation: shortcutting], we cannot omit
923 references to static function closures.
924 - But, since we will merge the SRT with one of the static function
925 closures (see [FUN]), we can omit references to *that* static
926 function closure from the SRT.
927 -}
928
929 -- | Build an SRT for a set of blocks
930 oneSRT
931 :: DynFlags
932 -> LabelMap CLabel -- which blocks are static function entry points
933 -> [SomeLabel] -- blocks in this set
934 -> [CAFLabel] -- labels for those blocks
935 -> Bool -- True <=> this SRT is for a CAF
936 -> Set CAFLabel -- SRT for this set
937 -> Set CLabel -- Static data labels in this group
938 -> StateT ModuleSRTInfo UniqSM
939 ( [CmmDeclSRTs] -- SRT objects we built
940 , [(Label, CLabel)] -- SRT fields for these blocks' itbls
941 , [(Label, [SRTEntry])] -- SRTs to attach to static functions
942 , Bool -- Whether the group has CAF references
943 )
944
945 oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
946 topSRT <- get
947
948 let
949 this_mod = thisModule topSRT
950 config = initNCGConfig dflags this_mod
951 profile = targetProfile dflags
952 platform = profilePlatform profile
953 srtMap = moduleSRTMap topSRT
954
955 blockids = getBlockLabels lbls
956
957 -- Can we merge this SRT with a FUN_STATIC closure?
958 maybeFunClosure :: Maybe (CLabel, Label)
959 otherFunLabels :: [CLabel]
960 (maybeFunClosure, otherFunLabels) =
961 case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
962 [] -> (Nothing, [])
963 ((l,b):xs) -> (Just (l,b), map fst xs)
964
965 -- Remove recursive references from the SRT
966 nonRec :: Set CAFLabel
967 nonRec = cafs `Set.difference` Set.fromList caf_lbls
968
969 -- Resolve references to their SRT entries
970 resolved :: [SRTEntry]
971 resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)
972
973 -- The set of all SRTEntries in SRTs that we refer to from here.
974 allBelow =
975 Set.unions [ lbls | caf <- resolved
976 , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
977
978 -- Remove SRTEntries that are also in an SRT that we refer to.
979 -- Implements the [Filter] optimisation.
980 filtered0 = Set.fromList resolved `Set.difference` allBelow
981
982 srtTraceM "oneSRT:"
983 (text "srtMap:" <+> pdoc platform srtMap $$
984 text "nonRec:" <+> pdoc platform nonRec $$
985 text "lbls:" <+> pdoc platform lbls $$
986 text "caf_lbls:" <+> pdoc platform caf_lbls $$
987 text "static_data:" <+> pdoc platform static_data $$
988 text "cafs:" <+> pdoc platform cafs $$
989 text "blockids:" <+> ppr blockids $$
990 text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$
991 text "otherFunLabels:" <+> pdoc platform otherFunLabels $$
992 text "resolved:" <+> pdoc platform resolved $$
993 text "allBelow:" <+> pdoc platform allBelow $$
994 text "filtered0:" <+> pdoc platform filtered0)
995
996 let
997 isStaticFun = isJust maybeFunClosure
998
999 -- For a label without a closure (e.g. a continuation), we must
1000 -- update the SRTMap for the label to point to a closure. It's
1001 -- important that we don't do this for static functions or CAFs,
1002 -- see Note [Invalid optimisation: shortcutting].
1003 updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
1004 updateSRTMap srtEntry =
1005 srtTrace "updateSRTMap"
1006 (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>
1007 "isStaticFun:" <+> ppr isStaticFun) $
1008 when (not isCAF && (not isStaticFun || isNothing srtEntry)) $
1009 modify' $ \state ->
1010 let !srt_map =
1011 foldl' (\srt_map cafLbl@(CAFLabel clbl) ->
1012 -- Only map static data to Nothing (== not CAFFY). For CAFFY
1013 -- statics we refer to the static itself instead of a SRT.
1014 if not (Set.member clbl static_data) || isNothing srtEntry then
1015 Map.insert cafLbl srtEntry srt_map
1016 else
1017 srt_map)
1018 (moduleSRTMap state)
1019 caf_lbls
1020 in
1021 state{ moduleSRTMap = srt_map }
1022
1023 allStaticData =
1024 all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls
1025
1026 if Set.null filtered0 then do
1027 srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)
1028 updateSRTMap Nothing
1029 return ([], [], [], False)
1030 else do
1031 -- We're going to build an SRT for this group, which should include function
1032 -- references in the group. See Note [recursive SRTs].
1033 let allBelow_funs =
1034 Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
1035 let filtered = filtered0 `Set.union` allBelow_funs
1036 srtTraceM "oneSRT" (text "filtered:" <+> pdoc platform filtered $$
1037 text "allBelow_funs:" <+> pdoc platform allBelow_funs)
1038 case Set.toList filtered of
1039 [] -> pprPanic "oneSRT" empty -- unreachable
1040
1041 -- [Inline] - when we have only one entry there is no need to
1042 -- build an SRT object at all, instead we put the singleton SRT
1043 -- entry in the info table.
1044 [one@(SRTEntry lbl)]
1045 | -- Info tables refer to SRTs by offset (as noted in the section
1046 -- "Referring to an SRT from the info table" of Note [SRTs]). However,
1047 -- when dynamic linking is used we cannot guarantee that the offset
1048 -- between the SRT and the info table will fit in the offset field.
1049 -- Consequently we build a singleton SRT in this case.
1050 not (labelDynamic config lbl)
1051
1052 -- MachO relocations can't express offsets between compilation units at
1053 -- all, so we are always forced to build a singleton SRT in this case.
1054 && (not (osMachOTarget $ platformOS $ profilePlatform profile)
1055 || isLocalCLabel this_mod lbl) -> do
1056
1057 -- If we have a static function closure, then it becomes the
1058 -- SRT object, and everything else points to it. (the only way
1059 -- we could have multiple labels here is if this is a
1060 -- recursive group, see Note [recursive SRTs])
1061 case maybeFunClosure of
1062 Just (staticFunLbl,staticFunBlock) ->
1063 return ([], withLabels, [], True)
1064 where
1065 withLabels =
1066 [ (b, if b == staticFunBlock then lbl else staticFunLbl)
1067 | b <- blockids ]
1068 Nothing -> do
1069 srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
1070 text "one:" <+> pdoc platform one)
1071 updateSRTMap (Just one)
1072 return ([], map (,lbl) blockids, [], True)
1073
1074 cafList | allStaticData ->
1075 return ([], [], [], not (null cafList))
1076
1077 cafList ->
1078 -- Check whether an SRT with the same entries has been emitted already.
1079 -- Implements the [Common] optimisation.
1080 case Map.lookup filtered (dedupSRTs topSRT) of
1081 Just srtEntry@(SRTEntry srtLbl) -> do
1082 srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)
1083 updateSRTMap (Just srtEntry)
1084 return ([], map (,srtLbl) blockids, [], True)
1085 Nothing -> do
1086 -- No duplicates: we have to build a new SRT object
1087 (decls, funSRTs, srtEntry) <-
1088 case maybeFunClosure of
1089 Just (fun,block) ->
1090 return ( [], [(block, cafList)], SRTEntry fun )
1091 Nothing -> do
1092 (decls, entry) <- lift $ buildSRTChain profile cafList
1093 return (decls, [], entry)
1094 updateSRTMap (Just srtEntry)
1095 let allBelowThis = Set.union allBelow filtered
1096 newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT)
1097 -- When all definition in this group are static data we don't
1098 -- generate any SRTs.
1099 newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
1100 modify' (\state -> state{ dedupSRTs = newDedupSRTs,
1101 flatSRTs = newFlatSRTs })
1102 srtTraceM "oneSRT: new" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
1103 text "filtered:" <+> pdoc platform filtered $$
1104 text "srtEntry:" <+> pdoc platform srtEntry $$
1105 text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$
1106 text "newFlatSRTs:" <+> pdoc platform newFlatSRTs)
1107 let SRTEntry lbl = srtEntry
1108 return (decls, map (,lbl) blockids, funSRTs, True)
1109
1110
1111 -- | Build a static SRT object (or a chain of objects) from a list of
1112 -- SRTEntries.
1113 buildSRTChain
1114 :: Profile
1115 -> [SRTEntry]
1116 -> UniqSM
1117 ( [CmmDeclSRTs] -- The SRT object(s)
1118 , SRTEntry -- label to use in the info table
1119 )
1120 buildSRTChain _ [] = panic "buildSRT: empty"
1121 buildSRTChain profile cafSet =
1122 case splitAt mAX_SRT_SIZE cafSet of
1123 (these, []) -> do
1124 (decl,lbl) <- buildSRT profile these
1125 return ([decl], lbl)
1126 (these,those) -> do
1127 (rest, rest_lbl) <- buildSRTChain profile (head these : those)
1128 (decl,lbl) <- buildSRT profile (rest_lbl : tail these)
1129 return (decl:rest, lbl)
1130 where
1131 mAX_SRT_SIZE = 16
1132
1133
1134 buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
1135 buildSRT profile refs = do
1136 id <- getUniqueM
1137 let
1138 lbl = mkSRTLabel id
1139 platform = profilePlatform profile
1140 srt_n_info = mkSRTInfoLabel (length refs)
1141 fields =
1142 mkStaticClosure profile srt_n_info dontCareCCS
1143 [ CmmLabel lbl | SRTEntry lbl <- refs ]
1144 [] -- no padding
1145 [mkIntCLit platform 0] -- link field
1146 [] -- no saved info
1147 return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
1148
1149 -- | Update info tables with references to their SRTs. Also generate
1150 -- static closures, splicing in SRT fields as necessary.
1151 updInfoSRTs
1152 :: Profile
1153 -> LabelMap CLabel -- SRT labels for each block
1154 -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures
1155 -> Bool -- Whether the CmmDecl's group has CAF references
1156 -> CmmDecl
1157 -> [CmmDeclSRTs]
1158
1159 updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
1160 = [CmmData s (CmmStaticsRaw lbl statics)]
1161
1162 updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
1163 = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
1164 where
1165 caf_info = if caffy then MayHaveCafRefs else NoCafRefs
1166 field_lits = mkStaticClosureFields profile itbl ccs caf_info payload
1167
1168 updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
1169 | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
1170 | otherwise = [ proc ]
1171 where
1172 caf_info = if caffy then MayHaveCafRefs else NoCafRefs
1173 proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
1174 newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
1175 updInfoTbl l info_tbl
1176 | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
1177 | otherwise = info_tbl { cit_srt = mapLookup l srt_env }
1178
1179 -- Generate static closures [FUN]. Note that this also generates
1180 -- static closures for thunks (CAFs), because it's easier to treat
1181 -- them uniformly in the code generator.
1182 maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
1183 maybeStaticClosure
1184 | Just info_tbl@CmmInfoTable{..} <-
1185 mapLookup (g_entry g) (info_tbls top_info)
1186 , Just (id, ccs) <- cit_clo
1187 , isStaticRep cit_rep =
1188 let
1189 (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
1190 Nothing ->
1191 -- if we don't add SRT entries to this closure, then we
1192 -- want to set the srt field in its info table as usual
1193 (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
1194 Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
1195 (info_tbl { cit_rep = new_rep }, res)
1196 where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
1197 fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
1198 new_rep = case cit_rep of
1199 HeapRep sta ptrs nptrs ty ->
1200 HeapRep sta (ptrs + length srtEntries) nptrs ty
1201 _other -> panic "maybeStaticFun"
1202 lbl = mkLocalClosureLabel (idName id) caf_info
1203 in
1204 Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
1205 | otherwise = Nothing
1206
1207
1208 srtTrace :: String -> SDoc -> b -> b
1209 -- srtTrace = pprTrace
1210 srtTrace _ _ b = b
1211
1212 srtTraceM :: Applicative f => String -> SDoc -> f ()
1213 srtTraceM str doc = srtTrace str doc (pure ())