Added support for recording terminator nodes (as well as root nodes) while building the flow graph
This commit is contained in:
Neil Brown
parent
f444d81f89
commit
0746219984
3
Main.hs
3
Main.hs
|
|
@ -306,7 +306,8 @@ 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 A.Process)]) = map (transformMaybe fst) graphs
|
||||
let (graphsTyped :: [Maybe (FlowGraph' Identity String A.Process)])
|
||||
= map (transformMaybe $ \(x,_,_) -> x) graphs
|
||||
-- TODO: output each process to a separate file, rather than just taking the first:
|
||||
liftIO $ hPutStr outHandle $ head $ map makeFlowGraphInstr (catMaybes graphsTyped)
|
||||
ModeCompile ->
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ usageCheckPass :: A.AST -> PassMR A.AST
|
|||
usageCheckPass t = do g' <- buildFlowGraph labelFunctions t
|
||||
(g, roots) <- case g' of
|
||||
Left err -> dieP (findMeta t) err
|
||||
Right (g,rs) -> return (g,rs)
|
||||
Right (g,rs,_) -> return (g,rs)
|
||||
checkPar nodeRep (joinCheckParFunctions checkArrayUsage checkPlainVarUsage) g
|
||||
checkParAssignUsage t
|
||||
checkProcCallArgsUsage t
|
||||
|
|
|
|||
|
|
@ -328,9 +328,10 @@ addNewSubProcFunc :: (Monad mLabel, Monad mAlter) =>
|
|||
addNewSubProcFunc m args body argsRoute
|
||||
= do root <- addNode' m labelStartNode (m, args) (AlterArguments argsRoute)
|
||||
denoteRootNode root
|
||||
bodyNode <- case body of
|
||||
Left (p,route) -> buildProcess p route >>* fst
|
||||
Right (s,route) -> buildStructuredEL s route >>* fst
|
||||
(bodyNode, termNode) <- case body of
|
||||
Left (p,route) -> buildProcess p route
|
||||
Right (s,route) -> buildStructuredEL s route
|
||||
denoteTerminatorNode termNode
|
||||
addEdge ESeq root bodyNode
|
||||
|
||||
buildProcess :: (Monad mLabel, Monad mAlter) => A.Process -> ASTModifier mAlter A.Process structType -> GraphMaker mLabel mAlter label structType (Node, Node)
|
||||
|
|
@ -385,24 +386,29 @@ buildProcess p route = addNode' (findMeta p) labelProcess p (AlterProcess route)
|
|||
-- the parameters, only in the result. The mLabel monad is the monad in
|
||||
-- which the labelling must be done; hence the flow-graph is returned inside
|
||||
-- the label monad.
|
||||
--
|
||||
-- Returns the flow graph, a list of start-roots and a list of terminator nodes
|
||||
-- ("end-roots")
|
||||
buildFlowGraph :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
||||
GraphLabelFuncs mLabel label ->
|
||||
A.AST ->
|
||||
mLabel (Either String (FlowGraph' mAlter label (), [Node]))
|
||||
mLabel (Either String (FlowGraph' mAlter label (), [Node], [Node]))
|
||||
buildFlowGraph funcs s
|
||||
= do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s id
|
||||
= do res <- flip runStateT (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredAST s id
|
||||
return $ case res of
|
||||
(Left err,_) -> Left err
|
||||
(Right _,(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, roots)
|
||||
(Right _,(_,_,(nodes, edges),roots,terminators))
|
||||
-> Right (mkGraph nodes edges, roots, terminators)
|
||||
|
||||
buildFlowGraphP :: forall mLabel mAlter label. (Monad mLabel, Monad mAlter) =>
|
||||
GraphLabelFuncs mLabel label ->
|
||||
A.Structured A.Process ->
|
||||
mLabel (Either String (FlowGraph' mAlter label A.Process, [Node]))
|
||||
mLabel (Either String (FlowGraph' mAlter label A.Process, [Node], [Node]))
|
||||
buildFlowGraphP funcs s
|
||||
= do res <- flip runStateT (0, 0, ([],[]), []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s id
|
||||
= do res <- flip runStateT (0, 0, ([],[]), [], []) $ flip runReaderT funcs $ runErrorT $ buildStructuredSeq s id
|
||||
return $ case res of
|
||||
(Left err,_) -> Left err
|
||||
(Right (root,_),(_,_,(nodes, edges),roots)) -> Right (mkGraph nodes edges, root : roots)
|
||||
(Right (root,_),(_,_,(nodes, edges),roots, terminators))
|
||||
-> Right (mkGraph nodes edges, root : roots, terminators)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -86,7 +86,8 @@ type NodesEdges m a b = ([LNode (FNode' m a b)],[LEdge EdgeLabel])
|
|||
-- * 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 b = (Node, Int, NodesEdges mAlter a b, [Node])
|
||||
-- * The list of terminator nodes thus far (those with no links from them)
|
||||
type GraphMakerState mAlter a b = (Node, Int, NodesEdges mAlter a b, [Node], [Node])
|
||||
|
||||
type GraphMaker mLabel mAlter a b c = ErrorT String (ReaderT (GraphLabelFuncs mLabel a) (StateT (GraphMakerState mAlter a b) mLabel)) c
|
||||
|
||||
|
|
@ -160,21 +161,27 @@ run func x = do f <- asks func
|
|||
lift . lift .lift $ f x
|
||||
|
||||
addNode :: (Monad mLabel, Monad mAlter) => (Meta, label, AlterAST mAlter structType) -> GraphMaker mLabel mAlter label structType Node
|
||||
addNode x = do (n,pi,(nodes, edges), rs) <- get
|
||||
put (n+1, pi,((n, Node x):nodes, edges), rs)
|
||||
addNode x = do (n,pi,(nodes, edges), rs, ts) <- get
|
||||
put (n+1, pi,((n, Node x):nodes, edges), rs, ts)
|
||||
return n
|
||||
|
||||
denoteRootNode :: (Monad mLabel, Monad mAlter) => Node -> GraphMaker mLabel mAlter label structType ()
|
||||
denoteRootNode root = do (n, pi, nes, roots) <- get
|
||||
put (n, pi, nes, root : roots)
|
||||
denoteRootNode root = do (n, pi, nes, roots, ts) <- get
|
||||
put (n, pi, nes, root : roots, ts)
|
||||
|
||||
denoteTerminatorNode :: (Monad mLabel, Monad mAlter) => Node -> GraphMaker mLabel mAlter label structType ()
|
||||
denoteTerminatorNode t = do (n, pi, nes, roots, ts) <- get
|
||||
put (n, pi, nes, roots, t : ts)
|
||||
|
||||
|
||||
addEdge :: (Monad mLabel, Monad mAlter) => EdgeLabel -> Node -> Node -> GraphMaker mLabel mAlter label structType ()
|
||||
addEdge label start end = do (n, pi, (nodes, edges), rs) <- get
|
||||
addEdge label start end = do (n, pi, (nodes, edges), rs, ts) <- 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), rs)
|
||||
else put (n + 1, pi, (nodes,(start, end, label):edges), rs,
|
||||
ts)
|
||||
|
||||
-- It is important for the flow-graph tests that the Meta tag passed in is the same as the
|
||||
-- result of calling findMeta on the third parameter
|
||||
|
|
@ -192,14 +199,14 @@ addDummyNode :: (Monad mLabel, Monad mAlter) => Meta -> GraphMaker mLabel mAlter
|
|||
addDummyNode m = addNode' m labelDummy m AlterNothing
|
||||
|
||||
getNextParEdgeId :: (Monad mLabel, Monad mAlter) => GraphMaker mLabel mAlter label structType Int
|
||||
getNextParEdgeId = do (a, pi, b, c) <- get
|
||||
put (a, pi + 1, b, c)
|
||||
getNextParEdgeId = do (a, pi, b, c, d) <- get
|
||||
put (a, pi + 1, b, c, d)
|
||||
return pi
|
||||
|
||||
addParEdges :: (Monad mLabel, Monad mAlter) => Int -> (Node,Node) -> [(Node,Node)] -> GraphMaker mLabel mAlter label structType ()
|
||||
addParEdges usePI (s,e) pairs
|
||||
= do (n,pi,(nodes,edges),rs) <- get
|
||||
put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs)
|
||||
= do (n,pi,(nodes,edges),rs,ts) <- get
|
||||
put (n,pi,(nodes,edges ++ (concatMap (parEdge usePI) pairs)),rs,ts)
|
||||
where
|
||||
parEdge :: Int -> (Node, Node) -> [LEdge EdgeLabel]
|
||||
parEdge id (a,z) = [(s,a,(EStartPar id)),(z,e,(EEndPar id))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user