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

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

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

#include "HsVersions.h"
import GHC.Prelude

import GHC.Driver.Ppr     (pprTrace)

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

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

import GHC.Platform
import GHC.Types.Unique.FM
import GHC.Utils.Misc

import GHC.Data.Graph.Directed
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.Maybe

-- DEBUGGING ONLY
--import GHC.Cmm.DebugBlock
--import Debug.Trace
import GHC.Data.List.SetOps (removeDups)

import GHC.Data.OrdList
import Data.List (sortOn, sortBy, nub)
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

{-
  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 = 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)
         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
<+> forall a. Outputable a => a -> SDoc
ppr (forall a. OrdList a -> [a]
fromOL 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) = 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 = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BlockChain -> [BlockId]
chainToBlocks [BlockChain]
chains :: [BlockId]
        ([BlockId]
_blocks, [NonEmpty BlockId]
dups) = forall a. (a -> a -> Ordering) -> [a] -> ([a], [NonEmpty a])
removeDups forall a. Ord a => a -> a -> Ordering
compare [BlockId]
chainBlocks
    in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NonEmpty BlockId]
dups then Bool
True
        else forall a. String -> SDoc -> a -> a
pprTrace String
"Duplicates:" (forall a. Outputable a => a -> SDoc
ppr (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> [a]
toList [NonEmpty BlockId]
dups) SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"chains" SDoc -> SDoc -> 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)
  = forall a. OrdList a -> a
headOL OrdList BlockId
seq forall a. Eq a => a -> a -> Bool
== BlockId
bid

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

chainFromList :: [BlockId] -> BlockChain
chainFromList :: [BlockId] -> BlockChain
chainFromList = OrdList BlockId -> BlockChain
BlockChain forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 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 forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId
blks2)

chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks (BlockChain OrdList BlockId
blks) = 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 forall a. Eq a => a -> a -> Bool
== forall a. [a] -> a
head [BlockId]
rblks)
    = forall a. String -> a
panic String
"Block not in chain"
    | Bool
otherwise
    = (OrdList BlockId -> BlockChain
BlockChain (forall a. [a] -> OrdList a
toOL [BlockId]
lblks),
       OrdList BlockId -> BlockChain
BlockChain (forall a. [a] -> OrdList a
toOL [BlockId]
rblks))
  where
    ([BlockId]
lblks, [BlockId]
rblks) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\BlockId
lbl -> BlockId
lbl forall a. Eq a => a -> a -> Bool
== BlockId
bid) (forall a. OrdList a -> [a]
fromOL OrdList BlockId
blks)

takeR :: Int -> BlockChain -> [BlockId]
takeR :: Int -> BlockChain -> [BlockId]
takeR Int
n (BlockChain OrdList BlockId
blks) =
    forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OrdList a -> [a]
fromOLReverse 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) =
    forall a. Int -> [a] -> [a]
take Int
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. OrdList a -> [a]
fromOL 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 (forall a. Set a
Set.empty)
    where
        --Build maps from chain ends to chains
        endFrontier, startFrontier :: FrontierMap
        endFrontier :: FrontierMap
endFrontier =
            forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
ends ) [BlockChain]
chains
        startFrontier :: FrontierMap
startFrontier =
            forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ 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 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 =
            (forall a. Ord a => [a] -> [a]
ordNub forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ 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) <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
from FrontierMap
chainEnds
            , Just ([BlockId]
c2_f,BlockChain
c2) <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
to FrontierMap
chainFronts
            , BlockChain
c1 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 =
                            forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
b FrontierMap
m :: FrontierMap) FrontierMap
chainFronts ([BlockId]
c2_f forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getFronts BlockChain
c1)
                        entry :: ([BlockId], BlockChain)
entry =
                            ([BlockId]
newChainFrontier,BlockChain
newChain) --let bound to ensure sharing
                    in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
x ([BlockId], BlockChain)
entry FrontierMap
m)
                              FrontierMap
withoutOld [BlockId]
newChainFrontier

                  newEnds :: FrontierMap
newEnds =
                    let withoutOld :: FrontierMap
withoutOld = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
b -> forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
b FrontierMap
m) FrontierMap
chainEnds ([BlockId]
c1_e forall a. [a] -> [a] -> [a]
++ BlockChain -> [BlockId]
getEnds BlockChain
c2)
                        entry :: ([BlockId], BlockChain)
entry = ([BlockId]
newChainEnds,BlockChain
newChain) --let bound to ensure sharing
                    in forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\FrontierMap
m BlockId
x -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
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 (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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
        let addChain :: map (Point s BlockChain)
-> BlockChain -> ST s (map (Point s BlockChain))
addChain map (Point s BlockChain)
m0 BlockChain
chain = do
                Point s BlockChain
ref <- forall a s. a -> ST s (Point s a)
fresh BlockChain
chain
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
chainFoldl (\map (Point s BlockChain)
m' BlockId
b -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
b Point s BlockChain
ref map (Point s BlockChain)
m') map (Point s BlockChain)
m0 BlockChain
chain
        LabelMap (Point s BlockChain)
chainMap' <- 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 -> forall {map :: * -> *} {s}.
(KeyOf map ~ BlockId, IsMap map) =>
map (Point s BlockChain)
-> BlockChain -> ST s (map (Point s BlockChain))
addChain LabelMap (Point s BlockChain)
m0 BlockChain
c) forall (map :: * -> *) a. IsMap map => map a
mapEmpty [BlockChain]
chains
        forall s.
[CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
merge [CfgEdge]
edges LabelMap (Point 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 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
            [BlockChain]
chains' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s a. Point s a -> ST s a
find forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. Eq a => [a] -> [a]
nub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall s a. Point s a -> ST s (Point s a)
repr forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap (Point s BlockChain)
chains)) :: ST s [BlockChain]
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' BlockChain -> BlockChain -> BlockChain
chainConcat (forall a. [a] -> a
head [BlockChain]
chains') (forall a. [a] -> [a]
tail [BlockChain]
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
            Bool
same <- forall s a. Point s a -> Point s a -> ST s Bool
equivalent Point s BlockChain
cFrom Point s BlockChain
cTo
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
same forall a b. (a -> b) -> a -> b
$ do
              BlockChain
cRight <- forall s a. Point s a -> ST s a
find Point s BlockChain
cTo
              BlockChain
cLeft <- forall s a. Point s a -> ST s a
find Point s BlockChain
cFrom
              Point s BlockChain
new_point <- forall a s. a -> ST s (Point s a)
fresh (BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
cLeft BlockChain
cRight)
              forall s a. Point s a -> Point s a -> ST s ()
union Point s BlockChain
cTo Point s BlockChain
new_point
              forall s a. Point s a -> Point s a -> ST s ()
union Point s BlockChain
cFrom Point s BlockChain
new_point
            forall s.
[CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
merge [CfgEdge]
edges LabelMap (Point s BlockChain)
chains
          where
            cFrom :: Point s BlockChain
cFrom = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:from" forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
from LabelMap (Point s BlockChain)
chains
            cTo :: Point s BlockChain
cTo = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"mergeChains:chainMap:to"   forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext forall set. IsSet set => set
setEmpty forall (map :: * -> *) a. IsMap map => map a
mapEmpty forall (map :: * -> *) a. IsMap map => map a
mapEmpty [CfgEdge]
edges 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
        LabelMap BlockChain
ends' <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a b. IsMap map => (a -> b) -> map a -> map b
mapMap 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
x -> Bool -> Bool
not (forall set. IsSet set => ElemOf set -> set -> Bool
setMember BlockId
x LabelSet
placed)) [BlockId]
blocks
            singletons :: [(BlockId, BlockChain)]
singletons = forall a b. (a -> b) -> [a] -> [b]
map (\BlockId
x -> (BlockId
x,BlockId -> BlockChain
chainSingleton BlockId
x)) [BlockId]
unplaced :: [(BlockId,BlockChain)]
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\LabelMap BlockChain
m (BlockId
k,BlockChain
v) -> forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert 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 forall a. Eq a => a -> a -> Bool
== BlockId
to
        -- We skip self edges
        = 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 (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' <- forall a s. a -> ST s (STRef s a)
newSTRef forall a b. (a -> b) -> a -> b
$ [BlockId] -> BlockChain
chainFromList [BlockId
from,BlockId
to]
            forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext
                (forall set. IsSet set => ElemOf set -> set -> set
setInsert BlockId
to (forall set. IsSet set => ElemOf set -> set -> set
setInsert BlockId
from LabelSet
placed))
                (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
from STRef s BlockChain
chain' LabelMap (STRef s BlockChain)
chainStarts)
                (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
to STRef s BlockChain
chain' LabelMap (STRef s BlockChain)
chainEnds)
                [CfgEdge]
todo
                (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 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
        , Just STRef s BlockChain
succChain <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
        , STRef s BlockChain
predChain 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)
          = 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 = (forall set. IsSet set => ElemOf set -> set -> 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
            BlockChain
fromChain <- forall s a. STRef s a -> ST s a
readSTRef STRef s BlockChain
fromRef
            BlockChain
toChain <- 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 <- forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
            let start :: BlockId
start = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL Int
1 BlockChain
newChain
            let end :: BlockId
end = forall a. [a] -> a
head 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
            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
                (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
start STRef s BlockChain
ref forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
to forall a b. (a -> b) -> a -> b
$ LabelMap (STRef s BlockChain)
chainStarts)
                (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
end STRef s BlockChain
ref forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
from forall a b. (a -> b) -> a -> b
$ LabelMap (STRef s BlockChain)
chainEnds)
                [CfgEdge]
todo
                (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 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
from LabelMap (STRef s BlockChain)
chainEnds
          = do
            BlockChain
chain <- 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
            forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s BlockChain
predChain BlockChain
newChain
            let chainEnds' :: LabelMap (STRef s BlockChain)
chainEnds' = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
to STRef s BlockChain
predChain forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
from LabelMap (STRef s BlockChain)
chainEnds
            -- chains <- sequence $ mapMap readSTRef chainStarts
            -- pprTraceM "from chains:" $ ppr chains
            forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext (forall set. IsSet set => ElemOf set -> set -> set
setInsert BlockId
to LabelSet
placed) LabelMap (STRef s BlockChain)
chainStarts LabelMap (STRef s BlockChain)
chainEnds' [CfgEdge]
todo (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 <- forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
to LabelMap (STRef s BlockChain)
chainStarts
          = do
            BlockChain
chain <- 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
            forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s BlockChain
succChain BlockChain
newChain
            let chainStarts' :: LabelMap (STRef s BlockChain)
chainStarts' = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
from STRef s BlockChain
succChain forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete BlockId
to LabelMap (STRef s BlockChain)
chainStarts
            -- chains <- sequence $ mapMap readSTRef chainStarts'
            -- pprTraceM "to chains:" $ ppr chains
            forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext (forall set. IsSet set => ElemOf set -> set -> set
setInsert BlockId
from LabelSet
placed) LabelMap (STRef s BlockChain)
chainStarts' LabelMap (STRef s BlockChain)
chainEnds [CfgEdge]
todo (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 <- forall a s. a -> ST s (STRef s a)
newSTRef BlockChain
newChain
            forall s.
LabelSet
-> LabelMap (STRef s BlockChain)
-> LabelMap (STRef s BlockChain)
-> [CfgEdge]
-> Set (BlockId, BlockId)
-> ST s (LabelMap BlockChain, Set (BlockId, BlockId))
buildNext (forall set. IsSet set => ElemOf set -> set -> set
setInsert BlockId
block LabelSet
placed) (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
block STRef s BlockChain
ref LabelMap (STRef s BlockChain)
chainStarts)
                      (forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
block STRef s BlockChain
ref LabelMap (STRef s BlockChain)
chainEnds) [CfgEdge]
todo (Set (BlockId, BlockId)
linked)
            where
              alreadyPlaced :: BlockId -> Bool
alreadyPlaced BlockId
blkId = (forall set. IsSet set => ElemOf set -> set -> 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map CfgEdge -> Maybe CfgEdge
relevantWeight forall a b. (a -> b) -> a -> b
$ (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.
                = forall a. Maybe a
Nothing
                | forall (map :: * -> *) a. IsMap map => KeyOf map -> map 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
                = forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
wforall a. Fractional a => a -> a -> a
/EdgeWeight
8 })
                | (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
trans_cmmNode = CmmNode O C
exitNode } EdgeWeight
_) <- EdgeInfo
edgeInfo
                , 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
                = forall a. a -> Maybe a
Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
CfgEdge BlockId
from BlockId
to EdgeInfo
edgeInfo { edgeWeight :: EdgeWeight
edgeWeight = EdgeWeight
w forall a. Num a => a -> a -> a
* EdgeWeight
0.96875 })
                | Bool
otherwise
                = 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
            = 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) ->
                        forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert BlockId
lbl GenBasicBlock i
blk LabelMap (GenBasicBlock i)
m)
                     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 (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 =
            forall a. (a -> Bool) -> [a] -> [a]
filter (\CfgEdge
edge -> Bool -> Bool
not (forall a. Ord a => a -> Set a -> Bool
Set.member (CfgEdge -> BlockId
edgeFrom CfgEdge
edge,CfgEdge -> BlockId
edgeTo CfgEdge
edge) Set (BlockId, BlockId)
builtEdges)) 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 (forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap BlockChain
builtChains)


        allEdges :: [CfgEdge]
        allEdges :: [CfgEdge]
allEdges = {-# SCC allEdges #-}
                   forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (CfgEdge -> EdgeWeight
relevantWeight) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. CfgEdge -> Bool
deadEdge) 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 forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId, BlockId)
e Set (BlockId, BlockId)
combined Bool -> Bool -> 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
weightforall a. Fractional a => a -> a -> a
/(EdgeWeight
64.0)
                | Bool
otherwise
                = EdgeWeight
weight
              where
                -- negate to sort descending
                weight :: EdgeWeight
weight = 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]
#if __GLASGOW_HASKELL__ <= 810
            | otherwise = pprPanic "Entry point eliminated" $
                            ppr masterChain
#endif

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

        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
        chainPlaced :: LabelSet
chainPlaced = forall set. IsSet set => [ElemOf set] -> set
setFromList forall a b. (a -> b) -> a -> b
$ [BlockId]
blockList :: LabelSet
        unplaced :: [BlockId]
unplaced =
            let blocks :: [KeyOf LabelMap]
blocks = forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap (GenBasicBlock i)
blockMap
                isPlaced :: BlockId -> Bool
isPlaced BlockId
b = forall set. IsSet set => ElemOf set -> set -> Bool
setMember (BlockId
b) LabelSet
chainPlaced
            in forall a. (a -> Bool) -> [a] -> [a]
filter (\BlockId
block -> Bool -> Bool
not (BlockId -> Bool
isPlaced BlockId
block)) [KeyOf LabelMap]
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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BlockId]
unplaced then [BlockId]
blockList else [BlockId]
blockList forall a. [a] -> [a] -> [a]
++ [BlockId]
unplaced
        getBlock :: BlockId -> GenBasicBlock i
getBlock BlockId
bid = forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"Block placement" forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup BlockId
bid LabelMap (GenBasicBlock i)
blockMap
    in
        --Assert we placed all blocks given as input
        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
        forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info forall a b. (a -> b) -> a -> b
$ 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)
    | Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [i]
ins --This can happen because of shortcutting
    , [BlockId
dest] <- forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr (forall a. [a] -> a
last [i]
ins)
    , ((BasicBlock BlockId
nextLbl [i]
_) : [GenBasicBlock i]
_) <- [GenBasicBlock i]
todo
    , Bool -> Bool
not (forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember BlockId
dest LabelMap a
info)
    , BlockId
nextLbl forall a. Eq a => a -> a -> Bool
== BlockId
dest
    = forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl (forall a. [a] -> [a]
init [i]
ins) forall a. a -> [a] -> [a]
: forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo
    | Bool
otherwise
    = forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [i]
ins forall a. a -> [a] -> [a]
: 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
    -> NatCmmDecl statics instr

sequenceTop :: forall instr statics jumpDest.
Instruction instr =>
NcgImpl statics instr jumpDest
-> Maybe CFG
-> NatCmmDecl statics instr
-> NatCmmDecl statics instr
sequenceTop NcgImpl statics instr jumpDest
_       Maybe CFG
_           top :: NatCmmDecl statics instr
top@(CmmData Section
_ statics
_) = 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))
  = let
      config :: NCGConfig
config     = forall statics instr jumpDest.
NcgImpl statics instr jumpDest -> NCGConfig
ncgConfig NcgImpl statics instr jumpDest
ncgImpl
      platform :: Platform
platform   = NCGConfig -> Platform
ncgPlatform NCGConfig
config

    in forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live forall a b. (a -> b) -> a -> b
$ forall i. [GenBasicBlock i] -> ListGraph i
ListGraph forall a b. (a -> b) -> a -> b
$ forall statics instr jumpDest.
NcgImpl statics instr jumpDest
-> LabelMap RawCmmStatics
-> [NatBasicBlock instr]
-> [NatBasicBlock instr]
ncgMakeFarBranches NcgImpl statics instr jumpDest
ncgImpl LabelMap RawCmmStatics
info forall a b. (a -> b) -> a -> b
$
         if -- Chain based algorithm
            | NCGConfig -> Bool
ncgCfgBlockLayout NCGConfig
config
            , Platform -> Bool
backendMaintainsCfg Platform
platform
            , Just CFG
cfg <- Maybe CFG
edgeWeights
            -> {-# SCC layoutBlocks #-} 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 #-} forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks forall a. Maybe a
Nothing LabelMap RawCmmStatics
info [GenBasicBlock instr]
blocks

            -- Old algorithm with edge weights (if any)
            | Bool
otherwise
            -> {-# SCC layoutBlocks #-} forall inst a.
Instruction inst =>
Maybe CFG
-> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
sequenceBlocks Maybe CFG
edgeWeights LabelMap RawCmmStatics
info [GenBasicBlock instr]
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 = 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 = forall a. [a] -> [a]
reverse
                    (forall a. [SCC a] -> [a]
flattenSCCs (forall instr.
Instruction instr =>
Maybe CFG
-> [NatBasicBlock instr]
-> [SCC (Node BlockId (NatBasicBlock instr))]
sccBlocks Maybe CFG
edgeWeights [GenBasicBlock inst]
blocks))
    in forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
infos forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i t1.
LabelMap i
-> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
seqBlocks LabelMap a
infos forall a b. (a -> b) -> a -> b
$ ( Node BlockId (GenBasicBlock inst)
entryNode 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 =
    forall key payload.
Uniquable key =>
[Node key payload] -> [SCC (Node key payload)]
stronglyConnCompFromEdgedVerticesUniqR
        (forall a b. (a -> b) -> [a] -> [b]
map (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) =
    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 <- 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)]
_)
              | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(BlockId, EdgeInfo)]
successors forall a. Ord a => a -> a -> Bool
> Int
2 Bool -> Bool -> Bool
|| EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info forall a. Ord a => a -> a -> Bool
<= EdgeWeight
0 -> []
              | Bool
otherwise -> [BlockId
target]
          | Bool
otherwise
          = case forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr (forall a. [a] -> a
last [t]
instrs) of
                [BlockId
one] -> [BlockId
one]
                [BlockId]
_many -> []


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 = 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     = forall a b. (a -> b) -> [a] -> [b]
map 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') <- 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 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])
        | forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember BlockId
next LabelMap i
infos
        = GenBasicBlock t1
block 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') <- forall elt.
UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
lookupDeleteUFM UniqFM BlockId (GenBasicBlock t1, [BlockId])
pullable BlockId
next
        = forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [t1]
instrs 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 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)
        = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"seqBlocks" (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
    elt
v <- forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId elt
m BlockId
k
    forall (m :: * -> *) a. Monad m => a -> m a
return (elt
v, forall key elt.
Uniquable key =>
UniqFM key elt -> key -> UniqFM key elt
delFromUFM UniqFM BlockId elt
m BlockId
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