{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

--
-- Copyright (c) 2018 Andreas Klebinger
--

module GHC.CmmToAsm.BlockLayout
    ( sequenceTop, backendMaintainsCfg)
where

import GHC.Prelude hiding (head, init, last, tail)
import qualified GHC.Prelude as Partial (head, tail)

import GHC.Platform

import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.CFG
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Config

import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Label

import GHC.Types.Unique.FM

import GHC.Data.Graph.Directed
import GHC.Data.Maybe
import GHC.Data.List.SetOps (removeDups)
import GHC.Data.OrdList

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc

import Data.List (sortOn, sortBy, nub)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Foldable (toList)
import qualified Data.Set as Set
import Data.STRef
import Control.Monad.ST.Strict
import Control.Monad (foldM, unless)
import GHC.Data.UnionFind
import GHC.Types.Unique.Supply (UniqSM)

{-
  Note [CFG based code layout]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  The major steps in placing blocks are as follow:
  * Compute a CFG based on the Cmm AST, see getCfgProc.
    This CFG will have edge weights representing a guess
    on how important they are.
  * After we convert Cmm to Asm we run `optimizeCFG` which
    adds a few more "educated guesses" to the equation.
  * Then we run loop analysis on the CFG (`loopInfo`) which tells us
    about loop headers, loop nesting levels and the sort.
  * Based on the CFG and loop information refine the edge weights
    in the CFG and normalize them relative to the most often visited
    node. (See `mkGlobalWeights`)
  * Feed this CFG into the block layout code (`sequenceTop`) in this
    module. Which will then produce a code layout based on the input weights.


  Note [Chain based CFG serialization]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  For additional information also look at
  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout

  We have a CFG with edge weights based on which we try to place blocks next to
  each other.

  Edge weights not only represent likelihood of control transfer between blocks
  but also how much a block would benefit from being placed sequentially after
  it's predecessor.
  For example blocks which are preceded by an info table are more likely to end
  up in a different cache line than their predecessor and we can't eliminate the jump
  so there is less benefit to placing them sequentially.

  For example consider this example:

  A:  ...
      jmp cond D (weak successor)
      jmp B
  B:  ...
      jmp C
  C:  ...
      jmp X
  D:  ...
      jmp B (weak successor)

  We determine a block layout by building up chunks (calling them chains) of
  possible control flows for which blocks will be placed sequentially.

  Eg for our example we might end up with two chains like:
  [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.
  However there is no particular order in which chains are placed since
  (hopefully) the blocks for which sequentiality is important have already
  been placed in the same chain.

  -----------------------------------------------------------------------------
     1) First try to create a list of good chains.
  -----------------------------------------------------------------------------

  Good chains are these which allow us to eliminate jump instructions.
  Which further eliminate often executed jumps first.

  We do so by:

  *)  Ignore edges which represent instructions which can not be replaced
      by fall through control flow. Primarily calls and edges to blocks which
      are prefixed by a info table we have to jump across.

  *)  Then process remaining edges in order of frequency taken and:

    +)  If source and target have not been placed build a new chain from them.

    +)  If source and target have been placed, and are ends of differing chains
        try to merge the two chains.

    +)  If one side of the edge is a end/front of a chain, add the other block of
        to edge to the same chain

        Eg if we look at edge (B -> C) and already have the chain (A -> B)
        then we extend the chain to (A -> B -> C).

    +)  If the edge was used to modify or build a new chain remove the edge from
        our working list.

  *) If there any blocks not being placed into a chain after these steps we place
     them into a chain consisting of only this block.

  Ranking edges by their taken frequency, if
  two edges compete for fall through on the same target block, the one taken
  more often will automatically win out. Resulting in fewer instructions being
  executed.

  Creating singleton chains is required for situations where we have code of the
  form:

    A: goto B:
    <infoTable>
    B: goto C:
    <infoTable>
    C: ...

  As the code in block B is only connected to the rest of the program via edges
  which will be ignored in this step we make sure that B still ends up in a chain
  this way.

  -----------------------------------------------------------------------------
     2) We also try to fuse chains.
  -----------------------------------------------------------------------------

  As a result from the above step we still end up with multiple chains which
  represent sequential control flow chunks. But they are not yet suitable for
  code layout as we need to place *all* blocks into a single sequence.

  In this step we combine chains result from the above step via these steps:

  *)  Look at the ranked list of *all* edges, including calls/jumps across info tables
      and the like.

  *)  Look at each edge and

    +) Given an edge (A -> B) try to find two chains for which
      * Block A is at the end of one chain
      * Block B is at the front of the other chain.
    +) If we find such a chain we "fuse" them into a single chain, remove the
       edge from working set and continue.
    +) If we can't find such chains we skip the edge and continue.

  -----------------------------------------------------------------------------
     3) Place indirect successors (neighbours) after each other
  -----------------------------------------------------------------------------

  We might have chains [A,B,C,X],[E] in a CFG of the sort:

    A ---> B ---> C --------> X(exit)
                   \- ->E- -/

  While E does not follow X it's still beneficial to place them near each other.
  This can be advantageous if eg C,X,E will end up in the same cache line.


  Note [Triangle Control Flow]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  Checking if an argument is already evaluated leads to a somewhat
  special case  which looks like this:

    A:
        if (R1 & 7 != 0) goto Leval; else goto Lwork;
    Leval: // global
        call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8;
    Lwork: // global
        ...

        A
        |\
        | Leval
        |/ - (This edge can be missing because of optimizations)
        Lwork

  Once we hit the metal the call instruction is just 2-3 bytes large
  depending on the register used. So we lay out the assembly like this:

        movq %rbx,%rax
        andl $7,%eax
        cmpq $1,%rax
        jne Lwork
    Leval:
        jmp *(%rbx) # encoded in 2-3 bytes.
    <info table>
    Lwork:
        ...

  We could explicitly check for this control flow pattern.

  This is advantageous because:
  * It's optimal if the argument isn't evaluated.
  * If it's evaluated we only have the extra cost of jumping over
    the 2-3 bytes for the call.
  * Guarantees the smaller encoding for the conditional jump.

  However given that Lwork usually has an info table we
  penalize this edge. So Leval should get placed first
  either way and things work out for the best.

  Optimizing for the evaluated case instead would penalize
  the other code path. It adds an jump as we can't fall through
  to Lwork because of the info table.
  Assuming that Lwork is large the chance that the "call" ends up
  in the same cache line is also fairly small.


  Note [Layout relevant edge weights]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  The input to the chain based code layout algorithm is a CFG
  with edges annotated with their frequency. The frequency
  of traversal corresponds quite well to the cost of not placing
  the connected blocks next to each other.

  However even if having the same frequency certain edges are
  inherently more or less relevant to code layout.

  In particular:

  * Edges which cross an info table are less relevant than others.

    If we place the blocks across this edge next to each other
    they are still separated by the info table which negates
    much of the benefit. It makes it less likely both blocks
    will share a cache line reducing the benefits from locality.
    But it also prevents us from eliminating jump instructions.

  * Conditional branches and switches are slightly less relevant.

    We can completely remove unconditional jumps by placing them
    next to each other. This is not true for conditional branch edges.
    We apply a small modifier to them to ensure edges for which we can
    eliminate the overhead completely are considered first. See also #18053.

  * Edges constituted by a call are ignored.

    Considering these hardly helped with performance and ignoring
    them helps quite a bit to improve compiler performance.

  So we perform a preprocessing step where we apply a multiplicator
  to these kinds of edges.

  -}


-- | Look at X number of blocks in two chains to determine
--   if they are "neighbours".
neighbourOverlapp :: Int
neighbourOverlapp :: Int
neighbourOverlapp = Int
2

-- | Maps blocks near the end of a chain to it's chain AND
-- the other blocks near the end.
-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))
-- where [A,B] are blocks in the end region of a chain.
-- This is cheaper then recomputing the ends multiple times.
type FrontierMap = LabelMap ([BlockId],BlockChain)

-- | A non empty ordered sequence of basic blocks.
--   It is suitable for serialization in this order.
--
--   We use OrdList instead of [] to allow fast append on both sides
--   when combining chains.
newtype BlockChain
    = BlockChain { BlockChain -> OrdList BlockId
chainBlocks :: (OrdList BlockId) }

-- All chains are constructed the same way so comparison
-- including structure is faster.
instance Eq BlockChain where
    BlockChain OrdList BlockId
b1 == :: BlockChain -> BlockChain -> Bool
== BlockChain OrdList BlockId
b2 = OrdList BlockId -> OrdList BlockId -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
strictlyEqOL OrdList BlockId
b1 OrdList BlockId
b2

-- Useful for things like sets and debugging purposes, sorts by blocks
-- in the chain.
instance Ord (BlockChain) where
   (BlockChain OrdList BlockId
lbls1) compare :: BlockChain -> BlockChain -> Ordering
`compare` (BlockChain OrdList BlockId
lbls2)
       = Bool -> Ordering -> Ordering
forall a. HasCallStack => Bool -> a -> a
assert (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList BlockId
lbls1 [BlockId] -> [BlockId] -> Bool
forall a. Eq a => a -> a -> Bool
/= OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList OrdList BlockId
lbls2 Bool -> Bool -> Bool
|| OrdList BlockId
lbls1 OrdList BlockId -> OrdList BlockId -> Bool
forall a. Eq a => OrdList a -> OrdList a -> Bool
`strictlyEqOL` OrdList BlockId
lbls2) (Ordering -> Ordering) -> Ordering -> Ordering
forall a b. (a -> b) -> a -> b
$
         OrdList BlockId -> OrdList BlockId -> Ordering
forall a. Ord a => OrdList a -> OrdList a -> Ordering
strictlyOrdOL OrdList BlockId
lbls1 OrdList BlockId
lbls2

instance Outputable (BlockChain) where
    ppr :: BlockChain -> SDoc
ppr (BlockChain OrdList BlockId
blks) =
        SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Chain:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks) )

chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl :: forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl b -> BlockId -> b
f b
z (BlockChain OrdList BlockId
blocks) = (b -> BlockId -> b) -> b -> OrdList BlockId -> b
forall b a. (b -> a -> b) -> b -> OrdList a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' b -> BlockId -> b
f b
z OrdList BlockId
blocks

noDups :: [BlockChain] -> Bool
noDups :: [BlockChain] -> Bool
noDups [BlockChain]
chains =
    let chainBlocks :: [BlockId]
chainBlocks = (BlockChain -> [BlockId]) -> [BlockChain] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BlockChain -> [BlockId]
chainToBlocks [BlockChain]
chains :: [BlockId]
        ([BlockId]
_blocks, [NonEmpty BlockId]
dups) = (BlockId -> BlockId -> Ordering)
-> [BlockId] -> ([BlockId], [NonEmpty BlockId])
forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups BlockId -> BlockId -> Ordering
forall a. Ord a => a -> a -> Ordering
compare [BlockId]
chainBlocks
    in if [NonEmpty BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty BlockId]
dups then Bool
True
        else String -> SDoc -> Bool -> Bool
forall a. String -> SDoc -> a -> a
pprTrace String
"Duplicates:" ([[BlockId]] -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((NonEmpty BlockId -> [BlockId])
-> [NonEmpty BlockId] -> [[BlockId]]
forall a b. (a -> b) -> [a] -> [b]
map NonEmpty BlockId -> [BlockId]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty BlockId]
dups) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"chains" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [BlockChain] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockChain]
chains ) Bool
False

inFront :: BlockId -> BlockChain -> Bool
inFront :: BlockId -> BlockChain -> Bool
inFront BlockId
bid (BlockChain OrdList BlockId
seq)
  = OrdList BlockId -> BlockId
forall a. OrdList a -> a
headOL OrdList BlockId
seq BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid

chainSingleton :: BlockId -> BlockChain
chainSingleton :: BlockId -> BlockChain
chainSingleton BlockId
lbl
    = OrdList BlockId -> BlockChain
BlockChain (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
lbl)

chainFromList :: [BlockId] -> BlockChain
chainFromList :: [BlockId] -> BlockChain
chainFromList = OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId -> BlockChain)
-> ([BlockId] -> OrdList BlockId) -> [BlockId] -> BlockChain
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL

chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc (BlockChain OrdList BlockId
blks) BlockId
lbl
  = OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId
blks OrdList BlockId -> BlockId -> OrdList BlockId
forall a. OrdList a -> a -> OrdList a
`snocOL` BlockId
lbl)

chainCons :: BlockId -> BlockChain -> BlockChain
chainCons :: BlockId -> BlockChain -> BlockChain
chainCons BlockId
lbl (BlockChain OrdList BlockId
blks)
  = OrdList BlockId -> BlockChain
BlockChain (BlockId
lbl BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BlockId
blks)

chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat (BlockChain OrdList BlockId
blks1) (BlockChain OrdList BlockId
blks2)
  = OrdList BlockId -> BlockChain
BlockChain (OrdList BlockId
blks1 OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId
blks2)

chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks (BlockChain OrdList BlockId
blks) = OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL OrdList BlockId
blks

-- | Given the Chain A -> B -> C -> D and we break at C
--   we get the two Chains (A -> B, C -> D) as result.
breakChainAt :: BlockId -> BlockChain
             -> (BlockChain,BlockChain)
breakChainAt :: BlockId -> BlockChain -> (BlockChain, BlockChain)
breakChainAt BlockId
bid (BlockChain OrdList BlockId
blks)
    | Bool -> Bool
not (BlockId
bid BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head [BlockId]
rblks)
    = String -> (BlockChain, BlockChain)
forall a. HasCallStack => String -> a
panic String
"Block not in chain"
    | Bool
otherwise
    = (OrdList BlockId -> BlockChain
BlockChain ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId]
lblks),
       OrdList BlockId -> BlockChain
BlockChain ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId]
rblks))
  where
    ([BlockId]
lblks, [BlockId]
rblks) = (BlockId -> Bool) -> [BlockId] -> ([BlockId], [BlockId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\BlockId
lbl -> BlockId
lbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid) (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL OrdList BlockId
blks)

takeR :: Int -> BlockChain -> [BlockId]
takeR :: Int -> BlockChain -> [BlockId]
takeR Int
n (BlockChain OrdList BlockId
blks) =
    Int -> [BlockId] -> [BlockId]
forall a. Int -> [a] -> [a]
take Int
n ([BlockId] -> [BlockId])
-> (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOLReverse (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks

takeL :: Int -> BlockChain -> [BlockId]
takeL :: Int -> BlockChain -> [BlockId]
takeL Int
n (BlockChain OrdList BlockId
blks) =
    Int -> [BlockId] -> [BlockId]
forall a. Int -> [a] -> [a]
take Int
n ([BlockId] -> [BlockId])
-> (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
blks


-- Note [Combining neighborhood chains]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- See also Note [Chain based CFG serialization]
-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E.
--
-- While placing the latter after the former doesn't result in sequential
-- control flow it is still beneficial. As block C and E might end
-- up in the same cache line.
--
-- So we place these chains next to each other even if we can't fuse them.
--
--   A -> B -> C -> D
--             v
--             - -> E -> F ...
--
-- A simple heuristic to chose which chains we want to combine:
--   * Process edges in descending priority.
--   * Check if there is a edge near the end of one chain which goes
--     to a block near the start of another edge.
--
-- While we could take into account the space between the two blocks which
-- share an edge this blows up compile times quite a bit. It requires
-- us to find all edges between two chains, check the distance for all edges,
-- rank them based on the distance and only then we can select two chains
-- to combine. Which would add a lot of complexity for little gain.
--
-- So instead we just rank by the strength of the edge and use the first pair we
-- find.

-- | For a given list of chains and edges try to combine chains with strong
--   edges between them.
combineNeighbourhood  :: [CfgEdge] -- ^ Edges to consider
                      -> [BlockChain] -- ^ Current chains of blocks
                      -> ([BlockChain], Set.Set (BlockId,BlockId))
                      -- ^ Resulting list of block chains, and a set of edges which
                      -- were used to fuse chains and as such no longer need to be
                      -- considered.
combineNeighbourhood :: [CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
combineNeighbourhood [CfgEdge]
edges [BlockChain]
chains
    = -- pprTraceIt "Neighbours" $
    --   pprTrace "combineNeighbours" (ppr edges) $
      [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
endFrontier FrontierMap
startFrontier (Set (BlockId, BlockId)
forall a. Set a
Set.empty)
    where
        --Build maps from chain ends to chains
        endFrontier, startFrontier :: FrontierMap
        endFrontier :: FrontierMap
endFrontier =
            [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall v. [(BlockId, v)] -> LabelMap v
mapFromList ([(BlockId, ([BlockId], BlockChain))] -> FrontierMap)
-> [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall a b. (a -> b) -> a -> b
$ (BlockChain -> [(BlockId, ([BlockId], BlockChain))])
-> [BlockChain] -> [(BlockId, ([BlockId], BlockChain))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\BlockChain
chain ->
                                let ends :: [BlockId]
ends = BlockChain -> [BlockId]
getEnds BlockChain
chain :: [BlockId]
                                    entry :: ([BlockId], BlockChain)
entry = ([BlockId]
ends,BlockChain
chain)
                                in (BlockId -> (BlockId, ([BlockId], BlockChain)))
-> [BlockId] -> [(BlockId, ([BlockId], BlockChain))]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
ends ) [BlockChain]
chains
        startFrontier :: FrontierMap
startFrontier =
            [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall v. [(BlockId, v)] -> LabelMap v
mapFromList ([(BlockId, ([BlockId], BlockChain))] -> FrontierMap)
-> [(BlockId, ([BlockId], BlockChain))] -> FrontierMap
forall a b. (a -> b) -> a -> b
$ (BlockChain -> [(BlockId, ([BlockId], BlockChain))])
-> [BlockChain] -> [(BlockId, ([BlockId], BlockChain))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\BlockChain
chain ->
                                let front :: [BlockId]
front = BlockChain -> [BlockId]
getFronts BlockChain
chain
                                    entry :: ([BlockId], BlockChain)
entry = ([BlockId]
front,BlockChain
chain)
                                in (BlockId -> (BlockId, ([BlockId], BlockChain)))
-> [BlockId] -> [(BlockId, ([BlockId], BlockChain))]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
front) [BlockChain]
chains
        applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId)
                   -> ([BlockChain], Set.Set (BlockId,BlockId))
        applyEdges :: [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [] FrontierMap
chainEnds FrontierMap
_chainFronts Set (BlockId, BlockId)
combined =
            ([BlockChain] -> [BlockChain]
forall a. Ord a => [a] -> [a]
ordNub ([BlockChain] -> [BlockChain]) -> [BlockChain] -> [BlockChain]
forall a b. (a -> b) -> a -> b
$ (([BlockId], BlockChain) -> BlockChain)
-> [([BlockId], BlockChain)] -> [BlockChain]
forall a b. (a -> b) -> [a] -> [b]
map ([BlockId], BlockChain) -> BlockChain
forall a b. (a, b) -> b
snd ([([BlockId], BlockChain)] -> [BlockChain])
-> [([BlockId], BlockChain)] -> [BlockChain]
forall a b. (a -> b) -> a -> b
$ FrontierMap -> [([BlockId], BlockChain)]
forall a. LabelMap a -> [a]
mapElems FrontierMap
chainEnds, Set (BlockId, BlockId)
combined)
        applyEdges ((CfgEdge BlockId
from BlockId
to EdgeInfo
_w):[CfgEdge]
edges) FrontierMap
chainEnds FrontierMap
chainFronts Set (BlockId, BlockId)
combined
            | Just ([BlockId]
c1_e,BlockChain
c1) <- BlockId -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from FrontierMap
chainEnds
            , Just ([BlockId]
c2_f,BlockChain
c2) <- BlockId -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to FrontierMap
chainFronts
            , BlockChain
c1 BlockChain -> BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockChain
c2 -- Avoid trying to concat a chain with itself.
            = let newChain :: BlockChain
newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
c1 BlockChain
c2
                  newChainFrontier :: [BlockId]
newChainFrontier = BlockChain -> [BlockId]
getFronts BlockChain
newChain
                  newChainEnds :: [BlockId]
newChainEnds = BlockChain -> [BlockId]
getEnds BlockChain
newChain
                  newFronts :: FrontierMap
                  newFronts :: FrontierMap
newFronts =
                    let withoutOld :: FrontierMap
withoutOld =
                            (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> BlockId -> FrontierMap -> FrontierMap
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
b FrontierMap
m :: FrontierMap) FrontierMap
chainFronts ([BlockId]
c2_f [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getFronts BlockChain
c1)
                        entry :: ([BlockId], BlockChain)
entry =
                            ([BlockId]
newChainFrontier,BlockChain
newChain) --let bound to ensure sharing
                    in (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> BlockId -> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
x ([BlockId], BlockChain)
entry FrontierMap
m)
                              FrontierMap
withoutOld [BlockId]
newChainFrontier

                  newEnds :: FrontierMap
newEnds =
                    let withoutOld :: FrontierMap
withoutOld = (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> BlockId -> FrontierMap -> FrontierMap
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
b FrontierMap
m) FrontierMap
chainEnds ([BlockId]
c1_e [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getEnds BlockChain
c2)
                        entry :: ([BlockId], BlockChain)
entry = ([BlockId]
newChainEnds,BlockChain
newChain) --let bound to ensure sharing
                    in (FrontierMap -> BlockId -> FrontierMap)
-> FrontierMap -> [BlockId] -> FrontierMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> BlockId -> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
x ([BlockId], BlockChain)
entry FrontierMap
m)
                              FrontierMap
withoutOld [BlockId]
newChainEnds
              in
                -- pprTrace "ApplyEdges"
                --  (text "before" $$
                --   text "fronts" <+> ppr chainFronts $$
                --   text "ends" <+> ppr chainEnds $$

                --   text "various" $$
                --   text "newChain" <+> ppr newChain $$
                --   text "newChainFrontier" <+> ppr newChainFrontier $$
                --   text "newChainEnds" <+> ppr newChainEnds $$
                --   text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$

                --   text "after" $$
                --   text "fronts" <+> ppr newFronts $$
                --   text "ends" <+> ppr newEnds
                --   )
                 [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
newEnds FrontierMap
newFronts ((BlockId, BlockId)
-> Set (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. Ord a => a -> Set a -> Set a
Set.insert (BlockId
from,BlockId
to) Set (BlockId, BlockId)
combined)
            | Bool
otherwise
            = [CfgEdge]
-> FrontierMap
-> FrontierMap
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId))
applyEdges [CfgEdge]
edges FrontierMap
chainEnds FrontierMap
chainFronts Set (BlockId, BlockId)
combined

        getFronts :: BlockChain -> [BlockId]
getFronts BlockChain
chain = Int -> BlockChain -> [BlockId]
takeL Int
neighbourOverlapp BlockChain
chain
        getEnds :: BlockChain -> [BlockId]
getEnds BlockChain
chain = Int -> BlockChain -> [BlockId]
takeR Int
neighbourOverlapp BlockChain
chain

-- In the last stop we combine all chains into a single one.
-- Trying to place chains with strong edges next to each other.
mergeChains :: [CfgEdge] -> [BlockChain]
            -> (BlockChain)
mergeChains :: [CfgEdge] -> [BlockChain] -> BlockChain
mergeChains [CfgEdge]
edges [BlockChain]
chains
    = (forall s. ST s BlockChain) -> BlockChain
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s BlockChain) -> BlockChain)
-> (forall s. ST s BlockChain) -> BlockChain
forall a b. (a -> b) -> a -> b
$ do
        let addChain :: LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
addChain LabelMap (Point s BlockChain)
m0 BlockChain
chain = do
                ref <- BlockChain -> ST s (Point s BlockChain)
forall a s. a -> ST s (Point s a)
fresh BlockChain
chain
                return $ chainFoldl (\LabelMap (Point s BlockChain)
m' BlockId
b -> BlockId
-> Point s BlockChain
-> LabelMap (Point s BlockChain)
-> LabelMap (Point s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
b Point s BlockChain
ref LabelMap (Point s BlockChain)
m') m0 chain
        chainMap' <- (LabelMap (Point s BlockChain)
 -> BlockChain -> ST s (LabelMap (Point s BlockChain)))
-> LabelMap (Point s BlockChain)
-> [BlockChain]
-> ST s (LabelMap (Point s BlockChain))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\LabelMap (Point s BlockChain)
m0 BlockChain
c -> LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
forall {s}.
LabelMap (Point s BlockChain)
-> BlockChain -> ST s (LabelMap (Point s BlockChain))
addChain LabelMap (Point s BlockChain)
m0 BlockChain
c) LabelMap (Point s BlockChain)
forall v. LabelMap v
mapEmpty [BlockChain]
chains
        merge edges chainMap'
    where
        -- We keep a map from ALL blocks to their respective chain (sigh)
        -- This is required since when looking at an edge we need to find
        -- the associated chains quickly.
        -- We use a union-find data structure to do this efficiently.

        merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
        merge :: forall s.
[CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
merge [] LabelMap (Point s BlockChain)
chains = do
            chains' <- (Point s BlockChain -> ST s BlockChain)
-> [Point s BlockChain] -> ST s [BlockChain]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Point s BlockChain -> ST s BlockChain
forall s a. Point s a -> ST s a
find ([Point s BlockChain] -> ST s [BlockChain])
-> ST s [Point s BlockChain] -> ST s [BlockChain]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ([Point s BlockChain] -> [Point s BlockChain]
forall a. Eq a => [a] -> [a]
nub ([Point s BlockChain] -> [Point s BlockChain])
-> ST s [Point s BlockChain] -> ST s [Point s BlockChain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Point s BlockChain -> ST s (Point s BlockChain))
-> [Point s BlockChain] -> ST s [Point s BlockChain]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Point s BlockChain -> ST s (Point s BlockChain)
forall s a. Point s a -> ST s (Point s a)
repr ([Point s BlockChain] -> ST s [Point s BlockChain])
-> [Point s BlockChain] -> ST s [Point s BlockChain]
forall a b. (a -> b) -> a -> b
$ LabelMap (Point s BlockChain) -> [Point s BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap (Point s BlockChain)
chains)) :: ST s [BlockChain]
            return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains')
        merge ((CfgEdge BlockId
from BlockId
to EdgeInfo
_):[CfgEdge]
edges) LabelMap (Point s BlockChain)
chains
        --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False
        --   = undefined
          = do
            same <- Point s BlockChain -> Point s BlockChain -> ST s Bool
forall s a. Point s a -> Point s a -> ST s Bool
equivalent Point s BlockChain
cFrom Point s BlockChain
cTo
            unless same $ do
              cRight <- find cTo
              cLeft <- find cFrom
              new_point <- fresh (chainConcat cLeft cRight)
              union cTo new_point
              union cFrom new_point
            merge edges chains
          where
            cFrom :: Point s BlockChain
cFrom = String -> Maybe (Point s BlockChain) -> Point s BlockChain
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:from" (Maybe (Point s BlockChain) -> Point s BlockChain)
-> Maybe (Point s BlockChain) -> Point s BlockChain
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (Point s BlockChain)
chains
            cTo :: Point s BlockChain
cTo = String -> Maybe (Point s BlockChain) -> Point s BlockChain
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:to"   (Maybe (Point s BlockChain) -> Point s BlockChain)
-> Maybe (Point s BlockChain) -> Point s BlockChain
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to   LabelMap (Point s BlockChain)
chains


-- See Note [Chain based CFG serialization] for the general idea.
-- This creates and fuses chains at the same time for performance reasons.

-- Try to build chains from a list of edges.
-- Edges must be sorted **descending** by their priority.
-- Returns the constructed chains, along with all edges which
-- are irrelevant past this point, this information doesn't need
-- to be complete - it's only used to speed up the process.
-- An Edge is irrelevant if the ends are part of the same chain.
-- We say these edges are already linked
buildChains :: [CfgEdge] -> [BlockId]
            -> ( LabelMap BlockChain  -- Resulting chains, indexed by end if chain.
               , Set.Set (BlockId, BlockId)) --List of fused edges.
buildChains :: [CfgEdge]
-> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains [CfgEdge]
edges [BlockId]
blocks
  = (forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (LabelMap BlockChain, Set (BlockId, BlockId))
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
 -> (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (forall s. ST s (LabelMap BlockChain, Set (BlockId, BlockId)))
-> (LabelMap BlockChain, Set (BlockId, BlockId))
forall a b. (a -> b) -> a -> b
$ LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
setEmpty LabelMap (STRef s BlockChain)
forall v. LabelMap v
mapEmpty LabelMap (STRef s BlockChain)
forall v. LabelMap v
mapEmpty [CfgEdge]
edges Set (BlockId, BlockId)
forall a. Set a
Set.empty
  where
    -- buildNext builds up chains from edges one at a time.

    -- We keep a map from the ends of chains to the chains.
    -- This way we can easily check if an block should be appended to an
    -- existing chain!
    -- We store them using STRefs so we don't have to rebuild the spine of both
    -- maps every time we update a chain.
    buildNext :: forall s. LabelSet
              -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain.
              -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain.
              -> [CfgEdge] -- Edges to check - ordered by decreasing weight
              -> Set.Set (BlockId, BlockId) -- Used edges
              -> ST s   ( LabelMap BlockChain -- Chains by end
                        , Set.Set (BlockId, BlockId) --List of fused edges
                        )
    buildNext :: forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
_chainStarts LabelMap (STRef s BlockChain)
chainEnds  [] Set (BlockId, BlockId)
linked = do
        ends' <- LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => LabelMap (m a) -> m (LabelMap a)
sequence (LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain))
-> LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain)
forall a b. (a -> b) -> a -> b
$ (STRef s BlockChain -> ST s BlockChain)
-> LabelMap (STRef s BlockChain) -> LabelMap (ST s BlockChain)
forall a v. (a -> v) -> LabelMap a -> LabelMap v
mapMap STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef LabelMap (STRef s BlockChain)
chainEnds :: ST s (LabelMap BlockChain)
        -- Any remaining blocks have to be made to singleton chains.
        -- They might be combined with other chains later on outside this function.
        let unplaced = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
x -> Bool -> Bool
not (BlockId -> LabelSet -> Bool
setMember BlockId
x LabelSet
placed)) [BlockId]
blocks
            singletons = (BlockId -> (BlockId, BlockChain))
-> [BlockId] -> [(BlockId, BlockChain)]
forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,BlockId -> BlockChain
chainSingleton BlockId
x)) [BlockId]
unplaced :: [(BlockId,BlockChain)]
        return (foldl' (\LabelMap BlockChain
m (BlockId
k,BlockChain
v) -> BlockId -> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
k BlockChain
v LabelMap BlockChain
m) ends' singletons , linked)
    buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds (CfgEdge
edge:[CfgEdge]
todo) Set (BlockId, BlockId)
linked
        | BlockId
from BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
to
        -- We skip self edges
        = LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds [CfgEdge]
todo ((BlockId, BlockId)
-> Set (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. Ord a => a -> Set a -> Set a
Set.insert (BlockId
from,BlockId
to) Set (BlockId, BlockId)
linked)
        | Bool -> Bool
not (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
          Bool -> Bool
not (BlockId -> Bool
alreadyPlaced BlockId
to)
        = do
            --pprTraceM "Edge-Chain:" (ppr edge)
            chain' <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef (BlockChain -> ST s (STRef s BlockChain))
-> BlockChain -> ST s (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ [BlockId] -> BlockChain
chainFromList [BlockId
from,BlockId
to]
            buildNext
                (setInsert to (setInsert from placed))
                (mapInsert from chain' chainStarts)
                (mapInsert to chain' chainEnds)
                todo
                (Set.insert (from,to) linked)

        | (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
          (BlockId -> Bool
alreadyPlaced BlockId
to)
        , Just STRef s BlockChain
predChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
        , Just STRef s BlockChain
succChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
        , STRef s BlockChain
predChain STRef s BlockChain -> STRef s BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
/= STRef s BlockChain
succChain -- Otherwise we try to create a cycle.
          = STRef s BlockChain
-> STRef s BlockChain
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
fuseChain STRef s BlockChain
predChain STRef s BlockChain
succChain

        | (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
          (BlockId -> Bool
alreadyPlaced BlockId
to)
          = LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext LabelSet
placed LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds [CfgEdge]
todo Set (BlockId, BlockId)
linked

        | Bool
otherwise
          = ST s (LabelMap BlockChain, Set (BlockId, BlockId))
findChain
      where
        from :: BlockId
from = CfgEdge -> BlockId
edgeFrom CfgEdge
edge
        to :: BlockId
to   = CfgEdge -> BlockId
edgeTo   CfgEdge
edge
        alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (BlockId -> LabelSet -> Bool
setMember BlockId
blkId LabelSet
placed)

        -- Combine two chains into a single one.
        fuseChain :: STRef s BlockChain -> STRef s BlockChain
                  -> ST s   ( LabelMap BlockChain -- Chains by end
                            , Set.Set (BlockId, BlockId) --List of fused edges
                            )
        fuseChain :: STRef s BlockChain
-> STRef s BlockChain
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
fuseChain STRef s BlockChain
fromRef STRef s BlockChain
toRef = do
            fromChain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
fromRef
            toChain <- readSTRef toRef
            let newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
fromChain BlockChain
toChain
            ref <- newSTRef newChain
            let start = [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL Int
1 BlockChain
newChain
            let end = [BlockId] -> BlockId
forall a. HasCallStack => [a] -> a
Partial.head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeR Int
1 BlockChain
newChain
            -- chains <- sequence $ mapMap readSTRef chainStarts
            -- pprTraceM "pre-fuse chains:" $ ppr chains
            buildNext
                placed
                (mapInsert start ref $ mapDelete to $ chainStarts)
                (mapInsert end ref $ mapDelete from $ chainEnds)
                todo
                (Set.insert (from,to) linked)


        --Add the block to a existing chain or creates a new chain
        findChain :: ST s   ( LabelMap BlockChain -- Chains by end
                            , Set.Set (BlockId, BlockId) --List of fused edges
                            )
        findChain :: ST s (LabelMap BlockChain, Set (BlockId, BlockId))
findChain
          -- We can attach the block to the end of a chain
          | BlockId -> Bool
alreadyPlaced BlockId
from
          , Just STRef s BlockChain
predChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
          = do
            chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
predChain
            let newChain = BlockChain -> BlockId -> BlockChain
chainSnoc BlockChain
chain BlockId
to
            writeSTRef predChain newChain
            let chainEnds' = BlockId
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
to STRef s BlockChain
predChain (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
from LabelMap (STRef s BlockChain)
chainEnds
            -- chains <- sequence $ mapMap readSTRef chainStarts
            -- pprTraceM "from chains:" $ ppr chains
            buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked)
          -- We can attack it to the front of a chain
          | BlockId -> Bool
alreadyPlaced BlockId
to
          , Just STRef s BlockChain
succChain <- BlockId
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
          = do
            chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
succChain
            let newChain = BlockId
from BlockId -> BlockChain -> BlockChain
`chainCons` BlockChain
chain
            writeSTRef succChain newChain
            let chainStarts' = BlockId
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
from STRef s BlockChain
succChain (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ BlockId
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall v. BlockId -> LabelMap v -> LabelMap v
mapDelete BlockId
to LabelMap (STRef s BlockChain)
chainStarts
            -- chains <- sequence $ mapMap readSTRef chainStarts'
            -- pprTraceM "to chains:" $ ppr chains
            buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked)
          -- The placed end of the edge is part of a chain already and not an end.
          | Bool
otherwise
          = do
            let block :: BlockId
block    = if BlockId -> Bool
alreadyPlaced BlockId
to then BlockId
from else BlockId
to
            --pprTraceM "Singleton" $ ppr block
            let newChain :: BlockChain
newChain = BlockId -> BlockChain
chainSingleton BlockId
block
            ref <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
            buildNext (setInsert block placed) (mapInsert block ref chainStarts)
                      (mapInsert block ref chainEnds) todo (linked)
            where
              alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (BlockId -> LabelSet -> Bool
setMember BlockId
blkId LabelSet
placed)

-- | Place basic blocks based on the given CFG.
-- See Note [Chain based CFG serialization]
sequenceChain :: forall a i. Instruction i
              => LabelMap a -- ^ Keys indicate an info table on the block.
              -> CFG -- ^ Control flow graph and some meta data.
              -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.
              -> [GenBasicBlock i] -- ^ Blocks placed in sequence.
sequenceChain :: forall a i.
Instruction i =>
LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain LabelMap a
_info CFG
_weights    [] = []
sequenceChain LabelMap a
_info CFG
_weights    [GenBasicBlock i
x] = [GenBasicBlock i
x]
sequenceChain  LabelMap a
info CFG
weights     blocks :: [GenBasicBlock i]
blocks@((BasicBlock BlockId
entry [i]
_):[GenBasicBlock i]
_) =
    let directEdges :: [CfgEdge]
        directEdges :: [CfgEdge]
directEdges = (CfgEdge -> CfgEdge -> Ordering) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((CfgEdge -> CfgEdge -> Ordering) -> CfgEdge -> CfgEdge -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip CfgEdge -> CfgEdge -> Ordering
forall a. Ord a => a -> a -> Ordering
compare) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CfgEdge -> Maybe CfgEdge) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CfgEdge -> Maybe CfgEdge
relevantWeight (CFG -> [CfgEdge]
infoEdgeList CFG
weights)
          where
            -- Apply modifiers to turn edge frequencies into useable weights
            -- for computing code layout.
            -- See also Note [Layout relevant edge weights]
            relevantWeight :: CfgEdge -> Maybe CfgEdge
            relevantWeight :: CfgEdge -> Maybe CfgEdge
relevantWeight edge :: CfgEdge
edge@(CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo)
                | (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmCall {} } EdgeWeight
_) <- EdgeInfo
edgeInfo
                -- Ignore edges across calls.
                = Maybe CfgEdge
forall a. Maybe a
Nothing
                | BlockId -> LabelMap a -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
to LabelMap a
info
                , EdgeWeight
w <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo
                -- The payoff is quite small if we jump over an info table
                = CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight = w/8 })
                | (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmNode O C
exitNode } EdgeWeight
_) <- EdgeInfo
edgeInfo
                , CmmNode O C -> Bool
forall {e :: Extensibility} {x :: Extensibility}.
CmmNode e x -> Bool
cantEliminate CmmNode O C
exitNode
                , EdgeWeight
w <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo
                -- A small penalty to edge types which
                -- we can't optimize away by layout.
                -- w * 0.96875 == w - w/32
                = CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight = w * 0.96875 })
                | Bool
otherwise
                = CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just CfgEdge
edge
                where
                  cantEliminate :: CmmNode e x -> Bool
cantEliminate CmmCondBranch {} = Bool
True
                  cantEliminate CmmSwitch {} = Bool
True
                  cantEliminate CmmNode e x
_ = Bool
False

        blockMap :: LabelMap (GenBasicBlock i)
        blockMap :: LabelMap (GenBasicBlock i)
blockMap
            = (LabelMap (GenBasicBlock i)
 -> GenBasicBlock i -> LabelMap (GenBasicBlock i))
-> LabelMap (GenBasicBlock i)
-> [GenBasicBlock i]
-> LabelMap (GenBasicBlock i)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap (GenBasicBlock i)
m blk :: GenBasicBlock i
blk@(BasicBlock BlockId
lbl [i]
_ins) ->
                        BlockId
-> GenBasicBlock i
-> LabelMap (GenBasicBlock i)
-> LabelMap (GenBasicBlock i)
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
lbl GenBasicBlock i
blk LabelMap (GenBasicBlock i)
m)
                     LabelMap (GenBasicBlock i)
forall v. LabelMap v
mapEmpty [GenBasicBlock i]
blocks

        (LabelMap BlockChain
builtChains, Set (BlockId, BlockId)
builtEdges)
            = {-# SCC "buildChains" #-}
              --pprTraceIt "generatedChains" $
              --pprTrace "blocks" (ppr (mapKeys blockMap)) $
              [CfgEdge]
-> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains [CfgEdge]
directEdges (LabelMap (GenBasicBlock i) -> [BlockId]
forall a. LabelMap a -> [BlockId]
mapKeys LabelMap (GenBasicBlock i)
blockMap)

        rankedEdges :: [CfgEdge]
        -- Sort descending by weight, remove fused edges
        rankedEdges :: [CfgEdge]
rankedEdges =
            (CfgEdge -> Bool) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter (\CfgEdge
edge -> Bool -> Bool
not ((BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (CfgEdge -> BlockId
edgeFrom CfgEdge
edge,CfgEdge -> BlockId
edgeTo CfgEdge
edge) Set (BlockId, BlockId)
builtEdges)) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$
            [CfgEdge]
directEdges

        ([BlockChain]
neighbourChains, Set (BlockId, BlockId)
combined)
            = Bool
-> ([BlockChain], Set (BlockId, BlockId))
-> ([BlockChain], Set (BlockId, BlockId))
forall a. HasCallStack => Bool -> a -> a
assert ([BlockChain] -> Bool
noDups ([BlockChain] -> Bool) -> [BlockChain] -> Bool
forall a b. (a -> b) -> a -> b
$ LabelMap BlockChain -> [BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap BlockChain
builtChains) (([BlockChain], Set (BlockId, BlockId))
 -> ([BlockChain], Set (BlockId, BlockId)))
-> ([BlockChain], Set (BlockId, BlockId))
-> ([BlockChain], Set (BlockId, BlockId))
forall a b. (a -> b) -> a -> b
$
              {-# SCC "groupNeighbourChains" #-}
            --   pprTraceIt "NeighbourChains" $
              [CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
combineNeighbourhood [CfgEdge]
rankedEdges (LabelMap BlockChain -> [BlockChain]
forall a. LabelMap a -> [a]
mapElems LabelMap BlockChain
builtChains)


        allEdges :: [CfgEdge]
        allEdges :: [CfgEdge]
allEdges = {-# SCC allEdges #-}
                   (CfgEdge -> EdgeWeight) -> [CfgEdge] -> [CfgEdge]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (CfgEdge -> EdgeWeight
relevantWeight) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CfgEdge -> Bool) -> [CfgEdge] -> [CfgEdge]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (CfgEdge -> Bool) -> CfgEdge -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgEdge -> Bool
deadEdge) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CFG -> [CfgEdge]
infoEdgeList CFG
weights)
          where
            deadEdge :: CfgEdge -> Bool
            deadEdge :: CfgEdge -> Bool
deadEdge (CfgEdge BlockId
from BlockId
to EdgeInfo
_) = let e :: (BlockId, BlockId)
e = (BlockId
from,BlockId
to) in (BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId, BlockId)
e Set (BlockId, BlockId)
combined Bool -> Bool -> Bool
|| (BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId, BlockId)
e Set (BlockId, BlockId)
builtEdges
            relevantWeight :: CfgEdge -> EdgeWeight
            relevantWeight :: CfgEdge -> EdgeWeight
relevantWeight (CfgEdge BlockId
_ BlockId
_ EdgeInfo
edgeInfo)
                | EdgeInfo (CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmCall {}}) EdgeWeight
_ <- EdgeInfo
edgeInfo
                -- Penalize edges across calls
                = EdgeWeight
weightEdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/(EdgeWeight
64.0)
                | Bool
otherwise
                = EdgeWeight
weight
              where
                -- negate to sort descending
                weight :: EdgeWeight
weight = EdgeWeight -> EdgeWeight
forall a. Num a => a -> a
negate (EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo)

        masterChain :: BlockChain
masterChain =
            {-# SCC "mergeChains" #-}
            -- pprTraceIt "MergedChains" $
            [CfgEdge] -> [BlockChain] -> BlockChain
mergeChains [CfgEdge]
allEdges [BlockChain]
neighbourChains

        --Make sure the first block stays first
        prepedChains :: [BlockChain]
prepedChains
            | BlockId -> BlockChain -> Bool
inFront BlockId
entry BlockChain
masterChain
            = [BlockChain
masterChain]
            | (BlockChain
rest,BlockChain
entry) <- BlockId -> BlockChain -> (BlockChain, BlockChain)
breakChainAt BlockId
entry BlockChain
masterChain
            = [BlockChain
entry,BlockChain
rest]

        blockList :: [BlockId]
blockList
            = Bool -> [BlockId] -> [BlockId]
forall a. HasCallStack => Bool -> a -> a
assert ([BlockChain] -> Bool
noDups [BlockChain
masterChain])
              ((OrdList BlockId -> [BlockId]) -> [OrdList BlockId] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL ([OrdList BlockId] -> [BlockId]) -> [OrdList BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockChain -> OrdList BlockId)
-> [BlockChain] -> [OrdList BlockId]
forall a b. (a -> b) -> [a] -> [b]
map BlockChain -> OrdList BlockId
chainBlocks [BlockChain]
prepedChains)

        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
        chainPlaced :: LabelSet
chainPlaced = [BlockId] -> LabelSet
setFromList ([BlockId] -> LabelSet) -> [BlockId] -> LabelSet
forall a b. (a -> b) -> a -> b
$ [BlockId]
blockList :: LabelSet
        unplaced :: [BlockId]
unplaced =
            let blocks :: [BlockId]
blocks = LabelMap (GenBasicBlock i) -> [BlockId]
forall a. LabelMap a -> [BlockId]
mapKeys LabelMap (GenBasicBlock i)
blockMap
                isPlaced :: BlockId -> Bool
isPlaced BlockId
b = BlockId -> LabelSet -> Bool
setMember (BlockId
b) LabelSet
chainPlaced
            in (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
block -> Bool -> Bool
not (BlockId -> Bool
isPlaced BlockId
block)) [BlockId]
blocks

        placedBlocks :: [BlockId]
placedBlocks =
            -- We want debug builds to catch this as it's a good indicator for
            -- issues with CFG invariants. But we don't want to blow up production
            -- builds if something slips through.
            Bool -> [BlockId] -> [BlockId]
forall a. HasCallStack => Bool -> a -> a
assert ([BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
unplaced) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$
            --pprTraceIt "placedBlocks" $
            -- ++ [] is still kinda expensive
            if [BlockId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
unplaced then [BlockId]
blockList else [BlockId]
blockList [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ [BlockId]
unplaced
        getBlock :: BlockId -> GenBasicBlock i
getBlock BlockId
bid = String -> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Block placement" (Maybe (GenBasicBlock i) -> GenBasicBlock i)
-> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a b. (a -> b) -> a -> b
$ BlockId -> LabelMap (GenBasicBlock i) -> Maybe (GenBasicBlock i)
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
bid LabelMap (GenBasicBlock i)
blockMap
    in
        --Assert we placed all blocks given as input
        Bool -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. HasCallStack => Bool -> a -> a
assert ((BlockId -> Bool) -> [BlockId] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\BlockId
bid -> BlockId -> LabelMap (GenBasicBlock i) -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
bid LabelMap (GenBasicBlock i)
blockMap) [BlockId]
placedBlocks) ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$
        LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$ (BlockId -> GenBasicBlock i) -> [BlockId] -> [GenBasicBlock i]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> GenBasicBlock i
getBlock [BlockId]
placedBlocks

{-# SCC dropJumps #-}
-- | Remove redundant jumps between blocks when we can rely on
-- fall through.
dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
          -> [GenBasicBlock i]
dropJumps :: forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
_    [] = []
dropJumps LabelMap a
info (BasicBlock BlockId
lbl [i]
ins:[GenBasicBlock i]
todo)
    | Just NonEmpty i
ins <- [i] -> Maybe (NonEmpty i)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [i]
ins --This can happen because of shortcutting
    , [BlockId
dest] <- i -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr (NonEmpty i -> i
forall a. NonEmpty a -> a
NE.last NonEmpty i
ins)
    , BasicBlock BlockId
nextLbl [i]
_ : [GenBasicBlock i]
_ <- [GenBasicBlock i]
todo
    , Bool -> Bool
not (BlockId -> LabelMap a -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
dest LabelMap a
info)
    , BlockId
nextLbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
dest
    = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl (NonEmpty i -> [i]
forall a. NonEmpty a -> [a]
NE.init NonEmpty i
ins) GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo
    | Bool
otherwise
    = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [i]
ins GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo


-- -----------------------------------------------------------------------------
-- Sequencing the basic blocks

-- Cmm BasicBlocks are self-contained entities: they always end in a
-- jump, either non-local or to another basic block in the same proc.
-- In this phase, we attempt to place the basic blocks in a sequence
-- such that as many of the local jumps as possible turn into
-- fallthroughs.

sequenceTop
    :: Instruction instr
    => NcgImpl statics instr jumpDest
    -> Maybe CFG -- ^ CFG if we have one.
    -> NatCmmDecl statics instr -- ^ Function to serialize
    -> UniqSM (NatCmmDecl statics instr)

sequenceTop :: forall instr statics jumpDest.
Instruction instr =>
NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> UniqSM (NatCmmDecl statics instr)
sequenceTop NcgImpl statics instr jumpDest
_       Maybe CFG
_           top :: NatCmmDecl statics instr
top@(CmmData Section
_ statics
_) = NatCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr)
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NatCmmDecl statics instr
top
sequenceTop NcgImpl statics instr jumpDest
ncgImpl Maybe CFG
edgeWeights (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live (ListGraph [GenBasicBlock instr]
blocks)) = do
    let config :: NCGConfig
config     = NcgImpl statics instr jumpDest -> NCGConfig
forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NCGConfig
ncgConfig NcgImpl statics instr jumpDest
ncgImpl
        platform :: Platform
platform   = NCGConfig -> Platform
ncgPlatform NCGConfig
config

        seq_blocks :: [GenBasicBlock instr]
seq_blocks =
                  if -- Chain based algorithm
                      | NCGConfig -> Bool
ncgCfgBlockLayout NCGConfig
config
                      , Platform -> Bool
backendMaintainsCfg Platform
platform
                      , Just CFG
cfg <- Maybe CFG
edgeWeights
                      -> {-# SCC layoutBlocks #-} LabelMap RawCmmStatics
-> CFG -> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a i.
Instruction i =>
LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain LabelMap RawCmmStatics
info CFG
cfg [GenBasicBlock instr]
blocks

                      -- Old algorithm without edge weights
                      | NCGConfig -> Bool
ncgCfgWeightlessLayout NCGConfig
config
                        Bool -> Bool -> Bool
|| Bool -> Bool
not (Platform -> Bool
backendMaintainsCfg Platform
platform)
                      -> {-# SCC layoutBlocks #-} Maybe CFG
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
forall a. Maybe a
Nothing LabelMap RawCmmStatics
info [GenBasicBlock instr]
blocks

                      -- Old algorithm with edge weights (if any)
                      | Bool
otherwise
                      -> {-# SCC layoutBlocks #-} Maybe CFG
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
edgeWeights LabelMap RawCmmStatics
info [GenBasicBlock instr]
blocks

    far_blocks <- (NcgImpl statics instr jumpDest
-> Platform
-> LabelMap RawCmmStatics
-> [GenBasicBlock instr]
-> UniqSM [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> UniqSM [NatBasicBlock instr]
ncgMakeFarBranches NcgImpl statics instr jumpDest
ncgImpl) Platform
platform LabelMap RawCmmStatics
info [GenBasicBlock instr]
seq_blocks
    pure $ CmmProc info lbl live $ ListGraph far_blocks


-- The old algorithm:
-- It is very simple (and stupid): We make a graph out of
-- the blocks where there is an edge from one block to another iff the
-- first block ends by jumping to the second.  Then we topologically
-- sort this graph.  Then traverse the list: for each block, we first
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.

-- FYI, the classic layout for basic blocks uses postorder DFS; this
-- algorithm is implemented in Hoopl.

sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
               -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks :: forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
_edgeWeight LabelMap a
_ [] = []
sequenceBlocks Maybe CFG
edgeWeights LabelMap a
infos (GenBasicBlock inst
entry:[GenBasicBlock inst]
blocks) =
    let entryNode :: Node BlockId (GenBasicBlock inst)
entryNode = Maybe CFG
-> GenBasicBlock inst -> Node BlockId (GenBasicBlock inst)
forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights GenBasicBlock inst
entry
        bodyNodes :: [Node BlockId (GenBasicBlock inst)]
bodyNodes = [Node BlockId (GenBasicBlock inst)]
-> [Node BlockId (GenBasicBlock inst)]
forall a. [a] -> [a]
reverse
                    ([SCC (Node BlockId (GenBasicBlock inst))]
-> [Node BlockId (GenBasicBlock inst)]
forall a. [SCC a] -> [a]
flattenSCCs (Maybe CFG
-> [GenBasicBlock inst]
-> [SCC (Node BlockId (GenBasicBlock inst))]
forall instr.
Instruction instr =>
Maybe CFG
-> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks Maybe CFG
edgeWeights [GenBasicBlock inst]
blocks))
    in LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
infos ([GenBasicBlock inst] -> [GenBasicBlock inst])
-> ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
-> [Node BlockId (GenBasicBlock inst)]
-> [GenBasicBlock inst]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LabelMap a
-> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
forall i t1.
LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap a
infos ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
-> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
forall a b. (a -> b) -> a -> b
$ ( Node BlockId (GenBasicBlock inst)
entryNode Node BlockId (GenBasicBlock inst)
-> [Node BlockId (GenBasicBlock inst)]
-> [Node BlockId (GenBasicBlock inst)]
forall a. a -> [a] -> [a]
: [Node BlockId (GenBasicBlock inst)]
bodyNodes)
  -- the first block is the entry point ==> it must remain at the start.

sccBlocks
        :: Instruction instr
        => Maybe CFG -> [NatBasicBlock instr]
        -> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks :: forall instr.
Instruction instr =>
Maybe CFG
-> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks Maybe CFG
edgeWeights [NatBasicBlock instr]
blocks =
    [Node BlockId (NatBasicBlock instr)]
-> [SCC (Node BlockId (NatBasicBlock instr))]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR
        ((NatBasicBlock instr -> Node BlockId (NatBasicBlock instr))
-> [NatBasicBlock instr] -> [Node BlockId (NatBasicBlock instr)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe CFG
-> NatBasicBlock instr -> Node BlockId (NatBasicBlock instr)
forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights) [NatBasicBlock instr]
blocks)

mkNode :: (Instruction t)
       => Maybe CFG -> GenBasicBlock t
       -> Node BlockId (GenBasicBlock t)
mkNode :: forall t.
Instruction t =>
Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode Maybe CFG
edgeWeights block :: GenBasicBlock t
block@(BasicBlock BlockId
id [t]
instrs) =
    GenBasicBlock t
-> BlockId -> [BlockId] -> Node BlockId (GenBasicBlock t)
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode GenBasicBlock t
block BlockId
id [BlockId]
outEdges
  where
    outEdges :: [BlockId]
    outEdges :: [BlockId]
outEdges
      --Select the heaviest successor, ignore weights <= zero
      = [BlockId]
successor
      where
        successor :: [BlockId]
successor
          | Just [(BlockId, EdgeInfo)]
successors <- (CFG -> [(BlockId, EdgeInfo)])
-> Maybe CFG -> Maybe [(BlockId, EdgeInfo)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CFG -> BlockId -> [(BlockId, EdgeInfo)]
`getSuccEdgesSorted` BlockId
id)
                                    Maybe CFG
edgeWeights -- :: Maybe [(Label, EdgeInfo)]
          = case [(BlockId, EdgeInfo)]
successors of
            [] -> []
            ((BlockId
target,EdgeInfo
info):[(BlockId, EdgeInfo)]
_)
              | [(BlockId, EdgeInfo)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(BlockId, EdgeInfo)]
successors Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
|| EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= EdgeWeight
0 -> []
              | Bool
otherwise -> [BlockId
target]
          | Just t
instr <- [t] -> Maybe t
forall a. [a] -> Maybe a
lastMaybe [t]
instrs
          , [BlockId
one] <- t -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr t
instr
          = [BlockId
one]
          | Bool
otherwise = []


seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
                        -> [GenBasicBlock t1]
seqBlocks :: forall i t1.
LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap i
infos [Node BlockId (GenBasicBlock t1)]
blocks = UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable0 [BlockId]
todo0
  where
    -- pullable: Blocks that are not yet placed
    -- todo:     Original order of blocks, to be followed if we have no good
    --           reason not to;
    --           may include blocks that have already been placed, but then
    --           these are not in pullable
    pullable0 :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable0 = [(BlockId, (GenBasicBlock t1, [BlockId]))]
-> UniqFM BlockId (GenBasicBlock t1, [BlockId])
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (BlockId
i,(GenBasicBlock t1
b,[BlockId]
n)) | DigraphNode GenBasicBlock t1
b BlockId
i [BlockId]
n <- [Node BlockId (GenBasicBlock t1)]
blocks ]
    todo0 :: [BlockId]
todo0     = (Node BlockId (GenBasicBlock t1) -> BlockId)
-> [Node BlockId (GenBasicBlock t1)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map Node BlockId (GenBasicBlock t1) -> BlockId
forall key payload. Node key payload -> key
node_key [Node BlockId (GenBasicBlock t1)]
blocks

    placeNext :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
_ [] = []
    placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable (BlockId
i:[BlockId]
rest)
        | Just ((GenBasicBlock t1, [BlockId])
block, UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
     ((GenBasicBlock t1, [BlockId]),
      UniqFM BlockId (GenBasicBlock t1, [BlockId]))
forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable BlockId
i
        = UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable' [BlockId]
rest (GenBasicBlock t1, [BlockId])
block
        | Bool
otherwise
        -- We already placed this block, so ignore
        = UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
rest

    place :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (GenBasicBlock t1
block,[])
                          = GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
    place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (block :: GenBasicBlock t1
block@(BasicBlock BlockId
id [t1]
instrs),[BlockId
next])
        | BlockId -> LabelMap i -> Bool
forall a. BlockId -> LabelMap a -> Bool
mapMember BlockId
next LabelMap i
infos
        = GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
        | Just ((GenBasicBlock t1, [BlockId])
nextBlock, UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
     ((GenBasicBlock t1, [BlockId]),
      UniqFM BlockId (GenBasicBlock t1, [BlockId]))
forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable BlockId
next
        = BlockId -> [t1] -> GenBasicBlock t1
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [t1]
instrs GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable' [BlockId]
todo (GenBasicBlock t1, [BlockId])
nextBlock
        | Bool
otherwise
        = GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM BlockId (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
    place UniqFM BlockId (GenBasicBlock t1, [BlockId])
_ [BlockId]
_ (GenBasicBlock t1
_,[BlockId]
tooManyNextNodes)
        = String -> SDoc -> [GenBasicBlock t1]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"seqBlocks" ([BlockId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [BlockId]
tooManyNextNodes)


lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
                -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM :: forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId elt
m BlockId
k = do -- Maybe monad
    v <- UniqFM BlockId elt -> BlockId -> Maybe elt
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId elt
m BlockId
k
    return (v, delFromUFM m k)

backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg :: Platform -> Bool
backendMaintainsCfg Platform
platform = case Platform -> Arch
platformArch Platform
platform of
    -- ArchX86 -- Should work but not tested so disabled currently.
    Arch
ArchX86_64 -> Bool
True
    Arch
_otherwise -> Bool
False