From f0c552663b2dcb556503d772a8c54e2acc7e3209 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 27 Oct 2007 21:18:55 +0000 Subject: [PATCH] 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. --- Makefile.am | 4 +- TestMain.hs | 6 ++ common/FlowGraph.hs | 86 ++++++++++++++++++++++++++++ common/FlowGraphTest.hs | 122 ++++++++++++++++++++++++++++++++++++++++ common/Metadata.hs | 2 +- 5 files changed, 217 insertions(+), 3 deletions(-) create mode 100644 common/FlowGraph.hs create mode 100644 common/FlowGraphTest.hs diff --git a/Makefile.am b/Makefile.am index 4453f34..56c508b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 diff --git a/TestMain.hs b/TestMain.hs index e69c886..87440fe 100644 --- a/TestMain.hs +++ b/TestMain.hs @@ -22,6 +22,10 @@ with this program. If not, see . -- -- * "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 diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs new file mode 100644 index 0000000..6834d28 --- /dev/null +++ b/common/FlowGraph.hs @@ -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 . +-} + +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) diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs new file mode 100644 index 0000000..df517ac --- /dev/null +++ b/common/FlowGraphTest.hs @@ -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 . +-} + +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 + ] diff --git a/common/Metadata.hs b/common/Metadata.hs index e239a50..d2caa24 100644 --- a/common/Metadata.hs +++ b/common/Metadata.hs @@ -30,7 +30,7 @@ data Meta = Meta { metaLine :: Int, metaColumn :: Int } - deriving (Typeable, Data) + deriving (Typeable, Data, Ord) emptyMeta :: Meta emptyMeta = Meta {