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 --Use new layout code
        -> NcgImpl statics instr jumpDest -> CFG
        -> NatCmmDecl statics instr -> 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
      = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
                                sequenceChain info edgeWeights blocks )
      | otherwise
      --Use old algorithm
      = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
                                sequenceBlocks cfg info blocks)
      where
        cfg
          | (gopt Opt_WeightlessBlocklayout dflags) ||
            (not $ backendMaintainsCfg dflags)
          -- Don't make use of cfg in the old algorithm
          = Nothing
          -- Use cfg in the old algorithm
          | otherwise = Just edgeWeights

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