From cbc6a70b304d332f3964ba49e790a2ccbe78e5ca Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 28 Oct 2007 18:26:09 +0000 Subject: [PATCH] Changed the control-flow graph generation to use the proposed function dictionary, and add the scope-out nodes --- Main.hs | 6 ++++- common/FlowGraph.hs | 54 ++++++++++++++++++++++------------------- common/FlowGraphTest.hs | 33 ++++++++++++++++--------- 3 files changed, 55 insertions(+), 38 deletions(-) diff --git a/Main.hs b/Main.hs index b9ca72c..dbca550 100644 --- a/Main.hs +++ b/Main.hs @@ -22,6 +22,7 @@ module Main (main) where import Control.Monad.Error import Control.Monad.State import Data.Either +import Data.Generics import Data.Maybe import List import System @@ -261,8 +262,11 @@ compile mode fn outHandle ModeParse -> return $ show ast1 ModeFlowGraph -> do procs <- findAllProcesses + let fs :: Data t => t -> PassM String + fs = ((liftM $ (take 20) . (filter ((/=) '\"'))) . pshowCode) + let labelFuncs = GLF fs fs fs fs fs fs graphs <- mapM - ((liftM $ either (const Nothing) Just) . (buildFlowGraph (const (return "")) ((liftM $ (take 20) . (filter ((/=) '\"'))) . pshowCode)) ) + ((liftM $ either (const Nothing) Just) . (buildFlowGraph labelFuncs) ) (map (A.OnlyP emptyMeta) (snd $ unzip $ procs)) --TODO output each process to a separate file, rather than just taking the first: return $ head $ map makeFlowGraphInstr (catMaybes graphs) diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index bf81b6f..127688c 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -41,11 +41,10 @@ with this program. If not, see . -- * If statements, on the other hand, have to be chained together. Each expression is connected -- to its body, but also to the next expression. There is no link between the last expression -- and the end of the if; if statements behave like STOP if nothing is matched. -module FlowGraph (EdgeLabel(..), FNode(..), FlowGraph, buildFlowGraph, makeFlowGraphInstr) where +module FlowGraph (EdgeLabel(..), FNode(..), FlowGraph, GraphLabelFuncs(..), buildFlowGraph, makeFlowGraphInstr) where import Control.Monad.Error import Control.Monad.State -import Data.Generics import Data.Graph.Inductive import qualified AST as A @@ -75,19 +74,32 @@ type NodesEdges a = ([LNode (FNode a)],[LEdge EdgeLabel]) type GraphMaker m a b = ErrorT String (StateT (Node, Int, NodesEdges a) m) b +data Monad m => GraphLabelFuncs m label = GLF { + labelDummy :: Meta -> m label + ,labelProcess :: A.Process -> m label + ,labelExpression :: A.Expression -> m label + ,labelExpressionList :: A.ExpressionList -> m label + ,labelScopeIn :: A.Specification -> m label + ,labelScopeOut :: A.Specification -> m label + } + -- | Builds the instructions to send to GraphViz makeFlowGraphInstr :: Show a => FlowGraph a -> String makeFlowGraphInstr = graphviz' -- The primary reason for having the blank generator take a Meta as an argument is actually for testing. But other uses can simply ignore it if they want. -buildFlowGraph :: Monad m => (Meta -> m a) -> (forall t. Data t => t -> m a) -> A.Structured -> m (Either String (FlowGraph a)) -buildFlowGraph blank f s +buildFlowGraph :: Monad m => GraphLabelFuncs m a -> A.Structured -> m (Either String (FlowGraph a)) +buildFlowGraph funcs s = do res <- runStateT (runErrorT $ buildStructured None s) (0, 0, ([],[]) ) return $ case res 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 + +-- Type commented out because it's not technically correct, but looks right to me: +-- run :: Monad m => (GraphLabelFuncs m a -> (b -> m a)) -> b -> m a + run func = func funcs addNode :: Monad m => (Meta, a) -> GraphMaker m a Node addNode x = do (n,pi,(nodes, edges)) <- get @@ -99,14 +111,13 @@ buildFlowGraph blank f s put (n + 1, pi, (nodes,(start, end, label):edges)) -- Type commented out because it's not technically correct, but looks right to me: --- addNode' :: (Monad m, Data t) => Meta -> t -> GraphMaker m a Node - addNode' m t = do val <- (lift . lift) (f t) - addNode (m, val) +-- addNode' :: Monad m => Meta -> (GraphLabelFuncs m a -> (b -> m a)) -> b -> GraphMaker m a Node + addNode' m f t = do val <- (lift . lift) (run f t) + addNode (m, val) -- Type commented out because it's not technically correct, but looks right to me: -- addDummyNode :: Meta -> GraphMaker m a Node - addDummyNode m = do val <- (lift . lift) (blank m) - addNode (m, val) + addDummyNode m = addNode' m labelDummy m addParEdges :: Monad m => Node -> Node -> [(Node,Node)] -> GraphMaker m a () addParEdges s e pairs = do (n,pi,(nodes,edges)) <- get @@ -152,7 +163,7 @@ buildFlowGraph blank f s return (-1,-1) buildStructured _ (A.OnlyP _ p) = buildProcess p buildStructured outer (A.OnlyC _ (A.Choice m exp p)) - = do nexp <- addNode' m exp + = do nexp <- addNode' m labelExpression exp (nbodys, nbodye) <- buildProcess p addEdge ESeq nexp nbodys case outer of @@ -165,7 +176,7 @@ buildFlowGraph blank f s = do (s,e) <- case opt of (A.Option m es p) -> do - nexp <- addNode' m (A.ExpressionList m es) + nexp <- addNode' m labelExpressionList (A.ExpressionList m es) (nbodys, nbodye) <- buildProcess p addEdge ESeq nexp nbodys return (nexp,nbodye) @@ -177,10 +188,12 @@ buildFlowGraph blank f s _ -> throwError "Option found outside CASE statement" return (s,e) buildStructured outer (A.Spec m spec str) - = do n <- addNode' m spec + = do n <- addNode' m labelScopeIn spec + n' <- addNode' m labelScopeOut spec (s,e) <- buildStructured outer str addEdge ESeq n s - return (n,e) + addEdge ESeq e n' + return (n,n') buildStructured _ s = do n <- addDummyNode (findMeta s) return (n,n) @@ -189,13 +202,13 @@ buildFlowGraph blank f s buildProcess (A.Seq _ s) = buildStructured Seq s buildProcess (A.Par _ _ s) = buildStructured Par s buildProcess (A.While m e p) - = do n <- addNode' m e + = do n <- addNode' m labelExpression e (start, end) <- buildProcess p addEdge ESeq n start addEdge ESeq end n return (n, n) buildProcess (A.Case m e s) - = do nStart <- addNode' (findMeta e) e + = do nStart <- addNode' (findMeta e) labelExpression e nEnd <- addDummyNode m buildStructured (Case (nStart,nEnd)) s return (nStart, nEnd) @@ -204,14 +217,5 @@ buildFlowGraph blank f s nEnd <- addDummyNode m buildStructured (If nStart nEnd) s return (nStart, nEnd) - buildProcess p = do val <- (lift . lift) (f p) - (liftM mkPair) $ addNode (findMeta p, val) - --- TODO keep record of all the types that f is applied to. --- I think it will end up being Process, Specification, Expression, Variant, Alternative, ExpressionList. --- So rather than using generics, we could have a small function dictionary instead. + buildProcess p = do (liftM mkPair) $ addNode' (findMeta p) labelProcess p --- Types definitely applied to: --- A.Specification, A.Process, A.Expression, A.ExpressionList - ---TODO have scopeIn and scopeOut functions for Specification, and accordingly have two nodes produced by Structured diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 1e90a0d..3bf266e 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -71,18 +71,22 @@ showGraph :: (Graph g, Show a, Show b) => g a b -> String showGraph g = " Nodes: " ++ show (labNodes g) ++ " Edges: " ++ show (labEdges g) nextId :: Data t => t -> State (Map.Map Meta Int) Int -nextId t = do mp <- get - case Map.lookup m mp of - Just n -> do put $ Map.adjust ((+) 1) m mp - return n - Nothing -> do put $ Map.insert m 1 mp - return 0 - where m = findMeta t +nextId = nextId' 1 + +nextId' :: Data t => Int -> t -> State (Map.Map Meta Int) Int +nextId' inc t + = do mp <- get + case Map.lookup m mp of + Just n -> do put $ Map.adjust ((+) inc) m mp + return n + Nothing -> do put $ Map.insert m inc mp + return 0 + where m = findMeta t testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test testGraph testName nodes edges proc = TestCase $ - case evalState (buildFlowGraph nextId nextId (A.OnlyP emptyMeta proc)) Map.empty of + case evalState (buildFlowGraph testOps (A.OnlyP emptyMeta proc)) Map.empty of Left err -> assertFailure (testName ++ " graph building failed: " ++ err) Right g -> checkGraphEquality (nodes, edges) g where @@ -95,6 +99,9 @@ testGraph testName nodes edges proc mapPair :: (x -> a) -> (y -> b) -> (x,y) -> (a,b) mapPair f g (x,y) = (f x, g y) + testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int + testOps = GLF nextId nextId nextId nextId (nextId' 100) (nextId' 100) + checkGraphEquality :: (Graph g, Show b, Ord b) => ([(Int, Meta)], [(Int, Int, b)]) -> g (FNode Int) b -> Assertion checkGraphEquality (nodes, edges) g = do let (remainingNodes, nodeLookup, ass) = foldl checkNodeEquality (Map.fromList (map revPair nodes),Map.empty, return ()) (map (mapPair id deNode) $ labNodes g) @@ -132,8 +139,10 @@ testSeq = TestList ,testSeq' 6 [(0,m3),(1,m5),(2,m7),(3,m9)] [(0,1,ESeq),(1,2,ESeq),(2,3,ESeq)] (A.Several m1 [A.Several m1 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7], A.OnlyP m8 sm9]) - ,testSeq' 10 [(0,m1),(1,m4)] [(0,1,ESeq)] (A.Spec m1 (someSpec m2) $ A.OnlyP m3 sm4) - ,testSeq' 11 [(1,m1),(3,m4),(5,m5),(7,m7),(9,m10)] [(1,3,ESeq),(3,5,ESeq),(5,7,ESeq),(7,9,ESeq)] + ,testSeq' 10 [(0,m1),(1,m4),(100,sub m1 100)] [(0,1,ESeq),(1,100,ESeq)] (A.Spec m1 (someSpec m2) $ A.OnlyP m3 sm4) + ,testSeq' 11 + [(1,m1),(3,m4),(5,m5),(7,m7),(9,m10),(101,sub m1 100),(105,sub m5 100),(107,sub m7 100)] + [(1,3,ESeq),(3,101,ESeq),(101,5,ESeq),(5,7,ESeq),(7,9,ESeq),(9,107,ESeq),(107,105,ESeq)] (A.Several m11 [A.Spec m1 (someSpec m2) $ A.OnlyP m3 sm4,A.Spec m5 (someSpec m6) $ A.Spec m7 (someSpec m8) $ A.OnlyP m9 sm10]) ] where @@ -160,8 +169,8 @@ testPar = TestList ,(0,10,EStartPar 1),(11,1,EEndPar 1),(0,9,EStartPar 1),(9,1,EEndPar 1)] (A.Several m1 [A.Several m10 [A.OnlyP m2 sm3,A.OnlyP m4 sm5,A.OnlyP m6 sm7], A.OnlyP m8 sm9]) - ,testPar' 10 [(0,m1), (1, m3), (2, m5), (3,sub m1 1), (4, m6)] - [(0,4,EStartPar 0),(4,1,ESeq),(1,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)] + ,testPar' 10 [(0,m1), (1, m3), (2, m5), (3,sub m1 1), (6, m6),(106,sub m6 100)] + [(0,6,EStartPar 0),(6,1,ESeq),(1,106,ESeq),(106,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)] (A.Several m1 [A.Spec m6 (someSpec m7) $ A.OnlyP m2 sm3,A.OnlyP m4 sm5]) --TODO test nested pars ]