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

@@ -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
 

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

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 <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)

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 <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
+ ]

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 {