Replace BlockSequence with OrdList in BlockLayout.hs

OrdList does the same thing and more so there is no reason
to have both.

2 files changed, 45 insertions, 77 deletions

diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
index 72aea5bf10..6ff0e06be2 100644
--- a/compiler/nativeGen/BlockLayout.hs
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -45,7 +45,6 @@ import Data.Foldable (toList)
 import Hoopl.Graph
 
 import qualified Data.Set as Set
-import Control.Applicative
 
 {-
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -211,13 +210,22 @@ neighbourOverlapp = 2
 fuseEdgeThreshold :: EdgeWeight
 fuseEdgeThreshold = 0
 
+-- | Maps blocks near the end of a chain to it's chain AND
+-- the other blocks near the end.
+-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))
+-- where [A,B] are blocks in the end region of a chain.
+-- This is cheaper then recomputing the ends multiple times.
+type FrontierMap = LabelMap ([BlockId],BlockChain)
 
 -- | A non empty ordered sequence of basic blocks.
 --   It is suitable for serialization in this order.
+--
+--   We use OrdList instead of [] to allow fast append on both sides
+--   when combining chains.
 data BlockChain
     = BlockChain
     { chainMembers :: !LabelSet
-    , chainBlocks :: !BlockSequence
+    , chainBlocks :: !(OrdList BlockId)
     }
 
 instance Eq (BlockChain) where
@@ -226,7 +234,7 @@ instance Eq (BlockChain) where
 
 instance Outputable (BlockChain) where
     ppr (BlockChain _ blks) =
-        parens (text "Chain:" <+> ppr (seqToList $ blks) )
+        parens (text "Chain:" <+> ppr (fromOL $ blks) )
 
 data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)
 
@@ -263,7 +271,7 @@ noDups chains =
 
 inFront :: BlockId -> BlockChain -> Bool
 inFront bid (BlockChain _ seq)
-  = seqFront seq == bid
+  = headOL seq == bid
 
 chainMember :: BlockId -> BlockChain -> Bool
 chainMember bid chain
@@ -271,18 +279,18 @@ chainMember bid chain
 
 chainSingleton :: BlockId -> BlockChain
 chainSingleton lbl
-    = BlockChain (setSingleton lbl) (Singleton lbl)
+    = BlockChain (setSingleton lbl) (unitOL lbl)
 
 chainSnoc :: BlockChain -> BlockId -> BlockChain
 chainSnoc (BlockChain lbls blks) lbl
-  = BlockChain (setInsert lbl lbls) (seqSnoc blks lbl)
+  = BlockChain (setInsert lbl lbls) (blks `snocOL` lbl)
 
 chainConcat :: BlockChain -> BlockChain -> BlockChain
 chainConcat (BlockChain lbls1 blks1) (BlockChain lbls2 blks2)
-  = BlockChain (setUnion lbls1 lbls2) (blks1 `seqConcat` blks2)
+  = BlockChain (setUnion lbls1 lbls2) (blks1 `appOL` blks2)
 
 chainToBlocks :: BlockChain -> [BlockId]
-chainToBlocks (BlockChain _ blks) = seqToList blks
+chainToBlocks (BlockChain _ blks) = fromOL blks
 
 -- | Given the Chain A -> B -> C -> D and we break at C
 --   we get the two Chains (A -> B, C -> D) as result.
@@ -293,24 +301,24 @@ breakChainAt bid (BlockChain lbls blks)
     = panic "Block not in chain"
     | otherwise
     = let (lblks, rblks) = break (\lbl -> lbl == bid)
-                                 (seqToList blks)
+                                 (fromOL 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))
+      (BlockChain (setFromList lblks) (toOL lblks),
+       BlockChain (setFromList rblks) (toOL rblks))
 
 takeR :: Int -> BlockChain -> [BlockId]
 takeR n (BlockChain _ blks) =
-    take n . seqToRList $ blks
+    take n . fromOLReverse $ blks
 
 
 takeL :: Int -> BlockChain -> [BlockId]
 takeL n (BlockChain _ blks) = --error "TODO: takeLn"
-    take n . seqToList $ blks
+    take n . fromOL $ blks
 
 -- | For a given list of chains try to fuse chains with strong
 --   edges between them into a single chain.
@@ -389,7 +397,7 @@ combineNeighbourhood edges chains
         endFrontier, startFrontier :: FrontierMap
         endFrontier =
             mapFromList $ concatMap (\chain ->
-                                let ends = getEnds chain
+                                let ends = getEnds chain :: [BlockId]
                                     entry = (ends,chain)
                                 in map (\x -> (x,entry)) ends ) chains
         startFrontier =
@@ -596,7 +604,7 @@ sequenceChain  info weights'     blocks@((BasicBlock entry _):_) =
             = entryChain':(entryRest++chains') :: [BlockChain]
         blockList
             -- = (concatMap chainToBlocks prepedChains)
-            = (concatMap seqToList $ map chainBlocks prepedChains)
+            = (concatMap fromOL $ map chainBlocks prepedChains)
 
         --chainPlaced = setFromList $ map blockId blockList :: LabelSet
         chainPlaced = setFromList $ blockList :: LabelSet
@@ -756,64 +764,3 @@ 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)
diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs
index 064712bbad..2d7a43f228 100644
--- a/compiler/utils/OrdList.hs
+++ b/compiler/utils/OrdList.hs
@@ -12,7 +12,8 @@ can be appended in linear time.
 module OrdList (
         OrdList,
         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,
-        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL
+        headOL,
+        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse
 ) where
 
 import GhcPrelude
@@ -62,14 +63,23 @@ snocOL   :: OrdList a   -> a         -> OrdList a
 consOL   :: a           -> OrdList a -> OrdList a
 appOL    :: OrdList a   -> OrdList a -> OrdList a
 concatOL :: [OrdList a] -> OrdList a
+headOL   :: OrdList a   -> a
 lastOL   :: OrdList a   -> a
 
+
 nilOL        = None
 unitOL as    = One as
 snocOL as   b    = Snoc as b
 consOL a    bs   = Cons a bs
 concatOL aas = foldr appOL None aas
 
+headOL None        = panic "headOL"
+headOL (One a)     = a
+headOL (Many as)   = head as
+headOL (Cons a _)  = a
+headOL (Snoc as _) = headOL as
+headOL (Two as _)  = headOL as
+
 lastOL None        = panic "lastOL"
 lastOL (One a)     = a
 lastOL (Many as)   = last as
@@ -95,6 +105,17 @@ fromOL a = go a []
         go (Two a b)  acc = go a (go b acc)
         go (Many xs)  acc = xs ++ acc
 
+fromOLReverse :: OrdList a -> [a]
+fromOLReverse a = go a []
+        -- acc is already in reverse order
+  where go :: OrdList a -> [a] -> [a]
+        go None       acc = acc
+        go (One a)    acc = a : acc
+        go (Cons a b) acc = go b (a : acc)
+        go (Snoc a b) acc = b : go a acc
+        go (Two a b)  acc = go b (go a acc)
+        go (Many xs)  acc = reverse xs ++ acc
+
 mapOL :: (a -> b) -> OrdList a -> OrdList b
 mapOL _ None = None
 mapOL f (One x) = One (f x)