module DDC.Llvm.Graph
(
Graph (..)
, Node (..)
, graphOfBlocks
, blocksOfGraph
, labelsOfGraph
, lookupNodeOfGraph
, modifyNodeOfGraph
, mapNodesOfGraph
, mapAnnotsOfGraph
, blockOfNode
, childrenOfNode)
where
import DDC.Llvm.Syntax
import Data.Maybe
import Data.Map (Map)
import Data.Set (Set)
import Data.Sequence (Seq)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
data Graph a
= Graph
{
graphEntry :: Label
, graphNodes :: Map Label (Node a) }
deriving Show
data Node a
= Node
{
nodeLabel :: Label
, nodeInstrs :: Seq AnnotInstr
, nodeAnnot :: a }
deriving Show
graphOfBlocks :: a -> [Block] -> Maybe (Graph a)
graphOfBlocks _ [] = Nothing
graphOfBlocks a blocks@(first : _)
= let entry = blockLabel first
nodes = Map.fromList
$ [ (label, Node label stmts a)
| Block label stmts <- blocks ]
in Just $ Graph entry nodes
blocksOfGraph :: Graph a -> [Block]
blocksOfGraph (Graph entry nodes)
= go Set.empty [entry]
where
go _ [] = []
go done (label : more)
= let Just node = Map.lookup label nodes
children = childrenOfNode node
done' = Set.insert label done
more' = Set.toList $ (Set.union (Set.fromList more) children)
`Set.difference` done'
in Block label (nodeInstrs node) : go done' more'
labelsOfGraph :: Graph a -> [Label]
labelsOfGraph graph
= map blockLabel $ blocksOfGraph graph
lookupNodeOfGraph :: Graph a -> Label -> Maybe (Node a)
lookupNodeOfGraph (Graph _ nodes) label
= Map.lookup label nodes
modifyNodeOfGraph
:: Label
-> (Node a -> Node a)
-> Graph a -> Graph a
modifyNodeOfGraph label modify graph@(Graph entry nodes)
= case Map.lookup label nodes of
Nothing -> graph
Just node -> Graph entry (Map.insert label (modify node) nodes)
mapNodesOfGraph :: (Node a -> Node b) -> Graph a -> Graph b
mapNodesOfGraph f (Graph entry nodes)
= Graph entry $ Map.map f nodes
mapAnnotsOfGraph :: (a -> b) -> Graph a -> Graph b
mapAnnotsOfGraph f graph
= let modifyNode (Node label nodes annot) = Node label nodes (f annot)
in mapNodesOfGraph modifyNode graph
blockOfNode :: Node a -> Block
blockOfNode (Node label instrs _)
= Block label instrs
childrenOfNode :: Node a -> Set Label
childrenOfNode node
= case Seq.viewr $ nodeInstrs node of
Seq.EmptyR
-> Set.empty
_ Seq.:> instr
-> fromMaybe Set.empty
$ branchTargetsOfInstr $ annotInstr instr