Added the initial implementation of a module (and tests) for generating a control-flow graph from an AST
This implementation needs to be changed; it currently uses Meta as a primary key for nodes, but that isn't valid.
This commit is contained in:
Neil Brown
parent
9fd67023b7
commit
f0c552663b
|
|
@ -54,7 +54,7 @@ tock_SOURCES += frontends/LexOccam.x frontends/LexRain.x
|
|||
tock_SOURCES += common/Pass.hs common/TreeUtil.hs common/Intrinsics.hs common/EvalLiterals.hs
|
||||
tock_SOURCES += common/Pattern.hs common/Errors.hs common/ShowCode.hs common/PrettyShow.hs
|
||||
tock_SOURCES += common/EvalConstants.hs common/Utils.hs common/CompState.hs common/Types.hs
|
||||
tock_SOURCES += common/Metadata.hs common/AST.hs
|
||||
tock_SOURCES += common/Metadata.hs common/AST.hs common/FlowGraph.hs
|
||||
tock_SOURCES += backends/TLP.hs backends/BackendPasses.hs backends/AnalyseAsm.hs
|
||||
tock_SOURCES += backends/GenerateC.hs backends/GenerateCPPCSP.hs
|
||||
tock_SOURCES += Main.hs
|
||||
|
|
@ -62,7 +62,7 @@ tock_SOURCES += Main.hs
|
|||
tocktest_SOURCES = $(tock_SOURCES)
|
||||
tocktest_SOURCES += transformations/PassTest.hs transformations/UsageCheckTest.hs
|
||||
tocktest_SOURCES += backends/GenerateCTest.hs backends/BackendPassesTest.hs
|
||||
tocktest_SOURCES += common/TestUtil.hs common/CommonTest.hs
|
||||
tocktest_SOURCES += common/TestUtil.hs common/CommonTest.hs common/FlowGraphTest.hs
|
||||
tocktest_SOURCES += frontends/ParseRainTest.hs frontends/RainPassesTest.hs frontends/RainTypesTest.hs
|
||||
tocktest_SOURCES += TestMain.hs
|
||||
|
||||
|
|
|
|||
|
|
@ -22,6 +22,10 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
--
|
||||
-- * "CommonTest"
|
||||
--
|
||||
-- * "FlowGraphTest"
|
||||
--
|
||||
-- * "GenerateCTest"
|
||||
--
|
||||
-- * "PassTest"
|
||||
--
|
||||
-- * "RainParseTest"
|
||||
|
|
@ -35,6 +39,7 @@ import Test.HUnit
|
|||
|
||||
import qualified BackendPassesTest (tests)
|
||||
import qualified CommonTest (tests)
|
||||
import qualified FlowGraphTest (tests)
|
||||
import qualified GenerateCTest (tests)
|
||||
import qualified ParseRainTest (tests)
|
||||
import qualified PassTest (tests)
|
||||
|
|
@ -47,6 +52,7 @@ main = do runTestTT $ TestList
|
|||
[
|
||||
BackendPassesTest.tests
|
||||
,CommonTest.tests
|
||||
,FlowGraphTest.tests
|
||||
,GenerateCTest.tests
|
||||
,ParseRainTest.tests
|
||||
,PassTest.tests
|
||||
|
|
|
|||
86
common/FlowGraph.hs
Normal file
86
common/FlowGraph.hs
Normal file
|
|
@ -0,0 +1,86 @@
|
|||
{-
|
||||
Tock: a compiler for parallel languages
|
||||
Copyright (C) 2007 University of Kent
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the GNU General Public License as published by the
|
||||
Free Software Foundation, either version 2 of the License, or (at your
|
||||
option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along
|
||||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
module FlowGraph (EdgeLabel(..), FlowGraph, buildFlowGraph) where
|
||||
|
||||
import Control.Monad.Error
|
||||
import Control.Monad.State
|
||||
import Data.Generics
|
||||
import Data.Graph.Inductive
|
||||
|
||||
import qualified AST as A
|
||||
import Metadata
|
||||
import Utils
|
||||
|
||||
data EdgeLabel = EChoice | ESeq | EPar deriving (Show, Eq, Ord)
|
||||
|
||||
data OuterType = None | Seq | Par
|
||||
|
||||
type FNode a = (Meta, a)
|
||||
--type FEdge = (Node, EdgeLabel, Node)
|
||||
|
||||
type FlowGraph a = Gr (FNode a) EdgeLabel
|
||||
|
||||
type NodesEdges a = ([LNode (FNode a)],[LEdge EdgeLabel])
|
||||
|
||||
type GraphMaker a b = ErrorT String (State (Node, NodesEdges a)) b
|
||||
|
||||
|
||||
buildFlowGraph :: a -> (forall t. Data t => t -> a) -> A.Structured -> Either String (FlowGraph a)
|
||||
buildFlowGraph blank f s = case runState (runErrorT $ buildStructured None s) (0, ([],[]) ) of
|
||||
(Left err,_) -> Left err
|
||||
(_,(_,(nodes, edges))) -> Right (mkGraph nodes edges)
|
||||
where
|
||||
-- All the functions return the new graph, and the identifier of the node just added
|
||||
|
||||
addNode :: FNode a -> GraphMaker a Node
|
||||
addNode x = do (n,(nodes, edges)) <- get
|
||||
put (n+1, ((n, x):nodes, edges))
|
||||
return n
|
||||
|
||||
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker a ()
|
||||
addEdge label start end = do (n, (nodes, edges)) <- get
|
||||
put (n + 1, (nodes,(start, end, label):edges))
|
||||
|
||||
-- Type commented out because it's not technically correct, but looks right to me:
|
||||
-- addDummyNode :: Meta -> GraphMaker a Node
|
||||
addDummyNode m = addNode (m, blank)
|
||||
|
||||
-- Returns a pair of beginning-node, end-node
|
||||
-- Type commented out because it's not technically correct, but looks right to me:
|
||||
-- buildStructured :: OuterType -> A.Structured -> GraphMaker a (Node, Node)
|
||||
buildStructured outer (A.Several m ss)
|
||||
= do nodes <- mapM (buildStructured outer) ss
|
||||
case outer of
|
||||
None -> throwError "Cannot handle Several without an outer context"
|
||||
Seq -> do sequence_ $ mapPairs (\(_,s) (e,_) -> addEdge ESeq s e) nodes
|
||||
case nodes of
|
||||
[] -> do n <- addDummyNode m
|
||||
return (n,n)
|
||||
_ -> return (fst (head nodes), snd (last nodes))
|
||||
Par -> do nStart <- addDummyNode m
|
||||
nEnd <- addDummyNode m
|
||||
mapM (\(a,z) -> addEdge EPar nStart a >> addEdge ESeq z nEnd) nodes
|
||||
return (nStart, nEnd)
|
||||
buildStructured _ (A.OnlyP _ p) = buildProcess p
|
||||
|
||||
-- Type commented out because it's not technically correct, but looks right to me:
|
||||
-- buildProcess :: A.Process -> GraphMaker a (Node, Node)
|
||||
buildProcess (A.Seq _ s) = buildStructured Seq s
|
||||
buildProcess (A.Par _ _ s) = buildStructured Par s
|
||||
buildProcess p@(A.Skip m) = (liftM mkPair) $ addNode (m, f p)
|
||||
122
common/FlowGraphTest.hs
Normal file
122
common/FlowGraphTest.hs
Normal file
|
|
@ -0,0 +1,122 @@
|
|||
{-
|
||||
Tock: a compiler for parallel languages
|
||||
Copyright (C) 2007 University of Kent
|
||||
|
||||
This program is free software; you can redistribute it and/or modify it
|
||||
under the terms of the GNU General Public License as published by the
|
||||
Free Software Foundation, either version 2 of the License, or (at your
|
||||
option) any later version.
|
||||
|
||||
This program is distributed in the hope that it will be useful, but
|
||||
WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public License along
|
||||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
module FlowGraphTest (tests) where
|
||||
|
||||
import Data.Generics
|
||||
import Data.Graph.Inductive
|
||||
import Data.List
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe
|
||||
import Test.HUnit hiding (Node, State)
|
||||
|
||||
import qualified AST as A
|
||||
import FlowGraph
|
||||
import Metadata
|
||||
import Utils
|
||||
|
||||
makeMeta :: Int -> Meta
|
||||
makeMeta n = Meta (Just "FlowGraphTest") n n
|
||||
|
||||
-- To make typing the tests as short as possible:
|
||||
m0 = makeMeta 0
|
||||
m1 = makeMeta 1
|
||||
m2 = makeMeta 2
|
||||
m3 = makeMeta 3
|
||||
m4 = makeMeta 4
|
||||
|
||||
sm0 = A.Skip m0
|
||||
sm1 = A.Skip m1
|
||||
sm2 = A.Skip m2
|
||||
sm3 = A.Skip m3
|
||||
sm4 = A.Skip m4
|
||||
|
||||
showGraph :: Graph g => g a b -> String
|
||||
showGraph g = " Nodes: " ++ show (nodes g) ++ " Edges: " ++ show (edges g)
|
||||
|
||||
testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test
|
||||
testGraph testName nodes edges proc
|
||||
= TestCase $
|
||||
case buildFlowGraph () (const ()) (A.OnlyP emptyMeta proc) of
|
||||
Left err -> assertFailure (testName ++ " graph building failed: " ++ err)
|
||||
Right g -> checkGraphEquality (nodes, edges) g
|
||||
where
|
||||
checkGraphEquality :: (Graph g, Show b, Ord b) => ([(Int, Meta)], [(Int, Int, b)]) -> g (Meta, a) b -> Assertion
|
||||
-- checkGraphEquality ([],[]) g = assertBool (testName ++ " Graph had nodes or edges remaining: " ++ showGraph g) (isEmpty g)
|
||||
checkGraphEquality (nodes, edges) g
|
||||
= do let (remainingNodes, nodeLookup, ass) = ufold checkNodeEquality (Map.fromList (map revPair nodes),Map.empty, return ()) g
|
||||
ass
|
||||
assertBool (testName ++ " Test graph had nodes not found in the real graph: " ++ show remainingNodes) (Map.null remainingNodes)
|
||||
edges' <- mapM (transformEdge nodeLookup) edges
|
||||
let (remainingEdges, ass') = ufold checkEdgeEquality (makeEdgeMap edges',return ()) g
|
||||
ass'
|
||||
assertBool (testName ++ " Test graph had edges not found in the real graph: " ++ show remainingEdges) (Map.null remainingEdges)
|
||||
|
||||
checkNodeEquality :: Show b => Context (Meta, a) b -> (Map.Map Meta Int, Map.Map Int Int, Assertion) -> (Map.Map Meta Int, Map.Map Int Int, Assertion)
|
||||
checkNodeEquality (_linksTo, nodeId, (metaTag,_), _linksFrom) (metaToTestId, realToTestId, ass)
|
||||
= case Map.lookup metaTag metaToTestId of
|
||||
Nothing -> (metaToTestId, realToTestId, ass >> assertFailure ("Node with meta tag " ++ show metaTag ++ " not found in expected test data"))
|
||||
Just testId -> let realToTestId' = Map.insert nodeId testId realToTestId in
|
||||
let metaToTestId' = Map.delete metaTag metaToTestId in
|
||||
(metaToTestId', realToTestId', ass)
|
||||
transformEdge :: Show b => Map.Map Int Int -> (Int, Int, b) -> IO (Int, Int, b)
|
||||
transformEdge nodeMap e@(start, end, label)
|
||||
= case mergeMaybe (Map.lookup start nodeMap) (Map.lookup end nodeMap) of
|
||||
Nothing -> do assertFailure ("Could not map test edge to real edge: " ++ show e)
|
||||
return e
|
||||
Just (start', end') -> return (start', end', label)
|
||||
|
||||
checkEdgeEquality :: (Show b, Ord b) => Context (Meta, a) b -> (Map.Map Int [(Int, Int, b)], Assertion) -> (Map.Map Int [(Int, Int, b)], Assertion)
|
||||
checkEdgeEquality (linksTo, nodeId, _metaTagPair, linksFrom) (nodeToEdges, ass)
|
||||
= (
|
||||
Map.delete nodeId nodeToEdges
|
||||
,ass >> (assertEqual (testName ++ " Edge lists not equal")
|
||||
((sort . concat . maybeToList) $ Map.lookup nodeId nodeToEdges)
|
||||
(sort $ (map (addSrc nodeId) linksFrom) ++ (map (addDest nodeId) linksTo)))
|
||||
)
|
||||
|
||||
addSrc :: Int -> (b, Node) -> (Int, Int, b)
|
||||
addSrc src (x, dest) = (src, dest, x)
|
||||
|
||||
addDest :: Int -> (b, Node) -> (Int, Int, b)
|
||||
addDest dest (x, src) = (src, dest, x)
|
||||
|
||||
makeEdgeMap :: [(Int, Int, b)] -> Map.Map Int [(Int, Int, b)]
|
||||
makeEdgeMap = foldl makeEdgeMap' Map.empty
|
||||
where
|
||||
makeEdgeMap' :: Map.Map Int [(Int, Int, b)] -> (Int,Int,b) -> Map.Map Int [(Int, Int, b)]
|
||||
makeEdgeMap' mp edge@(start, end, label) = Map.insertWith (++) start [edge] (Map.insertWith (++) end [edge] mp)
|
||||
|
||||
testSeq :: Test
|
||||
testSeq = TestList
|
||||
[
|
||||
testSeq' 0 [(0,m1)] [] (A.Several m1 [])
|
||||
,testSeq' 1 [(0,m2)] [] (A.OnlyP m1 sm2)
|
||||
--TODO need some sort of primary key for nodes?
|
||||
--,testSeq' 2 [(0,m1), (1,m2)] [(0,1,ESeq),(1,
|
||||
]
|
||||
where
|
||||
testSeq' :: Int -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
|
||||
testSeq' n a b s = testGraph ("testSeq " ++ show n) a b (A.Seq m0 s)
|
||||
|
||||
--Returns the list of tests:
|
||||
tests :: Test
|
||||
tests = TestList
|
||||
[
|
||||
testSeq
|
||||
]
|
||||
|
|
@ -30,7 +30,7 @@ data Meta = Meta {
|
|||
metaLine :: Int,
|
||||
metaColumn :: Int
|
||||
}
|
||||
deriving (Typeable, Data)
|
||||
deriving (Typeable, Data, Ord)
|
||||
|
||||
emptyMeta :: Meta
|
||||
emptyMeta = Meta {
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user