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

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

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

    #include "HsVersions.h"
    import GHC.Prelude

    import GHC.CmmToAsm.Instr
    import GHC.CmmToAsm.Monad
    import GHC.CmmToAsm.CFG

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

    import GHC.Platform
    import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
    import GHC.Types.Unique.FM
    import GHC.Utils.Misc

    import GHC.Data.Graph.Directed
    import GHC.Utils.Outputable
    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 = 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 :: forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
    chainFoldl b -> BlockId -> b
    f b
    z (BlockChain OrdList BlockId
    blocks) = (b -> BlockId -> b) -> b -> OrdList BlockId -> b
    forall (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 beneficial. As block C and E might end
    -- up in the same cache line.
    --
    -- So we place these chains next to each other even if we can't fuse them.
    --
    --   A -> B -> C -> D
    --             v
    --             - -> E -> F ...
    --
    -- A simple heuristic to chose which chains we want to combine:
    --   * Process edges in descending priority.
    --   * Check if there is a edge near the end of one chain which goes
    --     to a block near the start of another edge.
    --
    -- While we could take into account the space between the two blocks which
    -- share an edge this blows up compile times quite a bit. It requires
    -- us to find all edges between two chains, check the distance for all edges,
    -- rank them based on the distance and only then we can select two chains
    -- to combine. Which would add a lot of complexity for little gain.
    --
    -- So instead we just rank by the strength of the edge and use the first pair we
    -- find.

    -- | For a given list of chains and edges try to combine chains with strong
    --   edges between them.
    combineNeighbourhood  :: [CfgEdge] -- ^ Edges to consider
                          -> [BlockChain] -- ^ Current chains of blocks
                          -> ([BlockChain], Set.Set (BlockId,BlockId))
                          -- ^ Resulting list of block chains, and a set of edges which
                          -- were used to fuse chains and as such no longer need to be
                          -- considered.
    combineNeighbourhood :: [CfgEdge] -> [BlockChain] -> ([BlockChain], Set (BlockId, BlockId))
    combineNeighbourhood [CfgEdge]
    edges [BlockChain]
    chains
        = -- pprTraceIt "Neighbours" $
        --   pprTrace "combineNeighbours" (ppr edges) $
          [CfgEdge]
    -> FrontierMap
    -> FrontierMap
    -> Set (BlockId, BlockId)
    -> ([BlockChain], Set (BlockId, BlockId))
    applyEdges [CfgEdge]
    edges FrontierMap
    endFrontier FrontierMap
    startFrontier (Set (BlockId, BlockId)
    forall a. Set a
    Set.empty)
        where
            --Build maps from chain ends to chains
            endFrontier, startFrontier :: FrontierMap
            endFrontier :: FrontierMap
    endFrontier =
                [(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
        = (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 (Point s BlockChain)
    -> BlockChain -> ST s (map (Point s BlockChain))
    addChain map (Point s BlockChain)
    m0 BlockChain
    chain = do
                    Point s BlockChain
    ref <- BlockChain -> ST s (Point s BlockChain)
    forall a s. a -> ST s (Point s a)
    fresh BlockChain
    chain
                    map (Point s BlockChain) -> ST s (map (Point s BlockChain))
    forall (m :: * -> *) a. Monad m => a -> m a
    return (map (Point s BlockChain) -> ST s (map (Point s BlockChain)))
    -> map (Point s BlockChain) -> ST s (map (Point s BlockChain))
    forall a b. (a -> b) -> a -> b
    $ (map (Point s BlockChain) -> BlockId -> map (Point s BlockChain))
    -> map (Point s BlockChain)
    -> BlockChain
    -> map (Point s BlockChain)
    forall b. (b -> BlockId -> b) -> b -> BlockChain -> b
    chainFoldl (\map (Point s BlockChain)
    m' BlockId
    b -> KeyOf map
    -> Point s BlockChain
    -> map (Point s BlockChain)
    -> map (Point s BlockChain)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> a -> map a -> map a
    mapInsert KeyOf map
    BlockId
    b Point s BlockChain
    ref map (Point s BlockChain)
    m') map (Point s BlockChain)
    m0 BlockChain
    chain
            LabelMap (Point s BlockChain)
    chainMap' <- (LabelMap (Point s BlockChain)
     -> BlockChain -> ST s (LabelMap (Point s BlockChain)))
    -> LabelMap (Point s BlockChain)
    -> [BlockChain]
    -> ST s (LabelMap (Point s BlockChain))
    forall (t :: * -> *) (m :: * -> *) b a.
    (Foldable t, Monad m) =>
    (b -> a -> m b) -> b -> t a -> m b
    foldM (\LabelMap (Point s BlockChain)
    m0 BlockChain
    c -> LabelMap (Point s BlockChain)
    -> BlockChain -> ST s (LabelMap (Point s BlockChain))
    forall {map :: * -> *} {s}.
    (IsMap map, KeyOf map ~ BlockId) =>
    map (Point s BlockChain)
    -> BlockChain -> ST s (map (Point s BlockChain))
    addChain LabelMap (Point s BlockChain)
    m0 BlockChain
    c) LabelMap (Point s BlockChain)
    forall (map :: * -> *) a. IsMap map => map a
    mapEmpty [BlockChain]
    chains
            [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
    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' <- (Point s BlockChain -> ST s BlockChain)
    -> [Point s BlockChain] -> ST s [BlockChain]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Point s BlockChain -> ST s BlockChain
    forall s a. Point s a -> ST s a
    find ([Point s BlockChain] -> ST s [BlockChain])
    -> ST s [Point s BlockChain] -> ST s [BlockChain]
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< ([Point s BlockChain] -> [Point s BlockChain]
    forall a. Eq a => [a] -> [a]
    nub ([Point s BlockChain] -> [Point s BlockChain])
    -> ST s [Point s BlockChain] -> ST s [Point s BlockChain]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> ((Point s BlockChain -> ST s (Point s BlockChain))
    -> [Point s BlockChain] -> ST s [Point s BlockChain]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Point s BlockChain -> ST s (Point s BlockChain)
    forall s a. Point s a -> ST s (Point s a)
    repr ([Point s BlockChain] -> ST s [Point s BlockChain])
    -> [Point s BlockChain] -> ST s [Point s BlockChain]
    forall a b. (a -> b) -> a -> b
    $ LabelMap (Point s BlockChain) -> [Point s BlockChain]
    forall (map :: * -> *) a. IsMap map => map a -> [a]
    mapElems LabelMap (Point 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 (Point s BlockChain)
    chains
            --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False
            --   = undefined
              = do
                Bool
    same <- Point s BlockChain -> Point s BlockChain -> ST s Bool
    forall s a. Point s a -> Point s a -> ST s Bool
    equivalent Point s BlockChain
    cFrom Point s BlockChain
    cTo
                Bool -> ST s () -> ST s ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless Bool
    same (ST s () -> ST s ()) -> ST s () -> ST s ()
    forall a b. (a -> b) -> a -> b
    $ do
                  BlockChain
    cRight <- Point s BlockChain -> ST s BlockChain
    forall s a. Point s a -> ST s a
    find Point s BlockChain
    cTo
                  BlockChain
    cLeft <- Point s BlockChain -> ST s BlockChain
    forall s a. Point s a -> ST s a
    find Point s BlockChain
    cFrom
                  Point s BlockChain
    new_point <- BlockChain -> ST s (Point s BlockChain)
    forall a s. a -> ST s (Point s a)
    fresh (BlockChain -> BlockChain -> BlockChain
    chainConcat BlockChain
    cLeft BlockChain
    cRight)
                  Point s BlockChain -> Point s BlockChain -> ST s ()
    forall s a. Point s a -> Point s a -> ST s ()
    union Point s BlockChain
    cTo Point s BlockChain
    new_point
                  Point s BlockChain -> Point s BlockChain -> ST s ()
    forall s a. Point s a -> Point s a -> ST s ()
    union Point s BlockChain
    cFrom Point s BlockChain
    new_point
                [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
    forall s.
    [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain
    merge [CfgEdge]
    edges LabelMap (Point s BlockChain)
    chains
              where
                cFrom :: Point s BlockChain
    cFrom = String -> Maybe (Point s BlockChain) -> Point s BlockChain
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "mergeChains:chainMap:from" (Maybe (Point s BlockChain) -> Point s BlockChain)
    -> Maybe (Point s BlockChain) -> Point s BlockChain
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap
    -> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    BlockId
    from LabelMap (Point s BlockChain)
    chains
                cTo :: Point s BlockChain
    cTo = String -> Maybe (Point s BlockChain) -> Point s BlockChain
    forall a. HasCallStack => String -> Maybe a -> a
    expectJust String
    "mergeChains:chainMap:to"   (Maybe (Point s BlockChain) -> Point s BlockChain)
    -> Maybe (Point s BlockChain) -> Point s BlockChain
    forall a b. (a -> b) -> a -> b
    $ KeyOf LabelMap
    -> LabelMap (Point s BlockChain) -> Maybe (Point s BlockChain)
    forall (map :: * -> *) a.
    IsMap map =>
    KeyOf map -> map a -> Maybe a
    mapLookup KeyOf LabelMap
    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, 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 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' <- 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 :: forall a i.
    (Instruction i, Outputable i) =>
    LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
    sequenceChain LabelMap a
    _info CFG
    _weights    [] = []
    sequenceChain LabelMap a
    _info CFG
    _weights    [GenBasicBlock i
    x] = [GenBasicBlock i
    x]
    sequenceChain  LabelMap a
    info CFG
    weights     blocks :: [GenBasicBlock i]
    blocks@((BasicBlock BlockId
    entry [i]
    _):[GenBasicBlock i]
    _) =
        let directEdges :: [CfgEdge]
            directEdges :: [CfgEdge]
    directEdges = (CfgEdge -> CfgEdge -> Ordering) -> [CfgEdge] -> [CfgEdge]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy ((CfgEdge -> CfgEdge -> Ordering) -> CfgEdge -> CfgEdge -> Ordering
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip CfgEdge -> CfgEdge -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare) ([CfgEdge] -> [CfgEdge]) -> [CfgEdge] -> [CfgEdge]
    forall a b. (a -> b) -> a -> b
    $ [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
                -- Apply modifiers to turn edge frequencies into useable weights
                -- for computing code layout.
                -- See also Note [Layout relevant edge weights]
                relevantWeight :: CfgEdge -> Maybe CfgEdge
                relevantWeight :: CfgEdge -> Maybe CfgEdge
    relevantWeight edge :: CfgEdge
    edge@(CfgEdge BlockId
    from BlockId
    to EdgeInfo
    edgeInfo)
                    | (EdgeInfo CmmSource { trans_cmmNode :: TransitionSource -> CmmNode O C
    trans_cmmNode = CmmCall {} } EdgeWeight
    _) <- EdgeInfo
    edgeInfo
                    -- Ignore edges across calls.
                    = Maybe CfgEdge
    forall a. Maybe a
    Nothing
                    | 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 quite small if we jump over an info table
                    = CfgEdge -> Maybe CfgEdge
    forall a. a -> Maybe a
    Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
    CfgEdge BlockId
    from BlockId
    to EdgeInfo
    edgeInfo { edgeWeight :: EdgeWeight
    edgeWeight = EdgeWeight
    wEdgeWeight -> EdgeWeight -> EdgeWeight
    forall 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
                    , CmmNode O C -> Bool
    forall {e :: Extensibility} {x :: Extensibility}.
    CmmNode e x -> Bool
    cantEliminate CmmNode O C
    exitNode
                    , EdgeWeight
    w <- EdgeInfo -> EdgeWeight
    edgeWeight EdgeInfo
    edgeInfo
                    -- A small penalty to edge types which
                    -- we can't optimize away by layout.
                    -- w * 0.96875 == w - w/32
                    = CfgEdge -> Maybe CfgEdge
    forall a. a -> Maybe a
    Just (BlockId -> BlockId -> EdgeInfo -> CfgEdge
    CfgEdge BlockId
    from BlockId
    to EdgeInfo
    edgeInfo { edgeWeight :: EdgeWeight
    edgeWeight = EdgeWeight
    w EdgeWeight -> EdgeWeight -> EdgeWeight
    forall a. Num a => a -> a -> a
    * EdgeWeight
    0.96875 })
                    | Bool
    otherwise
                    = CfgEdge -> Maybe CfgEdge
    forall a. a -> Maybe a
    Just CfgEdge
    edge
                    where
                      cantEliminate :: CmmNode e x -> Bool
    cantEliminate CmmCondBranch {} = Bool
    True
                      cantEliminate CmmSwitch {} = Bool
    True
                      cantEliminate CmmNode e x
    _ = Bool
    False

            blockMap :: LabelMap (GenBasicBlock i)
            blockMap :: LabelMap (GenBasicBlock i)
    blockMap
                = (LabelMap (GenBasicBlock i)
     -> GenBasicBlock i -> LabelMap (GenBasicBlock i))
    -> LabelMap (GenBasicBlock i)
    -> [GenBasicBlock i]
    -> LabelMap (GenBasicBlock i)
    forall (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]
    #if __GLASGOW_HASKELL__ <= 810
                | otherwise = pprPanic "Entry point eliminated" $
                                ppr masterChain
    #endif

            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 placement" (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 :: 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 (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 :: forall instr statics jumpDest.
    (Instruction instr, Outputable instr) =>
    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 RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live (ListGraph [GenBasicBlock instr]
    blocks))
      | (GeneralFlag -> DynFlags -> Bool
    gopt GeneralFlag
    Opt_CfgBlocklayout DynFlags
    dflags) Bool -> Bool -> Bool
    && Platform -> Bool
    backendMaintainsCfg (DynFlags -> Platform
    targetPlatform DynFlags
    dflags)
      --Use chain based algorithm
      , Just CFG
    cfg <- Maybe CFG
    edgeWeights
      = LabelMap RawCmmStatics
    -> CLabel
    -> [GlobalReg]
    -> ListGraph instr
    -> NatCmmDecl statics instr
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    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 RawCmmStatics
    -> [GenBasicBlock instr]
    -> [GenBasicBlock instr]
    forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> LabelMap RawCmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr]
    ncgMakeFarBranches NcgImpl statics instr jumpDest
    ncgImpl LabelMap RawCmmStatics
    info ([GenBasicBlock instr] -> [GenBasicBlock instr])
    -> [GenBasicBlock instr] -> [GenBasicBlock instr]
    forall a b. (a -> b) -> a -> b
    $
                                {-# SCC layoutBlocks #-}
                                LabelMap RawCmmStatics
    -> CFG -> [GenBasicBlock instr] -> [GenBasicBlock instr]
    forall a i.
    (Instruction i, Outputable i) =>
    LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
    sequenceChain LabelMap RawCmmStatics
    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 RawCmmStatics
    -> CLabel
    -> [GlobalReg]
    -> ListGraph instr
    -> NatCmmDecl statics instr
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    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 RawCmmStatics
    -> [GenBasicBlock instr]
    -> [GenBasicBlock instr]
    forall statics instr jumpDest.
    NcgImpl statics instr jumpDest
    -> LabelMap RawCmmStatics
    -> [NatBasicBlock instr]
    -> [NatBasicBlock instr]
    ncgMakeFarBranches NcgImpl statics instr jumpDest
    ncgImpl LabelMap RawCmmStatics
    info ([GenBasicBlock instr] -> [GenBasicBlock instr])
    -> [GenBasicBlock instr] -> [GenBasicBlock instr]
    forall a b. (a -> b) -> a -> b
    $
                                    {-# SCC layoutBlocks #-}
                                    Maybe CFG
    -> LabelMap RawCmmStatics
    -> [GenBasicBlock instr]
    -> [GenBasicBlock instr]
    forall inst a.
    Instruction inst =>
    Maybe CFG
    -> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
    sequenceBlocks Maybe CFG
    cfg LabelMap RawCmmStatics
    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
    $ Platform -> Bool
    backendMaintainsCfg (DynFlags -> Platform
    targetPlatform 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 :: forall inst a.
    Instruction inst =>
    Maybe CFG
    -> LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
    sequenceBlocks Maybe CFG
    _edgeWeight LabelMap a
    _ [] = []
    sequenceBlocks Maybe CFG
    edgeWeights LabelMap a
    infos (GenBasicBlock inst
    entry:[GenBasicBlock inst]
    blocks) =
        let entryNode :: Node BlockId (GenBasicBlock inst)
    entryNode = Maybe CFG
    -> GenBasicBlock inst -> Node BlockId (GenBasicBlock inst)
    forall t.
    Instruction t =>
    Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
    mkNode Maybe CFG
    edgeWeights GenBasicBlock inst
    entry
            bodyNodes :: [Node BlockId (GenBasicBlock inst)]
    bodyNodes = [Node BlockId (GenBasicBlock inst)]
    -> [Node BlockId (GenBasicBlock inst)]
    forall a. [a] -> [a]
    reverse
                        ([SCC (Node BlockId (GenBasicBlock inst))]
    -> [Node BlockId (GenBasicBlock inst)]
    forall a. [SCC a] -> [a]
    flattenSCCs (Maybe CFG
    -> [GenBasicBlock inst]
    -> [SCC (Node BlockId (GenBasicBlock inst))]
    forall instr.
    Instruction instr =>
    Maybe CFG
    -> [NatBasicBlock instr]
    -> [SCC (Node BlockId (NatBasicBlock instr))]
    sccBlocks Maybe CFG
    edgeWeights [GenBasicBlock inst]
    blocks))
        in LabelMap a -> [GenBasicBlock inst] -> [GenBasicBlock inst]
    forall a i.
    Instruction i =>
    LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
    dropJumps LabelMap a
    infos ([GenBasicBlock inst] -> [GenBasicBlock inst])
    -> ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
    -> [Node BlockId (GenBasicBlock inst)]
    -> [GenBasicBlock inst]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LabelMap a
    -> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
    forall i t1.
    LabelMap i
    -> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
    seqBlocks LabelMap a
    infos ([Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst])
    -> [Node BlockId (GenBasicBlock inst)] -> [GenBasicBlock inst]
    forall a b. (a -> b) -> a -> b
    $ ( Node BlockId (GenBasicBlock inst)
    entryNode Node BlockId (GenBasicBlock inst)
    -> [Node BlockId (GenBasicBlock inst)]
    -> [Node BlockId (GenBasicBlock inst)]
    forall a. a -> [a] -> [a]
    : [Node BlockId (GenBasicBlock inst)]
    bodyNodes)
      -- the first block is the entry point ==> it must remain at the start.

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

    mkNode :: (Instruction t)
           => Maybe CFG -> GenBasicBlock t
           -> Node BlockId (GenBasicBlock t)
    mkNode :: forall t.
    Instruction t =>
    Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
    mkNode Maybe CFG
    edgeWeights block :: GenBasicBlock t
    block@(BasicBlock BlockId
    id [t]
    instrs) =
        GenBasicBlock t
    -> BlockId -> [BlockId] -> Node BlockId (GenBasicBlock t)
    forall key payload. payload -> key -> [key] -> Node key payload
    DigraphNode GenBasicBlock t
    block BlockId
    id [BlockId]
    outEdges
      where
        outEdges :: [BlockId]
        outEdges :: [BlockId]
    outEdges
          --Select the heaviest successor, ignore weights <= zero
          = [BlockId]
    successor
          where
            successor :: [BlockId]
    successor
              | Just [(BlockId, EdgeInfo)]
    successors <- (CFG -> [(BlockId, EdgeInfo)])
    -> Maybe CFG -> Maybe [(BlockId, EdgeInfo)]
    forall (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 :: forall i t1.
    LabelMap i
    -> [Node BlockId (GenBasicBlock t1)] -> [GenBasicBlock t1]
    seqBlocks LabelMap i
    infos [Node BlockId (GenBasicBlock t1)]
    blocks = UniqFM BlockId (GenBasicBlock t1, [BlockId])
    -> [BlockId] -> [GenBasicBlock t1]
    placeNext UniqFM BlockId (GenBasicBlock t1, [BlockId])
    pullable0 [BlockId]
    todo0
      where
        -- pullable: Blocks that are not yet placed
        -- todo:     Original order of blocks, to be followed if we have no good
        --           reason not to;
        --           may include blocks that have already been placed, but then
        --           these are not in pullable
        pullable0 :: UniqFM BlockId (GenBasicBlock t1, [BlockId])
    pullable0 = [(BlockId, (GenBasicBlock t1, [BlockId]))]
    -> UniqFM BlockId (GenBasicBlock t1, [BlockId])
    forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
    listToUFM [ (BlockId
    i,(GenBasicBlock t1
    b,[BlockId]
    n)) | DigraphNode GenBasicBlock t1
    b BlockId
    i [BlockId]
    n <- [Node BlockId (GenBasicBlock t1)]
    blocks ]
        todo0 :: [BlockId]
    todo0     = (Node BlockId (GenBasicBlock t1) -> BlockId)
    -> [Node BlockId (GenBasicBlock t1)] -> [BlockId]
    forall a b. (a -> b) -> [a] -> [b]
    map Node BlockId (GenBasicBlock t1) -> BlockId
    forall key payload. Node key payload -> key
    node_key [Node BlockId (GenBasicBlock t1)]
    blocks

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

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

    lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
                    -> Maybe (elt, UniqFM BlockId elt)
    lookupDeleteUFM :: forall elt.
    UniqFM BlockId elt -> BlockId -> Maybe (elt, UniqFM BlockId elt)
    lookupDeleteUFM UniqFM BlockId elt
    m BlockId
    k = do -- Maybe monad
        elt
    v <- UniqFM BlockId elt -> BlockId -> Maybe elt
    forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
    lookupUFM UniqFM BlockId elt
    m BlockId
    k
        (elt, UniqFM BlockId elt) -> Maybe (elt, UniqFM BlockId elt)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (elt
    v, UniqFM BlockId elt -> BlockId -> UniqFM BlockId elt
    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