{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}

module CmmBuildInfoTables
  ( CAFSet, CAFEnv, cafAnal
  , doSRTs, ModuleSRTInfo, emptySRT
  ) where

import GhcPrelude hiding (succ)

import Id
import BlockId
import Hoopl.Block
import Hoopl.Graph
import Hoopl.Label
import Hoopl.Collections
import Hoopl.Dataflow
import Module
import Platform
import Digraph
import CLabel
import PprCmmDecl ()
import Cmm
import CmmUtils
import DynFlags
import Maybes
import Outputable
import SMRep
import UniqSupply
import CostCentre
import StgCmmHeap

import PprCmm()
import Control.Monad
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Tuple
import Control.Monad.Trans.State
import Control.Monad.Trans.Class


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


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, becase SRTs are in the
   data section and *can* have relocatable references.

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

   i.e. instead of

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


   We can generate:

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


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

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

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


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

Another opportunity we don't exploit is this:

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

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

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

You might think that if we have something like

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

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

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

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

But this is NOT valid.

Consider these cases:

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

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

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

== How does this cause a problem? ==

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

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

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

So, no shortcutting.
-}

-- ---------------------------------------------------------------------
-- 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
$cp1Ord :: Eq CAFLabel
Ord,Rational -> CAFLabel -> SDoc
CAFLabel -> SDoc
(CAFLabel -> SDoc)
-> (Rational -> CAFLabel -> SDoc) -> Outputable CAFLabel
forall a. (a -> SDoc) -> (Rational -> a -> SDoc) -> Outputable a
pprPrec :: Rational -> CAFLabel -> SDoc
$cpprPrec :: Rational -> CAFLabel -> SDoc
ppr :: CAFLabel -> SDoc
$cppr :: CAFLabel -> SDoc
Outputable)

type CAFSet = Set CAFLabel
type CAFEnv = LabelMap CAFSet

mkCAFLabel :: CLabel -> CAFLabel
mkCAFLabel :: CLabel -> CAFLabel
mkCAFLabel lbl :: CLabel
lbl = CLabel -> CAFLabel
CAFLabel (CLabel -> CLabel
toClosureLbl 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
$cp1Ord :: Eq SRTEntry
Ord, Rational -> SRTEntry -> SDoc
SRTEntry -> SDoc
(SRTEntry -> SDoc)
-> (Rational -> SRTEntry -> SDoc) -> Outputable SRTEntry
forall a. (a -> SDoc) -> (Rational -> a -> SDoc) -> Outputable a
pprPrec :: Rational -> SRTEntry -> SDoc
$cpprPrec :: Rational -> SRTEntry -> SDoc
ppr :: SRTEntry -> SDoc
$cppr :: SRTEntry -> SDoc
Outputable)

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

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


cafLattice :: DataflowLattice CAFSet
cafLattice :: DataflowLattice CAFSet
cafLattice = CAFSet -> JoinFun CAFSet -> DataflowLattice CAFSet
forall a. a -> JoinFun a -> DataflowLattice a
DataflowLattice CAFSet
forall a. Set a
Set.empty JoinFun CAFSet
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 old :: Set a
old) (NewFact new :: 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 -> Int
forall a. Set a -> Int
Set.size Set a
new' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Set a -> Int
forall a. Set a -> Int
Set.size Set a
old) Set a
new'


cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet
cafTransfers contLbls :: LabelSet
contLbls entry :: Label
entry topLbl :: CLabel
topLbl
  (BlockCC eNode :: CmmNode C O
eNode middle :: Block CmmNode O O
middle xNode :: CmmNode O C
xNode) fBase :: CAFEnv
fBase =
    let joined :: CAFSet
joined = CmmNode O C -> CAFSet -> CAFSet
forall e x. CmmNode e x -> CAFSet -> CAFSet
cafsInNode CmmNode O C
xNode (CAFSet -> CAFSet) -> CAFSet -> CAFSet
forall a b. (a -> b) -> a -> b
$! CAFSet
live'
        !result :: CAFSet
result = (CmmNode O O -> CAFSet -> CAFSet)
-> Block CmmNode O O -> CAFSet -> CAFSet
forall f. (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f
foldNodesBwdOO CmmNode O O -> CAFSet -> CAFSet
forall e x. CmmNode e x -> CAFSet -> CAFSet
cafsInNode Block CmmNode O O
middle CAFSet
joined

        facts :: [CAFSet]
facts = (Label -> Maybe CAFSet) -> [Label] -> [CAFSet]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Label -> Maybe CAFSet
successorFact (CmmNode O C -> [Label]
forall (thing :: * -> * -> *) e.
NonLocal thing =>
thing e C -> [Label]
successors CmmNode O C
xNode)
        live' :: CAFSet
live' = DataflowLattice CAFSet -> [CAFSet] -> CAFSet
forall f. DataflowLattice f -> [f] -> f
joinFacts DataflowLattice CAFSet
cafLattice [CAFSet]
facts

        successorFact :: Label -> Maybe CAFSet
successorFact s :: Label
s
          -- If this is a loop back to the entry, we can refer to the
          -- entry label.
          | Label
s Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
entry = CAFSet -> Maybe CAFSet
forall a. a -> Maybe a
Just (CLabel -> CAFSet -> CAFSet
add CLabel
topLbl CAFSet
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
Label
s ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
contLbls
          = CAFSet -> Maybe CAFSet
forall a. a -> Maybe a
Just (CAFLabel -> CAFSet
forall a. a -> Set a
Set.singleton (CLabel -> CAFLabel
mkCAFLabel (Label -> CLabel
infoTblLbl Label
s)))
          -- Otherwise, takes the CAF references from the destination
          | Bool
otherwise
          = Label -> CAFEnv -> Maybe CAFSet
forall f. Label -> FactBase f -> Maybe f
lookupFact Label
s CAFEnv
fBase

        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
cafsInNode node :: CmmNode e x
node set :: CAFSet
set = (CmmExpr -> CAFSet -> CAFSet) -> CmmNode e x -> CAFSet -> CAFSet
forall z e x. (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
foldExpDeep CmmExpr -> CAFSet -> CAFSet
addCaf CmmNode e x
node CAFSet
set

        addCaf :: CmmExpr -> CAFSet -> CAFSet
addCaf expr :: CmmExpr
expr !CAFSet
set =
          case CmmExpr
expr of
              CmmLit (CmmLabel c :: CLabel
c) -> CLabel -> CAFSet -> CAFSet
add CLabel
c CAFSet
set
              CmmLit (CmmLabelOff c :: CLabel
c _) -> CLabel -> CAFSet -> CAFSet
add CLabel
c CAFSet
set
              CmmLit (CmmLabelDiffOff c1 :: CLabel
c1 c2 :: CLabel
c2 _ _) -> CLabel -> CAFSet -> CAFSet
add CLabel
c1 (CAFSet -> CAFSet) -> CAFSet -> CAFSet
forall a b. (a -> b) -> a -> b
$! CLabel -> CAFSet -> CAFSet
add CLabel
c2 CAFSet
set
              _ -> CAFSet
set
        add :: CLabel -> CAFSet -> CAFSet
add l :: CLabel
l s :: CAFSet
s | CLabel -> Bool
hasCAF CLabel
l  = CAFLabel -> CAFSet -> CAFSet
forall a. Ord a => a -> Set a -> Set a
Set.insert (CLabel -> CAFLabel
mkCAFLabel CLabel
l) CAFSet
s
                | Bool
otherwise = CAFSet
s

    in KeyOf LabelMap -> CAFSet -> CAFEnv
forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (CmmNode C O -> Label
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> Label
entryLabel CmmNode C O
eNode) CAFSet
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.
  }
instance Outputable ModuleSRTInfo where
  ppr :: ModuleSRTInfo -> SDoc
ppr ModuleSRTInfo{..} =
    String -> SDoc
text "ModuleSRTInfo:" SDoc -> SDoc -> SDoc
<+> Map (Set SRTEntry) SRTEntry -> SDoc
forall a. Outputable a => a -> SDoc
ppr Map (Set SRTEntry) SRTEntry
dedupSRTs SDoc -> SDoc -> SDoc
<+> Map SRTEntry (Set SRTEntry) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Map SRTEntry (Set SRTEntry)
flatSRTs

emptySRT :: Module -> ModuleSRTInfo
emptySRT :: Module -> ModuleSRTInfo
emptySRT mod :: Module
mod =
  ModuleSRTInfo :: Module
-> Map (Set SRTEntry) SRTEntry
-> Map SRTEntry (Set SRTEntry)
-> ModuleSRTInfo
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 }

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

{- Implementation notes

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

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

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

- We get the CAFSet for each entry from the CAFEnv

-}

-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
--   where the label is
--   - the info label for a continuation or dynamic closure
--   - the closure label for a top-level function (not a CAF)
getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]
getLabelledBlocks (CmmData _ _) = []
getLabelledBlocks (CmmProc top_info :: CmmTopInfo
top_info _ _ _) =
  [ (Label
blockId, CLabel -> CAFLabel
mkCAFLabel (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
info))
  | (blockId :: Label
blockId, info :: 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)
  ]


-- | Put the labelled blocks that we will be annotating with SRTs into
-- dependency order.  This is so that we can process them one at a
-- time, resolving references to earlier blocks to point to their
-- SRTs. CAFs themselves are not included here; see getCAFs below.
depAnalSRTs
  :: CAFEnv
  -> [CmmDecl]
  -> [SCC (Label, CAFLabel, Set CAFLabel)]
depAnalSRTs :: CAFEnv -> [CmmDecl] -> [SCC (Label, CAFLabel, CAFSet)]
depAnalSRTs cafEnv :: CAFEnv
cafEnv decls :: [CmmDecl]
decls =
  String
-> SDoc
-> [SCC (Label, CAFLabel, CAFSet)]
-> [SCC (Label, CAFLabel, CAFSet)]
forall b. String -> SDoc -> b -> b
srtTrace "depAnalSRTs" ([SCC (Label, CAFLabel, CAFSet)] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [SCC (Label, CAFLabel, CAFSet)]
graph) [SCC (Label, CAFLabel, CAFSet)]
graph
 where
  labelledBlocks :: [(Label, CAFLabel)]
labelledBlocks = (CmmDecl -> [(Label, CAFLabel)])
-> [CmmDecl] -> [(Label, CAFLabel)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmDecl -> [(Label, CAFLabel)]
getLabelledBlocks [CmmDecl]
decls
  labelToBlock :: Map CAFLabel Label
labelToBlock = [(CAFLabel, Label)] -> Map CAFLabel Label
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (((Label, CAFLabel) -> (CAFLabel, Label))
-> [(Label, CAFLabel)] -> [(CAFLabel, Label)]
forall a b. (a -> b) -> [a] -> [b]
map (Label, CAFLabel) -> (CAFLabel, Label)
forall a b. (a, b) -> (b, a)
swap [(Label, CAFLabel)]
labelledBlocks)
  graph :: [SCC (Label, CAFLabel, CAFSet)]
graph = [Node Label (Label, CAFLabel, CAFSet)]
-> [SCC (Label, CAFLabel, CAFSet)]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd
             [ let cafs' :: CAFSet
cafs' = CAFLabel -> CAFSet -> CAFSet
forall a. Ord a => a -> Set a -> Set a
Set.delete CAFLabel
lbl CAFSet
cafs in
               (Label, CAFLabel, CAFSet)
-> Label -> [Label] -> Node Label (Label, CAFLabel, CAFSet)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (Label
l,CAFLabel
lbl,CAFSet
cafs') Label
l
                 ((CAFLabel -> Maybe Label) -> [CAFLabel] -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((CAFLabel -> Map CAFLabel Label -> Maybe Label)
-> Map CAFLabel Label -> CAFLabel -> Maybe Label
forall a b c. (a -> b -> c) -> b -> a -> c
flip CAFLabel -> Map CAFLabel Label -> Maybe Label
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map CAFLabel Label
labelToBlock) (CAFSet -> [CAFLabel]
forall a. Set a -> [a]
Set.toList CAFSet
cafs'))
             | (l :: Label
l, lbl :: CAFLabel
lbl) <- [(Label, CAFLabel)]
labelledBlocks
             , Just cafs :: CAFSet
cafs <- [KeyOf LabelMap -> CAFEnv -> Maybe CAFSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
l CAFEnv
cafEnv] ]


-- | 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 :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, CAFSet)]
getCAFs cafEnv :: CAFEnv
cafEnv decls :: [CmmDecl]
decls =
  [ (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g, CLabel -> CAFLabel
mkCAFLabel CLabel
topLbl, CAFSet
cafs)
  | CmmProc top_info :: CmmTopInfo
top_info topLbl :: CLabel
topLbl _ g :: CmmGraph
g <- [CmmDecl]
decls
  , Just info :: CmmInfoTable
info <- [KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
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 cafs :: CAFSet
cafs <- [KeyOf LabelMap -> CAFEnv -> Maybe CAFSet
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
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] -> [(Label, CLabel)]
getStaticFuns decls :: [CmmDecl]
decls =
  [ (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g, CLabel
lbl)
  | CmmProc top_info :: CmmTopInfo
top_info _ _ g :: CmmGraph
g <- [CmmDecl]
decls
  , Just info :: CmmInfoTable
info <- [KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)]
  , Just (id :: Id
id, _) <- [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)

-- | resolve a CAFLabel to its SRTEntry using the SRTMap
resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF srtMap :: SRTMap
srtMap lbl :: CAFLabel
lbl@(CAFLabel l :: CLabel
l) =
  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 (CLabel -> CLabel
toClosureLbl 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])]
  -> IO (ModuleSRTInfo, [CmmDecl])

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

  -- Ignore the original grouping of decls, and combine all the
  -- CAFEnvs into a single CAFEnv.
  let (cafEnvs :: [CAFEnv]
cafEnvs, declss :: [[CmmDecl]]
declss) = [(CAFEnv, [CmmDecl])] -> ([CAFEnv], [[CmmDecl]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CAFEnv, [CmmDecl])]
tops
      cafEnv :: CAFEnv
cafEnv = [CAFEnv] -> CAFEnv
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions [CAFEnv]
cafEnvs
      decls :: [CmmDecl]
decls = [[CmmDecl]] -> [CmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDecl]]
declss
      staticFuns :: LabelMap CLabel
staticFuns = [(KeyOf LabelMap, CLabel)] -> LabelMap CLabel
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([CmmDecl] -> [(Label, CLabel)]
getStaticFuns [CmmDecl]
decls)

  -- 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 (Label, CAFLabel, CAFSet)]
sccs = CAFEnv -> [CmmDecl] -> [SCC (Label, CAFLabel, CAFSet)]
depAnalSRTs CAFEnv
cafEnv [CmmDecl]
decls
    cafsWithSRTs :: [(Label, CAFLabel, CAFSet)]
cafsWithSRTs = CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, CAFSet)]
getCAFs CAFEnv
cafEnv [CmmDecl]
decls

  -- On each strongly-connected group of decls, construct the SRT
  -- closures and the SRT fields for info tables.
  let result ::
        [ ( [CmmDecl]              -- generated SRTs
          , [(Label, CLabel)]      -- SRT fields for info tables
          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions
          ) ]
      ((result :: [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
result, _srtMap :: SRTMap
_srtMap), moduleSRTInfo' :: ModuleSRTInfo
moduleSRTInfo') =
        UniqSupply
-> UniqSM
     (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
      ModuleSRTInfo)
-> (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])],
     SRTMap),
    ModuleSRTInfo)
forall a. UniqSupply -> UniqSM a -> a
initUs_ UniqSupply
us (UniqSM
   (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
    ModuleSRTInfo)
 -> (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])],
      SRTMap),
     ModuleSRTInfo))
-> UniqSM
     (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
      ModuleSRTInfo)
-> (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])],
     SRTMap),
    ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$
        (StateT
   ModuleSRTInfo
   UniqSM
   ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
 -> ModuleSRTInfo
 -> UniqSM
      (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
       ModuleSRTInfo))
-> ModuleSRTInfo
-> StateT
     ModuleSRTInfo
     UniqSM
     ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
-> UniqSM
     (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
      ModuleSRTInfo)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  ModuleSRTInfo
  UniqSM
  ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
-> ModuleSRTInfo
-> UniqSM
     (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
      ModuleSRTInfo)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ModuleSRTInfo
moduleSRTInfo (StateT
   ModuleSRTInfo
   UniqSM
   ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
 -> UniqSM
      (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
       ModuleSRTInfo))
-> StateT
     ModuleSRTInfo
     UniqSM
     ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
-> UniqSM
     (([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap),
      ModuleSRTInfo)
forall a b. (a -> b) -> a -> b
$
        (StateT
   SRTMap
   (StateT ModuleSRTInfo UniqSM)
   [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
 -> SRTMap
 -> StateT
      ModuleSRTInfo
      UniqSM
      ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap))
-> SRTMap
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> StateT
     ModuleSRTInfo
     UniqSM
     ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  SRTMap
  (StateT ModuleSRTInfo UniqSM)
  [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> SRTMap
-> StateT
     ModuleSRTInfo
     UniqSM
     ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT SRTMap
forall k a. Map k a
Map.empty (StateT
   SRTMap
   (StateT ModuleSRTInfo UniqSM)
   [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
 -> StateT
      ModuleSRTInfo
      UniqSM
      ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap))
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> StateT
     ModuleSRTInfo
     UniqSM
     ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])], SRTMap)
forall a b. (a -> b) -> a -> b
$ do
          [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
nonCAFs <- (SCC (Label, CAFLabel, CAFSet)
 -> StateT
      SRTMap
      (StateT ModuleSRTInfo UniqSM)
      ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])]))
-> [SCC (Label, CAFLabel, CAFSet)]
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DynFlags
-> LabelMap CLabel
-> SCC (Label, CAFLabel, CAFSet)
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
doSCC DynFlags
dflags LabelMap CLabel
staticFuns) [SCC (Label, CAFLabel, CAFSet)]
sccs
          [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
cAFs <- [(Label, CAFLabel, CAFSet)]
-> ((Label, CAFLabel, CAFSet)
    -> StateT
         SRTMap
         (StateT ModuleSRTInfo UniqSM)
         ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])]))
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Label, CAFLabel, CAFSet)]
cafsWithSRTs (((Label, CAFLabel, CAFSet)
  -> StateT
       SRTMap
       (StateT ModuleSRTInfo UniqSM)
       ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])]))
 -> StateT
      SRTMap
      (StateT ModuleSRTInfo UniqSM)
      [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])])
-> ((Label, CAFLabel, CAFSet)
    -> StateT
         SRTMap
         (StateT ModuleSRTInfo UniqSM)
         ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])]))
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
forall a b. (a -> b) -> a -> b
$ \(l :: Label
l, cafLbl :: CAFLabel
cafLbl, cafs :: CAFSet
cafs) ->
            DynFlags
-> LabelMap CLabel
-> [Label]
-> [CAFLabel]
-> Bool
-> CAFSet
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [Label
l] [CAFLabel
cafLbl] Bool
True{-is a CAF-} CAFSet
cafs
          [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
nonCAFs [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
forall a. [a] -> [a] -> [a]
++ [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
cAFs)

      (declss :: [[CmmDecl]]
declss, pairs :: [[(Label, CLabel)]]
pairs, funSRTs :: [[(Label, [SRTEntry])]]
funSRTs) = [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
-> ([[CmmDecl]], [[(Label, CLabel)]], [[(Label, [SRTEntry])]])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 [([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])]
result

  -- 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 ([[(Label, CLabel)]] -> [(Label, CLabel)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, CLabel)]]
pairs)
    funSRTMap :: LabelMap [SRTEntry]
funSRTMap = [(KeyOf LabelMap, [SRTEntry])] -> LabelMap [SRTEntry]
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([[(Label, [SRTEntry])]] -> [(Label, [SRTEntry])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Label, [SRTEntry])]]
funSRTs)
    decls' :: [CmmDecl]
decls' = (CmmDecl -> [CmmDecl]) -> [CmmDecl] -> [CmmDecl]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags
-> LabelMap CLabel -> LabelMap [SRTEntry] -> CmmDecl -> [CmmDecl]
updInfoSRTs DynFlags
dflags LabelMap CLabel
srtFieldMap LabelMap [SRTEntry]
funSRTMap) [CmmDecl]
decls

  (ModuleSRTInfo, [CmmDecl]) -> IO (ModuleSRTInfo, [CmmDecl])
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleSRTInfo
moduleSRTInfo', [[CmmDecl]] -> [CmmDecl]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[CmmDecl]]
declss [CmmDecl] -> [CmmDecl] -> [CmmDecl]
forall a. [a] -> [a] -> [a]
++ [CmmDecl]
decls')


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

doSCC :: DynFlags
-> LabelMap CLabel
-> SCC (Label, CAFLabel, CAFSet)
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
doSCC dflags :: DynFlags
dflags staticFuns :: LabelMap CLabel
staticFuns  (AcyclicSCC (l :: Label
l, cafLbl :: CAFLabel
cafLbl, cafs :: CAFSet
cafs)) =
  DynFlags
-> LabelMap CLabel
-> [Label]
-> [CAFLabel]
-> Bool
-> CAFSet
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
oneSRT DynFlags
dflags LabelMap CLabel
staticFuns [Label
l] [CAFLabel
cafLbl] Bool
False CAFSet
cafs

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


{- Note [recursive SRTs]

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

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

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

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

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

oneSRT :: DynFlags
-> LabelMap CLabel
-> [Label]
-> [CAFLabel]
-> Bool
-> CAFSet
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
oneSRT dflags :: DynFlags
dflags staticFuns :: LabelMap CLabel
staticFuns blockids :: [Label]
blockids lbls :: [CAFLabel]
lbls isCAF :: Bool
isCAF cafs :: CAFSet
cafs = do
  SRTMap
srtMap <- StateT SRTMap (StateT ModuleSRTInfo UniqSM) SRTMap
forall (m :: * -> *) s. Monad m => StateT s m s
get
  ModuleSRTInfo
topSRT <- StateT ModuleSRTInfo UniqSM ModuleSRTInfo
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ModuleSRTInfo
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift StateT ModuleSRTInfo UniqSM ModuleSRTInfo
forall (m :: * -> *) s. Monad m => StateT s m s
get
  let
    -- Can we merge this SRT with a FUN_STATIC closure?
    (maybeFunClosure :: Maybe (CLabel, Label)
maybeFunClosure, otherFunLabels :: [CAFLabel]
otherFunLabels) =
      case [ (CLabel
l,Label
b) | Label
b <- [Label]
blockids, Just l :: CLabel
l <- [KeyOf LabelMap -> LabelMap CLabel -> Maybe CLabel
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
b LabelMap CLabel
staticFuns] ] of
        [] -> (Maybe (CLabel, Label)
forall a. Maybe a
Nothing, [])
        ((l :: CLabel
l,b :: Label
b):xs :: [(CLabel, Label)]
xs) -> ((CLabel, Label) -> Maybe (CLabel, Label)
forall a. a -> Maybe a
Just (CLabel
l,Label
b), ((CLabel, Label) -> CAFLabel) -> [(CLabel, Label)] -> [CAFLabel]
forall a b. (a -> b) -> [a] -> [b]
map (CLabel -> CAFLabel
mkCAFLabel (CLabel -> CAFLabel)
-> ((CLabel, Label) -> CLabel) -> (CLabel, Label) -> CAFLabel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CLabel, Label) -> CLabel
forall a b. (a, b) -> a
fst) [(CLabel, Label)]
xs)

    -- Remove recursive references from the SRT, except for (all but
    -- one of the) static functions. See Note [recursive SRTs].
    nonRec :: CAFSet
nonRec = CAFSet
cafs CAFSet -> CAFSet -> CAFSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference`
      ([CAFLabel] -> CAFSet
forall a. Ord a => [a] -> Set a
Set.fromList [CAFLabel]
lbls CAFSet -> CAFSet -> CAFSet
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` [CAFLabel] -> CAFSet
forall a. Ord a => [a] -> Set a
Set.fromList [CAFLabel]
otherFunLabels)

    -- First resolve all the CAFLabels to SRTEntries
    -- Implements the [Inline] optimisation.
    resolved :: Set SRTEntry
resolved =
       [SRTEntry] -> Set SRTEntry
forall a. Ord a => [a] -> Set a
Set.fromList ([SRTEntry] -> Set SRTEntry) -> [SRTEntry] -> Set SRTEntry
forall a b. (a -> b) -> a -> b
$
       [Maybe SRTEntry] -> [SRTEntry]
forall a. [Maybe a] -> [a]
catMaybes ((CAFLabel -> Maybe SRTEntry) -> [CAFLabel] -> [Maybe SRTEntry]
forall a b. (a -> b) -> [a] -> [b]
map (SRTMap -> CAFLabel -> Maybe SRTEntry
resolveCAF SRTMap
srtMap) (CAFSet -> [CAFLabel]
forall a. Set a -> [a]
Set.toList CAFSet
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 <- Set SRTEntry -> [SRTEntry]
forall a. Set a -> [a]
Set.toList Set SRTEntry
resolved
                        , Just lbls :: 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.
    filtered :: Set SRTEntry
filtered = Set SRTEntry -> Set SRTEntry -> Set SRTEntry
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set SRTEntry
resolved Set SRTEntry
allBelow

  String
-> SDoc
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall b. String -> SDoc -> b -> b
srtTrace "oneSRT:"
     (CAFSet -> SDoc
forall a. Outputable a => a -> SDoc
ppr CAFSet
cafs SDoc -> SDoc -> SDoc
<+> Set SRTEntry -> SDoc
forall a. Outputable a => a -> SDoc
ppr Set SRTEntry
resolved SDoc -> SDoc -> SDoc
<+> Set SRTEntry -> SDoc
forall a. Outputable a => a -> SDoc
ppr Set SRTEntry
allBelow SDoc -> SDoc -> SDoc
<+> Set SRTEntry -> SDoc
forall a. Outputable a => a -> SDoc
ppr Set SRTEntry
filtered) (StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
 -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ())
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  let
    isStaticFun :: Bool
isStaticFun = Maybe (CLabel, Label) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (CLabel, Label)
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 SRTMap (StateT ModuleSRTInfo UniqSM) ()
updateSRTMap srtEntry :: Maybe SRTEntry
srtEntry =
      Bool
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isCAF Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isStaticFun) (StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
 -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ())
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall a b. (a -> b) -> a -> b
$ do
        let newSRTMap :: SRTMap
newSRTMap = [(CAFLabel, Maybe SRTEntry)] -> SRTMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CAFLabel
cafLbl, Maybe SRTEntry
srtEntry) | CAFLabel
cafLbl <- [CAFLabel]
lbls]
        SRTMap -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (SRTMap -> SRTMap -> SRTMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union SRTMap
newSRTMap SRTMap
srtMap)

    this_mod :: Module
this_mod = ModuleSRTInfo -> Module
thisModule ModuleSRTInfo
topSRT

  case Set SRTEntry -> [SRTEntry]
forall a. Set a -> [a]
Set.toList Set SRTEntry
filtered of
    [] -> do
      String
-> SDoc
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall b. String -> SDoc -> b -> b
srtTrace "oneSRT: empty" ([CAFLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CAFLabel]
lbls) (StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
 -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ())
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Maybe SRTEntry -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
updateSRTMap Maybe SRTEntry
forall a. Maybe a
Nothing
      ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [], [])

    -- [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 lbl :: 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 in this case.
        Bool -> Bool
not (DynFlags -> Module -> CLabel -> Bool
labelDynamic DynFlags
dflags Module
this_mod 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
$ DynFlags -> Platform
targetPlatform DynFlags
dflags)
             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, Label)
maybeFunClosure of
          Just (staticFunLbl :: CLabel
staticFunLbl,staticFunBlock :: Label
staticFunBlock) -> ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(Label, CLabel)]
withLabels, [])
            where
              withLabels :: [(Label, CLabel)]
withLabels =
                [ (Label
b, if Label
b Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
staticFunBlock then CLabel
lbl else CLabel
staticFunLbl)
                | Label
b <- [Label]
blockids ]
          Nothing -> do
            Maybe SRTEntry -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
one)
            ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [Label]
blockids, [])

    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 srtLbl :: CLabel
srtLbl)  -> do
          String
-> SDoc
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall b. String -> SDoc -> b -> b
srtTrace "oneSRT [Common]" ([CAFLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CAFLabel]
lbls SDoc -> SDoc -> SDoc
<+> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
srtLbl) (StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
 -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ())
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Maybe SRTEntry -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
updateSRTMap (SRTEntry -> Maybe SRTEntry
forall a. a -> Maybe a
Just SRTEntry
srtEntry)
          ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
srtLbl) [Label]
blockids, [])
        Nothing -> do
          -- No duplicates: we have to build a new SRT object
          String
-> SDoc
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall b. String -> SDoc -> b -> b
srtTrace "oneSRT: new" ([CAFLabel] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CAFLabel]
lbls SDoc -> SDoc -> SDoc
<+> Set SRTEntry -> SDoc
forall a. Outputable a => a -> SDoc
ppr Set SRTEntry
filtered) (StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
 -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ())
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall a b. (a -> b) -> a -> b
$ () -> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (decls :: [CmmDecl]
decls, funSRTs :: [(Label, [SRTEntry])]
funSRTs, srtEntry :: SRTEntry
srtEntry) <-
            case Maybe (CLabel, Label)
maybeFunClosure of
              Just (fun :: CLabel
fun,block :: Label
block) ->
                ([CmmDecl], [(Label, [SRTEntry])], SRTEntry)
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [], [(Label
block, [SRTEntry]
cafList)], CLabel -> SRTEntry
SRTEntry CLabel
fun )
              Nothing -> do
                (decls :: [CmmDecl]
decls, entry :: SRTEntry
entry) <- StateT ModuleSRTInfo UniqSM ([CmmDecl], SRTEntry)
-> StateT
     SRTMap (StateT ModuleSRTInfo UniqSM) ([CmmDecl], SRTEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ModuleSRTInfo UniqSM ([CmmDecl], SRTEntry)
 -> StateT
      SRTMap (StateT ModuleSRTInfo UniqSM) ([CmmDecl], SRTEntry))
-> (UniqSM ([CmmDecl], SRTEntry)
    -> StateT ModuleSRTInfo UniqSM ([CmmDecl], SRTEntry))
-> UniqSM ([CmmDecl], SRTEntry)
-> StateT
     SRTMap (StateT ModuleSRTInfo UniqSM) ([CmmDecl], SRTEntry)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UniqSM ([CmmDecl], SRTEntry)
-> StateT ModuleSRTInfo UniqSM ([CmmDecl], SRTEntry)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (UniqSM ([CmmDecl], SRTEntry)
 -> StateT
      SRTMap (StateT ModuleSRTInfo UniqSM) ([CmmDecl], SRTEntry))
-> UniqSM ([CmmDecl], SRTEntry)
-> StateT
     SRTMap (StateT ModuleSRTInfo UniqSM) ([CmmDecl], SRTEntry)
forall a b. (a -> b) -> a -> b
$ DynFlags -> [SRTEntry] -> UniqSM ([CmmDecl], SRTEntry)
buildSRTChain DynFlags
dflags [SRTEntry]
cafList
                ([CmmDecl], [(Label, [SRTEntry])], SRTEntry)
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, [SRTEntry])], SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDecl]
decls, [], SRTEntry
entry)
          Maybe SRTEntry -> StateT SRTMap (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
              oldFlatSRTs :: Map SRTEntry (Set SRTEntry)
oldFlatSRTs = ModuleSRTInfo -> Map SRTEntry (Set SRTEntry)
flatSRTs ModuleSRTInfo
topSRT
              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 Map SRTEntry (Set SRTEntry)
oldFlatSRTs
              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)
          StateT ModuleSRTInfo UniqSM ()
-> StateT SRTMap (StateT ModuleSRTInfo UniqSM) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ModuleSRTInfo -> StateT ModuleSRTInfo UniqSM ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (ModuleSRTInfo
topSRT { dedupSRTs :: Map (Set SRTEntry) SRTEntry
dedupSRTs = Map (Set SRTEntry) SRTEntry
newDedupSRTs
                            , flatSRTs :: Map SRTEntry (Set SRTEntry)
flatSRTs = Map SRTEntry (Set SRTEntry)
newFlatSRTs }))
          let SRTEntry lbl :: CLabel
lbl = SRTEntry
srtEntry
          ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
-> StateT
     SRTMap
     (StateT ModuleSRTInfo UniqSM)
     ([CmmDecl], [(Label, CLabel)], [(Label, [SRTEntry])])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CmmDecl]
decls, (Label -> (Label, CLabel)) -> [Label] -> [(Label, CLabel)]
forall a b. (a -> b) -> [a] -> [b]
map (,CLabel
lbl) [Label]
blockids, [(Label, [SRTEntry])]
funSRTs)


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


buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)
buildSRT dflags :: DynFlags
dflags refs :: [SRTEntry]
refs = do
  Unique
id <- UniqSM Unique
forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
  let
    lbl :: CLabel
lbl = Unique -> CLabel
mkSRTLabel Unique
id
    srt_n_info :: CLabel
srt_n_info = Int -> CLabel
mkSRTInfoLabel ([SRTEntry] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SRTEntry]
refs)
    fields :: [CmmLit]
fields =
      DynFlags
-> CLabel
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
-> [CmmLit]
mkStaticClosure DynFlags
dflags CLabel
srt_n_info CostCentreStack
dontCareCCS
        [ CLabel -> CmmLit
CmmLabel CLabel
lbl | SRTEntry lbl :: CLabel
lbl <- [SRTEntry]
refs ]
        [] -- no padding
        [DynFlags -> Int -> CmmLit
mkIntCLit DynFlags
dflags 0] -- link field
        [] -- no saved info
  (CmmDecl, SRTEntry) -> UniqSM (CmmDecl, SRTEntry)
forall (m :: * -> *) a. Monad m => a -> m a
return (Section -> CLabel -> [CmmLit] -> CmmDecl
forall info stmt.
Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics 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
  :: DynFlags
  -> LabelMap CLabel               -- SRT labels for each block
  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures
  -> CmmDecl
  -> [CmmDecl]

updInfoSRTs :: DynFlags
-> LabelMap CLabel -> LabelMap [SRTEntry] -> CmmDecl -> [CmmDecl]
updInfoSRTs dflags :: DynFlags
dflags srt_env :: LabelMap CLabel
srt_env funSRTEnv :: LabelMap [SRTEntry]
funSRTEnv (CmmProc top_info :: CmmTopInfo
top_info top_l :: CLabel
top_l live :: [GlobalReg]
live g :: CmmGraph
g)
  | Just (_,closure :: CmmDecl
closure) <- Maybe (CmmInfoTable, CmmDecl)
maybeStaticClosure = [ CmmDecl
proc, CmmDecl
closure ]
  | Bool
otherwise = [ CmmDecl
proc ]
  where
    proc :: CmmDecl
proc = CmmTopInfo -> CLabel -> [GlobalReg] -> CmmGraph -> CmmDecl
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 CmmGraph
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
Label -> CmmInfoTable -> CmmInfoTable
updInfoTbl (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
    updInfoTbl :: Label -> CmmInfoTable -> CmmInfoTable
updInfoTbl l :: Label
l info_tbl :: CmmInfoTable
info_tbl
      | Label
l Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g, Just (inf :: CmmInfoTable
inf, _) <- Maybe (CmmInfoTable, CmmDecl)
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
Label
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, CmmDecl)
    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)
maybeStaticClosure
      | Just info_tbl :: CmmInfoTable
info_tbl@CmmInfoTable{..} <-
           KeyOf LabelMap -> LabelMap CmmInfoTable -> Maybe CmmInfoTable
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g) (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
top_info)
      , Just (id :: Id
id, ccs :: CostCentreStack
ccs) <- Maybe (Id, CostCentreStack)
cit_clo
      , SMRep -> Bool
isStaticRep SMRep
cit_rep =
        let
          (newInfo :: CmmInfoTable
newInfo, srtEntries :: [CmmLit]
srtEntries) = case KeyOf LabelMap -> LabelMap [SRTEntry] -> Maybe [SRTEntry]
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g) LabelMap [SRTEntry]
funSRTEnv of
            Nothing ->
              -- if we don't add SRT entries to this closure, then we
              -- want to set the srt field in its info table as usual
              (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 (CmmGraph -> Label
forall (n :: * -> * -> *). GenCmmGraph n -> Label
g_entry CmmGraph
g) LabelMap CLabel
srt_env }, [])
            Just srtEntries :: [SRTEntry]
srtEntries -> String
-> SDoc -> (CmmInfoTable, [CmmLit]) -> (CmmInfoTable, [CmmLit])
forall b. String -> SDoc -> b -> b
srtTrace "maybeStaticFun" ([CmmLit] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [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 lbl :: CLabel
lbl <- [SRTEntry]
srtEntries ]
          fields :: [CmmLit]
fields = DynFlags
-> CmmInfoTable
-> CostCentreStack
-> CafInfo
-> [CmmLit]
-> [CmmLit]
mkStaticClosureFields DynFlags
dflags CmmInfoTable
info_tbl CostCentreStack
ccs (Id -> CafInfo
idCafInfo Id
id)
            [CmmLit]
srtEntries
          new_rep :: SMRep
new_rep = case SMRep
cit_rep of
             HeapRep sta :: Bool
sta ptrs :: Int
ptrs nptrs :: Int
nptrs ty :: ClosureTypeInfo
ty ->
               Bool -> Int -> Int -> ClosureTypeInfo -> SMRep
HeapRep Bool
sta (Int
ptrs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [CmmLit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmLit]
srtEntries) Int
nptrs ClosureTypeInfo
ty
             _other :: SMRep
_other -> String -> SMRep
forall a. String -> a
panic "maybeStaticFun"
          lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
        in
          (CmmInfoTable, CmmDecl) -> Maybe (CmmInfoTable, CmmDecl)
forall a. a -> Maybe a
Just (CmmInfoTable
newInfo, Section -> CLabel -> [CmmLit] -> CmmDecl
forall info stmt.
Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
fields)
      | Bool
otherwise = Maybe (CmmInfoTable, CmmDecl)
forall a. Maybe a
Nothing

updInfoSRTs _ _ _ t :: CmmDecl
t = [CmmDecl
t]


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