suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Changed the control-flow graph generation to use the proposed function dictionary, and add the scope-out nodes

Browse Source
This commit is contained in:
Neil Brown 2007-10-28 18:26:09 +00:00
parent adafbd2cc4
commit cbc6a70b30
3 changed files with 55 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Main.hs
View File

@ -22,6 +22,7 @@ module Main (main) where
import Control.Monad.Error import Control.Monad.Error
import Control.Monad.State import Control.Monad.State
import Data.Either import Data.Either
import Data.Generics
import Data.Maybe import Data.Maybe
import List import List
import System import System
@ -261,8 +262,11 @@ compile mode fn outHandle
ModeParse -> return $ show ast1 ModeParse -> return $ show ast1
ModeFlowGraph -> ModeFlowGraph ->
do procs <- findAllProcesses 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 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)) (map (A.OnlyP emptyMeta) (snd $ unzip $ procs))
--TODO output each process to a separate file, rather than just taking the first: --TODO output each process to a separate file, rather than just taking the first:
return $ head $ map makeFlowGraphInstr (catMaybes graphs) return $ head $ map makeFlowGraphInstr (catMaybes graphs)

52
common/FlowGraph.hs
View File

@ -41,11 +41,10 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
-- * If statements, on the other hand, have to be chained together. Each expression is connected -- * 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 -- 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. -- 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.Error
import Control.Monad.State import Control.Monad.State
import Data.Generics
import Data.Graph.Inductive import Data.Graph.Inductive
import qualified AST as A import qualified AST as A
@ -75,13 +74,22 @@ type NodesEdges a = ([LNode (FNode a)],[LEdge EdgeLabel])
type GraphMaker m a b = ErrorT String (StateT (Node, Int, NodesEdges a) m) b 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 -- | Builds the instructions to send to GraphViz
makeFlowGraphInstr :: Show a => FlowGraph a -> String makeFlowGraphInstr :: Show a => FlowGraph a -> String
makeFlowGraphInstr = graphviz' 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. -- 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 :: Monad m => GraphLabelFuncs m a -> A.Structured -> m (Either String (FlowGraph a))
buildFlowGraph blank f s buildFlowGraph funcs s
= do res <- runStateT (runErrorT $ buildStructured None s) (0, 0, ([],[]) ) = do res <- runStateT (runErrorT $ buildStructured None s) (0, 0, ([],[]) )
return $ case res of return $ case res of
(Left err,_) -> Left err (Left err,_) -> Left err
@ -89,6 +97,10 @@ buildFlowGraph blank f s
where where
-- All the functions return the new graph, and the identifier of the node just added -- 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 :: Monad m => (Meta, a) -> GraphMaker m a Node
addNode x = do (n,pi,(nodes, edges)) <- get addNode x = do (n,pi,(nodes, edges)) <- get
put (n+1, pi,((n, Node x):nodes, edges)) put (n+1, pi,((n, Node x):nodes, edges))
@ -99,14 +111,13 @@ buildFlowGraph blank f s
put (n + 1, pi, (nodes,(start, end, label):edges)) put (n + 1, pi, (nodes,(start, end, label):edges))
-- Type commented out because it's not technically correct, but looks right to me: -- 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' :: Monad m => Meta -> (GraphLabelFuncs m a -> (b -> m a)) -> b -> GraphMaker m a Node
addNode' m t = do val <- (lift . lift) (f t) addNode' m f t = do val <- (lift . lift) (run f t)
addNode (m, val) addNode (m, val)
-- Type commented out because it's not technically correct, but looks right to me: -- Type commented out because it's not technically correct, but looks right to me:
-- addDummyNode :: Meta -> GraphMaker m a Node -- addDummyNode :: Meta -> GraphMaker m a Node
addDummyNode m = do val <- (lift . lift) (blank m) addDummyNode m = addNode' m labelDummy m
addNode (m, val)
addParEdges :: Monad m => Node -> Node -> [(Node,Node)] -> GraphMaker m a () addParEdges :: Monad m => Node -> Node -> [(Node,Node)] -> GraphMaker m a ()
addParEdges s e pairs = do (n,pi,(nodes,edges)) <- get addParEdges s e pairs = do (n,pi,(nodes,edges)) <- get
@ -152,7 +163,7 @@ buildFlowGraph blank f s
return (-1,-1) return (-1,-1)
buildStructured _ (A.OnlyP _ p) = buildProcess p buildStructured _ (A.OnlyP _ p) = buildProcess p
buildStructured outer (A.OnlyC _ (A.Choice m exp 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 (nbodys, nbodye) <- buildProcess p
addEdge ESeq nexp nbodys addEdge ESeq nexp nbodys
case outer of case outer of
@ -165,7 +176,7 @@ buildFlowGraph blank f s
= do (s,e) <- = do (s,e) <-
case opt of case opt of
(A.Option m es p) -> do (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 (nbodys, nbodye) <- buildProcess p
addEdge ESeq nexp nbodys addEdge ESeq nexp nbodys
return (nexp,nbodye) return (nexp,nbodye)
@ -177,10 +188,12 @@ buildFlowGraph blank f s
_ -> throwError "Option found outside CASE statement" _ -> throwError "Option found outside CASE statement"
return (s,e) return (s,e)
buildStructured outer (A.Spec m spec str) 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 (s,e) <- buildStructured outer str
addEdge ESeq n s addEdge ESeq n s
return (n,e) addEdge ESeq e n'
return (n,n')
buildStructured _ s = do n <- addDummyNode (findMeta s) buildStructured _ s = do n <- addDummyNode (findMeta s)
return (n,n) return (n,n)
@ -189,13 +202,13 @@ buildFlowGraph blank f s
buildProcess (A.Seq _ s) = buildStructured Seq s buildProcess (A.Seq _ s) = buildStructured Seq s
buildProcess (A.Par _ _ s) = buildStructured Par s buildProcess (A.Par _ _ s) = buildStructured Par s
buildProcess (A.While m e p) buildProcess (A.While m e p)
= do n <- addNode' m e = do n <- addNode' m labelExpression e
(start, end) <- buildProcess p (start, end) <- buildProcess p
addEdge ESeq n start addEdge ESeq n start
addEdge ESeq end n addEdge ESeq end n
return (n, n) return (n, n)
buildProcess (A.Case m e s) buildProcess (A.Case m e s)
= do nStart <- addNode' (findMeta e) e = do nStart <- addNode' (findMeta e) labelExpression e
nEnd <- addDummyNode m nEnd <- addDummyNode m
buildStructured (Case (nStart,nEnd)) s buildStructured (Case (nStart,nEnd)) s
return (nStart, nEnd) return (nStart, nEnd)
@ -204,14 +217,5 @@ buildFlowGraph blank f s
nEnd <- addDummyNode m nEnd <- addDummyNode m
buildStructured (If nStart nEnd) s buildStructured (If nStart nEnd) s
return (nStart, nEnd) return (nStart, nEnd)
buildProcess p = do val <- (lift . lift) (f p) buildProcess p = do (liftM mkPair) $ addNode' (findMeta p) labelProcess 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.
-- 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

25
common/FlowGraphTest.hs
View File

@ -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) showGraph g = " Nodes: " ++ show (labNodes g) ++ " Edges: " ++ show (labEdges g)
nextId :: Data t => t -> State (Map.Map Meta Int) Int nextId :: Data t => t -> State (Map.Map Meta Int) Int
nextId t = do mp <- get 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 case Map.lookup m mp of
Just n -> do put $ Map.adjust ((+) 1) m mp Just n -> do put $ Map.adjust ((+) inc) m mp
return n return n
Nothing -> do put $ Map.insert m 1 mp Nothing -> do put $ Map.insert m inc mp
return 0 return 0
where m = findMeta t where m = findMeta t
testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test
testGraph testName nodes edges proc testGraph testName nodes edges proc
= TestCase $ = 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) Left err -> assertFailure (testName ++ " graph building failed: " ++ err)
Right g -> checkGraphEquality (nodes, edges) g Right g -> checkGraphEquality (nodes, edges) g
where where
@ -95,6 +99,9 @@ testGraph testName nodes edges proc
mapPair :: (x -> a) -> (y -> b) -> (x,y) -> (a,b) mapPair :: (x -> a) -> (y -> b) -> (x,y) -> (a,b)
mapPair f g (x,y) = (f x, g y) 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 :: (Graph g, Show b, Ord b) => ([(Int, Meta)], [(Int, Int, b)]) -> g (FNode Int) b -> Assertion
checkGraphEquality (nodes, edges) g 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) = 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)] ,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]) (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' 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)] [(1,3,ESeq),(3,5,ESeq),(5,7,ESeq),(7,9,ESeq)] ,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]) (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 where
@ -160,8 +169,8 @@ testPar = TestList
,(0,10,EStartPar 1),(11,1,EEndPar 1),(0,9,EStartPar 1),(9,1,EEndPar 1)] ,(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]) (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)] ,testPar' 10 [(0,m1), (1, m3), (2, m5), (3,sub m1 1), (6, m6),(106,sub m6 100)]
[(0,4,EStartPar 0),(4,1,ESeq),(1,3,EEndPar 0), (0,2,EStartPar 0), (2,3,EEndPar 0)] [(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]) (A.Several m1 [A.Spec m6 (someSpec m7) $ A.OnlyP m2 sm3,A.OnlyP m4 sm5])
--TODO test nested pars --TODO test nested pars
] ]