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

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

module BlockLayout
    ( sequenceTop )
where

#include "HsVersions.h"
import GhcPrelude

import Instruction
import NCGMonad
import CFG

import BlockId
import Cmm
import Hoopl.Collections
import Hoopl.Label

import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)
import UniqFM
import Util
import Unique

import Digraph
import Outputable
import Maybes

-- DEBUGGING ONLY
--import Debug
--import Debug.Trace
import ListSetOps (removeDups)

import OrdList
import Data.List
import Data.Foldable (toList)

import qualified Data.Set as Set
import Data.STRef
import Control.Monad.ST.Strict
import Control.Monad (foldM)

{-
  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 likelyhood 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 preceeded 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.

-}


-- | 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)
       = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)
         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
parens (String -> SDoc
text String
"Chain:" SDoc -> SDoc -> SDoc
<+> [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 :: (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 (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 (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 (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty BlockId]
dups) SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"chains" SDoc -> SDoc -> SDoc
<+> [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. [a] -> a
head [BlockId]
rblks)
    = String -> (BlockChain, BlockChain)
forall a. 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 benefical. 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 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 "Neigbours" $
    --   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 =
            [(KeyOf LabelMap, ([BlockId], BlockChain))] -> FrontierMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, ([BlockId], BlockChain))] -> FrontierMap)
-> [(KeyOf LabelMap, ([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 =
            [(KeyOf LabelMap, ([BlockId], BlockChain))] -> FrontierMap
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, ([BlockId], BlockChain))] -> FrontierMap)
-> [(KeyOf LabelMap, ([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 (map :: * -> *) a. IsMap map => map 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) <- KeyOf LabelMap -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from FrontierMap
chainEnds
            , Just ([BlockId]
c2_f,BlockChain
c2) <- KeyOf LabelMap -> FrontierMap -> Maybe ([BlockId], BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> KeyOf LabelMap -> FrontierMap -> FrontierMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> KeyOf LabelMap
-> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> KeyOf LabelMap -> FrontierMap -> FrontierMap
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> KeyOf LabelMap
-> ([BlockId], BlockChain) -> FrontierMap -> FrontierMap
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
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
         where

        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
    = -- pprTrace "combine" (ppr edges) $
      (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 :: map (STRef s BlockChain)
-> BlockChain -> ST s (map (STRef s BlockChain))
addChain map (STRef s BlockChain)
m0 BlockChain
chain = do
                STRef s BlockChain
ref <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
chain
                map (STRef s BlockChain) -> ST s (map (STRef s BlockChain))
forall (m :: * -> *) a. Monad m => a -> m a
return (map (STRef s BlockChain) -> ST s (map (STRef s BlockChain)))
-> map (STRef s BlockChain) -> ST s (map (STRef s BlockChain))
forall a b. (a -> b) -> a -> b
$ (map (STRef s BlockChain) -> BlockId -> map (STRef s BlockChain))
-> map (STRef s BlockChain)
-> BlockChain
-> map (STRef s BlockChain)
forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl (\map (STRef s BlockChain)
m' BlockId
b -> KeyOf map
-> STRef s BlockChain
-> map (STRef s BlockChain)
-> map (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf map
BlockId
b STRef s BlockChain
ref map (STRef s BlockChain)
m') map (STRef s BlockChain)
m0 BlockChain
chain
        LabelMap (STRef s BlockChain)
chainMap' <- (LabelMap (STRef s BlockChain)
 -> BlockChain -> ST s (LabelMap (STRef s BlockChain)))
-> LabelMap (STRef s BlockChain)
-> [BlockChain]
-> ST s (LabelMap (STRef s BlockChain))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\LabelMap (STRef s BlockChain)
m0 BlockChain
c -> LabelMap (STRef s BlockChain)
-> BlockChain -> ST s (LabelMap (STRef s BlockChain))
forall (map :: * -> *) s.
(IsMap map, KeyOf map ~ BlockId) =>
map (STRef s BlockChain)
-> BlockChain -> ST s (map (STRef s BlockChain))
addChain LabelMap (STRef s BlockChain)
m0 BlockChain
c) LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [BlockChain]
chains
        [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
forall s.
[CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
merge [CfgEdge]
edges LabelMap (STRef s BlockChain)
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 map of STRefs, maintaining a invariant of one STRef per chain.
        -- When merging chains we can update the
        -- STRef of one chain once (instead of writing to the map for each block).
        -- We then overwrite the STRefs for the other chain so there is again only
        -- a single STRef for the combined chain.
        -- The difference in terms of allocations saved is ~0.2% with -O so actually
        -- significant compared to using a regular map.

        merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
        merge :: [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
merge [] LabelMap (STRef s BlockChain)
chains = do
            [BlockChain]
chains' <- [BlockChain] -> [BlockChain]
forall a. Ord a => [a] -> [a]
ordNub ([BlockChain] -> [BlockChain])
-> ST s [BlockChain] -> ST s [BlockChain]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((STRef s BlockChain -> ST s BlockChain)
-> [STRef s BlockChain] -> ST s [BlockChain]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef ([STRef s BlockChain] -> ST s [BlockChain])
-> [STRef s BlockChain] -> ST s [BlockChain]
forall a b. (a -> b) -> a -> b
$ LabelMap (STRef s BlockChain) -> [STRef s BlockChain]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap (STRef s BlockChain)
chains) :: ST s [BlockChain]
            BlockChain -> ST s BlockChain
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockChain -> ST s BlockChain) -> BlockChain -> ST s BlockChain
forall a b. (a -> b) -> a -> b
$ (BlockChain -> BlockChain -> BlockChain)
-> BlockChain -> [BlockChain] -> BlockChain
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' BlockChain -> BlockChain -> BlockChain
chainConcat ([BlockChain] -> BlockChain
forall a. [a] -> a
head [BlockChain]
chains') ([BlockChain] -> [BlockChain]
forall a. [a] -> [a]
tail [BlockChain]
chains')
        merge ((CfgEdge BlockId
from BlockId
to EdgeInfo
_):[CfgEdge]
edges) LabelMap (STRef s BlockChain)
chains
        --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False
        --   = undefined
          | STRef s BlockChain
cFrom STRef s BlockChain -> STRef s BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
== STRef s BlockChain
cTo
          = [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
forall s.
[CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
merge [CfgEdge]
edges LabelMap (STRef s BlockChain)
chains
          | Bool
otherwise
          = do
            LabelMap (STRef s BlockChain)
chains' <- STRef s BlockChain
-> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))
mergeComb STRef s BlockChain
cFrom STRef s BlockChain
cTo
            [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
forall s.
[CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
merge [CfgEdge]
edges LabelMap (STRef s BlockChain)
chains'
          where
            mergeComb :: STRef s BlockChain -> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))
            mergeComb :: STRef s BlockChain
-> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))
mergeComb STRef s BlockChain
refFrom STRef s BlockChain
refTo = do
                BlockChain
cRight <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
refTo
                BlockChain
chain <- (BlockChain -> BlockChain -> BlockChain)
-> ST s (BlockChain -> BlockChain -> BlockChain)
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockChain -> BlockChain -> BlockChain
chainConcat ST s (BlockChain -> BlockChain -> BlockChain)
-> ST s BlockChain -> ST s (BlockChain -> BlockChain)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
refFrom ST s (BlockChain -> BlockChain)
-> ST s BlockChain -> ST s BlockChain
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockChain -> ST s BlockChain
forall (f :: * -> *) a. Applicative f => a -> f a
pure BlockChain
cRight
                STRef s BlockChain -> BlockChain -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s BlockChain
refFrom BlockChain
chain
                LabelMap (STRef s BlockChain)
-> ST s (LabelMap (STRef s BlockChain))
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap (STRef s BlockChain)
 -> ST s (LabelMap (STRef s BlockChain)))
-> LabelMap (STRef s BlockChain)
-> ST s (LabelMap (STRef s BlockChain))
forall a b. (a -> b) -> a -> b
$ (LabelMap (STRef s BlockChain)
 -> BlockId -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain)
-> BlockChain
-> LabelMap (STRef s BlockChain)
forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl (\LabelMap (STRef s BlockChain)
m BlockId
b -> KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
b STRef s BlockChain
refFrom LabelMap (STRef s BlockChain)
m) LabelMap (STRef s BlockChain)
chains BlockChain
cRight

            cFrom :: STRef s BlockChain
cFrom = String -> Maybe (STRef s BlockChain) -> STRef s BlockChain
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:from" (Maybe (STRef s BlockChain) -> STRef s BlockChain)
-> Maybe (STRef s BlockChain) -> STRef s BlockChain
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from LabelMap (STRef s BlockChain)
chains
            cTo :: STRef s BlockChain
cTo = String -> Maybe (STRef s BlockChain) -> STRef s BlockChain
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:to"   (Maybe (STRef s BlockChain) -> STRef s BlockChain)
-> Maybe (STRef s BlockChain) -> STRef s BlockChain
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
to   LabelMap (STRef 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, indexd 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
forall set. IsSet set => set
setEmpty LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => map a
mapEmpty LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => map a
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 we 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 :: 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
        LabelMap BlockChain
ends' <- LabelMap (ST s BlockChain) -> ST s (LabelMap BlockChain)
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t 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 (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
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]
unplaced = (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
x -> Bool -> Bool
not (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
x LabelSet
placed)) [BlockId]
blocks
            singletons :: [(BlockId, BlockChain)]
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)]
        (LabelMap BlockChain, Set (BlockId, BlockId))
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
forall (m :: * -> *) a. Monad m => a -> m a
return ((LabelMap BlockChain
 -> (BlockId, BlockChain) -> LabelMap BlockChain)
-> LabelMap BlockChain
-> [(BlockId, BlockChain)]
-> LabelMap BlockChain
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap BlockChain
m (BlockId
k,BlockChain
v) -> KeyOf LabelMap
-> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
k BlockChain
v LabelMap BlockChain
m) LabelMap BlockChain
ends' [(BlockId, BlockChain)]
singletons , Set (BlockId, BlockId)
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)
            STRef s BlockChain
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]
            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
                (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
to (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
from LabelSet
placed))
                (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
from STRef s BlockChain
chain' LabelMap (STRef s BlockChain)
chainStarts)
                (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
to STRef s BlockChain
chain' 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)

        | (BlockId -> Bool
alreadyPlaced BlockId
from) Bool -> Bool -> Bool
&&
          (BlockId -> Bool
alreadyPlaced BlockId
to)
        , Just STRef s BlockChain
predChain <- KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from LabelMap (STRef s BlockChain)
chainEnds
        , Just STRef s BlockChain
succChain <- KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
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.
        = do
            -- pprTraceM "Fusing edge" (ppr edge)
            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)
        =   --pprTraceM "Skipping:" (ppr edge) >>
            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
        = do -- pprTraceM "Finding chain for:" (ppr edge $$
             --         text "placed" <+> ppr placed)
             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 = (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
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
            BlockChain
fromChain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
fromRef
            BlockChain
toChain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
toRef
            let newChain :: BlockChain
newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
fromChain BlockChain
toChain
            STRef s BlockChain
ref <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
            let start :: BlockId
start = [BlockId] -> BlockId
forall a. [a] -> a
head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL Int
1 BlockChain
newChain
            let end :: BlockId
end = [BlockId] -> BlockId
forall a. [a] -> a
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
            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
                (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
start STRef s BlockChain
ref (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
to (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ LabelMap (STRef s BlockChain)
chainStarts)
                (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
end STRef s BlockChain
ref (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from (LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain))
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall a b. (a -> b) -> a -> b
$ 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)


        --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 <- KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from LabelMap (STRef s BlockChain)
chainEnds
          = do
            BlockChain
chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
predChain
            let newChain :: BlockChain
newChain = BlockChain -> BlockId -> BlockChain
chainSnoc BlockChain
chain BlockId
to
            STRef s BlockChain -> BlockChain -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s BlockChain
predChain BlockChain
newChain
            let chainEnds' :: LabelMap (STRef s BlockChain)
chainEnds' = KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
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
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from LabelMap (STRef s BlockChain)
chainEnds
            -- chains <- sequence $ mapMap readSTRef chainStarts
            -- pprTraceM "from chains:" $ ppr chains
            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 (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
to 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)
          -- We can attack it to the front of a chain
          | BlockId -> Bool
alreadyPlaced BlockId
to
          , Just STRef s BlockChain
succChain <- KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> Maybe (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
to LabelMap (STRef s BlockChain)
chainStarts
          = do
            BlockChain
chain <- STRef s BlockChain -> ST s BlockChain
forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
succChain
            let newChain :: BlockChain
newChain = BlockId
from BlockId -> BlockChain -> BlockChain
`chainCons` BlockChain
chain
            STRef s BlockChain -> BlockChain -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s BlockChain
succChain BlockChain
newChain
            let chainStarts' :: LabelMap (STRef s BlockChain)
chainStarts' = KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
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
$ KeyOf LabelMap
-> LabelMap (STRef s BlockChain) -> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
to LabelMap (STRef s BlockChain)
chainStarts
            -- chains <- sequence $ mapMap readSTRef chainStarts'
            -- pprTraceM "to chains:" $ ppr chains
            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 (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
from 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)
          -- 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
            STRef s BlockChain
ref <- BlockChain -> ST s (STRef s BlockChain)
forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
            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 (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
block LabelSet
placed) (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
block STRef s BlockChain
ref LabelMap (STRef s BlockChain)
chainStarts)
                      (KeyOf LabelMap
-> STRef s BlockChain
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
block STRef s BlockChain
ref LabelMap (STRef s BlockChain)
chainEnds) [CfgEdge]
todo (Set (BlockId, BlockId)
linked)
            where
              alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
blkId LabelSet
placed)

-- | Place basic blocks based on the given CFG.
-- See Note [Chain based CFG serialization]
sequenceChain :: forall a i. (Instruction i, Outputable 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 :: 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 weights :: CFG
        weights :: CFG
weights = --pprTrace "cfg'" (pprEdgeWeights cfg')
                  CFG
cfg'
          where
            (LabelMap Double
_, LabelMap (LabelMap Double)
globalEdgeWeights) = {-# SCC mkGlobalWeights #-} HasDebugCallStack =>
BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
mkGlobalWeights BlockId
entry CFG
weights'
            cfg' :: CFG
cfg' = {-# SCC rewriteEdges #-}
                    (CFG -> KeyOf LabelMap -> LabelMap Double -> CFG)
-> CFG -> LabelMap (LabelMap Double) -> CFG
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
                        (\CFG
cfg KeyOf LabelMap
from LabelMap Double
m ->
                            (CFG -> KeyOf LabelMap -> Double -> CFG)
-> CFG -> LabelMap Double -> CFG
forall (map :: * -> *) b a.
IsMap map =>
(b -> KeyOf map -> a -> b) -> b -> map a -> b
mapFoldlWithKey
                                (\CFG
cfg KeyOf LabelMap
to Double
w -> CFG -> EdgeWeight -> BlockId -> BlockId -> CFG
setEdgeWeight CFG
cfg (Double -> EdgeWeight
EdgeWeight Double
w) KeyOf LabelMap
BlockId
from KeyOf LabelMap
BlockId
to )
                                CFG
cfg LabelMap Double
m )
                        CFG
weights'
                        LabelMap (LabelMap Double)
globalEdgeWeights

        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
$ [Maybe CfgEdge] -> [CfgEdge]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe CfgEdge] -> [CfgEdge])
-> ([CfgEdge] -> [Maybe CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CfgEdge -> Maybe CfgEdge) -> [CfgEdge] -> [Maybe CfgEdge]
forall a b. (a -> b) -> [a] -> [b]
map CfgEdge -> Maybe CfgEdge
relevantWeight ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
forall a b. (a -> b) -> a -> b
$ (CFG -> [CfgEdge]
infoEdgeList CFG
weights)
          where
            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
                | KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
to LabelMap a
info
                , EdgeWeight
w <- EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo
                -- The payoff is 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 :: EdgeWeight
edgeWeight = EdgeWeight
wEdgeWeight -> EdgeWeight -> EdgeWeight
forall a. Fractional a => a -> a -> a
/EdgeWeight
8 })
                | Bool
otherwise
                = CfgEdge -> Maybe CfgEdge
forall a. a -> Maybe a
Just CfgEdge
edge

        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 (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) ->
                        KeyOf LabelMap
-> GenBasicBlock i
-> LabelMap (GenBasicBlock i)
-> LabelMap (GenBasicBlock i)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
lbl GenBasicBlock i
blk LabelMap (GenBasicBlock i)
m)
                     LabelMap (GenBasicBlock i)
forall (map :: * -> *) a. IsMap map => map a
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) -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
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)
            = ASSERT(noDups $ mapElems builtChains)
              {-# SCC "groupNeighbourChains" #-}
            --   pprTraceIt "NeighbourChains" $
              [CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
combineNeighbourhood [CfgEdge]
rankedEdges (LabelMap BlockChain -> [BlockChain]
forall (map :: * -> *) a. IsMap map => map 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]
            | Bool
otherwise = String -> SDoc -> [BlockChain]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Entry point eliminated" (SDoc -> [BlockChain]) -> SDoc -> [BlockChain]
forall a b. (a -> b) -> a -> b
$
                            BlockChain -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockChain
masterChain

        blockList :: [BlockId]
blockList
            = ASSERT(noDups [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 = [ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList ([ElemOf LabelSet] -> LabelSet) -> [ElemOf LabelSet] -> LabelSet
forall a b. (a -> b) -> a -> b
$ [ElemOf LabelSet]
[BlockId]
blockList :: LabelSet
        unplaced :: [BlockId]
unplaced =
            let blocks :: [KeyOf LabelMap]
blocks = LabelMap (GenBasicBlock i) -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap (GenBasicBlock i)
blockMap
                isPlaced :: BlockId -> Bool
isPlaced BlockId
b = ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember (ElemOf LabelSet
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)) [KeyOf LabelMap]
[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.
            ASSERT(null unplaced)
            --pprTraceIt "placedBlocks" $
            -- ++ [] is stil kinda expensive
            if [BlockId] -> 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 placment" (Maybe (GenBasicBlock i) -> GenBasicBlock i)
-> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (GenBasicBlock i) -> Maybe (GenBasicBlock i)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap (GenBasicBlock i)
blockMap
    in
        --Assert we placed all blocks given as input
        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
        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 :: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
_    [] = []
dropJumps LabelMap a
info ((BasicBlock BlockId
lbl [i]
ins):[GenBasicBlock i]
todo)
    | Bool -> Bool
not (Bool -> Bool) -> ([i] -> Bool) -> [i] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [i] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([i] -> Bool) -> [i] -> Bool
forall a b. (a -> b) -> a -> b
$ [i]
ins --This can happen because of shortcutting
    , [BlockId
dest] <- i -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr ([i] -> i
forall a. [a] -> a
last [i]
ins)
    , ((BasicBlock BlockId
nextLbl [i]
_) : [GenBasicBlock i]
_) <- [GenBasicBlock i]
todo
    , Bool -> Bool
not (KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
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 ([i] -> [i]
forall a. [a] -> [a]
init [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, Outputable instr)
    => DynFlags -- Determine which layout algo to use
    -> NcgImpl statics instr jumpDest
    -> Maybe CFG -- ^ CFG if we have one.
    -> NatCmmDecl statics instr -- ^ Function to serialize
    -> NatCmmDecl statics instr

sequenceTop :: DynFlags
-> NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
sequenceTop DynFlags
_     NcgImpl statics instr jumpDest
_       Maybe CFG
_           top :: NatCmmDecl statics instr
top@(CmmData Section
_ statics
_) = NatCmmDecl statics instr
top
sequenceTop DynFlags
dflags NcgImpl statics instr jumpDest
ncgImpl Maybe CFG
edgeWeights
            (CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live (ListGraph [GenBasicBlock instr]
blocks))
  | (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_CfgBlocklayout DynFlags
dflags) Bool -> Bool -> Bool
&& DynFlags -> Bool
backendMaintainsCfg DynFlags
dflags
  --Use chain based algorithm
  , Just CFG
cfg <- Maybe CFG
edgeWeights
  = LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live ( [GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ NcgImpl statics instr jumpDest
-> LabelMap CmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> LabelMap CmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches NcgImpl statics instr jumpDest
ncgImpl LabelMap CmmStatics
info ([GenBasicBlock instr] -> [GenBasicBlock instr])
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> a -> b
$
                            {-# SCC layoutBlocks #-}
                            LabelMap CmmStatics
-> CFG -> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a i.
(Instruction i, Outputable i) =>
LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain LabelMap CmmStatics
info CFG
cfg [GenBasicBlock instr]
blocks )
  | Bool
otherwise
  --Use old algorithm
  = let cfg :: Maybe CFG
cfg = if Bool
dontUseCfg then Maybe CFG
forall a. Maybe a
Nothing else Maybe CFG
edgeWeights
    in  LabelMap CmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph instr
-> NatCmmDecl statics instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap CmmStatics
info CLabel
lbl [GlobalReg]
live ( [GenBasicBlock instr] -> ListGraph instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([GenBasicBlock instr] -> ListGraph instr)
-> [GenBasicBlock instr] -> ListGraph instr
forall a b. (a -> b) -> a -> b
$ NcgImpl statics instr jumpDest
-> LabelMap CmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> LabelMap CmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches NcgImpl statics instr jumpDest
ncgImpl LabelMap CmmStatics
info ([GenBasicBlock instr] -> [GenBasicBlock instr])
-> [GenBasicBlock instr] -> [GenBasicBlock instr]
forall a b. (a -> b) -> a -> b
$
                                {-# SCC layoutBlocks #-}
                                Maybe CFG
-> LabelMap CmmStatics
-> [GenBasicBlock instr]
-> [GenBasicBlock instr]
forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
cfg LabelMap CmmStatics
info [GenBasicBlock instr]
blocks)
  where
    dontUseCfg :: Bool
dontUseCfg = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WeightlessBlocklayout DynFlags
dflags Bool -> Bool -> Bool
||
                 (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Bool
backendMaintainsCfg DynFlags
dflags)

-- 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 :: 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 :: 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 :: 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 (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 (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]
          | Bool
otherwise
          = case t -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr ([t] -> t
forall a. [a] -> a
last [t]
instrs) of
                [BlockId
one] -> [BlockId
one]
                [BlockId]
_many -> []


seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
                        -> [GenBasicBlock t1]
seqBlocks :: LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap i
infos [Node BlockId (GenBasicBlock t1)]
blocks = UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (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 (GenBasicBlock t1, [BlockId])
pullable0 = [(BlockId, (GenBasicBlock t1, [BlockId]))]
-> UniqFM (GenBasicBlock t1, [BlockId])
forall key elt. Uniquable key => [(key, elt)] -> UniqFM 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 (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (GenBasicBlock t1, [BlockId])
_ [] = []
    placeNext UniqFM (GenBasicBlock t1, [BlockId])
pullable (BlockId
i:[BlockId]
rest)
        | Just ((GenBasicBlock t1, [BlockId])
block, UniqFM (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
     ((GenBasicBlock t1, [BlockId]),
      UniqFM (GenBasicBlock t1, [BlockId]))
forall key elt.
Uniquable key =>
UniqFM elt -> key -> Maybe (elt, UniqFM elt)
lookupDeleteUFM UniqFM (GenBasicBlock t1, [BlockId])
pullable BlockId
i
        = UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM (GenBasicBlock t1, [BlockId])
pullable' [BlockId]
rest (GenBasicBlock t1, [BlockId])
block
        | Bool
otherwise
        -- We already placed this block, so ignore
        = UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
rest

    place :: UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (GenBasicBlock t1
block,[])
                          = GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
    place UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo (block :: GenBasicBlock t1
block@(BasicBlock BlockId
id [t1]
instrs),[BlockId
next])
        | KeyOf LabelMap -> LabelMap i -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
next LabelMap i
infos
        = GenBasicBlock t1
block GenBasicBlock t1 -> [GenBasicBlock t1] -> [GenBasicBlock t1]
forall a. a -> [a] -> [a]
: UniqFM (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
        | Just ((GenBasicBlock t1, [BlockId])
nextBlock, UniqFM (GenBasicBlock t1, [BlockId])
pullable') <- UniqFM (GenBasicBlock t1, [BlockId])
-> BlockId
-> Maybe
     ((GenBasicBlock t1, [BlockId]),
      UniqFM (GenBasicBlock t1, [BlockId]))
forall key elt.
Uniquable key =>
UniqFM elt -> key -> Maybe (elt, UniqFM elt)
lookupDeleteUFM UniqFM (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 (GenBasicBlock t1, [BlockId])
-> [BlockId] -> (GenBasicBlock t1, [BlockId]) -> [GenBasicBlock t1]
place UniqFM (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 (GenBasicBlock t1, [BlockId])
-> [BlockId] -> [GenBasicBlock t1]
placeNext UniqFM (GenBasicBlock t1, [BlockId])
pullable [BlockId]
todo
    place UniqFM (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 :: Uniquable key => UniqFM elt -> key
                -> Maybe (elt, UniqFM elt)
lookupDeleteUFM :: UniqFM elt -> key -> Maybe (elt, UniqFM elt)
lookupDeleteUFM UniqFM elt
m key
k = do -- Maybe monad
    elt
v <- UniqFM elt -> key -> Maybe elt
forall key elt. Uniquable key => UniqFM elt -> key -> Maybe elt
lookupUFM UniqFM elt
m key
k
    (elt, UniqFM elt) -> Maybe (elt, UniqFM elt)
forall (m :: * -> *) a. Monad m => a -> m a
return (elt
v, UniqFM elt -> key -> UniqFM elt
forall key elt. Uniquable key => UniqFM elt -> key -> UniqFM elt
delFromUFM UniqFM elt
m key
k)