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

{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}

{-# OPTIONS_GHC -fprof-auto #-}
--{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}

module BlockLayout
    ( sequenceTop )
where

#include "HsVersions.h"
import GhcPrelude

import Instruction
import NCGMonad
import CFG

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

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

import Digraph
import Outputable
import Maybes

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

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

import qualified Data.Set as Set
import Control.Applicative

{-
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ~~~ Note [Chain based CFG serialization]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  For additional information also look at
  https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/CodeLayout

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

  Edge weights not only represent likelyhood of control transfer between blocks
  but also how much a block would benefit from being placed sequentially after
  it's predecessor.
  For example blocks which are preceeded by an info table are more likely to end
  up in a different cache line than their predecessor. So there is less benefit
  in 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 sequentially is important have already
  been placed in the same chain.

  -----------------------------------------------------------------------------
      First try to create a lists of good chains.
  -----------------------------------------------------------------------------

  We do so by taking a block not yet placed in a chain and
  looking at these cases:

  *)  Check if the best predecessor of the block is at the end of a chain.
      If so add the current block to the end of that chain.

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

      Combined with the fact that we process blocks in reverse post order
      this means loop bodies and trivially sequential control flow already
      ends up as a single chain.

  *)  Otherwise we create a singleton chain from the block we are looking at.
      Eg if we have from the example above already constructed (A->B)
      and look at D we create the chain (D) resulting in the chains [A->B, D]

  -----------------------------------------------------------------------------
      We then try to fuse chains.
  -----------------------------------------------------------------------------

  There are edge cases which result in two chains being created which trivially
  represent linear control flow. For example we might have the chains
  [(A-B-C),(D-E)] with an cfg triangle:

      A----->C->D->E
       \->B-/

  We also get three independent chains if two branches end with a jump
  to a common successor.

  We take care of these cases by fusing chains which are connected by an
  edge.

  We do so by looking at the list of edges sorted by weight.
  Given the edge (C -> D) we try to find two chains such that:
      * C is at the end of chain one.
      * D is in front of chain two.
      * If two such chains exist we fuse them.
  We then remove the edge and repeat the process for the rest of the edges.

  -----------------------------------------------------------------------------
      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.

  TODO: If we remove edges as we use them (eg if we build up A->B remove A->B
        from the list) we could save some more work in later phases.


  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  ~~~ Note [Triangle Control Flow]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

  Checking if an argument is already evaluating leads to a somewhat
  special case  which looks like this:

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

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

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

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

  We could explicitly check for this control flow pattern.

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

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

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

-}


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

-- | Only edges heavier than this are considered
--   for fusing two chains into a single chain.
fuseEdgeThreshold :: EdgeWeight
fuseEdgeThreshold :: EdgeWeight
fuseEdgeThreshold = 0


-- | A non empty ordered sequence of basic blocks.
--   It is suitable for serialization in this order.
data BlockChain
    = BlockChain
    { BlockChain -> LabelSet
chainMembers :: !LabelSet
    , BlockChain -> BlockSequence
chainBlocks :: !BlockSequence
    }

instance Eq (BlockChain) where
    (BlockChain s1 :: LabelSet
s1 _) == :: BlockChain -> BlockChain -> Bool
== (BlockChain s2 :: LabelSet
s2 _)
        = LabelSet
s1 LabelSet -> LabelSet -> Bool
forall a. Eq a => a -> a -> Bool
== LabelSet
s2

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

data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (WeightedEdge -> WeightedEdge -> Bool
(WeightedEdge -> WeightedEdge -> Bool)
-> (WeightedEdge -> WeightedEdge -> Bool) -> Eq WeightedEdge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WeightedEdge -> WeightedEdge -> Bool
$c/= :: WeightedEdge -> WeightedEdge -> Bool
== :: WeightedEdge -> WeightedEdge -> Bool
$c== :: WeightedEdge -> WeightedEdge -> Bool
Eq)

-- Useful for things like sets and debugging purposes, sorts by blocks
-- in the chain.
instance Ord (BlockChain) where
   (BlockChain lbls1 :: LabelSet
lbls1 _) compare :: BlockChain -> BlockChain -> Ordering
`compare` (BlockChain lbls2 :: LabelSet
lbls2 _)
       = LabelSet
lbls1 LabelSet -> LabelSet -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` LabelSet
lbls2

-- | Non deterministic! (Uniques) Sorts edges by weight and nodes.
instance Ord WeightedEdge where
  compare :: WeightedEdge -> WeightedEdge -> Ordering
compare (WeightedEdge from1 :: BlockId
from1 to1 :: BlockId
to1 weight1 :: EdgeWeight
weight1)
          (WeightedEdge from2 :: BlockId
from2 to2 :: BlockId
to2 weight2 :: EdgeWeight
weight2)
    | EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
< EdgeWeight
weight2 Bool -> Bool -> Bool
|| EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& BlockId
from1 BlockId -> BlockId -> Bool
forall a. Ord a => a -> a -> Bool
< BlockId
from2 Bool -> Bool -> Bool
||
      EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2 Bool -> Bool -> Bool
&& BlockId
from1 BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
from2 Bool -> Bool -> Bool
&& BlockId
to1 BlockId -> BlockId -> Bool
forall a. Ord a => a -> a -> Bool
< BlockId
to2
    = Ordering
LT
    | BlockId
from1 BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
from2 Bool -> Bool -> Bool
&& BlockId
to1 BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
to2 Bool -> Bool -> Bool
&& EdgeWeight
weight1 EdgeWeight -> EdgeWeight -> Bool
forall a. Eq a => a -> a -> Bool
== EdgeWeight
weight2
    = Ordering
EQ
    | Bool
otherwise
    = Ordering
GT

instance Outputable WeightedEdge where
    ppr :: WeightedEdge -> SDoc
ppr (WeightedEdge from :: BlockId
from to :: BlockId
to info :: EdgeWeight
info) =
        BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
from SDoc -> SDoc -> SDoc
<> String -> SDoc
text "->" SDoc -> SDoc -> SDoc
<> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
to SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (EdgeWeight -> SDoc
forall a. Outputable a => a -> SDoc
ppr EdgeWeight
info)

type WeightedEdgeList = [WeightedEdge]

noDups :: [BlockChain] -> Bool
noDups :: [BlockChain] -> Bool
noDups chains :: [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]
        (_blocks :: [BlockId]
_blocks, dups :: [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 "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 "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 bid :: BlockId
bid (BlockChain _ seq :: BlockSequence
seq)
  = BlockSequence -> BlockId
seqFront BlockSequence
seq BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid

chainMember :: BlockId -> BlockChain -> Bool
chainMember :: BlockId -> BlockChain -> Bool
chainMember bid :: BlockId
bid chain :: BlockChain
chain
  = ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
bid (LabelSet -> Bool)
-> (BlockChain -> LabelSet) -> BlockChain -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockChain -> LabelSet
chainMembers (BlockChain -> Bool) -> BlockChain -> Bool
forall a b. (a -> b) -> a -> b
$ BlockChain
chain

chainSingleton :: BlockId -> BlockChain
chainSingleton :: BlockId -> BlockChain
chainSingleton lbl :: BlockId
lbl
    = LabelSet -> BlockSequence -> BlockChain
BlockChain (ElemOf LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set
setSingleton ElemOf LabelSet
BlockId
lbl) (BlockId -> BlockSequence
Singleton BlockId
lbl)

chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc (BlockChain lbls :: LabelSet
lbls blks :: BlockSequence
blks) lbl :: BlockId
lbl
  = LabelSet -> BlockSequence -> BlockChain
BlockChain (ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert ElemOf LabelSet
BlockId
lbl LabelSet
lbls) (BlockSequence -> BlockId -> BlockSequence
seqSnoc BlockSequence
blks BlockId
lbl)

chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat (BlockChain lbls1 :: LabelSet
lbls1 blks1 :: BlockSequence
blks1) (BlockChain lbls2 :: LabelSet
lbls2 blks2 :: BlockSequence
blks2)
  = LabelSet -> BlockSequence -> BlockChain
BlockChain (LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => set -> set -> set
setUnion LabelSet
lbls1 LabelSet
lbls2) (BlockSequence
blks1 BlockSequence -> BlockSequence -> BlockSequence
`seqConcat` BlockSequence
blks2)

chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks :: BlockChain -> [BlockId]
chainToBlocks (BlockChain _ blks :: BlockSequence
blks) = BlockSequence -> [BlockId]
seqToList BlockSequence
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 bid :: BlockId
bid (BlockChain lbls :: LabelSet
lbls blks :: BlockSequence
blks)
    | Bool -> Bool
not (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
bid LabelSet
lbls)
    = String -> (BlockChain, BlockChain)
forall a. String -> a
panic "Block not in chain"
    | Bool
otherwise
    = let (lblks :: [BlockId]
lblks, rblks :: [BlockId]
rblks) = (BlockId -> Bool) -> [BlockId] -> ([BlockId], [BlockId])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\lbl :: BlockId
lbl -> BlockId
lbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
bid)
                                 (BlockSequence -> [BlockId]
seqToList BlockSequence
blks)
          --TODO: Remove old
          --lblSet :: [GenBasicBlock i] -> BlockChain
          --lblSet blks =
          --  setFromList
                --(map (\(BasicBlock lbl _) -> lbl) $ toList blks)
      in
      (LabelSet -> BlockSequence -> BlockChain
BlockChain ([ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList [ElemOf LabelSet]
[BlockId]
lblks) ([BlockId] -> BlockSequence
seqFromBids [BlockId]
lblks),
       LabelSet -> BlockSequence -> BlockChain
BlockChain ([ElemOf LabelSet] -> LabelSet
forall set. IsSet set => [ElemOf set] -> set
setFromList [ElemOf LabelSet]
[BlockId]
rblks) ([BlockId] -> BlockSequence
seqFromBids [BlockId]
rblks))

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


takeL :: Int -> BlockChain -> [BlockId]
takeL :: Int -> BlockChain -> [BlockId]
takeL n :: Int
n (BlockChain _ blks :: BlockSequence
blks) = --error "TODO: takeLn"
    Int -> [BlockId] -> [BlockId]
forall a. Int -> [a] -> [a]
take Int
n ([BlockId] -> [BlockId])
-> (BlockSequence -> [BlockId]) -> BlockSequence -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockSequence -> [BlockId]
seqToList (BlockSequence -> [BlockId]) -> BlockSequence -> [BlockId]
forall a b. (a -> b) -> a -> b
$ BlockSequence
blks

-- | For a given list of chains try to fuse chains with strong
--   edges between them into a single chain.
--   Returns the list of fused chains together with a set of
--   used edges. The set of edges is indirectly encoded in the
--   chains so doesn't need to be considered for later passes.
fuseChains :: WeightedEdgeList -> LabelMap BlockChain
           -> (LabelMap BlockChain, Set.Set WeightedEdge)
fuseChains :: WeightedEdgeList
-> LabelMap BlockChain -> (LabelMap BlockChain, Set WeightedEdge)
fuseChains weights :: WeightedEdgeList
weights chains :: LabelMap BlockChain
chains
    = let fronts :: LabelMap BlockChain
fronts = [(KeyOf LabelMap, BlockChain)] -> LabelMap BlockChain
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, BlockChain)] -> LabelMap BlockChain)
-> [(KeyOf LabelMap, BlockChain)] -> LabelMap BlockChain
forall a b. (a -> b) -> a -> b
$
                    (BlockChain -> (BlockId, BlockChain))
-> [BlockChain] -> [(BlockId, BlockChain)]
forall a b. (a -> b) -> [a] -> [b]
map (\chain :: BlockChain
chain -> ([BlockId] -> BlockId
forall a. [a] -> a
head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL 1 BlockChain
chain,BlockChain
chain)) ([BlockChain] -> [(KeyOf LabelMap, BlockChain)])
-> [BlockChain] -> [(KeyOf LabelMap, BlockChain)]
forall a b. (a -> b) -> a -> b
$
                    LabelMap BlockChain -> [BlockChain]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap BlockChain
chains :: LabelMap BlockChain
          (chains' :: LabelMap BlockChain
chains', used :: Set WeightedEdge
used, _) = WeightedEdgeList
-> LabelMap BlockChain
-> LabelMap BlockChain
-> Set WeightedEdge
-> (LabelMap BlockChain, Set WeightedEdge, LabelMap BlockChain)
applyEdges WeightedEdgeList
weights LabelMap BlockChain
chains LabelMap BlockChain
fronts Set WeightedEdge
forall a. Set a
Set.empty
      in (LabelMap BlockChain
chains', Set WeightedEdge
used)
    where
        applyEdges :: WeightedEdgeList -> LabelMap BlockChain
                   -> LabelMap BlockChain -> Set.Set WeightedEdge
                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)
        applyEdges :: WeightedEdgeList
-> LabelMap BlockChain
-> LabelMap BlockChain
-> Set WeightedEdge
-> (LabelMap BlockChain, Set WeightedEdge, LabelMap BlockChain)
applyEdges [] chainsEnd :: LabelMap BlockChain
chainsEnd chainsFront :: LabelMap BlockChain
chainsFront used :: Set WeightedEdge
used
            = (LabelMap BlockChain
chainsEnd, Set WeightedEdge
used, LabelMap BlockChain
chainsFront)
        applyEdges (edge :: WeightedEdge
edge@(WeightedEdge from :: BlockId
from to :: BlockId
to w :: EdgeWeight
w):edges :: WeightedEdgeList
edges) chainsEnd :: LabelMap BlockChain
chainsEnd chainsFront :: LabelMap BlockChain
chainsFront used :: Set WeightedEdge
used
            --Since we order edges descending by weight we can stop here
            | EdgeWeight
w EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= EdgeWeight
fuseEdgeThreshold
            = ( LabelMap BlockChain
chainsEnd, Set WeightedEdge
used, LabelMap BlockChain
chainsFront)
            --Fuse the two chains
            | Just c1 :: BlockChain
c1 <- KeyOf LabelMap -> LabelMap BlockChain -> Maybe BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
from LabelMap BlockChain
chainsEnd
            , Just c2 :: BlockChain
c2 <- KeyOf LabelMap -> LabelMap BlockChain -> Maybe BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
to LabelMap BlockChain
chainsFront
            , BlockChain
c1 BlockChain -> BlockChain -> Bool
forall a. Eq a => a -> a -> Bool
/= BlockChain
c2
            = let newChain :: BlockChain
newChain = BlockChain -> BlockChain -> BlockChain
chainConcat BlockChain
c1 BlockChain
c2
                  front :: BlockId
front = [BlockId] -> BlockId
forall a. [a] -> a
head ([BlockId] -> BlockId) -> [BlockId] -> BlockId
forall a b. (a -> b) -> a -> b
$ Int -> BlockChain -> [BlockId]
takeL 1 BlockChain
newChain
                  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 1 BlockChain
newChain
                  chainsFront' :: LabelMap BlockChain
chainsFront' = KeyOf LabelMap
-> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
front BlockChain
newChain (LabelMap BlockChain -> LabelMap BlockChain)
-> LabelMap BlockChain -> LabelMap BlockChain
forall a b. (a -> b) -> a -> b
$
                                 KeyOf LabelMap -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
to LabelMap BlockChain
chainsFront
                  chainsEnd' :: LabelMap BlockChain
chainsEnd'   = KeyOf LabelMap
-> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
end BlockChain
newChain (LabelMap BlockChain -> LabelMap BlockChain)
-> LabelMap BlockChain -> LabelMap BlockChain
forall a b. (a -> b) -> a -> b
$
                                 KeyOf LabelMap -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
from LabelMap BlockChain
chainsEnd
              in WeightedEdgeList
-> LabelMap BlockChain
-> LabelMap BlockChain
-> Set WeightedEdge
-> (LabelMap BlockChain, Set WeightedEdge, LabelMap BlockChain)
applyEdges WeightedEdgeList
edges LabelMap BlockChain
chainsEnd' LabelMap BlockChain
chainsFront'
                            (WeightedEdge -> Set WeightedEdge -> Set WeightedEdge
forall a. Ord a => a -> Set a -> Set a
Set.insert WeightedEdge
edge Set WeightedEdge
used)
            | Bool
otherwise
            --Check next edge
            = WeightedEdgeList
-> LabelMap BlockChain
-> LabelMap BlockChain
-> Set WeightedEdge
-> (LabelMap BlockChain, Set WeightedEdge, LabelMap BlockChain)
applyEdges WeightedEdgeList
edges LabelMap BlockChain
chainsEnd LabelMap BlockChain
chainsFront Set WeightedEdge
used


-- 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 later after the former doesn't result in sequential
-- control flow it is still be benefical since 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 ...
--
-- Simple heuristic to chose which chains we want to combine:
--   * Process edges in descending priority.
--   * Check if there is a edge near the end of one chain which goes
--     to a block near the start of another edge.
--
-- While we could take into account the space between the two blocks which
-- share an edge this blows up compile times quite a bit. It requires
-- us to find all edges between two chains, check the distance for all edges,
-- rank them based on the distance and and only then we can select two chains
-- to combine. Which would add a lot of complexity for little gain.

-- | For a given list of chains and edges try to combine chains with strong
--   edges between them.
combineNeighbourhood :: WeightedEdgeList -> [BlockChain]
                     -> [BlockChain]
combineNeighbourhood :: WeightedEdgeList -> [BlockChain] -> [BlockChain]
combineNeighbourhood edges :: WeightedEdgeList
edges chains :: [BlockChain]
chains
    = -- pprTraceIt "Neigbours" $
      WeightedEdgeList -> FrontierMap -> FrontierMap -> [BlockChain]
applyEdges WeightedEdgeList
edges FrontierMap
endFrontier FrontierMap
startFrontier
    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 (\chain :: BlockChain
chain ->
                                let ends :: [BlockId]
ends = BlockChain -> [BlockId]
getEnds BlockChain
chain
                                    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 (\x :: 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 (\chain :: 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 (\x :: BlockId
x -> (BlockId
x,([BlockId], BlockChain)
entry)) [BlockId]
front) [BlockChain]
chains
        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap
                   -> [BlockChain]
        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap -> [BlockChain]
applyEdges [] chainEnds :: FrontierMap
chainEnds _chainFronts :: FrontierMap
_chainFronts =
            [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
        applyEdges ((WeightedEdge from :: BlockId
from to :: BlockId
to _w :: EdgeWeight
_w):edges :: WeightedEdgeList
edges) chainEnds :: FrontierMap
chainEnds chainFronts :: FrontierMap
chainFronts
            | Just (c1_e :: [BlockId]
c1_e,c1 :: 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 (c2_f :: [BlockId]
c2_f,c2 :: 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 short 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' (\m :: FrontierMap
m b :: 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' (\m :: FrontierMap
m x :: 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' (\m :: FrontierMap
m b :: 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' (\m :: FrontierMap
m x :: 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
                --   )
                 WeightedEdgeList -> FrontierMap -> FrontierMap -> [BlockChain]
applyEdges WeightedEdgeList
edges FrontierMap
newEnds FrontierMap
newFronts
            | Bool
otherwise
            = --pprTrace "noNeigbours" (ppr ()) $
              WeightedEdgeList -> FrontierMap -> FrontierMap -> [BlockChain]
applyEdges WeightedEdgeList
edges FrontierMap
chainEnds FrontierMap
chainFronts
         where

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



-- See [Chain based CFG serialization]
buildChains :: CFG -> [BlockId]
            -> ( LabelMap BlockChain  -- Resulting chains.
               , Set.Set (BlockId, BlockId)) --List of fused edges.
buildChains :: CFG -> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains succWeights :: CFG
succWeights blocks :: [BlockId]
blocks
  = let (_, fusedEdges :: Set (BlockId, BlockId)
fusedEdges, chains :: LabelMap BlockChain
chains) = LabelSet
-> LabelMap BlockChain
-> [BlockId]
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId), LabelMap BlockChain)
buildNext LabelSet
forall set. IsSet set => set
setEmpty LabelMap BlockChain
forall (map :: * -> *) a. IsMap map => map a
mapEmpty [BlockId]
blocks Set (BlockId, BlockId)
forall a. Set a
Set.empty
    in (LabelMap BlockChain
chains, Set (BlockId, BlockId)
fusedEdges)
  where
    -- We keep a map from the last block in a chain to the chain itself.
    -- This we we can easily check if an block should be appened to an
    -- existing chain!
    buildNext :: LabelSet
              -> LabelMap BlockChain -- Map from last element to chain.
              -> [BlockId] -- Blocks to place
              -> Set.Set (BlockId, BlockId)
              -> ( [BlockChain]  -- Placed Blocks
                 , Set.Set (BlockId, BlockId) --List of fused edges
                 , LabelMap BlockChain
                 )
    buildNext :: LabelSet
-> LabelMap BlockChain
-> [BlockId]
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId), LabelMap BlockChain)
buildNext _placed :: LabelSet
_placed chains :: LabelMap BlockChain
chains [] linked :: Set (BlockId, BlockId)
linked =
        ([], Set (BlockId, BlockId)
linked, LabelMap BlockChain
chains)
    buildNext placed :: LabelSet
placed chains :: LabelMap BlockChain
chains (block :: BlockId
block:todo :: [BlockId]
todo) linked :: Set (BlockId, BlockId)
linked
        | ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
block LabelSet
placed
        = LabelSet
-> LabelMap BlockChain
-> [BlockId]
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId), LabelMap BlockChain)
buildNext LabelSet
placed LabelMap BlockChain
chains [BlockId]
todo Set (BlockId, BlockId)
linked
        | Bool
otherwise
        = LabelSet
-> LabelMap BlockChain
-> [BlockId]
-> Set (BlockId, BlockId)
-> ([BlockChain], Set (BlockId, BlockId), LabelMap BlockChain)
buildNext LabelSet
placed' LabelMap BlockChain
chains' [BlockId]
todo Set (BlockId, BlockId)
linked'
      where
        placed' :: LabelSet
placed' = ((LabelSet -> BlockId -> LabelSet)
-> LabelSet -> [BlockId] -> LabelSet
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((BlockId -> LabelSet -> LabelSet)
-> LabelSet -> BlockId -> LabelSet
forall a b c. (a -> b -> c) -> b -> a -> c
flip BlockId -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
setInsert) LabelSet
placed [BlockId]
placedBlocks)
        linked' :: Set (BlockId, BlockId)
linked' = Set (BlockId, BlockId)
-> Set (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (BlockId, BlockId)
linked Set (BlockId, BlockId)
linkedEdges
        (placedBlocks :: [BlockId]
placedBlocks, chains' :: LabelMap BlockChain
chains', linkedEdges :: Set (BlockId, BlockId)
linkedEdges) = BlockId -> ([BlockId], LabelMap BlockChain, Set (BlockId, BlockId))
findChain BlockId
block

        --Add the block to a existing or new chain
        --Returns placed blocks, list of resulting chains
        --and fused edges
        findChain :: BlockId
                -> ([BlockId],LabelMap BlockChain, Set.Set (BlockId, BlockId))
        findChain :: BlockId -> ([BlockId], LabelMap BlockChain, Set (BlockId, BlockId))
findChain block :: BlockId
block
        -- B) place block at end of existing chain if
        -- there is no better block to append.
          | (pred :: BlockId
pred:_) <- [BlockId]
preds
          , BlockId -> Bool
alreadyPlaced BlockId
pred
          , Just predChain :: BlockChain
predChain <- KeyOf LabelMap -> LabelMap BlockChain -> Maybe BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
pred LabelMap BlockChain
chains
          , (best :: BlockId
best:_) <- (BlockId -> Bool) -> [BlockId] -> [BlockId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (BlockId -> Bool) -> BlockId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> Bool
alreadyPlaced) ([BlockId] -> [BlockId]) -> [BlockId] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ BlockId -> [BlockId]
getSuccs BlockId
pred
          , BlockId
best BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
lbl
          = --pprTrace "B.2)" (ppr (pred,lbl)) $
            let newChain :: BlockChain
newChain = BlockChain -> BlockId -> BlockChain
chainSnoc BlockChain
predChain BlockId
block
                chainMap :: LabelMap BlockChain
chainMap = KeyOf LabelMap
-> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
lbl BlockChain
newChain (LabelMap BlockChain -> LabelMap BlockChain)
-> LabelMap BlockChain -> LabelMap BlockChain
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> map a
mapDelete KeyOf LabelMap
BlockId
pred LabelMap BlockChain
chains
            in  ( [BlockId
lbl]
                , LabelMap BlockChain
chainMap
                , (BlockId, BlockId) -> Set (BlockId, BlockId)
forall a. a -> Set a
Set.singleton (BlockId
pred,BlockId
lbl) )

          | Bool
otherwise
          = --pprTrace "single" (ppr lbl)
            ( [BlockId
lbl]
            , KeyOf LabelMap
-> BlockChain -> LabelMap BlockChain -> LabelMap BlockChain
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert KeyOf LabelMap
BlockId
lbl (BlockId -> BlockChain
chainSingleton BlockId
lbl) LabelMap BlockChain
chains
            , Set (BlockId, BlockId)
forall a. Set a
Set.empty)
            where
              alreadyPlaced :: BlockId -> Bool
alreadyPlaced blkId :: BlockId
blkId = (ElemOf LabelSet -> LabelSet -> Bool
forall set. IsSet set => ElemOf set -> set -> Bool
setMember ElemOf LabelSet
BlockId
blkId LabelSet
placed)
              lbl :: BlockId
lbl = BlockId
block
              getSuccs :: BlockId -> [BlockId]
getSuccs = ((BlockId, EdgeInfo) -> BlockId)
-> [(BlockId, EdgeInfo)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, EdgeInfo) -> BlockId
forall a b. (a, b) -> a
fst ([(BlockId, EdgeInfo)] -> [BlockId])
-> (BlockId -> [(BlockId, EdgeInfo)]) -> BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccEdgesSorted CFG
succWeights
              preds :: [BlockId]
preds = ((BlockId, EdgeInfo) -> BlockId)
-> [(BlockId, EdgeInfo)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, EdgeInfo) -> BlockId
forall a b. (a, b) -> a
fst ([(BlockId, EdgeInfo)] -> [BlockId])
-> [(BlockId, EdgeInfo)] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccEdgesSorted CFG
predWeights BlockId
lbl
    --For efficiency we also create the map to look up predecessors here
    predWeights :: CFG
predWeights = CFG -> CFG
reverseEdges CFG
succWeights



-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
newtype BlockNode e x = BN (BlockId,[BlockId])
instance NonLocal (BlockNode) where
  entryLabel :: BlockNode C x -> BlockId
entryLabel (BN (lbl :: BlockId
lbl,_))   = BlockId
lbl
  successors :: BlockNode e C -> [BlockId]
successors (BN (_,succs :: [BlockId]
succs)) = [BlockId]
succs

fromNode :: BlockNode C C -> BlockId
fromNode :: BlockNode C C -> BlockId
fromNode (BN x :: (BlockId, [BlockId])
x) = (BlockId, [BlockId]) -> BlockId
forall a b. (a, b) -> a
fst (BlockId, [BlockId])
x

sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG
            -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain :: LabelMap a -> CFG -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain _info :: LabelMap a
_info _weights :: CFG
_weights    [] = []
sequenceChain _info :: LabelMap a
_info _weights :: CFG
_weights    [x :: GenBasicBlock i
x] = [GenBasicBlock i
x]
sequenceChain  info :: LabelMap a
info weights' :: CFG
weights'     blocks :: [GenBasicBlock i]
blocks@((BasicBlock entry :: BlockId
entry _):_) =
    --Optimization, delete edges of weight <= 0.
    --This significantly improves performance whenever
    --we iterate over all edges, which is a few times!
    let weights :: CFG
        weights :: CFG
weights
            = (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
filterEdges (\_f :: BlockId
_f _t :: BlockId
_t edgeInfo :: EdgeInfo
edgeInfo -> EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
edgeInfo EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
> 0) CFG
weights'
        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' (\m :: LabelMap (GenBasicBlock i)
m blk :: GenBasicBlock i
blk@(BasicBlock lbl :: BlockId
lbl _ins :: [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

        toNode :: BlockId -> BlockNode C C
        toNode :: BlockId -> BlockNode C C
toNode bid :: BlockId
bid =
            -- sorted such that heavier successors come first.
            (BlockId, [BlockId]) -> BlockNode C C
forall e x. (BlockId, [BlockId]) -> BlockNode e x
BN (BlockId
bid,((BlockId, EdgeInfo) -> BlockId)
-> [(BlockId, EdgeInfo)] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map (BlockId, EdgeInfo) -> BlockId
forall a b. (a, b) -> a
fst ([(BlockId, EdgeInfo)] -> [BlockId])
-> (BlockId -> [(BlockId, EdgeInfo)]) -> BlockId -> [BlockId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFG -> BlockId -> [(BlockId, EdgeInfo)]
getSuccEdgesSorted CFG
weights' (BlockId -> [BlockId]) -> BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ BlockId
bid)

        orderedBlocks :: [BlockId]
        orderedBlocks :: [BlockId]
orderedBlocks
            = (BlockNode C C -> BlockId) -> [BlockNode C C] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map BlockNode C C -> BlockId
fromNode ([BlockNode C C] -> [BlockId]) -> [BlockNode C C] -> [BlockId]
forall a b. (a -> b) -> a -> b
$
              LabelMap (BlockNode C C) -> BlockId -> [BlockNode C C]
forall (block :: * -> * -> *).
NonLocal block =>
LabelMap (block C C) -> BlockId -> [block C C]
revPostorderFrom ((GenBasicBlock i -> BlockNode C C)
-> LabelMap (GenBasicBlock i) -> LabelMap (BlockNode C C)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (BlockId -> BlockNode C C
toNode (BlockId -> BlockNode C C)
-> (GenBasicBlock i -> BlockId) -> GenBasicBlock i -> BlockNode C C
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenBasicBlock i -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId) LabelMap (GenBasicBlock i)
blockMap) BlockId
entry

        (builtChains :: LabelMap BlockChain
builtChains, builtEdges :: Set (BlockId, BlockId)
builtEdges)
            = {-# SCC "buildChains" #-}
              --pprTraceIt "generatedChains" $
              --pprTrace "orderedBlocks" (ppr orderedBlocks) $
              CFG -> [BlockId] -> (LabelMap BlockChain, Set (BlockId, BlockId))
buildChains CFG
weights [BlockId]
orderedBlocks

        rankedEdges :: WeightedEdgeList
        -- Sort edges descending, remove fused eges
        rankedEdges :: WeightedEdgeList
rankedEdges =
            ((BlockId, BlockId, EdgeWeight) -> WeightedEdge)
-> [(BlockId, BlockId, EdgeWeight)] -> WeightedEdgeList
forall a b. (a -> b) -> [a] -> [b]
map (\(from :: BlockId
from, to :: BlockId
to, weight :: EdgeWeight
weight) -> BlockId -> BlockId -> EdgeWeight -> WeightedEdge
WeightedEdge BlockId
from BlockId
to EdgeWeight
weight) ([(BlockId, BlockId, EdgeWeight)] -> WeightedEdgeList)
-> ([(BlockId, BlockId, EdgeWeight)]
    -> [(BlockId, BlockId, EdgeWeight)])
-> [(BlockId, BlockId, EdgeWeight)]
-> WeightedEdgeList
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            ((BlockId, BlockId, EdgeWeight) -> Bool)
-> [(BlockId, BlockId, EdgeWeight)]
-> [(BlockId, BlockId, EdgeWeight)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(from :: BlockId
from, to :: BlockId
to, _)
                        -> Bool -> Bool
not ((BlockId, BlockId) -> Set (BlockId, BlockId) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (BlockId
from,BlockId
to) Set (BlockId, BlockId)
builtEdges)) ([(BlockId, BlockId, EdgeWeight)]
 -> [(BlockId, BlockId, EdgeWeight)])
-> ([(BlockId, BlockId, EdgeWeight)]
    -> [(BlockId, BlockId, EdgeWeight)])
-> [(BlockId, BlockId, EdgeWeight)]
-> [(BlockId, BlockId, EdgeWeight)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            ((BlockId, BlockId, EdgeWeight) -> EdgeWeight)
-> [(BlockId, BlockId, EdgeWeight)]
-> [(BlockId, BlockId, EdgeWeight)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (\(_,_,w :: EdgeWeight
w) -> - EdgeWeight
w) ([(BlockId, BlockId, EdgeWeight)] -> WeightedEdgeList)
-> [(BlockId, BlockId, EdgeWeight)] -> WeightedEdgeList
forall a b. (a -> b) -> a -> b
$ CFG -> [(BlockId, BlockId, EdgeWeight)]
weightedEdgeList CFG
weights

        (fusedChains :: LabelMap BlockChain
fusedChains, fusedEdges :: Set WeightedEdge
fusedEdges)
            = ASSERT(noDups $ mapElems builtChains)
              {-# SCC "fuseChains" #-}
              --(pprTrace "RankedEdges" $ ppr rankedEdges) $
              --pprTraceIt "FusedChains" $
              WeightedEdgeList
-> LabelMap BlockChain -> (LabelMap BlockChain, Set WeightedEdge)
fuseChains WeightedEdgeList
rankedEdges LabelMap BlockChain
builtChains

        rankedEdges' :: WeightedEdgeList
rankedEdges' =
            (WeightedEdge -> Bool) -> WeightedEdgeList -> WeightedEdgeList
forall a. (a -> Bool) -> [a] -> [a]
filter (\edge :: WeightedEdge
edge -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ WeightedEdge -> Set WeightedEdge -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member WeightedEdge
edge Set WeightedEdge
fusedEdges) (WeightedEdgeList -> WeightedEdgeList)
-> WeightedEdgeList -> WeightedEdgeList
forall a b. (a -> b) -> a -> b
$ WeightedEdgeList
rankedEdges

        neighbourChains :: [BlockChain]
neighbourChains
            = ASSERT(noDups $ mapElems fusedChains)
              {-# SCC "groupNeighbourChains" #-}
              --pprTraceIt "ResultChains" $
              WeightedEdgeList -> [BlockChain] -> [BlockChain]
combineNeighbourhood WeightedEdgeList
rankedEdges' (LabelMap BlockChain -> [BlockChain]
forall (map :: * -> *) a. IsMap map => map a -> [a]
mapElems LabelMap BlockChain
fusedChains)

        --Make sure the first block stays first
        ([entryChain :: BlockChain
entryChain],chains' :: [BlockChain]
chains')
            = ASSERT(noDups $ neighbourChains)
              (BlockChain -> Bool)
-> [BlockChain] -> ([BlockChain], [BlockChain])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (BlockId -> BlockChain -> Bool
chainMember BlockId
entry) [BlockChain]
neighbourChains
        (entryChain' :: BlockChain
entryChain':entryRest :: [BlockChain]
entryRest)
            | BlockId -> BlockChain -> Bool
inFront BlockId
entry BlockChain
entryChain = [BlockChain
entryChain]
            | (rest :: BlockChain
rest,entry :: BlockChain
entry) <- BlockId -> BlockChain -> (BlockChain, BlockChain)
breakChainAt BlockId
entry BlockChain
entryChain
            = [BlockChain
entry,BlockChain
rest]
            | Bool
otherwise = String -> SDoc -> [BlockChain]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "Entry point eliminated" (SDoc -> [BlockChain]) -> SDoc -> [BlockChain]
forall a b. (a -> b) -> a -> b
$
                            ([BlockChain], [BlockChain]) -> SDoc
forall a. Outputable a => a -> SDoc
ppr ([BlockChain
entryChain],[BlockChain]
chains')

        prepedChains :: [BlockChain]
prepedChains
            = BlockChain
entryChain'BlockChain -> [BlockChain] -> [BlockChain]
forall a. a -> [a] -> [a]
:([BlockChain]
entryRest[BlockChain] -> [BlockChain] -> [BlockChain]
forall a. [a] -> [a] -> [a]
++[BlockChain]
chains') :: [BlockChain]
        blockList :: [BlockId]
blockList
            -- = (concatMap chainToBlocks prepedChains)
            = ((BlockSequence -> [BlockId]) -> [BlockSequence] -> [BlockId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap BlockSequence -> [BlockId]
seqToList ([BlockSequence] -> [BlockId]) -> [BlockSequence] -> [BlockId]
forall a b. (a -> b) -> a -> b
$ (BlockChain -> BlockSequence) -> [BlockChain] -> [BlockSequence]
forall a b. (a -> b) -> [a] -> [b]
map BlockChain -> BlockSequence
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 b :: 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 (\block :: BlockId
block -> Bool -> Bool
not (BlockId -> Bool
isPlaced BlockId
block)) [KeyOf LabelMap]
[BlockId]
blocks

        placedBlocks :: [BlockId]
placedBlocks =
            --pprTraceIt "placedBlocks" $
            [BlockId]
blockList [BlockId] -> [BlockId] -> [BlockId]
forall a. [a] -> [a] -> [a]
++ [BlockId]
unplaced
        getBlock :: BlockId -> GenBasicBlock i
getBlock bid :: BlockId
bid = String -> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a. HasCallStack => String -> Maybe a -> a
expectJust "Block placment" (Maybe (GenBasicBlock i) -> GenBasicBlock i)
-> Maybe (GenBasicBlock i) -> GenBasicBlock i
forall a b. (a -> b) -> a -> b
$ KeyOf LabelMap
-> LabelMap (GenBasicBlock i) -> Maybe (GenBasicBlock i)
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
bid LabelMap (GenBasicBlock i)
blockMap
    in
        --Assert we placed all blocks given as input
        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
        LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$ (BlockId -> GenBasicBlock i) -> [BlockId] -> [GenBasicBlock i]
forall a b. (a -> b) -> [a] -> [b]
map BlockId -> GenBasicBlock i
getBlock [BlockId]
placedBlocks

dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
          -> [GenBasicBlock i]
dropJumps :: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps _    [] = []
dropJumps info :: LabelMap a
info ((BasicBlock lbl :: BlockId
lbl ins :: [i]
ins):todo :: [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
    , [dest :: BlockId
dest] <- i -> [BlockId]
forall instr. Instruction instr => instr -> [BlockId]
jumpDestsOfInstr ([i] -> i
forall a. [a] -> a
last [i]
ins)
    , ((BasicBlock nextLbl :: BlockId
nextLbl _) : _) <- [GenBasicBlock i]
todo
    , Bool -> Bool
not (KeyOf LabelMap -> LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => KeyOf map -> map a -> Bool
mapMember KeyOf LabelMap
BlockId
dest LabelMap a
info)
    , BlockId
nextLbl BlockId -> BlockId -> Bool
forall a. Eq a => a -> a -> Bool
== BlockId
dest
    = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl ([i] -> [i]
forall a. [a] -> [a]
init [i]
ins) GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo
    | Bool
otherwise
    = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [i]
ins GenBasicBlock i -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. a -> [a] -> [a]
: LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a i.
Instruction i =>
LabelMap a -> [GenBasicBlock i] -> [GenBasicBlock i]
dropJumps LabelMap a
info [GenBasicBlock i]
todo


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

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

sequenceTop
    :: (Instruction instr, Outputable instr)
    => DynFlags -- Determine which layout algo to use
    -> NcgImpl statics instr jumpDest
    -> Maybe CFG -- ^ CFG if we have one.
    -> NatCmmDecl statics instr -- ^ Function to serialize
    -> NatCmmDecl statics instr

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


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

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

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

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

mkNode :: (Instruction t)
       => Maybe CFG -> GenBasicBlock t
       -> Node BlockId (GenBasicBlock t)
mkNode :: Maybe CFG -> GenBasicBlock t -> Node BlockId (GenBasicBlock t)
mkNode edgeWeights :: Maybe CFG
edgeWeights block :: GenBasicBlock t
block@(BasicBlock id :: BlockId
id instrs :: [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 successors :: [(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
            [] -> []
            ((target :: BlockId
target,info :: EdgeInfo
info):_)
              | [(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
> 2 Bool -> Bool -> Bool
|| EdgeInfo -> EdgeWeight
edgeWeight EdgeInfo
info EdgeWeight -> EdgeWeight -> Bool
forall a. Ord a => a -> a -> Bool
<= 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
                [one :: BlockId
one] -> [BlockId
one]
                _many :: [BlockId]
_many -> []


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

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

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


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

-- -------------------------------------------------------------------
-- Some specialized data structures to speed things up:
--  * BlockSequence: A specialized version of Data.Sequence.
--    Better at indexing at the front/end but lacks ability
--    to do lookup by position.

type FrontierMap = LabelMap ([BlockId],BlockChain)

-- | A "reverse zipper" of sorts.
-- We store a list of blocks in two parts, the initial part from left to right
-- and the remaining part stored in reverse order. This makes it easy to look
-- the last/first element and append on both sides.
data BlockSequence
  = Singleton !BlockId
  | Pair (OrdList BlockId) (OrdList BlockId)
    -- ^ For a non empty pair there is at least one element in the left part.
  | Empty

seqFront :: BlockSequence -> BlockId
seqFront :: BlockSequence -> BlockId
seqFront Empty = String -> BlockId
forall a. String -> a
panic "Empty sequence"
seqFront (Singleton bid :: BlockId
bid) = BlockId
bid
seqFront (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) = String -> Maybe BlockId -> BlockId
forall a. HasCallStack => String -> Maybe a -> a
expectJust "Seq invariant" (Maybe BlockId -> BlockId) -> Maybe BlockId -> BlockId
forall a b. (a -> b) -> a -> b
$
    [BlockId] -> Maybe BlockId
forall a. [a] -> Maybe a
listToMaybe (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL OrdList BlockId
lefts) Maybe BlockId -> Maybe BlockId -> Maybe BlockId
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [BlockId] -> Maybe BlockId
forall a. [a] -> Maybe a
listToMaybe (OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a
reverseOL OrdList BlockId
rights)

-- seqEnd :: BlockSequence -> BlockId
-- seqEnd Empty = panic "Empty sequence"
-- seqEnd (Singleton bid) = bid
-- seqEnd (Pair lefts rights) = expectJust "Seq invariant" $
--     listToMaybe (fromOL rights) <|> listToMaybe (fromOL $ reverseOL lefts)

seqToList :: BlockSequence -> [BlockId]
seqToList :: BlockSequence -> [BlockId]
seqToList Empty = []
seqToList (Singleton bid :: BlockId
bid) = [BlockId
bid]
seqToList (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) = OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
lefts OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a
reverseOL OrdList BlockId
rights


seqToRList :: BlockSequence -> [BlockId]
seqToRList :: BlockSequence -> [BlockId]
seqToRList Empty = []
seqToRList (Singleton bid :: BlockId
bid) = [BlockId
bid]
seqToRList (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) = OrdList BlockId -> [BlockId]
forall a. OrdList a -> [a]
fromOL (OrdList BlockId -> [BlockId]) -> OrdList BlockId -> [BlockId]
forall a b. (a -> b) -> a -> b
$ OrdList BlockId
rights OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a
reverseOL OrdList BlockId
lefts

seqSnoc :: BlockSequence -> BlockId -> BlockSequence
seqSnoc :: BlockSequence -> BlockId -> BlockSequence
seqSnoc (BlockSequence
Empty) bid :: BlockId
bid = BlockId -> BlockSequence
Singleton BlockId
bid
seqSnoc (Singleton s :: BlockId
s) bid :: BlockId
bid= OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
s) (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
bid)
seqSnoc (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) bid :: BlockId
bid = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair OrdList BlockId
lefts (BlockId
bid BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BlockId
rights)

seqConcat :: BlockSequence -> BlockSequence -> BlockSequence
seqConcat :: BlockSequence -> BlockSequence -> BlockSequence
seqConcat (BlockSequence
Empty) x2 :: BlockSequence
x2 = BlockSequence
x2
seqConcat (Singleton b1 :: BlockId
b1) (Singleton b2 :: BlockId
b2) = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b1) (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b2)
seqConcat x1 :: BlockSequence
x1 (BlockSequence
Empty) = BlockSequence
x1
seqConcat (Singleton b1 :: BlockId
b1) (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (BlockId
b1 BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BlockId
lefts) OrdList BlockId
rights
seqConcat (Pair lefts :: OrdList BlockId
lefts rights :: OrdList BlockId
rights) (Singleton b2 :: BlockId
b2) = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair OrdList BlockId
lefts (BlockId
b2 BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
`consOL` OrdList BlockId
rights)
seqConcat (Pair lefts1 :: OrdList BlockId
lefts1 rights1 :: OrdList BlockId
rights1) (Pair lefts2 :: OrdList BlockId
lefts2 rights2 :: OrdList BlockId
rights2) =
    OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (OrdList BlockId
lefts1 OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a
reverseOL OrdList BlockId
rights1) OrdList BlockId -> OrdList BlockId -> OrdList BlockId
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList BlockId
lefts2) OrdList BlockId
rights2

seqFromBids :: [BlockId] -> BlockSequence
seqFromBids :: [BlockId] -> BlockSequence
seqFromBids [] = BlockSequence
Empty
seqFromBids [b1 :: BlockId
b1] = BlockId -> BlockSequence
Singleton BlockId
b1
seqFromBids [b1 :: BlockId
b1,b2 :: BlockId
b2] = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b1) (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b2)
seqFromBids [b1 :: BlockId
b1,b2 :: BlockId
b2,b3 :: BlockId
b3] = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair (BlockId -> OrdList BlockId -> OrdList BlockId
forall a. a -> OrdList a -> OrdList a
consOL BlockId
b1 (OrdList BlockId -> OrdList BlockId)
-> OrdList BlockId -> OrdList BlockId
forall a b. (a -> b) -> a -> b
$ BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b2) (BlockId -> OrdList BlockId
forall a. a -> OrdList a
unitOL BlockId
b3)
seqFromBids (b1 :: BlockId
b1:b2 :: BlockId
b2:b3 :: BlockId
b3:bs :: [BlockId]
bs) = OrdList BlockId -> OrdList BlockId -> BlockSequence
Pair ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId
b1,BlockId
b2,BlockId
b3]) ([BlockId] -> OrdList BlockId
forall a. [a] -> OrdList a
toOL [BlockId]
bs)