From 12b1617fec73628649664cebde5dadd4941b24cf Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Tue, 29 Jan 2008 20:05:38 +0000 Subject: [PATCH] Added a new labelling function to FlowGraph for labelling the arguments of functions/processes --- Main.hs | 2 +- checks/UsageCheckUtils.hs | 9 +++++++++ common/FlowGraph.hs | 41 +++++++++++++++++++++++++++++++++------ common/FlowGraphTest.hs | 4 ++-- 4 files changed, 47 insertions(+), 9 deletions(-) diff --git a/Main.hs b/Main.hs index 8db18bd..4907516 100644 --- a/Main.hs +++ b/Main.hs @@ -252,7 +252,7 @@ compile mode fn outHandle 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 + let labelFuncs = GLF fs fs fs fs fs fs fs graphs <- mapM ((liftM $ either (const Nothing) Just) . (buildFlowGraph labelFuncs) ) (map (A.OnlyP emptyMeta) (snd $ unzip $ procs)) diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index bb8e081..298a43a 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -26,6 +26,7 @@ import qualified Data.Set as Set import qualified AST as A import Errors import FlowGraph +import Metadata import OrdAST() import ShowCode @@ -174,6 +175,13 @@ getVarSpec = const emptyVars -- TODO getDecl :: (String -> Decl) -> A.Specification -> Maybe Decl getDecl _ _ = Nothing -- TODO +getVarFormals :: Meta -> [A.Formal] -> Vars +getVarFormals m = mapUnionVars (getVarFormal m) + where + -- We treat formal parameters as being written-to, so that they + -- appear initialised at the beginning of the function + getVarFormal :: Meta -> A.Formal -> Vars + getVarFormal m (A.Formal _ _ n) = processVarW $ A.Variable m n labelFunctions :: forall m. Die m => GraphLabelFuncs m (Maybe Decl, Vars) labelFunctions = GLF @@ -182,6 +190,7 @@ labelFunctions = GLF ,labelExpressionList = pair (const Nothing) getVarExpList ,labelDummy = const (return (Nothing, emptyVars)) ,labelProcess = pair (const Nothing) getVarProc + ,labelStartNode = pair (const Nothing) (uncurry getVarFormals) --don't forget about the variables used as initialisers in declarations (hence getVarSpec) ,labelScopeIn = pair (getDecl ScopeIn) getVarSpec ,labelScopeOut = pair (getDecl ScopeOut) (const emptyVars) diff --git a/common/FlowGraph.hs b/common/FlowGraph.hs index 6d75a57..7a60173 100644 --- a/common/FlowGraph.hs +++ b/common/FlowGraph.hs @@ -77,6 +77,7 @@ type ASTModifier m inner = (inner -> m inner) -> (A.Structured -> m A.Structured -- | A choice of AST altering functions built on ASTModifier. data AlterAST m = AlterProcess (ASTModifier m A.Process) + |AlterArguments (ASTModifier m [A.Formal]) |AlterExpression (ASTModifier m A.Expression) |AlterExpressionList (ASTModifier m A.ExpressionList) |AlterSpec (ASTModifier m A.Specification) @@ -116,6 +117,7 @@ type GraphMaker mLabel mAlter a b = ErrorT String (StateT (GraphMakerState mAlte -- can simply ignore it if they want. data Monad m => GraphLabelFuncs m label = GLF { labelDummy :: Meta -> m label + ,labelStartNode :: (Meta, [A.Formal]) -> m label ,labelProcess :: A.Process -> m label ,labelExpression :: A.Expression -> m label ,labelExpressionList :: A.ExpressionList -> m label @@ -132,6 +134,7 @@ joinLabelFuncs :: forall a b m. Monad m => GraphLabelFuncs m a -> GraphLabelFunc joinLabelFuncs fx fy = GLF { labelDummy = joinItem labelDummy, + labelStartNode = joinItem labelStartNode, labelProcess = joinItem labelProcess, labelExpression = joinItem labelExpression, labelExpressionList = joinItem labelExpressionList, @@ -295,12 +298,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) - >>= denoteRootNode . fst - (A.Specification _ _ (A.Function _ _ _ _ s)) -> - buildStructured None s (route55 (route33 (route23 route A.Spec) A.Specification) A.Function) - >>= denoteRootNode . fst + (A.Specification _ _ (A.Proc m _ args p)) -> + let procRoute = (route33 (route23 route A.Spec) A.Specification) in + addNewSubProcFunc m args (Left (p, route44 procRoute A.Proc)) (route34 procRoute A.Proc) + (A.Specification _ _ (A.Function m _ _ args s)) -> + let funcRoute = (route33 (route23 route A.Spec) A.Specification) in + addNewSubProcFunc m args (Right (s, route55 funcRoute A.Function)) (route45 funcRoute A.Function) _ -> return () addEdge ESeq n s addEdge ESeq e n' @@ -308,6 +311,16 @@ buildFlowGraph funcs s -- TODO replicator buildStructured _ s _ = do n <- addDummyNode (findMeta s) return (n,n) + + addNewSubProcFunc :: Meta -> [A.Formal] -> Either (A.Process, ASTModifier mAlter A.Process) (A.Structured, ASTModifier mAlter A.Structured) -> + ASTModifier mAlter [A.Formal] -> GraphMaker mLabel mAlter label () + 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) -> buildStructured None s route >>* fst + addEdge ESeq root bodyNode buildProcess :: A.Process -> ASTModifier mAlter A.Process -> GraphMaker mLabel mAlter label (Node, Node) buildProcess (A.Seq _ s) route = buildStructured Seq s (route22 route A.Seq) @@ -339,10 +352,18 @@ decomp23 con f1 = decomp3 con return f1 return decomp33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => (a0 -> a1 -> a2 -> a) -> (a2 -> m a2) -> (a -> m a) decomp33 con f2 = decomp3 con return return f2 +decomp34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => + (a0 -> a1 -> a2 -> a3 -> a) -> (a2 -> m a2) -> (a -> m a) +decomp34 con f2 = decomp4 con return return f2 return + decomp44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => (a0 -> a1 -> a2 -> a3 -> a) -> (a3 -> m a3) -> (a -> m a) decomp44 con f3 = decomp4 con return return return f3 +decomp45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => + (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a3 -> m a3) -> (a -> m a) +decomp45 con f3 = decomp5 con return return return f3 return + decomp55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> (a4 -> m a4) -> (a -> m a) decomp55 con f4 = decomp5 con return return return return f4 @@ -356,10 +377,18 @@ route23 route con = route @-> (decomp23 con) route33 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2) => ASTModifier m a -> (a0 -> a1 -> a2 -> a) -> ASTModifier m a2 route33 route con = route @-> (decomp33 con) +route34 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => + ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a2 +route34 route con = route @-> (decomp34 con) + route44 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3) => ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a) -> ASTModifier m a3 route44 route con = route @-> (decomp44 con) +route45 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => + ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a3 +route45 route con = route @-> (decomp45 con) + route55 :: (Monad m, Data a, Typeable a0, Typeable a1, Typeable a2, Typeable a3, Typeable a4) => ASTModifier m a -> (a0 -> a1 -> a2 -> a3 -> a4 -> a) -> ASTModifier m a4 route55 route con = route @-> (decomp55 con) diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index cf5089f..71b3159 100644 --- a/common/FlowGraphTest.hs +++ b/common/FlowGraphTest.hs @@ -122,7 +122,7 @@ testGraph' testName nodes edges code deNode (Node (x,y,_)) = (x,y) testOps :: GraphLabelFuncs (State (Map.Map Meta Int)) Int - testOps = GLF nextId nextId nextId nextId (nextId' 100) (nextId' 100) + testOps = GLF nextId nextId nextId nextId nextId (nextId' 100) (nextId' 100) checkGraphEquality :: (Graph g, Show b, Ord b, Monad m) => ([(Int, Meta)], [(Int, Int, b)]) -> g (FNode m Int) b -> Assertion checkGraphEquality (nodes, edges) g @@ -541,7 +541,7 @@ genGraph s = either (\e -> error $ "QuickCheck graph did not build properly: " + where empty :: a -> Identity () empty = const (return ()) - funcs = GLF empty empty empty empty empty empty + funcs = GLF empty empty empty empty empty empty empty -- | Given a flow-graph, it returns a list of all the identity alteration functions, -- for each node. Applying any, many or all of these functions to the source AST