Commit ff2d6018 authored by Andreas Klebinger's avatar Andreas Klebinger Committed by Ben Gamari

Replace BlockSequence with OrdList in BlockLayout.hs

OrdList does the same thing and more so there is no reason
to have both.
parent 5b970d8e
......@@ -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)
......@@ -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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment