Build.hs 41.5 KB
Newer Older
1
{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
2 3
    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
    ScopedTypeVariables, OverloadedStrings #-}
4

5
module GHC.Cmm.Info.Build
6 7 8
  ( CAFSet, CAFEnv, cafAnal, cafAnalData
  , doSRTs, ModuleSRTInfo (..), emptySRT
  , SRTMap, srtMapNonCAFs
9
  ) where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
10

11 12
import GhcPrelude hiding (succ)

13
import Id
14
import IdInfo
15 16 17 18 19 20
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
21
import Module
John Ericson's avatar
John Ericson committed
22
import GHC.Platform
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
23
import Digraph
24 25 26
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
Sylvain Henry's avatar
Sylvain Henry committed
27
import GHC.Driver.Session
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
28 29
import Maybes
import Outputable
30
import GHC.Runtime.Heap.Layout
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
31
import UniqSupply
32
import CostCentre
33
import GHC.StgToCmm.Heap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
34

Simon Marlow's avatar
Simon Marlow committed
35
import Control.Monad
36 37
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
38 39
import Data.Set (Set)
import qualified Data.Set as Set
40 41
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
42
import Data.List (unzip4)
43

44
import NameSet
45

46
{- Note [SRTs]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
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
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          | ...  |
                      |------|

120 121 122 123 124 125
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.

126
On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
127 128 129 130 131 132 133 134 135 136

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

137 138 139

EXAMPLE
^^^^^^^
140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160

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

161 162
   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
   [ g_entry{h_info, c1_closure} ]
163 164
   [ h_entry{c2_closure} ]

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
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]

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
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.
247 248 249 250 251 252 253 254 255 256

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.

257 258
1. [Inline] we never create an SRT with a single entry, instead we
   point to the single entry directly from the info table.
259 260 261 262 263 264 265 266 267 268 269

   i.e. instead of

    +------+
    | info |
    |      |     +-----+---+---+
    |   -------->|SRT_1| | | 0 |
    |------|     +-----+-|-+---+
    |      |             |
    | code |             |
    |      |             v
270
                         C
271 272 273 274 275 276

   we can point directly to the closure:

    +------+
    | info |
    |      |
277
    |   -------->C
278 279 280 281 282 283
    |------|
    |      |
    | code |
    |      |


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

287 288 289 290
   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
291
   optimisation and generate the singleton SRT, because SRTs are in the
292 293
   data section and *can* have relocatable references.

294 295 296 297
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.
298 299 300

   i.e. instead of

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
   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.)
335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354

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}

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
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.
412
-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
413

414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430
-- ---------------------------------------------------------------------
-- 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,Outputable)
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
431

432
type CAFSet = Set CAFLabel
433
type CAFEnv = LabelMap CAFSet
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
434

435
mkCAFLabel :: CLabel -> CAFLabel
436
mkCAFLabel lbl = CAFLabel $! toClosureLbl lbl
437 438 439 440 441 442 443 444 445

-- 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, Outputable)

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

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
addCafLabel :: CLabel -> CAFSet -> CAFSet
addCafLabel l s
  | Just _ <- hasHaskellName l
  , let caf_label = mkCAFLabel 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
  :: CmmStatics
  -> CAFSet

cafAnalData (CmmStaticsRaw _lbl _data) =
    Set.empty

cafAnalData (CmmStatics _lbl _itbl _ccs payload) =
    foldl' analyzeStatic Set.empty payload
  where
    analyzeStatic s lit =
      case lit of
        CmmLabel c -> addCafLabel c s
        CmmLabelOff c _ -> addCafLabel c s
        CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s
        _ -> s

475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494
-- |
-- 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
  :: 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 contLbls topLbl cmmGraph =
  analyzeCmmBwd cafLattice
    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty


dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
495
cafLattice :: DataflowLattice CAFSet
496 497 498 499 500
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'
501

502 503 504

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

        result :: CAFSet
510
        !result = foldNodesBwdOO cafsInNode middle joined
511

512
        facts :: [Set CAFLabel]
513
        facts = mapMaybe successorFact (successors xNode)
514 515

        live' :: CAFSet
516 517
        live' = joinFacts cafLattice facts

518
        successorFact :: Label -> Maybe (Set CAFLabel)
519 520 521
        successorFact s
          -- If this is a loop back to the entry, we can refer to the
          -- entry label.
522
          | s == entry = Just (addCafLabel topLbl Set.empty)
523 524 525 526 527 528 529 530 531
          -- 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 (infoTblLbl s)))
          -- Otherwise, takes the CAF references from the destination
          | otherwise
          = lookupFact s fBase

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

534 535
        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
        addCafExpr expr !set =
536
          case expr of
537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552
            CmmLit (CmmLabel c) ->
              addCafLabel c set
            CmmLit (CmmLabelOff c _) ->
              addCafLabel c set
            CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
              addCafLabel c1 $! addCafLabel c2 set
            _ ->
              set
    in
      srtTrace "cafTransfers" (text "block:" <+> ppr block $$
                                text "contLbls:" <+> ppr contLbls $$
                                text "entry:" <+> ppr entry $$
                                text "topLbl:" <+> ppr topLbl $$
                                text "cafs in exit:" <+> ppr joined $$
                                text "result:" <+> ppr result) $
        mapSingleton (entryLabel eNode) result
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
553

554 555 556 557 558 559 560 561 562 563 564 565 566 567 568

-- -----------------------------------------------------------------------------
-- 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.
569
  , moduleSRTMap :: SRTMap
570
  }
571

572 573
instance Outputable ModuleSRTInfo where
  ppr ModuleSRTInfo{..} =
574 575 576 577
    text "ModuleSRTInfo {" $$
      (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$
                text "flatSRTs =" <+> ppr flatSRTs $$
                text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}'
578

579 580 581 582 583
emptySRT :: Module -> ModuleSRTInfo
emptySRT mod =
  ModuleSRTInfo
    { thisModule = mod
    , dedupSRTs = Map.empty
584 585 586
    , flatSRTs = Map.empty
    , moduleSRTMap = Map.empty
    }
587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604

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

-}

605
data SomeLabel
606
  = BlockLabel !Label
607 608 609 610 611 612 613 614 615 616 617 618 619 620
  | DeclLabel CLabel
  deriving (Eq, Ord)

instance Outputable SomeLabel where
  ppr (BlockLabel l) = text "b:" <+> ppr l
  ppr (DeclLabel l) = text "s:" <+> ppr l

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

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

621 622 623 624
-- | 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)
625 626 627 628 629
getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =
  []
getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =
  [ (DeclLabel lbl, mkCAFLabel lbl) ]
630
getLabelledBlocks (CmmProc top_info _ _ _) =
631
  [ (BlockLabel blockId, caf_lbl)
632 633 634
  | (blockId, info) <- mapToList (info_tbls top_info)
  , let rep = cit_rep info
  , not (isStaticRep rep) || not (isThunkRep rep)
635
  , let !caf_lbl = mkCAFLabel (cit_lbl info)
636 637
  ]

Simon Marlow's avatar
Simon Marlow committed
638 639 640 641 642 643
-- | 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
  :: CAFEnv
644
  -> Map CLabel CAFSet -- CAFEnv for statics
Simon Marlow's avatar
Simon Marlow committed
645
  -> [CmmDecl]
646 647 648 649 650
  -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
depAnalSRTs cafEnv cafEnv_static decls =
  srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$
                           text "nodes:" <+> ppr (map node_payload nodes) $$
                           text "graph:" <+> ppr graph) graph
Simon Marlow's avatar
Simon Marlow committed
651
 where
652
  labelledBlocks :: [(SomeLabel, CAFLabel)]
Simon Marlow's avatar
Simon Marlow committed
653
  labelledBlocks = concatMap getLabelledBlocks decls
654 655
  labelToBlock :: Map CAFLabel SomeLabel
  labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
Simon Marlow's avatar
Simon Marlow committed
656

657 658 659 660 661 662 663 664 665 666 667 668 669
  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
Simon Marlow's avatar
Simon Marlow committed
670 671

-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
672
-- These are treated differently from other labelled blocks:
673
--  - we never shortcut a reference to a CAF to the contents of its
Simon Marlow's avatar
Simon Marlow committed
674
--    SRT, since the point of SRTs is to keep CAFs alive.
675
--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
676
--    instead we generate their SRTs after everything else.
Simon Marlow's avatar
Simon Marlow committed
677 678 679 680 681
getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
getCAFs cafEnv decls =
  [ (g_entry g, mkCAFLabel topLbl, cafs)
  | CmmProc top_info topLbl _ g <- decls
  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
682
  , let rep = cit_rep info
Simon Marlow's avatar
Simon Marlow committed
683 684 685 686
  , isStaticRep rep && isThunkRep rep
  , Just cafs <- [mapLookup (g_entry g) cafEnv]
  ]

687

688 689 690
-- | 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]
Simon Marlow's avatar
Simon Marlow committed
691 692 693 694 695 696
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]
697
  , let rep = cit_rep info
Simon Marlow's avatar
Simon Marlow committed
698
  , isStaticRep rep && isFunRep rep
699
  , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
Simon Marlow's avatar
Simon Marlow committed
700
  ]
701

702 703 704 705 706 707 708 709 710 711

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

712 713 714 715 716 717 718 719 720

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

721 722 723
-- | resolve a CAFLabel to its SRTEntry using the SRTMap
resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF srtMap lbl@(CAFLabel l) =
724 725 726
    srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret
  where
    ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap
727 728 729 730 731 732 733 734

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

738
doSRTs dflags moduleSRTInfo procs data_ = do
739 740 741 742
  us <- mkSplitUniqSupply 'u'

  -- Ignore the original grouping of decls, and combine all the
  -- CAFEnvs into a single CAFEnv.
743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761
  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:" <+> ppr 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
Simon Marlow's avatar
Simon Marlow committed
762
      staticFuns = mapFromList (getStaticFuns decls)
763 764

  -- Put the decls in dependency order. Why? So that we can implement
765
  -- [Inline] and [Filter].  If we need to refer to an SRT that has
766 767 768 769
  -- 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.
Simon Marlow's avatar
Simon Marlow committed
770
  let
771
    sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
772
    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls
773 774

    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
Simon Marlow's avatar
Simon Marlow committed
775
    cafsWithSRTs = getCAFs cafEnv decls
776

777 778 779 780 781 782
  srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$
                      text "procs:" <+> ppr procs $$
                      text "static_data_env:" <+> ppr static_data_env $$
                      text "sccs:" <+> ppr sccs $$
                      text "cafsWithSRTs:" <+> ppr cafsWithSRTs)

783 784
  -- On each strongly-connected group of decls, construct the SRT
  -- closures and the SRT fields for info tables.
Simon Marlow's avatar
Simon Marlow committed
785
  let result ::
786
        [ ( [CmmDeclSRTs]          -- generated SRTs
Simon Marlow's avatar
Simon Marlow committed
787 788
          , [(Label, CLabel)]      -- SRT fields for info tables
          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
789
          , Bool                   -- Whether the group has CAF references
Simon Marlow's avatar
Simon Marlow committed
790
          ) ]
791 792

      (result, moduleSRTInfo') =
793
        initUs_ us $
794 795
        flip runStateT moduleSRTInfo $ do
          nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs
Simon Marlow's avatar
Simon Marlow committed
796
          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
797 798
            oneSRT dflags staticFuns [BlockLabel l] [cafLbl]
                   True{-is a CAF-} cafs static_data
Simon Marlow's avatar
Simon Marlow committed
799
          return (nonCAFs ++ cAFs)
800

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

804
  -- Next, update the info tables with the SRTs
805 806 807
  let
    srtFieldMap = mapFromList (concat pairs)
    funSRTMap = mapFromList (concat funSRTs)
808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831
    has_caf_refs' = or has_caf_refs
    decls' =
      concatMap (updInfoSRTs dflags 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 analysed by oneSRT, declare it non-CAFFY here
                          Map.insert (mkCAFLabel lbl) Nothing srtMap
                      | otherwise ->
                          -- Not an IdLabel, ignore
                          srtMap
                    CmmProc{} ->
                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl))
               (moduleSRTMap moduleSRTInfo') data_

  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
832 833 834 835 836


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

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

850
doSCC dflags staticFuns static_data (CyclicSCC nodes) = do
851
  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
852
  let (lbls, caf_lbls, cafsets) = unzip3 nodes
853
      cafs = Set.unions cafsets
854
  oneSRT dflags staticFuns lbls caf_lbls False cafs static_data
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
{- 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.
-}

881 882 883
-- | Build an SRT for a set of blocks
oneSRT
  :: DynFlags
884
  -> LabelMap CLabel            -- which blocks are static function entry points
885
  -> [SomeLabel]                -- blocks in this set
886
  -> [CAFLabel]                 -- labels for those blocks
Simon Marlow's avatar
Simon Marlow committed
887
  -> Bool                       -- True <=> this SRT is for a CAF
888
  -> Set CAFLabel               -- SRT for this set
889 890 891
  -> Set CLabel                 -- Static data labels in this group
  -> StateT ModuleSRTInfo UniqSM
       ( [CmmDeclSRTs]                -- SRT objects we built
892
       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
893
       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
894
       , Bool                         -- Whether the group has CAF references
895 896
       )

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

900
  let
901 902 903 904
    srtMap = moduleSRTMap topSRT

    blockids = getBlockLabels lbls

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

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

917 918
    -- Resolve references to their SRT entries
    resolved :: [SRTEntry]
919
    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)
920 921 922

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

    -- Remove SRTEntries that are also in an SRT that we refer to.
    -- Implements the [Filter] optimisation.
928 929 930 931 932 933 934 935 936 937 938 939 940 941 942
    filtered0 = Set.fromList resolved `Set.difference` allBelow

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

  let
945 946 947 948 949 950
    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].
951
    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
Simon Marlow's avatar
Simon Marlow committed
952
    updateSRTMap srtEntry =
953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
      srtTrace "updateSRTMap"
        (ppr 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 }
970

971 972
    this_mod = thisModule topSRT

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
    allStaticData =
      all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls

  if Set.null filtered0 then do
    srtTraceM "oneSRT: empty" (ppr 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) otherFunLabels)
    let filtered = filtered0 `Set.union` allBelow_funs
    srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$
                        text "allBelow_funs:" <+> ppr 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 in this case.
          not (labelDynamic dflags 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 $ targetPlatform dflags)
               || 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:" <+> ppr caf_lbls $$
                                       text "one:" <+> ppr 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]" (ppr caf_lbls <+> ppr srtLbl)
            updateSRTMap (Just srtEntry)
            return ([], map (,srtLbl) blockids, [], True)
1035
          Nothing -> do
1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058
            -- 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 dflags 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:" <+> ppr caf_lbls $$
                                      text "filtered:" <+> ppr filtered $$
                                      text "srtEntry:" <+> ppr srtEntry $$
                                      text "newDedupSRTs:" <+> ppr newDedupSRTs $$
                                      text "newFlatSRTs:" <+> ppr newFlatSRTs)
            let SRTEntry lbl = srtEntry
            return (decls, map (,lbl) blockids, funSRTs, True)
1059 1060 1061 1062 1063 1064 1065 1066


-- | build a static SRT object (or a chain of objects) from a list of
-- SRTEntries.
buildSRTChain
   :: DynFlags
   -> [SRTEntry]
   -> UniqSM
1067 1068
        ( [CmmDeclSRTs] -- The SRT object(s)
        , SRTEntry      -- label to use in the info table
1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079
        )
buildSRTChain _ [] = panic "buildSRT: empty"
buildSRTChain dflags cafSet =
  case splitAt mAX_SRT_SIZE cafSet of
    (these, []) -> do
      (decl,lbl) <- buildSRT dflags these
      return ([decl], lbl)
    (these,those) -> do
      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
      return (decl:rest, lbl)
1080
  where
1081 1082 1083
    mAX_SRT_SIZE = 16


1084
buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096
buildSRT dflags refs = do
  id <- getUniqueM
  let
    lbl = mkSRTLabel id
    srt_n_info = mkSRTInfoLabel (length refs)
    fields =
      mkStaticClosure dflags srt_n_info dontCareCCS
        [ CmmLabel lbl | SRTEntry lbl <- refs ]
        [] -- no padding
        [mkIntCLit dflags 0] -- link field
        [] -- no saved info
  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
1097

1098 1099 1100 1101 1102 1103
-- | Update info tables with references to their SRTs. Also generate
-- static closures, splicing in SRT fields as necessary.
updInfoSRTs
  :: DynFlags
  -> LabelMap CLabel               -- SRT labels for each block
  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
1104
  -> Bool                          -- Whether the CmmDecl's group has CAF references
1105
  -> CmmDecl
1106 1107 1108 1109 1110 1111 1112 1113 1114 1115
  -> [CmmDeclSRTs]

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

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

1117
updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
1118 1119 1120
  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
  | otherwise = [ proc ]
  where
1121
    caf_info = if caffy then MayHaveCafRefs else NoCafRefs
1122 1123 1124 1125 1126 1127 1128 1129 1130
    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.
1131
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145
    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" (ppr res)
              (info_tbl { cit_rep = new_rep }, res)
              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
1146
          fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries
1147 1148 1149 1150
          new_rep = case cit_rep of
             HeapRep sta ptrs nptrs ty ->
               HeapRep sta (ptrs + length srtEntries) nptrs ty
             _other -> panic "maybeStaticFun"
1151
          lbl = mkLocalClosureLabel (idName id) caf_info
1152 1153 1154 1155
        in
          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
      | otherwise = Nothing

1156 1157

srtTrace :: String -> SDoc -> b -> b
1158
-- srtTrace = pprTrace
1159
srtTrace _ _ b = b
1160 1161 1162

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