CmmBuildInfoTables.hs 30.3 KB
Newer Older
1
{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
2
    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}
3

dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
4
module CmmBuildInfoTables
5 6 7
  ( CAFSet, CAFEnv, cafAnal
  , doSRTs, ModuleSRTInfo, emptySRT
  ) where
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
8

9 10
import GhcPrelude hiding (succ)

11
import Id
12
import BlockId
13 14 15 16 17
import Hoopl.Block
import Hoopl.Graph
import Hoopl.Label
import Hoopl.Collections
import Hoopl.Dataflow
18
import Module
John Ericson's avatar
John Ericson committed
19
import GHC.Platform
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
20 21
import Digraph
import CLabel
22
import Cmm
23
import CmmUtils
24
import DynFlags
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
25 26 27 28
import Maybes
import Outputable
import SMRep
import UniqSupply
29
import CostCentre
30
import GHC.StgToCmm.Heap
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
31

Simon Marlow's avatar
Simon Marlow committed
32
import Control.Monad
33 34
import Data.Map (Map)
import qualified Data.Map as Map
35 36
import Data.Set (Set)
import qualified Data.Set as Set
37 38 39
import Data.Tuple
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
40

41

42
{- Note [SRTs]
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
43

44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115
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          | ...  |
                      |------|

116 117 118 119 120 121
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.

122
On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
123 124 125 126 127 128 129 130 131 132

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

133 134 135

EXAMPLE
^^^^^^^
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156

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

157 158
   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
   [ g_entry{h_info, c1_closure} ]
159 160
   [ h_entry{c2_closure} ]

161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
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]


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.

196 197
1. [Inline] we never create an SRT with a single entry, instead we
   point to the single entry directly from the info table.
198 199 200 201 202 203 204 205 206 207 208

   i.e. instead of

    +------+
    | info |
    |      |     +-----+---+---+
    |   -------->|SRT_1| | | 0 |
    |------|     +-----+-|-+---+
    |      |             |
    | code |             |
    |      |             v
209
                         C
210 211 212 213 214 215

   we can point directly to the closure:

    +------+
    | info |
    |      |
216
    |   -------->C
217 218 219 220 221 222
    |------|
    |      |
    | code |
    |      |


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

226 227 228 229
   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
230
   optimisation and generate the singleton SRT, because SRTs are in the
231 232
   data section and *can* have relocatable references.

233 234 235 236
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.
237 238 239

   i.e. instead of

240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273
   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.)
274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293

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}

294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
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.
351
-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
352

353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369
-- ---------------------------------------------------------------------
-- 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
370

371
type CAFSet = Set CAFLabel
372
type CAFEnv = LabelMap CAFSet
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
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
mkCAFLabel :: CLabel -> CAFLabel
mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)

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

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

-- |
-- 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
405
cafLattice :: DataflowLattice CAFSet
406 407 408 409 410
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'
411

412 413 414 415 416

cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers contLbls entry topLbl
  (BlockCC eNode middle xNode) fBase =
    let joined = cafsInNode xNode $! live'
417
        !result = foldNodesBwdOO cafsInNode middle joined
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440

        facts = mapMaybe successorFact (successors xNode)
        live' = joinFacts cafLattice facts

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

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

        addCaf expr !set =
          case expr of
              CmmLit (CmmLabel c) -> add c set
              CmmLit (CmmLabelOff c _) -> add c set
441
              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set
442 443 444 445
              _ -> set
        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s
                | otherwise = s

446
    in mapSingleton (entryLabel eNode) result
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
447

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462

-- -----------------------------------------------------------------------------
-- 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.
463
  }
464 465 466
instance Outputable ModuleSRTInfo where
  ppr ModuleSRTInfo{..} =
    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs
467

468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505
emptySRT :: Module -> ModuleSRTInfo
emptySRT mod =
  ModuleSRTInfo
    { thisModule = mod
    , dedupSRTs = Map.empty
    , flatSRTs = Map.empty }

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

{- Implementation notes

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

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

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

- We get the CAFSet for each entry from the CAFEnv

-}

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


Simon Marlow's avatar
Simon Marlow committed
506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527
-- | 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
  -> [CmmDecl]
  -> [SCC (Label, CAFLabel, Set CAFLabel)]
depAnalSRTs cafEnv decls =
  srtTrace "depAnalSRTs" (ppr graph) graph
 where
  labelledBlocks = concatMap getLabelledBlocks decls
  labelToBlock = Map.fromList (map swap labelledBlocks)
  graph = stronglyConnCompFromEdgedVerticesOrd
             [ let cafs' = Set.delete lbl cafs in
               DigraphNode (l,lbl,cafs') l
                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
             | (l, lbl) <- labelledBlocks
             , Just cafs <- [mapLookup l cafEnv] ]


-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
528
-- These are treated differently from other labelled blocks:
529
--  - we never shortcut a reference to a CAF to the contents of its
Simon Marlow's avatar
Simon Marlow committed
530
--    SRT, since the point of SRTs is to keep CAFs alive.
531
--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
532
--    instead we generate their SRTs after everything else.
Simon Marlow's avatar
Simon Marlow committed
533 534 535 536 537
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)]
538
  , let rep = cit_rep info
Simon Marlow's avatar
Simon Marlow committed
539 540 541 542
  , isStaticRep rep && isThunkRep rep
  , Just cafs <- [mapLookup (g_entry g) cafEnv]
  ]

543

544 545 546
-- | 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
547 548 549 550 551 552
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]
553
  , let rep = cit_rep info
Simon Marlow's avatar
Simon Marlow committed
554
  , isStaticRep rep && isFunRep rep
555
  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
Simon Marlow's avatar
Simon Marlow committed
556
  ]
557

558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582

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

-- | resolve a CAFLabel to its SRTEntry using the SRTMap
resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF srtMap lbl@(CAFLabel l) =
  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap


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

Simon Marlow's avatar
Simon Marlow committed
583
doSRTs dflags moduleSRTInfo tops = do
584 585 586 587 588 589 590
  us <- mkSplitUniqSupply 'u'

  -- Ignore the original grouping of decls, and combine all the
  -- CAFEnvs into a single CAFEnv.
  let (cafEnvs, declss) = unzip tops
      cafEnv = mapUnions cafEnvs
      decls = concat declss
Simon Marlow's avatar
Simon Marlow committed
591
      staticFuns = mapFromList (getStaticFuns decls)
592 593

  -- Put the decls in dependency order. Why? So that we can implement
594
  -- [Inline] and [Filter].  If we need to refer to an SRT that has
595 596 597 598
  -- 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
599 600 601
  let
    sccs = depAnalSRTs cafEnv decls
    cafsWithSRTs = getCAFs cafEnv decls
602 603 604

  -- 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
605 606 607 608 609 610
  let result ::
        [ ( [CmmDecl]              -- generated SRTs
          , [(Label, CLabel)]      -- SRT fields for info tables
          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
          ) ]
      ((result, _srtMap), moduleSRTInfo') =
611
        initUs_ us $
Simon Marlow's avatar
Simon Marlow committed
612
        flip runStateT moduleSRTInfo $
Simon Marlow's avatar
Simon Marlow committed
613 614 615 616 617
        flip runStateT Map.empty $ do
          nonCAFs <- mapM (doSCC dflags staticFuns) sccs
          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs
          return (nonCAFs ++ cAFs)
618 619

      (declss, pairs, funSRTs) = unzip3 result
620 621

  -- Next, update the info tables with the SRTs
622 623 624 625
  let
    srtFieldMap = mapFromList (concat pairs)
    funSRTMap = mapFromList (concat funSRTs)
    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls
626

Simon Marlow's avatar
Simon Marlow committed
627
  return (moduleSRTInfo', concat declss ++ decls')
628 629 630 631 632


-- | Build the SRT for a strongly-connected component of blocks
doSCC
  :: DynFlags
633
  -> LabelMap CLabel           -- which blocks are static function entry points
634 635 636
  -> SCC (Label, CAFLabel, Set CAFLabel)
  -> StateT SRTMap
        (StateT ModuleSRTInfo UniqSM)
637 638 639
        ( [CmmDecl]              -- generated SRTs
        , [(Label, CLabel)]      -- SRT fields for info tables
        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
640 641
        )

642
doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =
Simon Marlow's avatar
Simon Marlow committed
643
  oneSRT dflags staticFuns [l] [cafLbl] False cafs
644

645
doSCC dflags staticFuns (CyclicSCC nodes) = do
646
  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
647
  let (blockids, lbls, cafsets) = unzip3 nodes
648
      cafs = Set.unions cafsets
Simon Marlow's avatar
Simon Marlow committed
649
  oneSRT dflags staticFuns blockids lbls False cafs
650 651


652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675
{- 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.
-}

676 677 678
-- | Build an SRT for a set of blocks
oneSRT
  :: DynFlags
679
  -> LabelMap CLabel            -- which blocks are static function entry points
680 681
  -> [Label]                    -- blocks in this set
  -> [CAFLabel]                 -- labels for those blocks
Simon Marlow's avatar
Simon Marlow committed
682
  -> Bool                       -- True <=> this SRT is for a CAF
683 684 685 686 687
  -> Set CAFLabel               -- SRT for this set
  -> StateT SRTMap
       (StateT ModuleSRTInfo UniqSM)
       ( [CmmDecl]                    -- SRT objects we built
       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls
688
       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions
689 690
       )

Simon Marlow's avatar
Simon Marlow committed
691
oneSRT dflags staticFuns blockids lbls isCAF cafs = do
692 693 694
  srtMap <- get
  topSRT <- lift get
  let
695 696 697 698 699 700 701 702 703
    -- Can we merge this SRT with a FUN_STATIC closure?
    (maybeFunClosure, otherFunLabels) =
      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
        [] -> (Nothing, [])
        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)

    -- Remove recursive references from the SRT, except for (all but
    -- one of the) static functions. See Note [recursive SRTs].
    nonRec = cafs `Set.difference`
704
      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)
705

706
    -- First resolve all the CAFLabels to SRTEntries
707
    -- Implements the [Inline] optimisation.
708
    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)
709 710 711

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

    -- Remove SRTEntries that are also in an SRT that we refer to.
    -- Implements the [Filter] optimisation.
717
    filtered = Set.difference (Set.fromList resolved) allBelow
718 719 720 721 722

  srtTrace "oneSRT:"
     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()

  let
723 724 725 726 727 728
    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].
Simon Marlow's avatar
Simon Marlow committed
729
    updateSRTMap srtEntry =
730
      when (not isCAF && (not isStaticFun || isNothing srtEntry)) $ do
Simon Marlow's avatar
Simon Marlow committed
731 732
        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]
        put (Map.union newSRTMap srtMap)
733

734 735
    this_mod = thisModule topSRT

736 737 738 739
  case Set.toList filtered of
    [] -> do
      srtTrace "oneSRT: empty" (ppr lbls) $ return ()
      updateSRTMap Nothing
740
      return ([], [], [])
741

742 743 744
    -- [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.
745
    [one@(SRTEntry lbl)]
746 747 748 749 750 751 752 753 754 755 756
      | -- 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
757 758 759 760 761 762 763 764 765 766 767 768 769 770

        -- 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, [])
            where
              withLabels =
                [ (b, if b == staticFunBlock then lbl else staticFunLbl)
                | b <- blockids ]
          Nothing -> do
            updateSRTMap (Just one)
            return ([], map (,lbl) blockids, [])
771 772 773 774 775 776 777 778

    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
          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()
          updateSRTMap (Just srtEntry)
779
          return ([], map (,srtLbl) blockids, [])
780 781 782
        Nothing -> do
          -- No duplicates: we have to build a new SRT object
          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()
783 784 785 786 787 788 789
          (decls, funSRTs, srtEntry) <-
            case maybeFunClosure of
              Just (fun,block) ->
                return ( [], [(block, cafList)], SRTEntry fun )
              Nothing -> do
                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList
                return (decls, [], entry)
790 791 792 793 794 795 796 797
          updateSRTMap (Just srtEntry)
          let allBelowThis = Set.union allBelow filtered
              oldFlatSRTs = flatSRTs topSRT
              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs
              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
          lift (put (topSRT { dedupSRTs = newDedupSRTs
                            , flatSRTs = newFlatSRTs }))
          let SRTEntry lbl = srtEntry
798
          return (decls, map (,lbl) blockids, funSRTs)
799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819


-- | build a static SRT object (or a chain of objects) from a list of
-- SRTEntries.
buildSRTChain
   :: DynFlags
   -> [SRTEntry]
   -> UniqSM
        ( [CmmDecl]    -- The SRT object(s)
        , SRTEntry     -- label to use in the info table
        )
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)
820
  where
821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836
    mAX_SRT_SIZE = 16


buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
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)
837 838


839 840 841 842 843 844 845 846
-- | 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
  -> CmmDecl
  -> [CmmDecl]
847

848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887
updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)
  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
  | otherwise = [ proc ]
  where
    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
    updInfoTbl l info_tbl
      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }

    -- Generate static closures [FUN].  Note that this also generates
    -- static closures for thunks (CAFs), because it's easier to treat
    -- them uniformly in the code generator.
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
    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 ]
          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)
            srtEntries
          new_rep = case cit_rep of
             HeapRep sta ptrs nptrs ty ->
               HeapRep sta (ptrs + length srtEntries) nptrs ty
             _other -> panic "maybeStaticFun"
          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
        in
          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
      | otherwise = Nothing

updInfoSRTs _ _ _ t = [t]
888 889 890


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