summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm/Info/Build.hs
blob: b2078ae4621e5d18e30e9fc3672ae44c88439822 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}


module GHC.Cmm.Info.Build
  ( CAFSet, CAFEnv, cafAnal, cafAnalData
  , doSRTs, ModuleSRTInfo (..), emptySRT
  , SRTMap, srtMapNonCAFs
  ) where

import GHC.Prelude hiding (succ)

import GHC.Platform
import GHC.Platform.Profile

import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Unit.Module
import GHC.Data.Graph.Directed
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Driver.Session
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Runtime.Heap.Layout
import GHC.Types.Unique.Supply
import GHC.Types.CostCentre
import GHC.StgToCmm.Heap
import GHC.CmmToAsm

import Control.Monad
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Data.List (unzip4)

import GHC.Types.Name.Set

{- Note [SRTs]

SRTs are the mechanism by which the garbage collector can determine
the live CAFs in the program.

Representation
^^^^^^^^^^^^^^

+------+
| info |
|      |     +-----+---+---+---+
|   -------->|SRT_2| | | | | 0 |
|------|     +-----+-|-+-|-+---+
|      |             |   |
| code |             |   |
|      |             v   v

An SRT is simply an object in the program's data segment. It has the
same representation as a static constructor.  There are 16
pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
representing SRT objects with 1-16 pointers, respectively.

The entries of an SRT object point to static closures, which are either
- FUN_STATIC, THUNK_STATIC or CONSTR
- Another SRT (actually just a CONSTR)

The final field of the SRT is the static link field, used by the
garbage collector to chain together static closures that it visits and
to determine whether a static closure has been visited or not. (see
Note [STATIC_LINK fields])

By traversing the transitive closure of an SRT, the GC will reach all
of the CAFs that are reachable from the code associated with this SRT.

If we need to create an SRT with more than 16 entries, we build a
chain of SRT objects with all but the last having 16 entries.

+-----+---+- -+---+---+
|SRT16| | |   | | | 0 |
+-----+-|-+- -+-|-+---+
        |       |
        v       v
              +----+---+---+---+
              |SRT2| | | | | 0 |
              +----+-|-+-|-+---+
                     |   |
                     |   |
                     v   v

Referring to an SRT from the info table
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

The following things have SRTs:

- Static functions (FUN)
- Static thunks (THUNK), ie. CAFs
- Continuations (RET_SMALL, etc.)

In each case, the info table points to the SRT.

- info->srt is zero if there's no SRT, otherwise:
- info->srt == 1 and info->f.srt_offset points to the SRT

e.g. for a FUN with an SRT:

StgFunInfoTable       +------+
  info->f.srt_offset  |  ------------> offset to SRT object
StgStdInfoTable       +------+
  info->layout.ptrs   | ...  |
  info->layout.nptrs  | ...  |
  info->srt           |  1   |
  info->type          | ...  |
                      |------|

On x86_64, we optimise the info table representation further.  The
offset to the SRT can be stored in 32 bits (all code lives within a
2GB region in x86_64's small memory model), so we can save a word in
the info table by storing the srt_offset in the srt field, which is
half a word.

On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):

- info->srt is zero if there's no SRT, otherwise:
- info->srt is an offset from the info pointer to the SRT object

StgStdInfoTable       +------+
  info->layout.ptrs   |      |
  info->layout.nptrs  |      |
  info->srt           |  ------------> offset to SRT object
                      |------|


EXAMPLE
^^^^^^^

f = \x. ... g ...
  where
    g = \y. ... h ... c1 ...
    h = \z. ... c2 ...

c1 & c2 are CAFs

g and h are local functions, but they have no static closures.  When
we generate code for f, we start with a CmmGroup of four CmmDecls:

   [ f_closure, f_entry, g_entry, h_entry ]

we process each CmmDecl separately in cpsTop, giving us a list of
CmmDecls. e.g. for f_entry, we might end up with

   [ f_entry, f1_ret, f2_proc ]

where f1_ret is a return point, and f2_proc is a proc-point.  We have
a CAFSet for each of these CmmDecls, let's suppose they are

   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
   [ g_entry{h_info, c1_closure} ]
   [ h_entry{c2_closure} ]

Next, we make an SRT for each of these functions:

  f_srt : [g_info]
  g_srt : [h_info, c1_closure]
  h_srt : [c2_closure]

Now, for g_info and h_info, we want to refer to the SRTs for g and h
respectively, which we'll label g_srt and h_srt:

  f_srt : [g_srt]
  g_srt : [h_srt, c1_closure]
  h_srt : [c2_closure]

Now, when an SRT has a single entry, we don't actually generate an SRT
closure for it, instead we just replace references to it with its
single element.  So, since h_srt == c2_closure, we have

  f_srt : [g_srt]
  g_srt : [c2_closure, c1_closure]
  h_srt : [c2_closure]

and the only SRT closure we generate is

  g_srt = SRT_2 [c2_closure, c1_closure]

Algorithm
^^^^^^^^^

0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}
   Maps closures to their SRT entries (i.e. how they appear in a SRT payload)

1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG
   after code-generation.

2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might
   be multiple CmmDecls in the result, due to proc-point splitting.

3. In cpsTop, *before* proc-point splitting, when we still have a single
   CmmDecl, we do cafAnal for procs:

   * cafAnal performs a backwards analysis on the code blocks

   * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel),
     representing all the CAFLabels reachable from this label.

   * A label is added to the set if it refers to a FUN, THUNK, or RET,
     and its CafInfo /= NoCafRefs.
     (NB. all CafInfo for Ids in the current module should be initialised to
     MayHaveCafRefs)

   * The result is CAFEnv = LabelMap CAFSet

   (Why *before* proc-point splitting? Because the analysis needs to propagate
   information across branches, and proc-point splitting turns branches into
   CmmCalls to top-level CmmDecls.  The analysis would fail to find all the
   references to CAFFY labels if we did it after proc-point splitting.)

   For static data, cafAnalData simply returns set of all labels that refer to a
   FUN, THUNK, and RET whose CafInfos /= NoCafRefs.

4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl)
   for static data. So after `mapM cpsTop decls` we have
   [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)]

5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl])

6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets)

7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel

8. For each SCC in dependency order
   - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC
   - Apply CAFEnv to each label and concat the result :: [CAFLabel]
   - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get
     srt :: [SRTEntry]
   - Make a label for this SRT, call it l
   - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the
     group to the SRT (see Note [Invalid optimisation: shortcutting])
   - Add to srtMap: lbls -> if null srt then Nothing else Just l

9. At the end, for every top-level binding x, if srtMap x == Nothing, then the
   binding is non-CAFFY, otherwise it is CAFFY.

Optimisations
^^^^^^^^^^^^^

To reduce the code size overhead and the cost of traversing SRTs in
the GC, we want to simplify SRTs where possible. We therefore apply
the following optimisations.  Each has a [keyword]; search for the
keyword in the code below to see where the optimisation is
implemented.

1. [Inline] we never create an SRT with a single entry, instead we
   point to the single entry directly from the info table.

   i.e. instead of

    +------+
    | info |
    |      |     +-----+---+---+
    |   -------->|SRT_1| | | 0 |
    |------|     +-----+-|-+---+
    |      |             |
    | code |             |
    |      |             v
                         C

   we can point directly to the closure:

    +------+
    | info |
    |      |
    |   -------->C
    |------|
    |      |
    | code |
    |      |


   Furthermore, the SRT for any code that refers to this info table
   can point directly to C.

   The exception to this is when we're doing dynamic linking. In that
   case, if the closure is not locally defined then we can't point to
   it directly from the info table, because this is the text section
   which cannot contain runtime relocations. In this case we skip this
   optimisation and generate the singleton SRT, because SRTs are in the
   data section and *can* have relocatable references.

2. [FUN] A static function closure can also be an SRT, we simply put
   the SRT entries as fields in the static closure.  This makes a lot
   of sense: the static references are just like the free variables of
   the FUN closure.

   i.e. instead of

   f_closure:
   +-----+---+
   |  |  | 0 |
   +- |--+---+
      |            +------+
      |            | info |     f_srt:
      |            |      |     +-----+---+---+---+
      |            |   -------->|SRT_2| | | | + 0 |
      `----------->|------|     +-----+-|-+-|-+---+
                   |      |             |   |
                   | code |             |   |
                   |      |             v   v


   We can generate:

   f_closure:
   +-----+---+---+---+
   |  |  | | | | | 0 |
   +- |--+-|-+-|-+---+
      |    |   |   +------+
      |    v   v   | info |
      |            |      |
      |            |   0  |
      `----------->|------|
                   |      |
                   | code |
                   |      |


   (note: we can't do this for THUNKs, because the thunk gets
   overwritten when it is entered, so we wouldn't be able to share
   this SRT with other info tables that want to refer to it (see
   [Common] below). FUNs are immutable so don't have this problem.)

3. [Common] Identical SRTs can be commoned up.

4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
   refers to C (perhaps transitively), then we can omit the reference
   to C from A.


Note that there are many other optimisations that we could do, but
aren't implemented. In general, we could omit any reference from an
SRT if everything reachable from it is also reachable from the other
fields in the SRT. Our [Filter] optimisation is a special case of
this.

Another opportunity we don't exploit is this:

A = {X,Y,Z}
B = {Y,Z}
C = {X,B}

Here we could use C = {A} and therefore [Inline] C = A.
-}

-- ---------------------------------------------------------------------
{- Note [Invalid optimisation: shortcutting]

You might think that if we have something like

A's SRT = {B}
B's SRT = {X}

that we could replace the reference to B in A's SRT with X.

A's SRT = {X}
B's SRT = {X}

and thereby perhaps save a little work at runtime, because we don't
have to visit B.

But this is NOT valid.

Consider these cases:

0. B can't be a constructor, because constructors don't have SRTs

1. B is a CAF. This is the easy one. Obviously we want A's SRT to
   point to B, so that it keeps B alive.

2. B is a function.  This is the tricky one. The reason we can't
shortcut in this case is that we aren't allowed to resurrect static
objects.

== How does this cause a problem? ==

The particular case that cropped up when we tried this was #15544.
- A is a thunk
- B is a static function
- X is a CAF
- suppose we GC when A is alive, and B is not otherwise reachable.
- B is "collected", meaning that it doesn't make it onto the static
  objects list during this GC, but nothing bad happens yet.
- Next, suppose we enter A, and then call B. (remember that A refers to B)
  At the entry point to B, we GC. This puts B on the stack, as part of the
  RET_FUN stack frame that gets pushed when we GC at a function entry point.
- This GC will now reach B
- But because B was previous "collected", it breaks the assumption
  that static objects are never resurrected. See Note [STATIC_LINK
  fields] in rts/sm/Storage.h for why this is bad.
- In practice, the GC thinks that B has already been visited, and so
  doesn't visit X, and catastrophe ensues.

== Isn't this caused by the RET_FUN business? ==

Maybe, but could you prove that RET_FUN is the only way that
resurrection can occur?

So, no shortcutting.

Note [Ticky labels in SRT analysis]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered
non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing`
(meaning they're not CAFFY).

However when building with -ticky we generate ticky CLabels using the function's
`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky
build we get two IdLabels using the name `sat_s1rQ`:

- For the function itself: IdLabel sat_s1rQ ... Entry
- For the ticky counter: IdLabel sat_s1rQ ... RednCounts

In these cases we really want to use the function definition for the SRT
analysis of this Name, because that's what we export for this Name -- ticky
counters are not exported. So we ignore ticky counters in SRT analysis (which
are never CAFFY and never exported).

Not doing this caused #17947 where we analysed the function first mapped the
name to CAFFY. We then saw the ticky constructor, and becuase it has the same
Name as the function and is not CAFFY we overrode the CafInfo of the name as
non-CAFFY.
-}

-- ---------------------------------------------------------------------
-- Label types

-- Labels that come from cafAnal can be:
--   - _closure labels for static functions or CAFs
--   - _info labels for dynamic functions, thunks, or continuations
--   - _entry labels for functions or thunks
--
-- Meanwhile the labels on top-level blocks are _entry labels.
--
-- To put everything in the same namespace we convert all labels to
-- closure labels using toClosureLbl.  Note that some of these
-- labels will not actually exist; that's ok because we're going to
-- map them to SRTEntry later, which ranges over labels that do exist.
--
newtype CAFLabel = CAFLabel CLabel
  deriving (Eq,Ord)

deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel

type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet

mkCAFLabel :: Platform -> CLabel -> CAFLabel
mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)

-- This is a label that we can put in an SRT.  It *must* be a closure label,
-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
newtype SRTEntry = SRTEntry CLabel
  deriving (Eq, Ord)

deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry


-- ---------------------------------------------------------------------
-- CAF analysis

addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel platform l s
  | Just _ <- hasHaskellName l
  , let caf_label = mkCAFLabel platform l
    -- For imported Ids hasCAF will have accurate CafInfo
    -- Locals are initialized as CAFFY. We turn labels with empty SRTs into
    -- non-CAFFYs in doSRTs
  , hasCAF l
  = Set.insert caf_label s
  | otherwise
  = s

cafAnalData
  :: Platform
  -> CmmStatics
  -> CAFSet
cafAnalData platform st = case st of
   CmmStaticsRaw _lbl _data           -> Set.empty
   CmmStatics _lbl _itbl _ccs payload ->
       foldl' analyzeStatic Set.empty payload
     where
       analyzeStatic s lit =
         case lit of
           CmmLabel c -> addCafLabel platform c s
           CmmLabelOff c _ -> addCafLabel platform c s
           CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s
           _ -> s

-- |
-- For each code block:
--   - collect the references reachable from this code block to FUN,
--     THUNK or RET labels for which hasCAF == True
--
-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
--
cafAnal
  :: Platform
  -> LabelSet   -- The blocks representing continuations, ie. those
                -- that will get RET info tables.  These labels will
                -- get their own SRTs, so we don't aggregate CAFs from
                -- references to these labels, we just use the label.
  -> CLabel     -- The top label of the proc
  -> CmmGraph
  -> CAFEnv
cafAnal platform contLbls topLbl cmmGraph =
  analyzeCmmBwd cafLattice
    (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty


cafLattice :: DataflowLattice CAFSet
cafLattice = DataflowLattice Set.empty add
  where
    add (OldFact old) (NewFact new) =
        let !new' = old `Set.union` new
        in changedIf (Set.size new' > Set.size old) new'


cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers platform contLbls entry topLbl
  block@(BlockCC eNode middle xNode) fBase =
    let joined :: CAFSet
        joined = cafsInNode xNode $! live'

        result :: CAFSet
        !result = foldNodesBwdOO cafsInNode middle joined

        facts :: [Set CAFLabel]
        facts = mapMaybe successorFact (successors xNode)

        live' :: CAFSet
        live' = joinFacts cafLattice facts

        successorFact :: Label -> Maybe (Set CAFLabel)
        successorFact s
          -- If this is a loop back to the entry, we can refer to the
          -- entry label.
          | s == entry = Just (addCafLabel platform topLbl Set.empty)
          -- If this is a continuation, we want to refer to the
          -- SRT for the continuation's info table
          | s `setMember` contLbls
          = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))
          -- Otherwise, takes the CAF references from the destination
          | otherwise
          = lookupFact s fBase

        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
        cafsInNode node set = foldExpDeep addCafExpr node set

        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
        addCafExpr expr !set =
          case expr of
            CmmLit (CmmLabel c) ->
              addCafLabel platform c set
            CmmLit (CmmLabelOff c _) ->
              addCafLabel platform c set
            CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
              addCafLabel platform c1 $! addCafLabel platform c2 set
            _ ->
              set
    in
      srtTrace "cafTransfers" (text "block:"         <+> pdoc platform block $$
                                text "contLbls:"     <+> ppr contLbls $$
                                text "entry:"        <+> ppr entry $$
                                text "topLbl:"       <+> pdoc platform topLbl $$
                                text "cafs in exit:" <+> pdoc platform joined $$
                                text "result:"       <+> pdoc platform result) $
        mapSingleton (entryLabel eNode) result


-- -----------------------------------------------------------------------------
-- ModuleSRTInfo

data ModuleSRTInfo = ModuleSRTInfo
  { thisModule :: Module
    -- ^ Current module being compiled. Required for calling labelDynamic.
  , dedupSRTs :: Map (Set SRTEntry) SRTEntry
    -- ^ previous SRTs we've emitted, so we can de-duplicate.
    -- Used to implement the [Common] optimisation.
  , flatSRTs :: Map SRTEntry (Set SRTEntry)
    -- ^ The reverse mapping, so that we can remove redundant
    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b
    -- points to [c,d], we can omit c and emit [a,b].
    -- Used to implement the [Filter] optimisation.
  , moduleSRTMap :: SRTMap
  }

instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where
  pdoc env ModuleSRTInfo{..} =
    text "ModuleSRTInfo {" $$
      (nest 4 $ text "dedupSRTs ="    <+> pdoc env dedupSRTs $$
                text "flatSRTs ="     <+> pdoc env flatSRTs $$
                text "moduleSRTMap =" <+> pdoc env moduleSRTMap) $$ char '}'

emptySRT :: Module -> ModuleSRTInfo
emptySRT mod =
  ModuleSRTInfo
    { thisModule = mod
    , dedupSRTs = Map.empty
    , flatSRTs = Map.empty
    , moduleSRTMap = Map.empty
    }

-- -----------------------------------------------------------------------------
-- Constructing SRTs

{- Implementation notes

- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable

- The entry in info_tbls corresponding to g_entry is the closure info
  table, the rest are continuations.

- Each entry in info_tbls possibly needs an SRT.  We need to make a
  label for each of these.

- We get the CAFSet for each entry from the CAFEnv

-}

data SomeLabel
  = BlockLabel !Label
  | DeclLabel CLabel
  deriving (Eq, Ord)

instance OutputableP env CLabel => OutputableP env SomeLabel where
   pdoc env = \case
      BlockLabel l -> text "b:" <+> pdoc env l
      DeclLabel l  -> text "s:" <+> pdoc env l

getBlockLabel :: SomeLabel -> Maybe Label
getBlockLabel (BlockLabel l) = Just l
getBlockLabel (DeclLabel _) = Nothing

getBlockLabels :: [SomeLabel] -> [Label]
getBlockLabels = mapMaybe getBlockLabel

-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
--   where the label is
--   - the info label for a continuation or dynamic closure
--   - the closure label for a top-level function (not a CAF)
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks platform decl = case decl of
   CmmData _ (CmmStaticsRaw _ _)    -> []
   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]
   CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)
                                       | (blockId, info) <- mapToList (info_tbls top_info)
                                       , let rep = cit_rep info
                                       , not (isStaticRep rep) || not (isThunkRep rep)
                                       , let !caf_lbl = mkCAFLabel platform (cit_lbl info)
                                       ]

-- | Put the labelled blocks that we will be annotating with SRTs into
-- dependency order.  This is so that we can process them one at a
-- time, resolving references to earlier blocks to point to their
-- SRTs. CAFs themselves are not included here; see getCAFs below.
depAnalSRTs
  :: Platform
  -> CAFEnv
  -> Map CLabel CAFSet -- CAFEnv for statics
  -> [CmmDecl]
  -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
depAnalSRTs platform cafEnv cafEnv_static decls =
  srtTrace "depAnalSRTs" (text "decls:"  <+> pdoc platform decls $$
                           text "nodes:" <+> pdoc platform (map node_payload nodes) $$
                           text "graph:" <+> pdoc platform graph) graph
 where
  labelledBlocks :: [(SomeLabel, CAFLabel)]
  labelledBlocks = concatMap (getLabelledBlocks platform) decls
  labelToBlock :: Map CAFLabel SomeLabel
  labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks

  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
  nodes = [ DigraphNode (l,lbl,cafs') l
              (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
          | (l, lbl) <- labelledBlocks
          , Just (cafs :: Set CAFLabel) <-
              [case l of
                 BlockLabel l -> mapLookup l cafEnv
                 DeclLabel cl -> Map.lookup cl cafEnv_static]
          , let cafs' = Set.delete lbl cafs
          ]

  graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
  graph = stronglyConnCompFromEdgedVerticesOrd nodes

-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
-- These are treated differently from other labelled blocks:
--  - we never shortcut a reference to a CAF to the contents of its
--    SRT, since the point of SRTs is to keep CAFs alive.
--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
--    instead we generate their SRTs after everything else.
getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
getCAFs platform cafEnv decls =
  [ (g_entry g, mkCAFLabel platform topLbl, cafs)
  | CmmProc top_info topLbl _ g <- decls
  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
  , let rep = cit_rep info
  , isStaticRep rep && isThunkRep rep
  , Just cafs <- [mapLookup (g_entry g) cafEnv]
  ]


-- | Get the list of blocks that correspond to the entry points for
-- FUN_STATIC closures.  These are the blocks for which if we have an
-- SRT we can merge it with the static closure. [FUN]
getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns decls =
  [ (g_entry g, lbl)
  | CmmProc top_info _ _ g <- decls
  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
  , Just (id, _) <- [cit_clo info]
  , let rep = cit_rep info
  , isStaticRep rep && isFunRep rep
  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
  ]


-- | Maps labels from 'cafAnal' to the final CLabel that will appear
-- in the SRT.
--   - closures with singleton SRTs resolve to their single entry
--   - closures with larger SRTs map to the label for that SRT
--   - CAFs must not map to anything!
--   - if a labels maps to Nothing, we found that this label's SRT
--     is empty, so we don't need to refer to it from other SRTs.
type SRTMap = Map CAFLabel (Maybe SRTEntry)


-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
-- module.  Any 'Name's not in the set are CAFFY.
srtMapNonCAFs :: SRTMap -> NonCaffySet
srtMapNonCAFs srtMap =
    NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
  where
    get_name (CAFLabel l, Nothing) = hasHaskellName l
    get_name (_l, Just _srt_entry) = Nothing

-- | resolve a CAFLabel to its SRTEntry using the SRTMap
resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF platform srtMap lbl@(CAFLabel l) =
    srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret
  where
    ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap

-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
-- declarations to the ModuleSRTInfo.
--
doSRTs
  :: DynFlags
  -> ModuleSRTInfo
  -> [(CAFEnv, [CmmDecl])]
  -> [(CAFSet, CmmDecl)]
  -> IO (ModuleSRTInfo, [CmmDeclSRTs])

doSRTs dflags moduleSRTInfo procs data_ = do
  us <- mkSplitUniqSupply 'u'

  let profile = targetProfile dflags

  -- Ignore the original grouping of decls, and combine all the
  -- CAFEnvs into a single CAFEnv.
  let static_data_env :: Map CLabel CAFSet
      static_data_env =
        Map.fromList $
        flip map data_ $
        \(set, decl) ->
          case decl of
            CmmProc{} ->
              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)
            CmmData _ static ->
              case static of
                CmmStatics lbl _ _ _ -> (lbl, set)
                CmmStaticsRaw lbl _ -> (lbl, set)

      static_data :: Set CLabel
      static_data = Map.keysSet static_data_env

      (proc_envs, procss) = unzip procs
      cafEnv = mapUnions proc_envs
      decls = map snd data_ ++ concat procss
      staticFuns = mapFromList (getStaticFuns decls)

      platform = targetPlatform dflags

  -- Put the decls in dependency order. Why? So that we can implement
  -- [Inline] and [Filter].  If we need to refer to an SRT that has
  -- a single entry, we use the entry itself, which means that we
  -- don't need to generate the singleton SRT in the first place.  But
  -- to do this we need to process blocks before things that depend on
  -- them.
  let
    sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls

    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
    cafsWithSRTs = getCAFs platform cafEnv decls

  srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$
                      text "procs:"           <+> pdoc platform procs $$
                      text "static_data_env:" <+> pdoc platform static_data_env $$
                      text "sccs:"            <+> pdoc platform sccs $$
                      text "cafsWithSRTs:"    <+> pdoc platform cafsWithSRTs)

  -- On each strongly-connected group of decls, construct the SRT
  -- closures and the SRT fields for info tables.
  let result ::
        [ ( [CmmDeclSRTs]          -- generated SRTs
          , [(Label, CLabel)]      -- SRT fields for info tables
          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
          , Bool                   -- Whether the group has CAF references
          ) ]

      (result, moduleSRTInfo') =
        initUs_ us $
        flip runStateT moduleSRTInfo $ do
          nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs
          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
            oneSRT dflags staticFuns [BlockLabel l] [cafLbl]
                   True{-is a CAF-} cafs static_data
          return (nonCAFs ++ cAFs)

      (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
      srt_decls = concat srt_declss

  -- Next, update the info tables with the SRTs
  let
    srtFieldMap = mapFromList (concat pairs)
    funSRTMap = mapFromList (concat funSRTs)
    has_caf_refs' = or has_caf_refs
    decls' =
      concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls

  -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are
  -- not analysed in oneSRT so we never add entries for them to the SRTMap.
  let srtMap_w_raws =
        foldl' (\(srtMap :: SRTMap) (_, decl) ->
                  case decl of
                    CmmData _ CmmStatics{} ->
                      -- already updated by oneSRT
                      srtMap
                    CmmData _ (CmmStaticsRaw lbl _)
                      | isIdLabel lbl && not (isTickyLabel lbl) ->
                          -- Raw data are not analysed by oneSRT and they can't
                          -- be CAFFY.
                          -- See Note [Ticky labels in SRT analysis] above for
                          -- why we exclude ticky labels here.
                          Map.insert (mkCAFLabel platform lbl) Nothing srtMap
                      | otherwise ->
                          -- Not an IdLabel, ignore
                          srtMap
                    CmmProc{} ->
                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))
               (moduleSRTMap moduleSRTInfo') data_

  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')


-- | Build the SRT for a strongly-connected component of blocks
doSCC
  :: DynFlags
  -> LabelMap CLabel -- which blocks are static function entry points
  -> Set CLabel -- static data
  -> SCC (SomeLabel, CAFLabel, Set CAFLabel)
  -> StateT ModuleSRTInfo UniqSM
        ( [CmmDeclSRTs]          -- generated SRTs
        , [(Label, CLabel)]      -- SRT fields for info tables
        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
        , Bool                   -- Whether the group has CAF references
        )

doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =
  oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data

doSCC dflags staticFuns static_data (CyclicSCC nodes) = do
  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
  let (lbls, caf_lbls, cafsets) = unzip3 nodes
      cafs = Set.unions cafsets
  oneSRT dflags staticFuns lbls caf_lbls False cafs static_data


{- Note [recursive SRTs]

If the dependency analyser has found us a recursive group of
declarations, then we build a single SRT for the whole group, on the
grounds that everything in the group is reachable from everything
else, so we lose nothing by having a single SRT.

However, there are a couple of wrinkles to be aware of.

* The Set CAFLabel for this SRT will contain labels in the group
itself. The SRTMap will therefore not contain entries for these labels
yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
can just remove recursive references from the Set CAFLabel before
generating the SRT - the SRT will still contain all the CAFLabels that
we need to refer to from this group's SRT.

* That is, EXCEPT for static function closures. For the same reason
described in Note [Invalid optimisation: shortcutting], we cannot omit
references to static function closures.
  - But, since we will merge the SRT with one of the static function
    closures (see [FUN]), we can omit references to *that* static
    function closure from the SRT.
-}

-- | Build an SRT for a set of blocks
oneSRT
  :: DynFlags
  -> LabelMap CLabel            -- which blocks are static function entry points
  -> [SomeLabel]                -- blocks in this set
  -> [CAFLabel]                 -- labels for those blocks
  -> Bool                       -- True <=> this SRT is for a CAF
  -> Set CAFLabel               -- SRT for this set
  -> Set CLabel                 -- Static data labels in this group
  -> StateT ModuleSRTInfo UniqSM
       ( [CmmDeclSRTs]                -- SRT objects we built
       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
       , Bool                         -- Whether the group has CAF references
       )

oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
  topSRT <- get

  let
    config = initNCGConfig dflags
    profile = targetProfile dflags
    platform = profilePlatform profile
    srtMap = moduleSRTMap topSRT

    blockids = getBlockLabels lbls

    -- Can we merge this SRT with a FUN_STATIC closure?
    maybeFunClosure :: Maybe (CLabel, Label)
    otherFunLabels :: [CLabel]
    (maybeFunClosure, otherFunLabels) =
      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
        [] -> (Nothing, [])
        ((l,b):xs) -> (Just (l,b), map fst xs)

    -- Remove recursive references from the SRT
    nonRec :: Set CAFLabel
    nonRec = cafs `Set.difference` Set.fromList caf_lbls

    -- Resolve references to their SRT entries
    resolved :: [SRTEntry]
    resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)

    -- The set of all SRTEntries in SRTs that we refer to from here.
    allBelow =
      Set.unions [ lbls | caf <- resolved
                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]

    -- Remove SRTEntries that are also in an SRT that we refer to.
    -- Implements the [Filter] optimisation.
    filtered0 = Set.fromList resolved `Set.difference` allBelow

  srtTraceM "oneSRT:"
     (text "srtMap:"          <+> pdoc platform srtMap $$
      text "nonRec:"          <+> pdoc platform nonRec $$
      text "lbls:"            <+> pdoc platform lbls $$
      text "caf_lbls:"        <+> pdoc platform caf_lbls $$
      text "static_data:"     <+> pdoc platform static_data $$
      text "cafs:"            <+> pdoc platform cafs $$
      text "blockids:"        <+> ppr blockids $$
      text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$
      text "otherFunLabels:"  <+> pdoc platform otherFunLabels $$
      text "resolved:"        <+> pdoc platform resolved $$
      text "allBelow:"        <+> pdoc platform allBelow $$
      text "filtered0:"       <+> pdoc platform filtered0)

  let
    isStaticFun = isJust maybeFunClosure

    -- For a label without a closure (e.g. a continuation), we must
    -- update the SRTMap for the label to point to a closure. It's
    -- important that we don't do this for static functions or CAFs,
    -- see Note [Invalid optimisation: shortcutting].
    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
    updateSRTMap srtEntry =
      srtTrace "updateSRTMap"
        (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>
         "isStaticFun:" <+> ppr isStaticFun) $
      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $
        modify' $ \state ->
           let !srt_map =
                 foldl' (\srt_map cafLbl@(CAFLabel clbl) ->
                          -- Only map static data to Nothing (== not CAFFY). For CAFFY
                          -- statics we refer to the static itself instead of a SRT.
                          if not (Set.member clbl static_data) || isNothing srtEntry then
                            Map.insert cafLbl srtEntry srt_map
                          else
                            srt_map)
                        (moduleSRTMap state)
                        caf_lbls
           in
               state{ moduleSRTMap = srt_map }

    this_mod = thisModule topSRT

    allStaticData =
      all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls

  if Set.null filtered0 then do
    srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)
    updateSRTMap Nothing
    return ([], [], [], False)
  else do
    -- We're going to build an SRT for this group, which should include function
    -- references in the group. See Note [recursive SRTs].
    let allBelow_funs =
          Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
    let filtered = filtered0 `Set.union` allBelow_funs
    srtTraceM "oneSRT" (text "filtered:"      <+> pdoc platform filtered $$
                        text "allBelow_funs:" <+> pdoc platform allBelow_funs)
    case Set.toList filtered of
      [] -> pprPanic "oneSRT" empty -- unreachable

      -- [Inline] - when we have only one entry there is no need to
      -- build an SRT object at all, instead we put the singleton SRT
      -- entry in the info table.
      [one@(SRTEntry lbl)]
        | -- Info tables refer to SRTs by offset (as noted in the section
          -- "Referring to an SRT from the info table" of Note [SRTs]). However,
          -- when dynamic linking is used we cannot guarantee that the offset
          -- between the SRT and the info table will fit in the offset field.
          -- Consequently we build a singleton SRT in this case.
          not (labelDynamic config this_mod lbl)

          -- MachO relocations can't express offsets between compilation units at
          -- all, so we are always forced to build a singleton SRT in this case.
            && (not (osMachOTarget $ platformOS $ profilePlatform profile)
               || isLocalCLabel this_mod lbl) -> do

          -- If we have a static function closure, then it becomes the
          -- SRT object, and everything else points to it. (the only way
          -- we could have multiple labels here is if this is a
          -- recursive group, see Note [recursive SRTs])
          case maybeFunClosure of
            Just (staticFunLbl,staticFunBlock) ->
                return ([], withLabels, [], True)
              where
                withLabels =
                  [ (b, if b == staticFunBlock then lbl else staticFunLbl)
                  | b <- blockids ]
            Nothing -> do
              srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$
                                       text "one:"      <+> pdoc platform one)
              updateSRTMap (Just one)
              return ([], map (,lbl) blockids, [], True)

      cafList | allStaticData ->
        return ([], [], [], not (null cafList))

      cafList ->
        -- Check whether an SRT with the same entries has been emitted already.
        -- Implements the [Common] optimisation.
        case Map.lookup filtered (dedupSRTs topSRT) of
          Just srtEntry@(SRTEntry srtLbl)  -> do
            srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)
            updateSRTMap (Just srtEntry)
            return ([], map (,srtLbl) blockids, [], True)
          Nothing -> do
            -- No duplicates: we have to build a new SRT object
            (decls, funSRTs, srtEntry) <-
              case maybeFunClosure of
                Just (fun,block) ->
                  return ( [], [(block, cafList)], SRTEntry fun )
                Nothing -> do
                  (decls, entry) <- lift $ buildSRTChain profile cafList
                  return (decls, [], entry)
            updateSRTMap (Just srtEntry)
            let allBelowThis = Set.union allBelow filtered
                newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT)
                -- When all definition in this group are static data we don't
                -- generate any SRTs.
                newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
            modify' (\state -> state{ dedupSRTs = newDedupSRTs,
                                      flatSRTs = newFlatSRTs })
            srtTraceM "oneSRT: new" (text "caf_lbls:"      <+> pdoc platform caf_lbls $$
                                      text "filtered:"     <+> pdoc platform filtered $$
                                      text "srtEntry:"     <+> pdoc platform srtEntry $$
                                      text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$
                                      text "newFlatSRTs:"  <+> pdoc platform newFlatSRTs)
            let SRTEntry lbl = srtEntry
            return (decls, map (,lbl) blockids, funSRTs, True)


-- | Build a static SRT object (or a chain of objects) from a list of
-- SRTEntries.
buildSRTChain
   :: Profile
   -> [SRTEntry]
   -> UniqSM
        ( [CmmDeclSRTs] -- The SRT object(s)
        , SRTEntry      -- label to use in the info table
        )
buildSRTChain _ [] = panic "buildSRT: empty"
buildSRTChain profile cafSet =
  case splitAt mAX_SRT_SIZE cafSet of
    (these, []) -> do
      (decl,lbl) <- buildSRT profile these
      return ([decl], lbl)
    (these,those) -> do
      (rest, rest_lbl) <- buildSRTChain profile (head these : those)
      (decl,lbl) <- buildSRT profile (rest_lbl : tail these)
      return (decl:rest, lbl)
  where
    mAX_SRT_SIZE = 16


buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT profile refs = do
  id <- getUniqueM
  let
    lbl = mkSRTLabel id
    platform = profilePlatform profile
    srt_n_info = mkSRTInfoLabel (length refs)
    fields =
      mkStaticClosure profile srt_n_info dontCareCCS
        [ CmmLabel lbl | SRTEntry lbl <- refs ]
        [] -- no padding
        [mkIntCLit platform 0] -- link field
        [] -- no saved info
  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)

-- | Update info tables with references to their SRTs. Also generate
-- static closures, splicing in SRT fields as necessary.
updInfoSRTs
  :: Profile
  -> LabelMap CLabel               -- SRT labels for each block
  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
  -> Bool                          -- Whether the CmmDecl's group has CAF references
  -> CmmDecl
  -> [CmmDeclSRTs]

updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
  = [CmmData s (CmmStaticsRaw lbl statics)]

updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
  = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
  where
    caf_info = if caffy then MayHaveCafRefs else NoCafRefs
    field_lits = mkStaticClosureFields profile itbl ccs caf_info payload

updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
  | otherwise = [ proc ]
  where
    caf_info = if caffy then MayHaveCafRefs else NoCafRefs
    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
    updInfoTbl l info_tbl
      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }

    -- Generate static closures [FUN].  Note that this also generates
    -- static closures for thunks (CAFs), because it's easier to treat
    -- them uniformly in the code generator.
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
    maybeStaticClosure
      | Just info_tbl@CmmInfoTable{..} <-
           mapLookup (g_entry g) (info_tbls top_info)
      , Just (id, ccs) <- cit_clo
      , isStaticRep cit_rep =
        let
          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
            Nothing ->
              -- if we don't add SRT entries to this closure, then we
              -- want to set the srt field in its info table as usual
              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
            Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)
              (info_tbl { cit_rep = new_rep }, res)
              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
          fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
          new_rep = case cit_rep of
             HeapRep sta ptrs nptrs ty ->
               HeapRep sta (ptrs + length srtEntries) nptrs ty
             _other -> panic "maybeStaticFun"
          lbl = mkLocalClosureLabel (idName id) caf_info
        in
          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
      | otherwise = Nothing


srtTrace :: String -> SDoc -> b -> b
-- srtTrace = pprTrace
srtTrace _ _ b = b

srtTraceM :: Applicative f => String -> SDoc -> f ()
srtTraceM str doc = srtTrace str doc (pure ())