From 70586518df33a448032732e3ee3c150eca794e79 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 2 Feb 2008 17:08:13 +0000 Subject: [PATCH] Created a common UsageLabel type, had a first attempt at handling replicators properly, and added a flag to declarations to indicate whether they included initialisation --- checks/ArrayUsageCheck.hs | 4 +- checks/Check.hs | 28 +++++++------- checks/RainUsageCheckTest.hs | 8 ++-- checks/UsageCheckAlgorithms.hs | 67 +++++++++++++++++++++++----------- checks/UsageCheckUtils.hs | 33 +++++++++++------ 5 files changed, 87 insertions(+), 53 deletions(-) diff --git a/checks/ArrayUsageCheck.hs b/checks/ArrayUsageCheck.hs index 08f2ec5..dd18cbc 100644 --- a/checks/ArrayUsageCheck.hs +++ b/checks/ArrayUsageCheck.hs @@ -36,9 +36,9 @@ import Types import UsageCheckUtils import Utils -checkArrayUsage :: forall m. (Die m, CSM m) => (Meta, ParItems (Maybe Decl, Vars)) -> m () +checkArrayUsage :: forall m. (Die m, CSM m) => (Meta, ParItems UsageLabel) -> m () checkArrayUsage (m,p) = mapM_ (checkIndexes m) $ Map.toList $ - groupArrayIndexes $ transformParItems snd p + groupArrayIndexes $ transformParItems nodeVars p where -- Returns (array name, list of written-to indexes, list of read-from indexes) groupArrayIndexes :: ParItems Vars -> Map.Map String (ParItems ([A.Expression], [A.Expression])) diff --git a/checks/Check.hs b/checks/Check.hs index 6bb3adb..83ec5a7 100644 --- a/checks/Check.hs +++ b/checks/Check.hs @@ -48,7 +48,7 @@ usageCheckPass t = do g' <- buildFlowGraph labelFunctions t (g, roots) <- case g' of Left err -> dieP (findMeta t) err Right (g,rs) -> return (g,rs) - sequence_ $ checkPar (joinCheckParFunctions checkArrayUsage checkPlainVarUsage) g + checkPar nodeRep (joinCheckParFunctions checkArrayUsage checkPlainVarUsage) g checkParAssignUsage t checkProcCallArgsUsage t mapM_ (checkInitVar (findMeta t) g) roots @@ -75,15 +75,15 @@ permuteHelper func (x:xs) = permuteHelper' func [] x xs permuteHelper' func prev cur [] = [func cur prev] permuteHelper' func prev cur (next:rest) = (func cur (prev ++ (next:rest))) : (permuteHelper' func (prev ++ [cur]) next rest) -checkPlainVarUsage :: forall m. (Die m, CSM m) => (Meta, ParItems (Maybe Decl, Vars)) -> m () +checkPlainVarUsage :: forall m. (Die m, CSM m) => (Meta, ParItems UsageLabel) -> m () checkPlainVarUsage (m, p) = check p where - getVars :: ParItems (Maybe Decl, Vars) -> Vars - getVars (SeqItems ss) = foldUnionVars $ map snd ss + getVars :: ParItems UsageLabel -> Vars + getVars (SeqItems ss) = foldUnionVars $ map nodeVars ss getVars (ParItems ps) = foldUnionVars $ map getVars ps getVars (RepParItem _ p) = getVars p - check :: ParItems (Maybe Decl, Vars) -> m () + check :: ParItems UsageLabel -> m () check (SeqItems {}) = return () check (ParItems ps) = sequence_ $ permuteHelper checkCREW (map getVars ps) check (RepParItem _ p) = check (ParItems [p,p]) -- Easy way to check two replicated branches @@ -142,7 +142,7 @@ showCodeExSet (NormalSet s) return $ "{" ++ concat (intersperse ", " ss) ++ "}" -- | 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 :: forall m. (Monad m, Die m, CSM m) => Meta -> FlowGraph m UsageLabel -> Node -> m () checkInitVar m graph startNode = do startLabel <- checkJust (Just m, "Could not find starting node in the control-flow graph") (lab graph startNode) >>* writeNode @@ -160,12 +160,12 @@ checkInitVar m graph startNode connectedNodes = dfs [startNode] graph -- Gets all variables read-from in a particular node, and the node identifier - readNode :: (Node, FNode m (Maybe Decl, Vars)) -> (Node, ExSet Var) - readNode (n, Node (_,(_,Vars read _ _),_)) = (n,NormalSet read) + readNode :: (Node, FNode m UsageLabel) -> (Node, ExSet Var) + readNode (n, Node (_,ul,_)) = (n,NormalSet $ readVars $ nodeVars ul) -- Gets all variables written-to in a particular node - writeNode :: FNode m (Maybe Decl, Vars) -> ExSet Var - writeNode (Node (_,(_,Vars _ written _),_)) = NormalSet written + writeNode :: FNode m UsageLabel -> ExSet Var + writeNode (Node (_,ul,_)) = NormalSet $ writtenVars $ nodeVars ul -- Nothing is treated as if were the set of all possible variables: nodeFunction :: (Node, EdgeLabel) -> ExSet Var -> Maybe (ExSet Var) -> ExSet Var @@ -209,8 +209,8 @@ checkParAssignUsage = mapM_ checkParAssign . listify isParAssign = do checkPlainVarUsage (m, mockedupParItems) checkArrayUsage (m, mockedupParItems) where - mockedupParItems :: ParItems (Maybe Decl, Vars) - mockedupParItems = ParItems [SeqItems [(Nothing, processVarW v)] | v <- vs] + mockedupParItems :: ParItems UsageLabel + mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing $ processVarW v] | v <- vs] checkProcCallArgsUsage :: forall m t. (CSM m, Die m, Data t) => t -> m () @@ -227,5 +227,5 @@ checkProcCallArgsUsage = mapM_ checkArgs . listify isProcCall = do checkPlainVarUsage (m, mockedupParItems) checkArrayUsage (m, mockedupParItems) where - mockedupParItems :: ParItems (Maybe Decl, Vars) - mockedupParItems = ParItems [SeqItems [(Nothing, v)] | v <- map getVarActual params] + mockedupParItems :: ParItems UsageLabel + mockedupParItems = ParItems [SeqItems [Usage Nothing Nothing v] | v <- map getVarActual params] diff --git a/checks/RainUsageCheckTest.hs b/checks/RainUsageCheckTest.hs index ec933d8..4748a70 100644 --- a/checks/RainUsageCheckTest.hs +++ b/checks/RainUsageCheckTest.hs @@ -140,14 +140,14 @@ testParUsageCheck = TestList (map doTest tests) --TODO add tests for initialising a variable before use. --TODO especially test things like only initialising the variable in one part of an if -buildTestFlowGraph :: [(Int, [Var], [Var])] -> [(Int, Int, EdgeLabel)] -> Int -> Int -> String -> FlowGraph Identity (Maybe Decl, Vars) +buildTestFlowGraph :: [(Int, [Var], [Var])] -> [(Int, Int, EdgeLabel)] -> Int -> Int -> String -> FlowGraph Identity UsageLabel buildTestFlowGraph ns es start end v = mkGraph - ([(-1,Node (emptyMeta,(Just $ ScopeIn v, emptyVars), undefined)),(-2,Node (emptyMeta,(Just $ ScopeOut v,emptyVars), undefined))] ++ (map transNode ns)) + ([(-1,Node (emptyMeta,Usage Nothing (Just $ ScopeIn False v) emptyVars, undefined)),(-2,Node (emptyMeta,Usage Nothing (Just $ ScopeOut v) emptyVars, undefined))] ++ (map transNode ns)) ([(-1,start,ESeq),(end,-2,ESeq)] ++ es) where - transNode :: (Int, [Var], [Var]) -> (Int, FNode Identity (Maybe Decl, Vars)) - transNode (n,r,w) = (n,Node (emptyMeta, (Nothing,vars r w []), undefined)) + transNode :: (Int, [Var], [Var]) -> (Int, FNode Identity UsageLabel) + transNode (n,r,w) = (n,Node (emptyMeta, (Usage Nothing Nothing $ vars r w []), undefined)) testInitVar :: Test diff --git a/checks/UsageCheckAlgorithms.hs b/checks/UsageCheckAlgorithms.hs index 5defc77..df4b342 100644 --- a/checks/UsageCheckAlgorithms.hs +++ b/checks/UsageCheckAlgorithms.hs @@ -18,11 +18,14 @@ with this program. If not, see . module UsageCheckAlgorithms (checkPar, findReachDef, joinCheckParFunctions) where +import Control.Monad import Data.Graph.Inductive +import Data.List import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set +import qualified AST as A import FlowAlgorithms import FlowGraph import Metadata @@ -33,29 +36,51 @@ joinCheckParFunctions :: Monad m => ((Meta, ParItems a) -> m b) -> ((Meta, ParIt joinCheckParFunctions f g x = seqPair (f x, g x) -- | Given a function to check a list of graph labels and a flow graph, --- returns a list of monadic actions (slightly --- more flexible than a monadic action giving a list) that will check --- all PAR items in the flow graph -checkPar :: forall m a b. Monad m => ((Meta, ParItems a) -> m b) -> FlowGraph m a -> [m b] -checkPar f g = map f allParItems +-- checks all PAR items in the flow graph +checkPar :: forall m a b. Monad m => (a -> Maybe A.Replicator) -> ((Meta, ParItems a) -> m b) -> FlowGraph m a -> m [b] +checkPar getRep f g = mapM f =<< allParItems where - -- TODO deal with replicators - - allStartParEdges :: Map.Map Int [(Node,Node)] - allStartParEdges = foldl (\mp (s,e,n) -> Map.insertWith (++) n [(s,e)] mp) Map.empty $ mapMaybe tagStartParEdge $ labEdges g + allStartParEdges :: m (Map.Map Int (Maybe A.Replicator, [(Node,Node)])) + allStartParEdges = foldM helper Map.empty parEdges + where + parEdges = mapMaybe tagStartParEdge $ labEdges g + + helper :: Map.Map Int (Maybe A.Replicator, [(Node,Node)]) -> (Node,Node,Int) -> + m (Map.Map Int (Maybe A.Replicator, [(Node,Node)])) + helper mp (s,e,n) + | r == Nothing = fail "Could not find label for node" + | join r /= join (liftM fst $ Map.lookup n mp) = fail "Replicator not the same for all nodes at beginning of PAR" + | otherwise = return $ Map.insertWith add n (join r,[(s,e)]) mp + where + add (newR, newNS) (oldR, oldNS) = (newR, oldNS ++ newNS) + r :: Maybe (Maybe A.Replicator) + r = lab g s >>* (getRep . (\(Node (_,l,_)) -> l)) tagStartParEdge :: (Node,Node,EdgeLabel) -> Maybe (Node,Node,Int) tagStartParEdge (s,e,EStartPar n) = Just (s,e,n) tagStartParEdge _ = Nothing - allParItems :: [(Meta, ParItems a)] - allParItems = map makeEntry $ map findNodes $ Map.toList allStartParEdges + allParItems :: m [(Meta, ParItems a)] + allParItems = mapM findMetaAndNodes . Map.toList =<< allStartParEdges where - findNodes :: (Int,[(Node,Node)]) -> (Node,[ParItems a]) - findNodes (n,ses) = (undefined, [SeqItems (followUntilEdge e (EEndPar n)) | (_,e) <- ses]) + checkAndGetMeta :: [(Node, Node)] -> m Meta + checkAndGetMeta ns = case distinctItems of + [] -> fail "No edges in list of PAR edges" + [n] -> case lab g n of + Nothing -> fail "Label not found for node at start of PAR" + Just (Node (m,_,_)) -> return m + _ -> fail "PAR edges did not all start at the same node" + where + distinctItems = nub $ map fst ns + + findMetaAndNodes :: (Int,(Maybe A.Replicator, [(Node,Node)])) -> m (Meta, ParItems a) + findMetaAndNodes x@(_,(_,ns)) = seqPair (checkAndGetMeta ns, return $ findNodes x) + + findNodes :: (Int,(Maybe A.Replicator, [(Node,Node)])) -> ParItems a + findNodes (n, (mr, ses)) = maybe id RepParItem mr $ ParItems $ map (makeSeqItems n . snd) ses - makeEntry :: (Node,[ParItems a]) -> (Meta, ParItems a) - makeEntry (_,xs) = (emptyMeta {- TODO fix this again -} , ParItems xs) + makeSeqItems :: Int -> Node -> ParItems a + makeSeqItems n e = SeqItems (followUntilEdge e (EEndPar n)) -- | We need to follow all edges out of a particular node until we reach -- an edge that matches the given edge. So what we effectively need @@ -96,7 +121,7 @@ checkPar f g = map f allParItems customSucc c = [n | (n,e) <- lsuc' c, e /= endEdge] -- | Returns either an error, or map *from* the node with a read, *to* the node whose definitions might be available at that point -findReachDef :: forall m. Monad m => FlowGraph m (Maybe Decl, Vars) -> Node -> Either String (Map.Map Node (Map.Map Var (Set.Set Node))) +findReachDef :: forall m. Monad m => FlowGraph m UsageLabel -> Node -> Either String (Map.Map Node (Map.Map Var (Set.Set Node))) findReachDef graph startNode = do r <- flowAlgorithm graphFuncs (nodes graph) (startNode, Map.empty) -- These lines remove the maps where the variable is not read in that particular node: @@ -115,18 +140,18 @@ findReachDef graph startNode readInNode' :: Node -> Var -> a -> Bool readInNode' n v _ = readInNode v (lab graph n) - readInNode :: Var -> Maybe (FNode m (Maybe Decl, Vars)) -> Bool - readInNode v (Just (Node (_,(_,Vars read _ _),_))) = Set.member v read + readInNode :: Var -> Maybe (FNode m UsageLabel) -> Bool + readInNode v (Just (Node (_,ul,_))) = (Set.member v . readVars . nodeVars) ul - writeNode :: FNode m (Maybe Decl, Vars) -> Set.Set Var - writeNode (Node (_,(_,Vars _ written _),_)) = written + writeNode :: FNode m UsageLabel -> Set.Set Var + writeNode (Node (_,ul,_)) = writtenVars $ nodeVars ul -- | A confusiing function used by processNode. It takes a node and node label, and uses -- these to form a multi-map modifier function that replaces all node-sources for variables -- written to by the given with node with a singleton set containing the given node. -- That is, nodeLabelToMapInsert N (Node (_,Vars _ written _ _)) is a function that replaces -- the sets for each v (v in written) with a singleton set {N}. - nodeLabelToMapInsert :: Node -> FNode m (Maybe Decl, Vars) -> Map.Map Var (Set.Set Node) -> Map.Map Var (Set.Set Node) + nodeLabelToMapInsert :: Node -> FNode m UsageLabel -> Map.Map Var (Set.Set Node) -> Map.Map Var (Set.Set Node) nodeLabelToMapInsert n = foldFuncs . (map (\v -> Map.insert v (Set.singleton n) )) . Set.toList . writeNode processNode :: (Node, EdgeLabel) -> Map.Map Var (Set.Set Node) -> Maybe (Map.Map Var (Set.Set Node)) -> Map.Map Var (Set.Set Node) diff --git a/checks/UsageCheckUtils.hs b/checks/UsageCheckUtils.hs index 4c85d79..acc5723 100644 --- a/checks/UsageCheckUtils.hs +++ b/checks/UsageCheckUtils.hs @@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along with this program. If not, see . -} -module UsageCheckUtils (customVarCompare, Decl(..), emptyVars, foldUnionVars, getVarActual, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, Var(..), Vars(..), vars) where +module UsageCheckUtils (customVarCompare, Decl(..), emptyVars, foldUnionVars, getVarActual, getVarProc, labelFunctions, mapUnionVars, ParItems(..), processVarW, transformParItems, UsageLabel(..), Var(..), Vars(..), vars) where import Data.Generics hiding (GT) import Data.List @@ -63,7 +63,8 @@ data Vars = Vars { ,usedVars :: Set.Set Var -- for channels, barriers, etc } deriving (Eq, Show) -data Decl = ScopeIn String | ScopeOut String deriving (Show, Eq) +-- | The Bool indicates whether the variable was initialised (True = yes) +data Decl = ScopeIn Bool String | ScopeOut String deriving (Show, Eq) -- | A data type representing things that happen in parallel. data ParItems a @@ -71,6 +72,11 @@ data ParItems a | ParItems [ParItems a] -- ^ A list of items that are all in parallel with each other | RepParItem A.Replicator (ParItems a) -- ^ A list of replicated items that happen in parallel +data UsageLabel = Usage + {nodeRep :: Maybe A.Replicator + ,nodeDecl :: Maybe Decl + ,nodeVars :: Vars} + transformParItems :: (a -> b) -> ParItems a -> ParItems b transformParItems f (SeqItems xs) = SeqItems $ map f xs transformParItems f (ParItems ps) = ParItems $ map (transformParItems f) ps @@ -187,19 +193,22 @@ getVarRepExp :: A.Replicator -> Vars getVarRepExp (A.For _ _ e0 e1) = getVarExp e0 `unionVars` getVarExp e1 getVarRepExp (A.ForEach _ _ e) = getVarExp e -labelFunctions :: forall m. Die m => GraphLabelFuncs m (Maybe Decl, Vars) +labelFunctions :: forall m. Die m => GraphLabelFuncs m UsageLabel labelFunctions = GLF { - labelExpression = pair (const Nothing) getVarExp - ,labelExpressionList = pair (const Nothing) getVarExpList - ,labelDummy = const (return (Nothing, emptyVars)) - ,labelProcess = pair (const Nothing) getVarProc - ,labelStartNode = pair (const Nothing) (uncurry getVarFormals) - ,labelReplicator = pair (const Nothing) getVarRepExp + labelExpression = single getVarExp + ,labelExpressionList = single getVarExpList + ,labelDummy = const (return $ Usage Nothing Nothing emptyVars) + ,labelProcess = single getVarProc + ,labelStartNode = single (uncurry getVarFormals) + ,labelReplicator = \x -> return (Usage (Just x) Nothing (getVarRepExp x)) --don't forget about the variables used as initialisers in declarations (hence getVarSpec) - ,labelScopeIn = pair (getDecl ScopeIn) getVarSpec + ,labelScopeIn = pair (getDecl $ ScopeIn False) getVarSpec ,labelScopeOut = pair (getDecl ScopeOut) (const emptyVars) } where - pair :: (a -> b) -> (a -> c) -> (a -> m (b,c)) - pair f0 f1 x = return (f0 x, f1 x) + single :: (a -> Vars) -> (a -> m UsageLabel) + single f x = return $ Usage Nothing Nothing (f x) + + pair :: (a -> Maybe Decl) -> (a -> Vars) -> (a -> m UsageLabel) + pair f0 f1 x = return $ Usage Nothing (f0 x) (f1 x)