{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}


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

import GHC.Prelude hiding (succ)

import GHC.Platform
import GHC.Platform.Profile

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

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

import GHC.Types.Name.Set

{- Note [SRTs]

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

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

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

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

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

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

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

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

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

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

The following things have SRTs:

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

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

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

e.g. for a FUN with an SRT:

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

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

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

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

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


EXAMPLE
^^^^^^^

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

c1 & c2 are CAFs

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

   [ f_closure, f_entry, g_entry, h_entry ]

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

   [ f_entry, f1_ret, f2_proc ]

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

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

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

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

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

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

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

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

and the only SRT closure we generate is

  g_srt = SRT_2 [c2_closure, c1_closure]

Algorithm
^^^^^^^^^

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

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

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

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

   * cafAnal performs a backwards analysis on the code blocks

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

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

   * The result is CAFEnv = LabelMap CAFSet

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

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

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

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

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

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

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

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

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

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

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

   i.e. instead of

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

   we can point directly to the closure:

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


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

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

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

   i.e. instead of

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


   We can generate:

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


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

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

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


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

Another opportunity we don't exploit is this:

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

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

-- ---------------------------------------------------------------------
{-
Note [No static object resurrection]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The "static flag" mechanism (see Note [STATIC_LINK fields] in smStorage.h) that
the GC uses to track liveness of static objects assumes that unreachable
objects will never become reachable again (i.e. are never "resurrected").
Breaking this assumption can result in extremely subtle GC soundness issues
(e.g. #15544, #20959).

Guaranteeing that this assumption is not violated requires that all CAFfy
static objects reachable from the object's code are reachable from its SRT.  In
the past we have gotten this wrong in a few ways:

 * shortcutting references to FUN_STATICs to instead point to the FUN_STATIC's
   SRT. This lead to #15544 and is described in more detail in Note [Invalid
   optimisation: shortcutting].

 * omitting references to static data constructor applications. This previously
   happened due to an oversight (#20959): when generating an SRT for a
   recursive group we would drop references to the CAFfy static data
   constructors.

To see why we cannot allow object resurrection, see the examples in the
above-mentioned Notes.

If a static closure definitely does not transitively refer to any CAFs, then it
*may* be advertised as not-CAFfy in the interface file and consequently *may*
be omitted from SRTs. Regardless of whether the closure is advertised as CAFfy
or non-CAFfy, its STATIC_LINK field *must* be set to 3, so that it never
appears on the static closure list.
-}

{-
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 for the reason described in Note [No static object resurrection].
   We noticed this in #15544.

The particular case that cropped up when we tried this in #15544 was:

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



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

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

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

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

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

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

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

deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel

type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet

-- | Records the CAFfy references of a set of static data decls.
type DataCAFEnv = Map CLabel CAFSet

mkCAFLabel :: Platform -> CLabel -> CAFLabel
mkCAFLabel :: Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl = CLabel -> CAFLabel
CAFLabel (Platform -> CLabel -> CLabel
toClosureLbl Platform
platform CLabel
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 (SRTEntry -> SRTEntry -> Bool
(SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool) -> Eq SRTEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SRTEntry -> SRTEntry -> Bool
$c/= :: SRTEntry -> SRTEntry -> Bool
== :: SRTEntry -> SRTEntry -> Bool
$c== :: SRTEntry -> SRTEntry -> Bool
Eq, Eq SRTEntry
Eq SRTEntry
-> (SRTEntry -> SRTEntry -> Ordering)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> Bool)
-> (SRTEntry -> SRTEntry -> SRTEntry)
-> (SRTEntry -> SRTEntry -> SRTEntry)
-> Ord SRTEntry
SRTEntry -> SRTEntry -> Bool
SRTEntry -> SRTEntry -> Ordering
SRTEntry -> SRTEntry -> SRTEntry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SRTEntry -> SRTEntry -> SRTEntry
$cmin :: SRTEntry -> SRTEntry -> SRTEntry
max :: SRTEntry -> SRTEntry -> SRTEntry
$cmax :: SRTEntry -> SRTEntry -> SRTEntry
>= :: SRTEntry -> SRTEntry -> Bool
$c>= :: SRTEntry -> SRTEntry -> Bool
> :: SRTEntry -> SRTEntry -> Bool
$c> :: SRTEntry -> SRTEntry -> Bool
<= :: SRTEntry -> SRTEntry -> Bool
$c<= :: SRTEntry -> SRTEntry -> Bool
< :: SRTEntry -> SRTEntry -> Bool
$c< :: SRTEntry -> SRTEntry -> Bool
compare :: SRTEntry -> SRTEntry -> Ordering
$ccompare :: SRTEntry -> SRTEntry -> Ordering
Ord)

deriving newtype instance OutputableP env CLabel => OutputableP env SRTEntry


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

addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
addCafLabel :: Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
l Set CAFLabel
s
  | Just Name
_ <- CLabel -> Maybe Name
hasHaskellName CLabel
l
  , let caf_label :: CAFLabel
caf_label = Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
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
  , CLabel -> Bool
hasCAF CLabel
l
  = CAFLabel -> Set CAFLabel -> Set CAFLabel
forall a. Ord a => a -> Set a -> Set a
Set.insert CAFLabel
caf_label Set CAFLabel
s
  | Bool
otherwise
  = Set CAFLabel
s

cafAnalData
  :: Platform
  -> CmmStatics
  -> CAFSet
cafAnalData :: Platform -> GenCmmStatics 'False -> Set CAFLabel
cafAnalData Platform
platform GenCmmStatics 'False
st = case GenCmmStatics 'False
st of
   CmmStaticsRaw CLabel
_lbl [CmmStatic]
_data           -> Set CAFLabel
forall a. Set a
Set.empty
   CmmStatics CLabel
_lbl CmmInfoTable
_itbl CostCentreStack
_ccs [CmmLit]
payload ->
       (Set CAFLabel -> CmmLit -> Set CAFLabel)
-> Set CAFLabel -> [CmmLit] -> Set CAFLabel
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set CAFLabel -> CmmLit -> Set CAFLabel
analyzeStatic Set CAFLabel
forall a. Set a
Set.empty [CmmLit]
payload
     where
       analyzeStatic :: Set CAFLabel -> CmmLit -> Set CAFLabel
analyzeStatic Set CAFLabel
s CmmLit
lit =
         case CmmLit
lit of
           CmmLabel CLabel
c -> Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c Set CAFLabel
s
           CmmLabelOff CLabel
c WordOff
_ -> Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c Set CAFLabel
s
           CmmLabelDiffOff CLabel
c1 CLabel
c2 WordOff
_ Width
_ -> Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c1 (Set CAFLabel -> Set CAFLabel) -> Set CAFLabel -> Set CAFLabel
forall a b. (a -> b) -> a -> b
$! Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c2 Set CAFLabel
s
           CmmLit
_ -> Set CAFLabel
s

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


cafLattice :: DataflowLattice CAFSet
cafLattice :: DataflowLattice (Set CAFLabel)
cafLattice = Set CAFLabel
-> JoinFun (Set CAFLabel) -> DataflowLattice (Set CAFLabel)
forall a. a -> JoinFun a -> DataflowLattice a
DataflowLattice Set CAFLabel
forall a. Set a
Set.empty JoinFun (Set CAFLabel)
forall {a}.
Ord a =>
OldFact (Set a) -> NewFact (Set a) -> JoinedFact (Set a)
add
  where
    add :: OldFact (Set a) -> NewFact (Set a) -> JoinedFact (Set a)
add (OldFact Set a
old) (NewFact Set a
new) =
        let !new' :: Set a
new' = Set a
old Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set a
new
        in Bool -> Set a -> JoinedFact (Set a)
forall a. Bool -> a -> JoinedFact a
changedIf (Set a -> WordOff
forall a. Set a -> WordOff
Set.size Set a
new' WordOff -> WordOff -> Bool
forall a. Ord a => a -> a -> Bool
> Set a -> WordOff
forall a. Set a -> WordOff
Set.size Set a
old) Set a
new'


cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers :: Platform
-> LabelSet -> BlockId -> CLabel -> TransferFun (Set CAFLabel)
cafTransfers Platform
platform LabelSet
contLbls BlockId
entry CLabel
topLbl
  block :: CmmBlock
block@(BlockCC CmmNode C O
eNode Block CmmNode O O
middle CmmNode O C
xNode) CAFEnv
fBase =
    let joined :: CAFSet
        joined :: Set CAFLabel
joined = CmmNode O C -> Set CAFLabel -> Set CAFLabel
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Set CAFLabel -> Set CAFLabel
cafsInNode CmmNode O C
xNode (Set CAFLabel -> Set CAFLabel) -> Set CAFLabel -> Set CAFLabel
forall a b. (a -> b) -> a -> b
$! Set CAFLabel
live'

        result :: CAFSet
        !result :: Set CAFLabel
result = (CmmNode O O -> Set CAFLabel -> Set CAFLabel)
-> Block CmmNode O O -> Set CAFLabel -> Set CAFLabel
forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO CmmNode O O -> Set CAFLabel -> Set CAFLabel
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Set CAFLabel -> Set CAFLabel
cafsInNode Block CmmNode O O
middle Set CAFLabel
joined

        facts :: [Set CAFLabel]
        facts :: [Set CAFLabel]
facts = (BlockId -> Maybe (Set CAFLabel)) -> [BlockId] -> [Set CAFLabel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe BlockId -> Maybe (Set CAFLabel)
successorFact (CmmNode O C -> [BlockId]
forall (thing :: Extensibility -> Extensibility -> *)
       (e :: Extensibility).
NonLocal thing =>
thing e C -> [BlockId]
successors CmmNode O C
xNode)

        live' :: CAFSet
        live' :: Set CAFLabel
live' = DataflowLattice (Set CAFLabel) -> [Set CAFLabel] -> Set CAFLabel
forall f. DataflowLattice f -> [f] -> f
joinFacts DataflowLattice (Set CAFLabel)
cafLattice [Set CAFLabel]
facts

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

        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
        cafsInNode :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> Set CAFLabel -> Set CAFLabel
cafsInNode CmmNode e x
node Set CAFLabel
set = (CmmExpr -> Set CAFLabel -> Set CAFLabel)
-> CmmNode e x -> Set CAFLabel -> Set CAFLabel
forall z (e :: Extensibility) (x :: Extensibility).
(CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep CmmExpr -> Set CAFLabel -> Set CAFLabel
addCafExpr CmmNode e x
node Set CAFLabel
set

        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
addCafExpr CmmExpr
expr !Set CAFLabel
set =
          case CmmExpr
expr of
            CmmLit (CmmLabel CLabel
c) ->
              Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c Set CAFLabel
set
            CmmLit (CmmLabelOff CLabel
c WordOff
_) ->
              Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c Set CAFLabel
set
            CmmLit (CmmLabelDiffOff CLabel
c1 CLabel
c2 WordOff
_ Width
_) ->
              Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c1 (Set CAFLabel -> Set CAFLabel) -> Set CAFLabel -> Set CAFLabel
forall a b. (a -> b) -> a -> b
$! Platform -> CLabel -> Set CAFLabel -> Set CAFLabel
addCafLabel Platform
platform CLabel
c2 Set CAFLabel
set
            CmmExpr
_ ->
              Set CAFLabel
set
    in
      String -> SDoc -> CAFEnv -> CAFEnv
forall b. String -> SDoc -> b -> b
srtTrace String
"cafTransfers" (String -> SDoc
text String
"block:"         SDoc -> SDoc -> SDoc
<+> Platform -> CmmBlock -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmBlock
block SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"contLbls:"     SDoc -> SDoc -> SDoc
<+> LabelSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr LabelSet
contLbls SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"entry:"        SDoc -> SDoc -> SDoc
<+> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
entry SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"topLbl:"       SDoc -> SDoc -> SDoc
<+> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
topLbl SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"cafs in exit:" SDoc -> SDoc -> SDoc
<+> Platform -> Set CAFLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set CAFLabel
joined SDoc -> SDoc -> SDoc
$$
                                String -> SDoc
text String
"result:"       SDoc -> SDoc -> SDoc
<+> Platform -> Set CAFLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set CAFLabel
result) (CAFEnv -> CAFEnv) -> CAFEnv -> CAFEnv
forall a b. (a -> b) -> a -> b
$
        KeyOf LabelMap -> Set CAFLabel -> CAFEnv
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (CmmNode C O -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmNode C O
eNode) Set CAFLabel
result


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

data ModuleSRTInfo = ModuleSRTInfo
  { ModuleSRTInfo -> Module
thisModule :: Module
    -- ^ Current module being compiled. Required for calling labelDynamic.
  , ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs :: Map (Set SRTEntry) SRTEntry
    -- ^ previous SRTs we've emitted, so we can de-duplicate.
    -- Used to implement the [Common] optimisation.
  , ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
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.
  , ModuleSRTInfo -> SRTMap
moduleSRTMap :: SRTMap
  }

instance OutputableP env CLabel => OutputableP env ModuleSRTInfo where
  pdoc :: env -> ModuleSRTInfo -> SDoc
pdoc env
env ModuleSRTInfo{Map (Set SRTEntry) SRTEntry
SRTMap
Map SRTEntry (Set SRTEntry)
Module
moduleSRTMap :: SRTMap
flatSRTs :: Map SRTEntry (Set SRTEntry)
dedupSRTs :: Map (Set SRTEntry) SRTEntry
thisModule :: Module
moduleSRTMap :: ModuleSRTInfo -> SRTMap
flatSRTs :: ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
dedupSRTs :: ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
thisModule :: ModuleSRTInfo -> Module
..} =
    String -> SDoc
text String
"ModuleSRTInfo {" SDoc -> SDoc -> SDoc
$$
      (WordOff -> SDoc -> SDoc
nest WordOff
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"dedupSRTs ="    SDoc -> SDoc -> SDoc
<+> env -> Map (Set SRTEntry) SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Map (Set SRTEntry) SRTEntry
dedupSRTs SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text String
"flatSRTs ="     SDoc -> SDoc -> SDoc
<+> env -> Map SRTEntry (Set SRTEntry) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Map SRTEntry (Set SRTEntry)
flatSRTs SDoc -> SDoc -> SDoc
$$
                String -> SDoc
text String
"moduleSRTMap =" SDoc -> SDoc -> SDoc
<+> env -> SRTMap -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env SRTMap
moduleSRTMap) SDoc -> SDoc -> SDoc
$$ Char -> SDoc
char Char
'}'

emptySRT :: Module -> ModuleSRTInfo
emptySRT :: Module -> ModuleSRTInfo
emptySRT Module
mod =
  ModuleSRTInfo
    { thisModule :: Module
thisModule = Module
mod
    , dedupSRTs :: Map (Set SRTEntry) SRTEntry
dedupSRTs = Map (Set SRTEntry) SRTEntry
forall k a. Map k a
Map.empty
    , flatSRTs :: Map SRTEntry (Set SRTEntry)
flatSRTs = Map SRTEntry (Set SRTEntry)
forall k a. Map k a
Map.empty
    , moduleSRTMap :: SRTMap
moduleSRTMap = SRTMap
forall k a. Map k a
Map.empty
    }

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

{- Implementation notes

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

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

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

- We get the CAFSet for each entry from the CAFEnv

-}

data SomeLabel
  = BlockLabel !Label
  | DeclLabel CLabel
  deriving (SomeLabel -> SomeLabel -> Bool
(SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool) -> Eq SomeLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SomeLabel -> SomeLabel -> Bool
$c/= :: SomeLabel -> SomeLabel -> Bool
== :: SomeLabel -> SomeLabel -> Bool
$c== :: SomeLabel -> SomeLabel -> Bool
Eq, Eq SomeLabel
Eq SomeLabel
-> (SomeLabel -> SomeLabel -> Ordering)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> Bool)
-> (SomeLabel -> SomeLabel -> SomeLabel)
-> (SomeLabel -> SomeLabel -> SomeLabel)
-> Ord SomeLabel
SomeLabel -> SomeLabel -> Bool
SomeLabel -> SomeLabel -> Ordering
SomeLabel -> SomeLabel -> SomeLabel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SomeLabel -> SomeLabel -> SomeLabel
$cmin :: SomeLabel -> SomeLabel -> SomeLabel
max :: SomeLabel -> SomeLabel -> SomeLabel
$cmax :: SomeLabel -> SomeLabel -> SomeLabel
>= :: SomeLabel -> SomeLabel -> Bool
$c>= :: SomeLabel -> SomeLabel -> Bool
> :: SomeLabel -> SomeLabel -> Bool
$c> :: SomeLabel -> SomeLabel -> Bool
<= :: SomeLabel -> SomeLabel -> Bool
$c<= :: SomeLabel -> SomeLabel -> Bool
< :: SomeLabel -> SomeLabel -> Bool
$c< :: SomeLabel -> SomeLabel -> Bool
compare :: SomeLabel -> SomeLabel -> Ordering
$ccompare :: SomeLabel -> SomeLabel -> Ordering
Ord)

instance OutputableP env CLabel => OutputableP env SomeLabel where
   pdoc :: env -> SomeLabel -> SDoc
pdoc env
env = \case
      BlockLabel BlockId
l -> String -> SDoc
text String
"b:" SDoc -> SDoc -> SDoc
<+> env -> BlockId -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env BlockId
l
      DeclLabel CLabel
l  -> String -> SDoc
text String
"s:" SDoc -> SDoc -> SDoc
<+> env -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env CLabel
l

getBlockLabel :: SomeLabel -> Maybe Label
getBlockLabel :: SomeLabel -> Maybe BlockId
getBlockLabel (BlockLabel BlockId
l) = BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
l
getBlockLabel (DeclLabel CLabel
_) = Maybe BlockId
forall a. Maybe a
Nothing

getBlockLabels :: [SomeLabel] -> [Label]
getBlockLabels :: [SomeLabel] -> [BlockId]
getBlockLabels = (SomeLabel -> Maybe BlockId) -> [SomeLabel] -> [BlockId]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SomeLabel -> Maybe BlockId
getBlockLabel

-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
--   where the label is
--   - the info label for a continuation or dynamic closure
--   - the closure label for a top-level function (not a CAF)
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
getLabelledBlocks Platform
platform CmmDecl
decl = case CmmDecl
decl of
   CmmData Section
_ (CmmStaticsRaw CLabel
_ [CmmStatic]
_)    -> []
   CmmData Section
_ (CmmStatics CLabel
lbl CmmInfoTable
_ CostCentreStack
_ [CmmLit]
_) -> [ (CLabel -> SomeLabel
DeclLabel CLabel
lbl, Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl) ]
   CmmProc CmmTopInfo
top_info CLabel
_ [GlobalReg]
_ GenCmmGraph CmmNode
_           -> [ (BlockId -> SomeLabel
BlockLabel BlockId
blockId, CAFLabel
caf_lbl)
                                       | (BlockId
blockId, CmmInfoTable
info) <- LabelMap CmmInfoTable -> [(KeyOf LabelMap, CmmInfoTable)]
forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
                                       , let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info
                                       , Bool -> Bool
not (SMRep -> Bool
isStaticRep SMRep
rep) Bool -> Bool -> Bool
|| Bool -> Bool
not (SMRep -> Bool
isThunkRep SMRep
rep)
                                       , let !caf_lbl :: CAFLabel
caf_lbl = Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info)
                                       ]

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

  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
nodes = [ (SomeLabel, CAFLabel, Set CAFLabel)
-> SomeLabel
-> [SomeLabel]
-> Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (SomeLabel
l,CAFLabel
lbl,Set CAFLabel
cafs') SomeLabel
l
              ((CAFLabel -> Maybe SomeLabel) -> [CAFLabel] -> [SomeLabel]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((CAFLabel -> Map CAFLabel SomeLabel -> Maybe SomeLabel)
-> Map CAFLabel SomeLabel -> CAFLabel -> Maybe SomeLabel
forall a b c. (a -> b -> c) -> b -> a -> c
flip CAFLabel -> Map CAFLabel SomeLabel -> Maybe SomeLabel
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map CAFLabel SomeLabel
labelToBlock) (Set CAFLabel -> [CAFLabel]
forall a. Set a -> [a]
Set.toList Set CAFLabel
cafs'))
          | (SomeLabel
l, CAFLabel
lbl) <- [(SomeLabel, CAFLabel)]
labelledBlocks
          , Just (Set CAFLabel
cafs :: Set CAFLabel) <-
              [case SomeLabel
l of
                 BlockLabel BlockId
l -> KeyOf LabelMap -> CAFEnv -> Maybe (Set CAFLabel)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l CAFEnv
cafEnv
                 DeclLabel CLabel
cl -> CLabel -> DataCAFEnv -> Maybe (Set CAFLabel)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CLabel
cl DataCAFEnv
cafEnv_static]
          , let cafs' :: Set CAFLabel
cafs' = CAFLabel -> Set CAFLabel -> Set CAFLabel
forall a. Ord a => a -> Set a -> Set a
Set.delete CAFLabel
lbl Set CAFLabel
cafs
          ]

  graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
  graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
graph = [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
-> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
nodes

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


-- | Get the list of blocks that correspond to the entry points for
-- FUN_STATIC closures.  These are the blocks for which if we have an
-- SRT we can merge it with the static closure. [FUN]
getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns [CmmDecl]
decls =
  [ (GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g, CLabel
lbl)
  | CmmProc CmmTopInfo
top_info CLabel
_ [GlobalReg]
_ GenCmmGraph CmmNode
g <- [CmmDecl]
decls
  , Just CmmInfoTable
info <- [KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)]
  , Just (Id
id, CostCentreStack
_) <- [CmmInfoTable -> Maybe (Id, CostCentreStack)
cit_clo CmmInfoTable
info]
  , let rep :: SMRep
rep = CmmInfoTable -> SMRep
cit_rep CmmInfoTable
info
  , SMRep -> Bool
isStaticRep SMRep
rep Bool -> Bool -> Bool
&& SMRep -> Bool
isFunRep SMRep
rep
  , let !lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
  ]


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


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

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

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

doSRTs :: DynFlags
-> ModuleSRTInfo
-> [(CAFEnv, [CmmDecl])]
-> [(Set CAFLabel, CmmDecl)]
-> IO (ModuleSRTInfo, [CmmDeclSRTs])
doSRTs DynFlags
dflags ModuleSRTInfo
moduleSRTInfo [(CAFEnv, [CmmDecl])]
procs [(Set CAFLabel, CmmDecl)]
data_ = do
  UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'u'

  let profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags

  -- Ignore the original grouping of decls, and combine all the
  -- CAFEnvs into a single CAFEnv.
  let static_data_env :: DataCAFEnv
      static_data_env :: DataCAFEnv
static_data_env =
        [(CLabel, Set CAFLabel)] -> DataCAFEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CLabel, Set CAFLabel)] -> DataCAFEnv)
-> [(CLabel, Set CAFLabel)] -> DataCAFEnv
forall a b. (a -> b) -> a -> b
$
        (((Set CAFLabel, CmmDecl) -> (CLabel, Set CAFLabel))
 -> [(Set CAFLabel, CmmDecl)] -> [(CLabel, Set CAFLabel)])
-> [(Set CAFLabel, CmmDecl)]
-> ((Set CAFLabel, CmmDecl) -> (CLabel, Set CAFLabel))
-> [(CLabel, Set CAFLabel)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Set CAFLabel, CmmDecl) -> (CLabel, Set CAFLabel))
-> [(Set CAFLabel, CmmDecl)] -> [(CLabel, Set CAFLabel)]
forall a b. (a -> b) -> [a] -> [b]
map [(Set CAFLabel, CmmDecl)]
data_ (((Set CAFLabel, CmmDecl) -> (CLabel, Set CAFLabel))
 -> [(CLabel, Set CAFLabel)])
-> ((Set CAFLabel, CmmDecl) -> (CLabel, Set CAFLabel))
-> [(CLabel, Set CAFLabel)]
forall a b. (a -> b) -> a -> b
$
        \(Set CAFLabel
set, CmmDecl
decl) ->
          case CmmDecl
decl of
            CmmProc{} ->
              String -> SDoc -> (CLabel, Set CAFLabel)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doSRTs" (String -> SDoc
text String
"Proc in static data list:" SDoc -> SDoc -> SDoc
<+> Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmDecl
decl)
            CmmData Section
_ GenCmmStatics 'False
static ->
              case GenCmmStatics 'False
static of
                CmmStatics CLabel
lbl CmmInfoTable
_ CostCentreStack
_ [CmmLit]
_ -> (CLabel
lbl, Set CAFLabel
set)
                CmmStaticsRaw CLabel
lbl [CmmStatic]
_ -> (CLabel
lbl, Set CAFLabel
set)

      ([CAFEnv]
proc_envs, [[CmmDecl]]
procss) = [(CAFEnv, [CmmDecl])] -> ([CAFEnv], [[CmmDecl]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CAFEnv, [CmmDecl])]
procs
      cafEnv :: CAFEnv
cafEnv = [CAFEnv] -> CAFEnv
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions [CAFEnv]
proc_envs
      decls :: [CmmDecl]
decls = ((Set CAFLabel, CmmDecl) -> CmmDecl)
-> [(Set CAFLabel, CmmDecl)] -> [CmmDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Set CAFLabel, CmmDecl) -> CmmDecl
forall a b. (a, b) -> b
snd [(Set CAFLabel, CmmDecl)]
data_ [CmmDecl] -> [CmmDecl] -> [CmmDecl]
forall a. [a] -> [a] -> [a]
++ [[CmmDecl]] -> [CmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDecl]]
procss
      staticFuns :: LabelMap CLabel
staticFuns = [(KeyOf LabelMap, CLabel)] -> LabelMap CLabel
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([CmmDecl] -> [(BlockId, CLabel)]
getStaticFuns [CmmDecl]
decls)

      platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

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

    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
    cafsWithSRTs :: [(BlockId, CAFLabel, Set CAFLabel)]
cafsWithSRTs = Platform
-> CAFEnv -> [CmmDecl] -> [(BlockId, CAFLabel, Set CAFLabel)]
getCAFs Platform
platform CAFEnv
cafEnv [CmmDecl]
decls

  String -> SDoc -> IO ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"doSRTs" (String -> SDoc
text String
"data:"            SDoc -> SDoc -> SDoc
<+> Platform -> [(Set CAFLabel, CmmDecl)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(Set CAFLabel, CmmDecl)]
data_ SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"procs:"           SDoc -> SDoc -> SDoc
<+> Platform -> [(CAFEnv, [CmmDecl])] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(CAFEnv, [CmmDecl])]
procs SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"static_data_env:" SDoc -> SDoc -> SDoc
<+> Platform -> DataCAFEnv -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform DataCAFEnv
static_data_env SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"sccs:"            SDoc -> SDoc -> SDoc
<+> Platform -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
sccs SDoc -> SDoc -> SDoc
$$
                      String -> SDoc
text String
"cafsWithSRTs:"    SDoc -> SDoc -> SDoc
<+> Platform -> [(BlockId, CAFLabel, Set CAFLabel)] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [(BlockId, CAFLabel, Set CAFLabel)]
cafsWithSRTs)

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

      ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
result, ModuleSRTInfo
moduleSRTInfo') =
        UniqSupply
-> UniqSM
     ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)],
      ModuleSRTInfo)
-> ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
      Bool)],
    ModuleSRTInfo)
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM
   ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
      Bool)],
    ModuleSRTInfo)
 -> ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)],
     ModuleSRTInfo))
-> UniqSM
     ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)],
      ModuleSRTInfo)
-> ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
      Bool)],
    ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$
        (StateT
   ModuleSRTInfo
   UniqSM
   [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
     Bool)]
 -> ModuleSRTInfo
 -> UniqSM
      ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
         Bool)],
       ModuleSRTInfo))
-> ModuleSRTInfo
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
-> UniqSM
     ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)],
      ModuleSRTInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  ModuleSRTInfo
  UniqSM
  [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
    Bool)]
-> ModuleSRTInfo
-> UniqSM
     ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)],
      ModuleSRTInfo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ModuleSRTInfo
moduleSRTInfo (StateT
   ModuleSRTInfo
   UniqSM
   [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
     Bool)]
 -> UniqSM
      ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
         Bool)],
       ModuleSRTInfo))
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
-> UniqSM
     ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)],
      ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$ do
          [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
nonCAFs <- (SCC (SomeLabel, CAFLabel, Set CAFLabel)
 -> StateT
      ModuleSRTInfo
      UniqSM
      ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool))
-> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags
-> LabelMap CLabel
-> DataCAFEnv
-> SCC (SomeLabel, CAFLabel, Set CAFLabel)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
doSCC DynFlags
dflags LabelMap CLabel
staticFuns DataCAFEnv
static_data_env) [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
sccs
          [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
cAFs <- [(BlockId, CAFLabel, Set CAFLabel)]
-> ((BlockId, CAFLabel, Set CAFLabel)
    -> StateT
         ModuleSRTInfo
         UniqSM
         ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
          Bool))
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(BlockId, CAFLabel, Set CAFLabel)]
cafsWithSRTs (((BlockId, CAFLabel, Set CAFLabel)
  -> StateT
       ModuleSRTInfo
       UniqSM
       ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool))
 -> StateT
      ModuleSRTInfo
      UniqSM
      [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
        Bool)])
-> ((BlockId, CAFLabel, Set CAFLabel)
    -> StateT
         ModuleSRTInfo
         UniqSM
         ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
          Bool))
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
forall a b. (a -> b) -> a -> b
$ \(BlockId
l, CAFLabel
cafLbl, Set CAFLabel
cafs) ->
            DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> Set CAFLabel
-> DataCAFEnv
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [BlockId -> SomeLabel
BlockLabel BlockId
l] [CAFLabel
cafLbl]
                   Bool
True{-is a CAF-} Set CAFLabel
cafs DataCAFEnv
static_data_env
          [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
-> StateT
     ModuleSRTInfo
     UniqSM
     [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
       Bool)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
nonCAFs [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
-> [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
     Bool)]
-> [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
     Bool)]
forall a. [a] -> [a] -> [a]
++ [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
cAFs)

      ([[CmmDeclSRTs]]
srt_declss, [[(BlockId, CLabel)]]
pairs, [[(BlockId, [SRTEntry])]]
funSRTs, [Bool]
has_caf_refs) = [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
-> ([[CmmDeclSRTs]], [[(BlockId, CLabel)]],
    [[(BlockId, [SRTEntry])]], [Bool])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])],
  Bool)]
result
      srt_decls :: [CmmDeclSRTs]
srt_decls = [[CmmDeclSRTs]] -> [CmmDeclSRTs]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDeclSRTs]]
srt_declss

  -- Next, update the info tables with the SRTs
  let
    srtFieldMap :: LabelMap CLabel
srtFieldMap = [(KeyOf LabelMap, CLabel)] -> LabelMap CLabel
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([[(BlockId, CLabel)]] -> [(BlockId, CLabel)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(BlockId, CLabel)]]
pairs)
    funSRTMap :: LabelMap [SRTEntry]
funSRTMap = [(KeyOf LabelMap, [SRTEntry])] -> LabelMap [SRTEntry]
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([[(BlockId, [SRTEntry])]] -> [(BlockId, [SRTEntry])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(BlockId, [SRTEntry])]]
funSRTs)
    has_caf_refs' :: Bool
has_caf_refs' = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
has_caf_refs
    decls' :: [CmmDeclSRTs]
decls' =
      (CmmDecl -> [CmmDeclSRTs]) -> [CmmDecl] -> [CmmDeclSRTs]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Profile
-> LabelMap CLabel
-> LabelMap [SRTEntry]
-> Bool
-> CmmDecl
-> [CmmDeclSRTs]
updInfoSRTs Profile
profile LabelMap CLabel
srtFieldMap LabelMap [SRTEntry]
funSRTMap Bool
has_caf_refs') [CmmDecl]
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 :: SRTMap
srtMap_w_raws =
        (SRTMap -> (Set CAFLabel, CmmDecl) -> SRTMap)
-> SRTMap -> [(Set CAFLabel, CmmDecl)] -> SRTMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(SRTMap
srtMap :: SRTMap) (Set CAFLabel
_, CmmDecl
decl) ->
                  case CmmDecl
decl of
                    CmmData Section
_ CmmStatics{} ->
                      -- already updated by oneSRT
                      SRTMap
srtMap
                    CmmData Section
_ (CmmStaticsRaw CLabel
lbl [CmmStatic]
_)
                      | CLabel -> Bool
isIdLabel CLabel
lbl Bool -> Bool -> Bool
&& Bool -> Bool
not (CLabel -> Bool
isTickyLabel CLabel
lbl) ->
                          -- Raw data are not analysed by oneSRT and they can't
                          -- be CAFFY.
                          -- See Note [Ticky labels in SRT analysis] above for
                          -- why we exclude ticky labels here.
                          CAFLabel -> Maybe SRTEntry -> SRTMap -> SRTMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Platform -> CLabel -> CAFLabel
mkCAFLabel Platform
platform CLabel
lbl) Maybe SRTEntry
forall a. Maybe a
Nothing SRTMap
srtMap
                      | Bool
otherwise ->
                          -- Not an IdLabel, ignore
                          SRTMap
srtMap
                    CmmProc{} ->
                      String -> SDoc -> SRTMap
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"doSRTs" (String -> SDoc
text String
"Found Proc in static data list:" SDoc -> SDoc -> SDoc
<+> Platform -> CmmDecl -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmDecl
decl))
               (ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
moduleSRTInfo') [(Set CAFLabel, CmmDecl)]
data_

  (ModuleSRTInfo, [CmmDeclSRTs]) -> IO (ModuleSRTInfo, [CmmDeclSRTs])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleSRTInfo
moduleSRTInfo'{ moduleSRTMap :: SRTMap
moduleSRTMap = SRTMap
srtMap_w_raws }, [CmmDeclSRTs]
srt_decls [CmmDeclSRTs] -> [CmmDeclSRTs] -> [CmmDeclSRTs]
forall a. [a] -> [a] -> [a]
++ [CmmDeclSRTs]
decls')


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

doSCC :: DynFlags
-> LabelMap CLabel
-> DataCAFEnv
-> SCC (SomeLabel, CAFLabel, Set CAFLabel)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
doSCC DynFlags
dflags LabelMap CLabel
staticFuns DataCAFEnv
static_data_env (AcyclicSCC (SomeLabel
l, CAFLabel
cafLbl, Set CAFLabel
cafs)) =
  DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> Set CAFLabel
-> DataCAFEnv
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel
l] [CAFLabel
cafLbl] Bool
False Set CAFLabel
cafs DataCAFEnv
static_data_env

doSCC DynFlags
dflags LabelMap CLabel
staticFuns DataCAFEnv
static_data_env (CyclicSCC [(SomeLabel, CAFLabel, Set CAFLabel)]
nodes) = do
  -- build a single SRT for the whole cycle, see Note [recursive SRTs]
  let ([SomeLabel]
lbls, [CAFLabel]
caf_lbls, [Set CAFLabel]
cafsets) = [(SomeLabel, CAFLabel, Set CAFLabel)]
-> ([SomeLabel], [CAFLabel], [Set CAFLabel])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [(SomeLabel, CAFLabel, Set CAFLabel)]
nodes
      cafs :: Set CAFLabel
cafs = [Set CAFLabel] -> Set CAFLabel
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set CAFLabel]
cafsets
  DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> Set CAFLabel
-> DataCAFEnv
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel]
lbls [CAFLabel]
caf_lbls Bool
False Set CAFLabel
cafs DataCAFEnv
static_data_env


{- 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 CAFfyLabel 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 group SRT will consist of the union of the SRTs of
  each of group's constituents minus recursive references.

* That is, EXCEPT for static function closures and static data constructor
  applications. For the same reason described in Note [No static object
  resurrection], we cannot omit references to static function closures and
  constructor applications.

  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.

* Similarly, we must reintroduce recursive references to static data
  constructor applications into the group's SRT.
-}

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

oneSRT :: DynFlags
-> LabelMap CLabel
-> [SomeLabel]
-> [CAFLabel]
-> Bool
-> Set CAFLabel
-> DataCAFEnv
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [SomeLabel]
lbls [CAFLabel]
caf_lbls Bool
isCAF Set CAFLabel
cafs DataCAFEnv
static_data_env = do
  ModuleSRTInfo
topSRT <- StateT ModuleSRTInfo UniqSM ModuleSRTInfo
forall (m :: * -> *) s. Monad m => StateT s m s
get

  let
    this_mod :: Module
this_mod = ModuleSRTInfo -> Module
thisModule ModuleSRTInfo
topSRT
    config :: NCGConfig
config = DynFlags -> Module -> NCGConfig
initNCGConfig DynFlags
dflags Module
this_mod
    profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    srtMap :: SRTMap
srtMap = ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
topSRT

    blockids :: [BlockId]
blockids = [SomeLabel] -> [BlockId]
getBlockLabels [SomeLabel]
lbls

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

    -- Remove recursive references from the SRT as described in
    -- Note [recursive SRTs]. We carefully reintroduce references to static
    -- functions and data constructor applications below, as is necessary due
    -- to Note [No static object resurrection].
    nonRec :: Set CAFLabel
    nonRec :: Set CAFLabel
nonRec = Set CAFLabel
cafs Set CAFLabel -> Set CAFLabel -> Set CAFLabel
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [CAFLabel] -> Set CAFLabel
forall a. Ord a => [a] -> Set a
Set.fromList [CAFLabel]
caf_lbls

    -- Resolve references to their SRT entries
    resolved :: [SRTEntry]
    resolved :: [SRTEntry]
resolved = (CAFLabel -> Maybe SRTEntry) -> [CAFLabel] -> [SRTEntry]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF Platform
platform SRTMap
srtMap) (Set CAFLabel -> [CAFLabel]
forall a. Set a -> [a]
Set.toList Set CAFLabel
nonRec)

    -- The set of all SRTEntries in SRTs that we refer to from here.
    allBelow :: Set SRTEntry
allBelow =
      [Set SRTEntry] -> Set SRTEntry
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [ Set SRTEntry
lbls | SRTEntry
caf <- [SRTEntry]
resolved
                        , Just Set SRTEntry
lbls <- [SRTEntry -> Map SRTEntry (Set SRTEntry) -> Maybe (Set SRTEntry)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup SRTEntry
caf (ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs ModuleSRTInfo
topSRT)] ]

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

  String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT:"
     (String -> SDoc
text String
"srtMap:"          SDoc -> SDoc -> SDoc
<+> Platform -> SRTMap -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTMap
srtMap SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"nonRec:"          SDoc -> SDoc -> SDoc
<+> Platform -> Set CAFLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set CAFLabel
nonRec SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"lbls:"            SDoc -> SDoc -> SDoc
<+> Platform -> [SomeLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SomeLabel]
lbls SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"caf_lbls:"        SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"static_data_env:" SDoc -> SDoc -> SDoc
<+> Platform -> DataCAFEnv -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform DataCAFEnv
static_data_env SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"cafs:"            SDoc -> SDoc -> SDoc
<+> Platform -> Set CAFLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set CAFLabel
cafs SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"blockids:"        SDoc -> SDoc -> SDoc
<+> [BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockId]
blockids SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"maybeFunClosure:" SDoc -> SDoc -> SDoc
<+> Platform -> Maybe (CLabel, BlockId) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Maybe (CLabel, BlockId)
maybeFunClosure SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"otherFunLabels:"  SDoc -> SDoc -> SDoc
<+> Platform -> [CLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CLabel]
otherFunLabels SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"resolved:"        SDoc -> SDoc -> SDoc
<+> Platform -> [SRTEntry] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [SRTEntry]
resolved SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"allBelow:"        SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
allBelow SDoc -> SDoc -> SDoc
$$
      String -> SDoc
text String
"filtered0:"       SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered0)

  let
    isStaticFun :: Bool
isStaticFun = Maybe (CLabel, BlockId) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (CLabel, BlockId)
maybeFunClosure

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

    allStaticData :: Bool
allStaticData =
      (CAFLabel -> Bool) -> [CAFLabel] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(CAFLabel CLabel
clbl) -> CLabel -> DataCAFEnv -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member CLabel
clbl DataCAFEnv
static_data_env) [CAFLabel]
caf_lbls

  if Set SRTEntry -> Bool
forall a. Set a -> Bool
Set.null Set SRTEntry
filtered0 then do
    String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: empty" (Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls)
    Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap Maybe SRTEntry
forall a. Maybe a
Nothing
    ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [], Bool
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 SRTEntry
allBelow_funs =
          [SRTEntry] -> Set SRTEntry
forall a. Ord a => [a] -> Set a
Set.fromList ((CLabel -> SRTEntry) -> [CLabel] -> [SRTEntry]
forall a b. (a -> b) -> [a] -> [b]
map (CLabel -> SRTEntry
SRTEntry (CLabel -> SRTEntry) -> (CLabel -> CLabel) -> CLabel -> SRTEntry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> CLabel -> CLabel
toClosureLbl Platform
platform) [CLabel]
otherFunLabels)
    -- We must also ensure that all CAFfy static data constructor applications
    -- are included. See Note [recursive SRTs] and #20959.
    let allBelow_data :: Set SRTEntry
allBelow_data =
          [SRTEntry] -> Set SRTEntry
forall a. Ord a => [a] -> Set a
Set.fromList
          [ CLabel -> SRTEntry
SRTEntry (CLabel -> SRTEntry) -> CLabel -> SRTEntry
forall a b. (a -> b) -> a -> b
$ Platform -> CLabel -> CLabel
toClosureLbl Platform
platform CLabel
lbl
          | DeclLabel CLabel
lbl <- [SomeLabel]
lbls
          , Just Set CAFLabel
refs <- Maybe (Set CAFLabel) -> [Maybe (Set CAFLabel)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Set CAFLabel) -> [Maybe (Set CAFLabel)])
-> Maybe (Set CAFLabel) -> [Maybe (Set CAFLabel)]
forall a b. (a -> b) -> a -> b
$ CLabel -> DataCAFEnv -> Maybe (Set CAFLabel)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CLabel
lbl DataCAFEnv
static_data_env
          , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Set CAFLabel -> Bool
forall a. Set a -> Bool
Set.null Set CAFLabel
refs
          ]
    let filtered :: Set SRTEntry
filtered = Set SRTEntry
filtered0 Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SRTEntry
allBelow_funs Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SRTEntry
allBelow_data
    String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT" (String -> SDoc
text String
"filtered:"      SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered SDoc -> SDoc -> SDoc
$$
                        String -> SDoc
text String
"allBelow_funs:" SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
allBelow_funs)
    case Set SRTEntry -> [SRTEntry]
forall a. Set a -> [a]
Set.toList Set SRTEntry
filtered of
      [] -> String
-> SDoc
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"oneSRT" SDoc
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
one@(SRTEntry CLabel
lbl)]
        | -- Info tables refer to SRTs by offset (as noted in the section
          -- "Referring to an SRT from the info table" of Note [SRTs]). However,
          -- when dynamic linking is used we cannot guarantee that the offset
          -- between the SRT and the info table will fit in the offset field.
          -- Consequently we build a singleton SRT in this case.
          Bool -> Bool
not (NCGConfig -> CLabel -> Bool
labelDynamic NCGConfig
config CLabel
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.
            Bool -> Bool -> Bool
&& (Bool -> Bool
not (OS -> Bool
osMachOTarget (OS -> Bool) -> OS -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> OS
platformOS (Platform -> OS) -> Platform -> OS
forall a b. (a -> b) -> a -> b
$ Profile -> Platform
profilePlatform Profile
profile)
               Bool -> Bool -> Bool
|| Module -> CLabel -> Bool
isLocalCLabel Module
this_mod CLabel
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 Maybe (CLabel, BlockId)
maybeFunClosure of
            Just (CLabel
staticFunLbl,BlockId
staticFunBlock) ->
                ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(BlockId, CLabel)]
withLabels, [], Bool
True)
              where
                withLabels :: [(BlockId, CLabel)]
withLabels =
                  [ (BlockId
b, if BlockId
b BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
staticFunBlock then CLabel
lbl else CLabel
staticFunLbl)
                  | BlockId
b <- [BlockId]
blockids ]
            Maybe (CLabel, BlockId)
Nothing -> do
              String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: one" (String -> SDoc
text String
"caf_lbls:" SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
                                       String -> SDoc
text String
"one:"      SDoc -> SDoc -> SDoc
<+> Platform -> SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTEntry
one)
              Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
one)
              ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (BlockId -> (BlockId, CLabel)) -> [BlockId] -> [(BlockId, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [BlockId]
blockids, [], Bool
True)

      [SRTEntry]
cafList | Bool
allStaticData ->
        ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [], Bool -> Bool
not ([SRTEntry] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SRTEntry]
cafList))

      [SRTEntry]
cafList ->
        -- Check whether an SRT with the same entries has been emitted already.
        -- Implements the [Common] optimisation.
        case Set SRTEntry -> Map (Set SRTEntry) SRTEntry -> Maybe SRTEntry
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Set SRTEntry
filtered (ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs ModuleSRTInfo
topSRT) of
          Just srtEntry :: SRTEntry
srtEntry@(SRTEntry CLabel
srtLbl)  -> do
            String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT [Common]" (Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
<+> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
srtLbl)
            Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
srtEntry)
            ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (BlockId -> (BlockId, CLabel)) -> [BlockId] -> [(BlockId, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
srtLbl) [BlockId]
blockids, [], Bool
True)
          Maybe SRTEntry
Nothing -> do
            -- No duplicates: we have to build a new SRT object
            ([CmmDeclSRTs]
decls, [(BlockId, [SRTEntry])]
funSRTs, SRTEntry
srtEntry) <-
              case Maybe (CLabel, BlockId)
maybeFunClosure of
                Just (CLabel
fun,BlockId
block) ->
                  ([CmmDeclSRTs], [(BlockId, [SRTEntry])], SRTEntry)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [], [(BlockId
block, [SRTEntry]
cafList)], CLabel -> SRTEntry
SRTEntry CLabel
fun )
                Maybe (CLabel, BlockId)
Nothing -> do
                  ([CmmDeclSRTs]
decls, SRTEntry
entry) <- UniqSM ([CmmDeclSRTs], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UniqSM ([CmmDeclSRTs], SRTEntry)
 -> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry))
-> UniqSM ([CmmDeclSRTs], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDeclSRTs], SRTEntry)
forall a b. (a -> b) -> a -> b
$ Profile -> [SRTEntry] -> UniqSM ([CmmDeclSRTs], SRTEntry)
buildSRTChain Profile
profile [SRTEntry]
cafList
                  ([CmmDeclSRTs], [(BlockId, [SRTEntry])], SRTEntry)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDeclSRTs]
decls, [], SRTEntry
entry)
            Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
srtEntry)
            let allBelowThis :: Set SRTEntry
allBelowThis = Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set SRTEntry
allBelow Set SRTEntry
filtered
                newFlatSRTs :: Map SRTEntry (Set SRTEntry)
newFlatSRTs = SRTEntry
-> Set SRTEntry
-> Map SRTEntry (Set SRTEntry)
-> Map SRTEntry (Set SRTEntry)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SRTEntry
srtEntry Set SRTEntry
allBelowThis (ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs ModuleSRTInfo
topSRT)
                -- When all definition in this group are static data we don't
                -- generate any SRTs.
                newDedupSRTs :: Map (Set SRTEntry) SRTEntry
newDedupSRTs = Set SRTEntry
-> SRTEntry
-> Map (Set SRTEntry) SRTEntry
-> Map (Set SRTEntry) SRTEntry
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Set SRTEntry
filtered SRTEntry
srtEntry (ModuleSRTInfo -> Map (Set SRTEntry) SRTEntry
dedupSRTs ModuleSRTInfo
topSRT)
            (ModuleSRTInfo -> ModuleSRTInfo) -> StateT ModuleSRTInfo UniqSM ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' (\ModuleSRTInfo
state -> ModuleSRTInfo
state{ dedupSRTs :: Map (Set SRTEntry) SRTEntry
dedupSRTs = Map (Set SRTEntry) SRTEntry
newDedupSRTs,
                                      flatSRTs :: Map SRTEntry (Set SRTEntry)
flatSRTs = Map SRTEntry (Set SRTEntry)
newFlatSRTs })
            String -> SDoc -> StateT ModuleSRTInfo UniqSM ()
forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
"oneSRT: new" (String -> SDoc
text String
"caf_lbls:"      SDoc -> SDoc -> SDoc
<+> Platform -> [CAFLabel] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [CAFLabel]
caf_lbls SDoc -> SDoc -> SDoc
$$
                                      String -> SDoc
text String
"filtered:"     SDoc -> SDoc -> SDoc
<+> Platform -> Set SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Set SRTEntry
filtered SDoc -> SDoc -> SDoc
$$
                                      String -> SDoc
text String
"srtEntry:"     SDoc -> SDoc -> SDoc
<+> Platform -> SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform SRTEntry
srtEntry SDoc -> SDoc -> SDoc
$$
                                      String -> SDoc
text String
"newDedupSRTs:" SDoc -> SDoc -> SDoc
<+> Platform -> Map (Set SRTEntry) SRTEntry -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Map (Set SRTEntry) SRTEntry
newDedupSRTs SDoc -> SDoc -> SDoc
$$
                                      String -> SDoc
text String
"newFlatSRTs:"  SDoc -> SDoc -> SDoc
<+> Platform -> Map SRTEntry (Set SRTEntry) -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform Map SRTEntry (Set SRTEntry)
newFlatSRTs)
            let SRTEntry CLabel
lbl = SRTEntry
srtEntry
            ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
-> StateT
     ModuleSRTInfo
     UniqSM
     ([CmmDeclSRTs], [(BlockId, CLabel)], [(BlockId, [SRTEntry])], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDeclSRTs]
decls, (BlockId -> (BlockId, CLabel)) -> [BlockId] -> [(BlockId, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [BlockId]
blockids, [(BlockId, [SRTEntry])]
funSRTs, Bool
True)


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


buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
buildSRT Profile
profile [SRTEntry]
refs = do
  Unique
id <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  let
    lbl :: CLabel
lbl = Unique -> CLabel
mkSRTLabel Unique
id
    platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
    srt_n_info :: CLabel
srt_n_info = WordOff -> CLabel
mkSRTInfoLabel ([SRTEntry] -> WordOff
forall (t :: * -> *) a. Foldable t => t a -> WordOff
length [SRTEntry]
refs)
    fields :: [CmmLit]
fields =
      Profile
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure Profile
profile CLabel
srt_n_info CostCentreStack
dontCareCCS
        [ CLabel -> CmmLit
CmmLabel CLabel
lbl | SRTEntry CLabel
lbl <- [SRTEntry]
refs ]
        [] -- no padding
        [Platform -> WordOff -> CmmLit
mkIntCLit Platform
platform WordOff
0] -- link field
        [] -- no saved info
  (CmmDeclSRTs, SRTEntry) -> UniqSM (CmmDeclSRTs, SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Section -> CLabel -> [CmmLit] -> CmmDeclSRTs
forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
fields, CLabel -> SRTEntry
SRTEntry CLabel
lbl)

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

updInfoSRTs :: Profile
-> LabelMap CLabel
-> LabelMap [SRTEntry]
-> Bool
-> CmmDecl
-> [CmmDeclSRTs]
updInfoSRTs Profile
_ LabelMap CLabel
_ LabelMap [SRTEntry]
_ Bool
_ (CmmData Section
s (CmmStaticsRaw CLabel
lbl [CmmStatic]
statics))
  = [Section -> RawCmmStatics -> CmmDeclSRTs
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
s (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
statics)]

updInfoSRTs Profile
profile LabelMap CLabel
_ LabelMap [SRTEntry]
_ Bool
caffy (CmmData Section
s (CmmStatics CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload))
  = [Section -> RawCmmStatics -> CmmDeclSRTs
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
s (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl ((CmmLit -> CmmStatic) -> [CmmLit] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> CmmStatic
CmmStaticLit [CmmLit]
field_lits))]
  where
    caf_info :: CafInfo
caf_info = if Bool
caffy then CafInfo
MayHaveCafRefs else CafInfo
NoCafRefs
    field_lits :: [CmmLit]
field_lits = Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
itbl CostCentreStack
ccs CafInfo
caf_info [CmmLit]
payload

updInfoSRTs Profile
profile LabelMap CLabel
srt_env LabelMap [SRTEntry]
funSRTEnv Bool
caffy (CmmProc CmmTopInfo
top_info CLabel
top_l [GlobalReg]
live GenCmmGraph CmmNode
g)
  | Just (CmmInfoTable
_,CmmDeclSRTs
closure) <- Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure = [ CmmDeclSRTs
proc, CmmDeclSRTs
closure ]
  | Bool
otherwise = [ CmmDeclSRTs
proc ]
  where
    caf_info :: CafInfo
caf_info = if Bool
caffy then CafInfo
MayHaveCafRefs else CafInfo
NoCafRefs
    proc :: CmmDeclSRTs
proc = CmmTopInfo
-> CLabel -> [GlobalReg] -> GenCmmGraph CmmNode -> CmmDeclSRTs
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc CmmTopInfo
top_info { info_tbls :: LabelMap CmmInfoTable
info_tbls = LabelMap CmmInfoTable
newTopInfo } CLabel
top_l [GlobalReg]
live GenCmmGraph CmmNode
g
    newTopInfo :: LabelMap CmmInfoTable
newTopInfo = (KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable)
-> LabelMap CmmInfoTable -> LabelMap CmmInfoTable
forall (map :: * -> *) a b.
IsMap map =>
(KeyOf map -> a -> b) -> map a -> map b
mapMapWithKey KeyOf LabelMap -> CmmInfoTable -> CmmInfoTable
BlockId -> CmmInfoTable -> CmmInfoTable
updInfoTbl (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
    updInfoTbl :: BlockId -> CmmInfoTable -> CmmInfoTable
updInfoTbl BlockId
l CmmInfoTable
info_tbl
      | BlockId
l BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g, Just (CmmInfoTable
inf, CmmDeclSRTs
_) <- Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure = CmmInfoTable
inf
      | Bool
otherwise  = CmmInfoTable
info_tbl { cit_srt :: Maybe CLabel
cit_srt = KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
l LabelMap CLabel
srt_env }

    -- Generate static closures [FUN].  Note that this also generates
    -- static closures for thunks (CAFs), because it's easier to treat
    -- them uniformly in the code generator.
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
maybeStaticClosure
      | Just info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{Maybe (Id, CostCentreStack)
Maybe CLabel
SMRep
CLabel
ProfilingInfo
cit_prof :: CmmInfoTable -> ProfilingInfo
cit_clo :: Maybe (Id, CostCentreStack)
cit_srt :: Maybe CLabel
cit_prof :: ProfilingInfo
cit_rep :: SMRep
cit_lbl :: CLabel
cit_srt :: CmmInfoTable -> Maybe CLabel
cit_clo :: CmmInfoTable -> Maybe (Id, CostCentreStack)
cit_lbl :: CmmInfoTable -> CLabel
cit_rep :: CmmInfoTable -> SMRep
..} <-
           KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
      , Just (Id
id, CostCentreStack
ccs) <- Maybe (Id, CostCentreStack)
cit_clo
      , SMRep -> Bool
isStaticRep SMRep
cit_rep =
        let
          (CmmInfoTable
newInfo, [CmmLit]
srtEntries) = case KeyOf LabelMap -> LabelMap [SRTEntry] -> Maybe [SRTEntry]
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g) LabelMap [SRTEntry]
funSRTEnv of
            Maybe [SRTEntry]
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
              (CmmInfoTable
info_tbl { cit_srt :: Maybe CLabel
cit_srt = KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (GenCmmGraph CmmNode -> BlockId
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry GenCmmGraph CmmNode
g) LabelMap CLabel
srt_env }, [])
            Just [SRTEntry]
srtEntries -> String
-> SDoc -> (CmmInfoTable, [CmmLit]) -> (CmmInfoTable, [CmmLit])
forall b. String -> SDoc -> b -> b
srtTrace String
"maybeStaticFun" (Platform -> [CmmLit] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc (Profile -> Platform
profilePlatform Profile
profile) [CmmLit]
res)
              (CmmInfoTable
info_tbl { cit_rep :: SMRep
cit_rep = SMRep
new_rep }, [CmmLit]
res)
              where res :: [CmmLit]
res = [ CLabel -> CmmLit
CmmLabel CLabel
lbl | SRTEntry CLabel
lbl <- [SRTEntry]
srtEntries ]
          fields :: [CmmLit]
fields = Profile
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields Profile
profile CmmInfoTable
info_tbl CostCentreStack
ccs CafInfo
caf_info [CmmLit]
srtEntries
          new_rep :: SMRep
new_rep = case SMRep
cit_rep of
             HeapRep Bool
sta WordOff
ptrs WordOff
nptrs ClosureTypeInfo
ty ->
               Bool -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep
HeapRep Bool
sta (WordOff
ptrs WordOff -> WordOff -> WordOff
forall a. Num a => a -> a -> a
+ [CmmLit] -> WordOff
forall (t :: * -> *) a. Foldable t => t a -> WordOff
length [CmmLit]
srtEntries) WordOff
nptrs ClosureTypeInfo
ty
             SMRep
_other -> String -> SMRep
forall a. String -> a
panic String
"maybeStaticFun"
          lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) CafInfo
caf_info
        in
          (CmmInfoTable, CmmDeclSRTs) -> Maybe (CmmInfoTable, CmmDeclSRTs)
forall a. a -> Maybe a
Just (CmmInfoTable
newInfo, Section -> CLabel -> [CmmLit] -> CmmDeclSRTs
forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
fields)
      | Bool
otherwise = Maybe (CmmInfoTable, CmmDeclSRTs)
forall a. Maybe a
Nothing


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

srtTraceM :: Applicative f => String -> SDoc -> f ()
srtTraceM :: forall (f :: * -> *). Applicative f => String -> SDoc -> f ()
srtTraceM String
str SDoc
doc = String -> SDoc -> f () -> f ()
forall b. String -> SDoc -> b -> b
srtTrace String
str SDoc
doc (() -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())