-- Manipulate graphs for metadata generation {-# LANGUAGE TupleSections #-} module DDC.Core.Llvm.Metadata.Graph ( -- * Graphs and Trees for TBAA metadata UG(..), DG(..) , orientUG, partitionDG , Tree(..) , sources, anchor -- * Quickcheck Testing ONLY , Dom, Rel , fromList, toList , transClosure, transOrient , aliasMeasure, isTree ) where import Data.List import Data.Ord import Data.Maybe -- Binary relations ----------------------------------------------------------- -- | A binary relation. type Rel a = a -> a -> Bool type Dom a = [a] -- | Convert a relation. toList :: Dom a -> Rel a -> [(a, a)] toList dom r = [ (x, y) | x <- dom, y <- dom, r x y ] -- | Convert a list to a relation. fromList :: Eq a => [(a, a)] -> Rel a fromList s = \x y -> (x,y) `elem` s -- | Union two relations. unionR :: Rel a -> Rel a -> Rel a unionR f g = \x y -> f x y || g x y -- | Find the transitive closure of a binary relation -- using Floyd-Warshall algorithm transClosure :: (Eq a) => Dom a -> Rel a -> Rel a transClosure dom r = fromList $ step dom $ toList dom r where step [] es = es step (_:xs) es = step xs $ nub (es ++ [(a, d) | (a, b) <- es , (c, d) <- es , b == c]) -- Graphs --------------------------------------------------------------------- -- | An undirected graph. newtype UG a = UG (Dom a, Rel a) -- | A directed graph. newtype DG a = DG (Dom a, Rel a) instance Show a => Show (UG a) where show (UG (d,r)) = "UG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")" instance Show a => Show (DG a) where show (DG (d,r)) = "DG (" ++ (show d) ++ ", fromList " ++ (show $ toList d r) ++ ")" instance Show a => Eq (DG a) where a == b = show a == show b neighbourUG :: Rel a -> a -> a -> Bool neighbourUG f v x = f v x || f x v -- | A partition (class) of vertices type Class a = [a] -- | Enforce an ordering on the relation of an undirected graph forceOrder :: Ord a => Class a -> Rel a -> Rel a forceOrder ordering f = let index = fromJust . (flip elemIndex ordering) in \x y -> neighbourUG f x y && index x < index y -- | Set of vertices is not a singleton or empty set nonSingleton :: Class a -> Bool nonSingleton [] = False nonSingleton [_] = False nonSingleton _ = True -- | Use lexicographic breadth-first search on an undirected graph to produce an ordering of the vertices -- lexBFS :: (Show a, Ord a) => UG a -> Class a lexBFS (UG (vertices, f)) = refine [] [vertices] where refine acc classes | any nonSingleton classes = pivot acc classes | otherwise = concat classes ++ acc pivot acc ([vertex]:classes) = refine (vertex:acc) $ classes `splitAllOn` vertex pivot acc ((vertex:vs):classes) = refine (vertex:acc) $ (vs:classes) `splitAllOn` vertex pivot _ _ = error "ddc-core-llvm.lexBFS: bogus warning suppression." splitAllOn [] _ = [] splitAllOn (cl:classes) vertex | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) cl , all (not . null) [neighbours, nonneighbours] = nonneighbours : neighbours : (classes `splitAllOn` vertex) | otherwise = cl : (classes `splitAllOn` vertex) -- | Transitively orient an undireted graph -- -- Using the algorithm from -- "Lex-BFS and partition refinement, with applications to transitive orientation, interval -- graph recognition and consecutive ones testing", R. McConnell et al 2000 -- -- In the case where the transitive orientation does not exist, it simply gives some orientation -- -- note: gave up on modular decomposition, this approach has very slightly worse time -- complexity but much simpler -- transOrient :: (Show a, Ord a) => UG a -> DG a transOrient g@(UG (vertices, f)) = let vertices' = refine $ [(lexBFS g, maxBound)] in DG (vertices, forceOrder vertices' f) where refine classes | any nonSingleton $ map fst classes = let (before, after) = partition (\(c,lastused) -> length c > lastused `div` 2) classes in refine (splitOthers before after) | otherwise = concatMap fst classes -- Split all other classes with respect to each member of a pivot class splitOthers before [] = splitLargest (largestClass before) before splitOthers before ((pivot,_):after) = foldl' (split True) before pivot ++ [(pivot, length pivot)] ++ foldl' (split False) after pivot -- Split a class cl with regard to some vertex split _ [] _ = [] split isBefore (cl:classes) vertex | (neighbours, nonneighbours) <- partition (neighbourUG f vertex) $ fst cl , all (not . null) [neighbours, nonneighbours] = let lastused = snd cl in if isBefore then (nonneighbours, lastused) : (neighbours, lastused) : (split isBefore classes vertex) else (neighbours, lastused) : (nonneighbours, lastused) : (split isBefore classes vertex) | otherwise = cl:classes -- Split the largest class by the last vertex in the class found by lexBFS splitLargest _ [] = [] splitLargest cl ((cs, lastused):css) | cl == cs = (tail cs, lastused) : ([head cs], maxBound) : css | otherwise = (cs, lastused) : (splitLargest cl css) largestClass [] = [] largestClass classes = maximumBy (comparing length) $ map fst classes orientUG :: (Show a, Ord a) => UG a -> DG a orientUG = transOrient -- | A vertex partitioning of a graph. type Partitioning a = [Class a] -- | Generate all possible partitions of a list -- by nondeterministically decide which sublist to add an element to. partitionings :: Eq a => [a] -> [Partitioning a] partitionings [] = [[]] partitionings (x:xs) = concatMap (nondetPut x) $ partitionings xs where nondetPut :: a -> Partitioning a -> [Partitioning a] nondetPut y [] = [ [[y]] ] nondetPut y (l:ls) = let putHere = (y:l):ls putLater = map (l:) $ nondetPut y ls in putHere:putLater -- | Calculate the aliasing induced by a set of trees this includes aliasing -- within each of the trees and aliasing among trees. --- -- ISSUE #298: Need a more efficient way to compute the -- aliasing measure. Currently O(|V|^5) -- aliasMeasure :: Eq a => Rel a -> Partitioning a -> Int aliasMeasure g p = (outerAliasing $ map length p) + (sum $ map innerAliasing p) where innerAliasing t = length $ toList t $ transClosure t g outerAliasing (l:ls) = l * (sum ls) + outerAliasing ls outerAliasing [] = 0 -- Trees ---------------------------------------------------------------------- -- | An inverted tree (with edges going from child to parent) newtype Tree a = Tree (Dom a, Rel a) instance Show a => Show (Tree a) where show (Tree (d,r)) = "tree (" ++ (show d) ++ ", " ++ (show $ toList d r) ++ ")" -- | A relation is an (inverted) tree if each node has at most one outgoing arc isTree :: Dom a -> Rel a -> Bool isTree dom r = let neighbours x = filter (r x) dom in all ((<=1) . length . neighbours) dom -- | Get the sources of a tree. sources :: Eq a => a -> Tree a -> [a] sources x (Tree (d, r)) = [y | y <- d, r y x] -- | Partition a DG into the minimum set of (directed) trees -- partitionDG :: Eq a => DG a -> [Tree a] partitionDG (DG (d,g)) = let mkGraph g' nodes = (nodes, fromList [ (x,y) | x <- nodes, y <- nodes, g' x y ]) in map Tree $ fromMaybe (error "ddc-core-llvm.partitionDG: no partition found!") $ find (all $ uncurry isTree) $ map (map (mkGraph g)) $ sortBy (comparing (aliasMeasure g)) $ partitionings d -- | Enroot a tree with the given root. anchor :: Eq a => a -> Tree a -> Tree a anchor root (Tree (d,g)) = let leaves = filter (null . flip filter d . g) d arcs = map (, root) leaves in Tree (root:d, g `unionR` fromList arcs)