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 ())