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

Changed FlowGraph to keep a record of all the root nodes in the tree and return them in a list

Browse Source
This commit is contained in:
Neil Brown 2008-01-29 12:46:14 +00:00
parent 0a1270f109
commit 5567d8cee0
4 changed files with 40 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Main.hs
View File

@ -48,6 +48,7 @@ import Pass
import PassList
import PreprocessOccam
import PrettyShow
import Utils
type OptFunc = CompState -> IO CompState
@ -260,7 +261,7 @@ compile mode fn outHandle
-- since it is never used. Then we used graphsTyped (rather than graphs)
-- to prevent a compiler warning at graphsTyped being unused;
-- graphs is of course identical to graphsTyped, as you can see here:
let (graphsTyped :: [Maybe (FlowGraph Identity String)]) = graphs
let (graphsTyped :: [Maybe (FlowGraph Identity String)]) = map (transformMaybe fst) graphs
--TODO output each process to a separate file, rather than just taking the first:
return $ head $ map makeFlowGraphInstr (catMaybes graphsTyped)

6
checks/Check.hs
View File

@ -44,12 +44,13 @@ import UsageCheckUtils
usageCheckPass :: Pass
usageCheckPass t = do g' <- buildFlowGraph labelFunctions t
g <- case g' of
(g, roots) <- case g' of
Left err -> dieP (findMeta t) err
Right g -> return g
Right (g,rs) -> return (g,rs)
sequence_ $ checkPar (joinCheckParFunctions checkArrayUsage checkPlainVarUsage) g
checkParAssignUsage t
checkProcCallArgsUsage t
mapM_ (checkInitVar (findMeta t) g) roots
-- TODO add checkInitVar here (need to find roots in the tree)
return t
@ -129,6 +130,7 @@ showCodeExSet (NormalSet s)
-- | Checks that no variable is used uninitialised. That is, it checks that every variable is written to before it is read.
checkInitVar :: forall m. (Monad m, Die m, CSM m) => Meta -> FlowGraph m (Maybe Decl, Vars) -> Node -> m ()
checkInitVar m graph startNode
-- TODO don't pass in all the nodes from the graph, just those connected to startNode
= do vwb <- case flowAlgorithm graphFuncs (nodes graph) startNode of
Left err -> dieP m $ "Error building control-flow graph: " ++ err
Right x -> return x

42
common/FlowGraph.hs
View File

@ -82,6 +82,8 @@ data AlterAST m =
|AlterSpec (ASTModifier m A.Specification)
|AlterNothing
-- | The label for a node. A Meta tag, a custom label, and a function
-- for altering the part of the AST that this node came from
data Monad m => FNode m a = Node (Meta, a, AlterAST m)
--type FEdge = (Node, EdgeLabel, Node)
@ -93,9 +95,17 @@ instance (Monad m, Show a) => Show (FNode m a) where
-- must occur. The a parameter is the type of the node labels.
type FlowGraph m a = Gr (FNode m a) EdgeLabel
-- | A list of nodes and edges. Used for building up the graph.
type NodesEdges m a = ([LNode (FNode m a)],[LEdge EdgeLabel])
type GraphMaker mLabel mAlter a b = ErrorT String (StateT (Node, Int, NodesEdges mAlter a) mLabel) b
-- | The state carried around when building up the graph. In order they are:
-- * The next node identifier
-- * The next identifier for a PAR item (for the EStartPar/EEndPar edges)
-- * The list of nodes and edges to put into the graph
-- * The list of root nodes thus far (those with no links to them)
type GraphMakerState mAlter a = (Node, Int, NodesEdges mAlter a, [Node])
type GraphMaker mLabel mAlter a b = ErrorT String (StateT (GraphMakerState mAlter a) mLabel) b
-- | The GraphLabelFuncs type. These are a group of functions
-- used to provide labels for different elements of AST.
@ -145,12 +155,12 @@ joinLabelFuncs fx fy = GLF
buildFlowGraph :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
GraphLabelFuncs mLabel label ->
A.Structured ->
mLabel (Either String (FlowGraph mAlter label))
mLabel (Either String (FlowGraph mAlter label, [Node]))
buildFlowGraph funcs s
= do res <- runStateT (runErrorT $ buildStructured None s id) (0, 0, ([],[]) )
= do res <- runStateT (runErrorT $ buildStructured None s id) (0, 0, ([],[]), [])
return $ case res of
(Left err,_) -> Left err
(_,(_,_,(nodes, edges))) -> Right (mkGraph nodes edges)
(Right (root,_),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, root : roots)
where
-- All the functions return the new graph, and the identifier of the node just added
@ -158,17 +168,21 @@ buildFlowGraph funcs s
run func = func funcs
addNode :: (Meta, label, AlterAST mAlter) -> GraphMaker mLabel mAlter label Node
addNode x = do (n,pi,(nodes, edges)) <- get
put (n+1, pi,((n, Node x):nodes, edges))
addNode x = do (n,pi,(nodes, edges), rs) <- get
put (n+1, pi,((n, Node x):nodes, edges), rs)
return n
denoteRootNode :: Node -> GraphMaker mLabel mAlter label ()
denoteRootNode root = do (n, pi, nes, roots) <- get
put (n, pi, nes, root : roots)
addEdge :: EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label ()
addEdge label start end = do (n, pi, (nodes, edges)) <- get
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
-- Edges should only be added after the nodes, so
-- for safety here we can check that the nodes exist:
if (notElem start $ map fst nodes) || (notElem end $ map fst nodes)
then throwError "Could not add edge between non-existent nodes"
else put (n + 1, pi, (nodes,(start, end, label):edges))
else put (n + 1, pi, (nodes,(start, end, label):edges), rs)
addNode' :: Meta -> (GraphLabelFuncs mLabel label -> (b -> mLabel label)) -> b -> AlterAST mAlter -> GraphMaker mLabel mAlter label Node
addNode' m f t r = do val <- (lift . lift) (run f t)
@ -184,8 +198,8 @@ buildFlowGraph funcs s
addDummyNode m = addNode' m labelDummy m AlterNothing
addParEdges :: Node -> Node -> [(Node,Node)] -> GraphMaker mLabel mAlter label ()
addParEdges s e pairs = do (n,pi,(nodes,edges)) <- get
put (n,pi+1,(nodes,edges ++ (concatMap (parEdge pi) pairs)))
addParEdges s e pairs = do (n,pi,(nodes,edges),rs) <- get
put (n,pi+1,(nodes,edges ++ (concatMap (parEdge pi) pairs)),rs)
where
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
@ -281,8 +295,12 @@ buildFlowGraph funcs s
-- If it's a process or function spec we must process it too. No need to
-- connect it up to the outer part though
case spec of
(A.Specification _ _ (A.Proc _ _ _ p)) -> buildProcess p (route44 (route33 (route23 route A.Spec) A.Specification) A.Proc) >> return ()
(A.Specification _ _ (A.Function _ _ _ _ s)) -> buildStructured None s (route55 (route33 (route23 route A.Spec) A.Specification) A.Function) >> return ()
(A.Specification _ _ (A.Proc _ _ _ p)) ->
buildProcess p (route44 (route33 (route23 route A.Spec) A.Specification) A.Proc)
>>= denoteRootNode . fst
(A.Specification _ _ (A.Function _ _ _ _ s)) ->
buildStructured None s (route55 (route33 (route23 route A.Spec) A.Specification) A.Function)
>>= denoteRootNode . fst
_ -> return ()
addEdge ESeq n s
addEdge ESeq e n'

6
common/FlowGraphTest.hs
View File

@ -106,12 +106,14 @@ nextId' inc t
testGraph :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Process -> Test
testGraph testName nodes edges proc = testGraph' testName nodes edges (A.OnlyP emptyMeta proc)
--TODO test root nodes too
testGraph' :: String -> [(Int, Meta)] -> [(Int, Int, EdgeLabel)] -> A.Structured -> Test
testGraph' testName nodes edges code
= TestCase $
case evalState (buildFlowGraph testOps code) Map.empty of
Left err -> assertFailure (testName ++ " graph building failed: " ++ err)
Right g -> checkGraphEquality (nodes, edges) (g :: FlowGraph Identity Int)
Right (g,_) -> checkGraphEquality (nodes, edges) (g :: FlowGraph Identity Int)
where
-- Checks two graphs are equal by creating a node mapping from the expected graph to the real map (checkNodeEquality),
-- then mapping the edges across (transformEdge) and checking everything is right (in checkGraphEquality)
@ -535,7 +537,7 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
-- | Generates a flow-graph from the given AST.
-- TODO put this in proper error monad
genGraph :: A.Structured -> FlowGraph Identity ()
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) id $ runIdentity $ buildFlowGraph funcs s
genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " ++ e ++ ", from: " ++ pshow s) fst $ runIdentity $ buildFlowGraph funcs s
where
empty :: a -> Identity ()
empty = const (return ())