Small optimizations to BlockLayout.

* Remove `takeL/R 1` occurences by lastOL/headOL.

* Make BlockChain a OrdList newtype by removing the set of blocks.

Initially BlockChain contained both, a set for membership test
and a ordered list of blocks. The set is not used for any
performance sensitive lookups so we get rid of it.

1 files changed, 31 insertions, 39 deletions

diff --git a/compiler/nativeGen/BlockLayout.hs b/compiler/nativeGen/BlockLayout.hs
index 6ff0e06be2..51ff34d028 100644
--- a/compiler/nativeGen/BlockLayout.hs
+++ b/compiler/nativeGen/BlockLayout.hs
@@ -222,27 +222,25 @@ type FrontierMap = LabelMap ([BlockId],BlockChain)
 --
 --   We use OrdList instead of [] to allow fast append on both sides
 --   when combining chains.
-data BlockChain
-    = BlockChain
-    { chainMembers :: !LabelSet
-    , chainBlocks :: !(OrdList BlockId)
-    }
+newtype BlockChain
+    = BlockChain { chainBlocks :: (OrdList BlockId) }
 
 instance Eq (BlockChain) where
-    (BlockChain s1 _) == (BlockChain s2 _)
-        = s1 == s2
+    (BlockChain blks1) == (BlockChain blks2)
+        = fromOL blks1 == fromOL blks2
+
+-- Useful for things like sets and debugging purposes, sorts by blocks
+-- in the chain.
+instance Ord (BlockChain) where
+   (BlockChain lbls1) `compare` (BlockChain lbls2)
+       = (fromOL lbls1) `compare` (fromOL lbls2)
 
 instance Outputable (BlockChain) where
-    ppr (BlockChain _ blks) =
+    ppr (BlockChain blks) =
         parens (text "Chain:" <+> ppr (fromOL $ 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
@@ -270,54 +268,48 @@ noDups chains =
         else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False
 
 inFront :: BlockId -> BlockChain -> Bool
-inFront bid (BlockChain _ seq)
+inFront bid (BlockChain seq)
   = headOL seq == bid
 
 chainMember :: BlockId -> BlockChain -> Bool
 chainMember bid chain
-  = setMember bid . chainMembers $ chain
+  = elem bid $ fromOL . chainBlocks $ chain
+--   = setMember bid . chainMembers $ chain
 
 chainSingleton :: BlockId -> BlockChain
 chainSingleton lbl
-    = BlockChain (setSingleton lbl) (unitOL lbl)
+    = BlockChain (unitOL lbl)
 
 chainSnoc :: BlockChain -> BlockId -> BlockChain
-chainSnoc (BlockChain lbls blks) lbl
-  = BlockChain (setInsert lbl lbls) (blks `snocOL` lbl)
+chainSnoc (BlockChain blks) lbl
+  = BlockChain (blks `snocOL` lbl)
 
 chainConcat :: BlockChain -> BlockChain -> BlockChain
-chainConcat (BlockChain lbls1 blks1) (BlockChain lbls2 blks2)
-  = BlockChain (setUnion lbls1 lbls2) (blks1 `appOL` blks2)
+chainConcat (BlockChain blks1) (BlockChain blks2)
+  = BlockChain (blks1 `appOL` blks2)
 
 chainToBlocks :: BlockChain -> [BlockId]
-chainToBlocks (BlockChain _ blks) = fromOL 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.
 breakChainAt :: BlockId -> BlockChain
              -> (BlockChain,BlockChain)
-breakChainAt bid (BlockChain lbls blks)
-    | not (setMember bid lbls)
+breakChainAt bid (BlockChain blks)
+    | not (bid == head rblks)
     = panic "Block not in chain"
     | otherwise
-    = let (lblks, rblks) = break (\lbl -> lbl == bid)
-                                 (fromOL blks)
-          --TODO: Remove old
-          --lblSet :: [GenBasicBlock i] -> BlockChain
-          --lblSet blks =
-          --  setFromList
-                --(map (\(BasicBlock lbl _) -> lbl) $ toList blks)
-      in
-      (BlockChain (setFromList lblks) (toOL lblks),
-       BlockChain (setFromList rblks) (toOL rblks))
+    = (BlockChain (toOL lblks),
+       BlockChain (toOL rblks))
+  where
+    (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks)
 
 takeR :: Int -> BlockChain -> [BlockId]
-takeR n (BlockChain _ blks) =
+takeR n (BlockChain blks) =
     take n . fromOLReverse $ blks
 
-
 takeL :: Int -> BlockChain -> [BlockId]
-takeL n (BlockChain _ blks) = --error "TODO: takeLn"
+takeL n (BlockChain blks) =
     take n . fromOL $ blks
 
 -- | For a given list of chains try to fuse chains with strong
@@ -329,7 +321,7 @@ fuseChains :: WeightedEdgeList -> LabelMap BlockChain
            -> (LabelMap BlockChain, Set.Set WeightedEdge)
 fuseChains weights chains
     = let fronts = mapFromList $
-                    map (\chain -> (head $ takeL 1 chain,chain)) $
+                    map (\chain -> (headOL . chainBlocks $ chain,chain)) $
                     mapElems chains :: LabelMap BlockChain
           (chains', used, _) = applyEdges weights chains fronts Set.empty
       in (chains', used)
@@ -348,8 +340,8 @@ fuseChains weights chains
             , Just c2 <- mapLookup to chainsFront
             , c1 /= c2
             = let newChain = chainConcat c1 c2
-                  front = head $ takeL 1 newChain
-                  end = head $ takeR 1 newChain
+                  front = headOL . chainBlocks $ newChain
+                  end = lastOL . chainBlocks $ newChain
                   chainsFront' = mapInsert front newChain $
                                  mapDelete to chainsFront
                   chainsEnd'   = mapInsert end newChain $