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

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

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