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
This commit is contained in:
Neil Brown
parent
60c9613549
commit
70586518df
|
|
@ -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]))
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -18,11 +18,14 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
|
|||
|
||||
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)
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along
|
|||
with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
-}
|
||||
|
||||
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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user