diff --git a/Main.hs b/Main.hs index ecfbd15..4eaa4a0 100644 --- a/Main.hs +++ b/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 -> diff --git a/checks/Check.hs b/checks/Check.hs index c397aef..5e218e4 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -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 diff --git a/flow/FlowGraph.hs b/flow/FlowGraph.hs index a1c0abf..b6ba7b0 100644 --- a/flow/FlowGraph.hs +++ b/flow/FlowGraph.hs @@ -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) diff --git a/flow/FlowUtils.hs b/flow/FlowUtils.hs index 54b8b6e..946a5a4 100644 --- a/flow/FlowUtils.hs +++ b/flow/FlowUtils.hs @@ -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))]