path: root/compiler/nativeGen/BlockLayout.hs

--
-- 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 = 2

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


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

instance Eq (BlockChain) where
    (BlockChain s1 _) == (BlockChain s2 _)
        = s1 == s2

instance Outputable (BlockChain) where
    ppr (BlockChain _ blks) =
        parens (text "Chain:" <+> ppr (seqToList $ blks) )

data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)

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

-- | Non deterministic! (Uniques) Sorts edges by weight and nodes.
instance Ord WeightedEdge where
  compare (WeightedEdge from1 to1 weight1)
          (WeightedEdge from2 to2 weight2)
    | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
      weight1 == weight2 && from1 == from2 && to1 < to2
    = LT
    | from1 == from2 && to1 == to2 && weight1 == weight2
    = EQ
    | otherwise
    = GT

instance Outputable WeightedEdge where
    ppr (WeightedEdge from to info) =
        ppr from <> text "->" <> ppr to <> brackets (ppr info)

type WeightedEdgeList = [WeightedEdge]

noDups :: [BlockChain] -> Bool
noDups chains =
    let chainBlocks = concatMap chainToBlocks chains :: [BlockId]
        (_blocks, dups) = removeDups compare chainBlocks
    in if null dups then True
        else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False

inFront :: BlockId -> BlockChain -> Bool
inFront bid (BlockChain _ seq)
  = seqFront seq == bid

chainMember :: BlockId -> BlockChain -> Bool
chainMember bid chain
  = setMember bid . chainMembers $ chain

chainSingleton :: BlockId -> BlockChain
chainSingleton lbl
    = BlockChain (setSingleton lbl) (Singleton lbl)

chainSnoc :: BlockChain -> BlockId -> BlockChain
chainSnoc (BlockChain lbls blks) lbl
  = BlockChain (setInsert lbl lbls) (seqSnoc blks lbl)

chainConcat :: BlockChain -> BlockChain -> BlockChain
chainConcat (BlockChain lbls1 blks1) (BlockChain lbls2 blks2)
  = BlockChain (setUnion lbls1 lbls2) (blks1 `seqConcat` blks2)

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

takeR :: Int -> BlockChain -> [BlockId]
takeR n (BlockChain _ blks) =
    take n . seqToRList $ blks


takeL :: Int -> BlockChain -> [BlockId]
takeL n (BlockChain _ blks) = --error "TODO: takeLn"
    take n . seqToList $ 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 weights chains
    = let fronts = mapFromList $
                    map (\chain -> (head $ takeL 1 chain,chain)) $
                    mapElems chains :: LabelMap BlockChain
          (chains', used, _) = applyEdges weights chains fronts Set.empty
      in (chains', used)
    where
        applyEdges :: WeightedEdgeList -> LabelMap BlockChain
                   -> LabelMap BlockChain -> Set.Set WeightedEdge
                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)
        applyEdges [] chainsEnd chainsFront used
            = (chainsEnd, used, chainsFront)
        applyEdges (edge@(WeightedEdge from to w):edges) chainsEnd chainsFront used
            --Since we order edges descending by weight we can stop here
            | w <= fuseEdgeThreshold
            = ( chainsEnd, used, chainsFront)
            --Fuse the two chains
            | Just c1 <- mapLookup from chainsEnd
            , Just c2 <- mapLookup to chainsFront
            , c1 /= c2
            = let newChain = chainConcat c1 c2
                  front = head $ takeL 1 newChain
                  end = head $ takeR 1 newChain
                  chainsFront' = mapInsert front newChain $
                                 mapDelete to chainsFront
                  chainsEnd'   = mapInsert end newChain $
                                 mapDelete from chainsEnd
              in applyEdges edges chainsEnd' chainsFront'
                            (Set.insert edge used)
            | otherwise
            --Check next edge
            = applyEdges edges chainsEnd chainsFront 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 edges chains
    = -- pprTraceIt "Neigbours" $
      applyEdges edges endFrontier startFrontier
    where
        --Build maps from chain ends to chains
        endFrontier, startFrontier :: FrontierMap
        endFrontier =
            mapFromList $ concatMap (\chain ->
                                let ends = getEnds chain
                                    entry = (ends,chain)
                                in map (\x -> (x,entry)) ends ) chains
        startFrontier =
            mapFromList $ concatMap (\chain ->
                                let front = getFronts chain
                                    entry = (front,chain)
                                in map (\x -> (x,entry)) front) chains
        applyEdges :: WeightedEdgeList -> FrontierMap -> FrontierMap
                   -> [BlockChain]
        applyEdges [] chainEnds _chainFronts =
            ordNub $ map snd $ mapElems chainEnds
        applyEdges ((WeightedEdge from to _w):edges) chainEnds chainFronts
            | Just (c1_e,c1) <- mapLookup from chainEnds
            , Just (c2_f,c2) <- mapLookup to chainFronts
            , c1 /= c2 -- Avoid trying to concat a short chain with itself.
            = let newChain = chainConcat c1 c2
                  newChainFrontier = getFronts newChain
                  newChainEnds = getEnds newChain
                  newFronts :: FrontierMap
                  newFronts =
                    let withoutOld =
                            foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1)
                        entry =
                            (newChainFrontier,newChain) --let bound to ensure sharing
                    in foldl' (\m x -> mapInsert x entry m)
                              withoutOld newChainFrontier

                  newEnds =
                    let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2)
                        entry = (newChainEnds,newChain) --let bound to ensure sharing
                    in foldl' (\m x -> mapInsert x entry m)
                              withoutOld 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
                --   )
                 applyEdges edges newEnds newFronts
            | otherwise
            = --pprTrace "noNeigbours" (ppr ()) $
              applyEdges edges chainEnds chainFronts
         where

        getFronts chain = takeL neighbourOverlapp chain
        getEnds chain = takeR neighbourOverlapp chain



-- See [Chain based CFG serialization]
buildChains :: CFG -> [BlockId]
            -> ( LabelMap BlockChain  -- Resulting chains.
               , Set.Set (BlockId, BlockId)) --List of fused edges.
buildChains succWeights blocks
  = let (_, fusedEdges, chains) = buildNext setEmpty mapEmpty blocks Set.empty
    in (chains, 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 _placed chains [] linked =
        ([], linked, chains)
    buildNext placed chains (block:todo) linked
        | setMember block placed
        = buildNext placed chains todo linked
        | otherwise
        = buildNext placed' chains' todo linked'
      where
        placed' = (foldl' (flip setInsert) placed placedBlocks)
        linked' = Set.union linked linkedEdges
        (placedBlocks, chains', linkedEdges) = findChain 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 block
        -- B) place block at end of existing chain if
        -- there is no better block to append.
          | (pred:_) <- preds
          , alreadyPlaced pred
          , Just predChain <- mapLookup pred chains
          , (best:_) <- filter (not . alreadyPlaced) $ getSuccs pred
          , best == lbl
          = --pprTrace "B.2)" (ppr (pred,lbl)) $
            let newChain = chainSnoc predChain block
                chainMap = mapInsert lbl newChain $ mapDelete pred chains
            in  ( [lbl]
                , chainMap
                , Set.singleton (pred,lbl) )

          | otherwise
          = --pprTrace "single" (ppr lbl)
            ( [lbl]
            , mapInsert lbl (chainSingleton lbl) chains
            , Set.empty)
            where
              alreadyPlaced blkId = (setMember blkId placed)
              lbl = block
              getSuccs = map fst . getSuccEdgesSorted succWeights
              preds = map fst $ getSuccEdgesSorted predWeights lbl
    --For efficiency we also create the map to look up predecessors here
    predWeights = reverseEdges 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 (BN (lbl,_))   = lbl
  successors (BN (_,succs)) = succs

fromNode :: BlockNode C C -> BlockId
fromNode (BN x) = fst x

sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG
            -> [GenBasicBlock i] -> [GenBasicBlock i]
sequenceChain _info _weights    [] = []
sequenceChain _info _weights    [x] = [x]
sequenceChain  info weights'     blocks@((BasicBlock 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
            = filterEdges (\_f _t edgeInfo -> edgeWeight edgeInfo > 0) weights'
        blockMap :: LabelMap (GenBasicBlock i)
        blockMap
            = foldl' (\m blk@(BasicBlock lbl _ins) ->
                        mapInsert lbl blk m)
                     mapEmpty blocks

        toNode :: BlockId -> BlockNode C C
        toNode bid =
            -- sorted such that heavier successors come first.
            BN (bid,map fst . getSuccEdgesSorted weights' $ bid)

        orderedBlocks :: [BlockId]
        orderedBlocks
            = map fromNode $
              revPostorderFrom (fmap (toNode . blockId) blockMap) entry

        (builtChains, builtEdges)
            = {-# SCC "buildChains" #-}
              --pprTraceIt "generatedChains" $
              --pprTrace "orderedBlocks" (ppr orderedBlocks) $
              buildChains weights orderedBlocks

        rankedEdges :: WeightedEdgeList
        -- Sort edges descending, remove fused eges
        rankedEdges =
            map (\(from, to, weight) -> WeightedEdge from to weight) .
            filter (\(from, to, _)
                        -> not (Set.member (from,to) builtEdges)) .
            sortWith (\(_,_,w) -> - w) $ weightedEdgeList weights

        (fusedChains, fusedEdges)
            = ASSERT(noDups $ mapElems builtChains)
              {-# SCC "fuseChains" #-}
              --(pprTrace "RankedEdges" $ ppr rankedEdges) $
              --pprTraceIt "FusedChains" $
              fuseChains rankedEdges builtChains

        rankedEdges' =
            filter (\edge -> not $ Set.member edge fusedEdges) $ rankedEdges

        neighbourChains
            = ASSERT(noDups $ mapElems fusedChains)
              {-# SCC "groupNeighbourChains" #-}
              --pprTraceIt "ResultChains" $
              combineNeighbourhood rankedEdges' (mapElems fusedChains)

        --Make sure the first block stays first
        ([entryChain],chains')
            = ASSERT(noDups $ neighbourChains)
              partition (chainMember entry) neighbourChains
        (entryChain':entryRest)
            | inFront entry entryChain = [entryChain]
            | (rest,entry) <- breakChainAt entry entryChain
            = [entry,rest]
            | otherwise = pprPanic "Entry point eliminated" $
                            ppr ([entryChain],chains')

        prepedChains
            = entryChain':(entryRest++chains') :: [BlockChain]
        blockList
            -- = (concatMap chainToBlocks prepedChains)
            = (concatMap seqToList $ map chainBlocks prepedChains)

        --chainPlaced = setFromList $ map blockId blockList :: LabelSet
        chainPlaced = setFromList $ blockList :: LabelSet
        unplaced =
            let blocks = mapKeys blockMap
                isPlaced b = setMember (b) chainPlaced
            in filter (\block -> not (isPlaced block)) blocks

        placedBlocks =
            --pprTraceIt "placedBlocks" $
            blockList ++ unplaced
        getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap
    in
        --Assert we placed all blocks given as input
        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
        dropJumps info $ map getBlock placedBlocks

dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
          -> [GenBasicBlock i]
dropJumps _    [] = []
dropJumps info ((BasicBlock lbl ins):todo)
    | not . null $ ins --This can happen because of shortcutting
    , [dest] <- jumpDestsOfInstr (last ins)
    , ((BasicBlock nextLbl _) : _) <- todo
    , not (mapMember dest info)
    , nextLbl == dest
    = BasicBlock lbl (init ins) : dropJumps info todo
    | otherwise
    = BasicBlock lbl ins : dropJumps info 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 _     _       _           top@(CmmData _ _) = top
sequenceTop dflags ncgImpl edgeWeights
            (CmmProc info lbl live (ListGraph blocks))
  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg dflags
  --Use chain based algorithm
  , Just cfg <- edgeWeights
  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
                            {-# SCC layoutBlocks #-}
                            sequenceChain info cfg blocks )
  | otherwise
  --Use old algorithm
  = let cfg = if dontUseCfg then Nothing else edgeWeights
    in  CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
                                {-# SCC layoutBlocks #-}
                                sequenceBlocks cfg info blocks)
  where
    dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
                 (not $ backendMaintainsCfg 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 _edgeWeight _ [] = []
sequenceBlocks edgeWeights infos (entry:blocks) =
    let entryNode = mkNode edgeWeights entry
        bodyNodes = reverse
                    (flattenSCCs (sccBlocks edgeWeights blocks))
    in dropJumps infos . seqBlocks infos $ ( entryNode : 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 edgeWeights blocks =
    stronglyConnCompFromEdgedVerticesUniqR
        (map (mkNode edgeWeights) blocks)

mkNode :: (Instruction t)
       => Maybe CFG -> GenBasicBlock t
       -> Node BlockId (GenBasicBlock t)
mkNode edgeWeights block@(BasicBlock id instrs) =
    DigraphNode block id outEdges
  where
    outEdges :: [BlockId]
    outEdges
      --Select the heaviest successor, ignore weights <= zero
      = successor
      where
        successor
          | Just successors <- fmap (`getSuccEdgesSorted` id)
                                    edgeWeights -- :: Maybe [(Label, EdgeInfo)]
          = case successors of
            [] -> []
            ((target,info):_)
              | length successors > 2 || edgeWeight info <= 0 -> []
              | otherwise -> [target]
          | otherwise
          = case jumpDestsOfInstr (last instrs) of
                [one] -> [one]
                _many -> []


seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
                        -> [GenBasicBlock t1]
seqBlocks infos blocks = placeNext pullable0 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 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
    todo0     = map node_key blocks

    placeNext _ [] = []
    placeNext pullable (i:rest)
        | Just (block, pullable') <- lookupDeleteUFM pullable i
        = place pullable' rest block
        | otherwise
        -- We already placed this block, so ignore
        = placeNext pullable rest

    place pullable todo (block,[])
                          = block : placeNext pullable todo
    place pullable todo (block@(BasicBlock id instrs),[next])
        | mapMember next infos
        = block : placeNext pullable todo
        | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
        = BasicBlock id instrs : place pullable' todo nextBlock
        | otherwise
        = block : placeNext pullable todo
    place _ _ (_,tooManyNextNodes)
        = pprPanic "seqBlocks" (ppr tooManyNextNodes)


lookupDeleteUFM :: Uniquable key => UniqFM elt -> key
                -> Maybe (elt, UniqFM elt)
lookupDeleteUFM m k = do -- Maybe monad
    v <- lookupUFM m k
    return (v, delFromUFM m 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 Empty = panic "Empty sequence"
seqFront (Singleton bid) = bid
seqFront (Pair lefts rights) = expectJust "Seq invariant" $
    listToMaybe (fromOL lefts) <|> listToMaybe (fromOL $ reverseOL 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 Empty = []
seqToList (Singleton bid) = [bid]
seqToList (Pair lefts rights) = fromOL $ lefts `appOL` reverseOL rights


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

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

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

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