module GraphHammer.SimplestParallel(
Index
, Nil
, (:.)
, GraphHammer
, graphHammerNew
, GraphHammerM
, runAnalysesStack
, Value
, Composed
, localValue
, cst
, ($=)
, (+.), (-.), (*.), divV
, (===), (=/=)
, Analysis
, AnM
, onEdges
, anIf
, getAnalysisResult
, putAnalysisResult
, incrementAnalysisResult
, RequiredAnalyses
, basicAnalysis
, derivedAnalysis
, EnabledAnalysis, EnabledAnalyses
) where
import Control.Concurrent
import Control.Monad
import Control.Monad.State
import Data.Array
import Data.Array.IO
import qualified Data.Array.Unboxed as UA
import Data.Bits
import Data.Int
import Data.List (sort)
import Data.Time.Clock ( getCurrentTime, diffUTCTime )
import System.IO
import System.Mem (performGC)
import G500.Index
import GraphHammer.HList
import qualified GraphHammer.IntSet as ISet
import qualified GraphHammer.IntMap as IMap
analysisSliceSizeShift :: Int
analysisSliceSizeShift = 8
analysisSliceSize :: Int
analysisSliceSize = 2^analysisSliceSizeShift
analysisSliceSizeMask :: Int
analysisSliceSizeMask = analysisSliceSize 1
type IntMap a = IMap.IntMap a
type IntSet = ISet.IntSet
type VertexAnalyses = IntMap Int64
type AnalysesMap = IntMap VertexAnalyses
type OtherAnalyses = IntMap AnalysesMap
type AnalysesArrays = Array Int32 (Array Int32 (IOUArray Int32 Int64))
type EdgeSet = IntMap VertexSet
data GraphHammer as = GraphHammer {
graphHammerMaxNodes :: !Int
, graphHammerNodeIndex :: !Int
, _graphHammerBatchCounter :: !Int
, graphHammerEdges :: !EdgeSet
, graphHammerAnalyses :: !AnalysesArrays
, graphHammerNodesAffected :: !IntSet
, _graphHammerAnalysesAffected :: !(IntMap Int)
, graphHammerChannels :: !(Array Int32 (Chan (Msg as)))
, graphHammerSendReceiveChannel :: !(Chan SendReceive)
, graphHammerPortionEdges :: (Array Int EdgeSet)
, graphHammerOthersAnalyses :: !OtherAnalyses
, graphHammerContinuationGroups :: !(IntMap [IntSt as])
}
type GraphHammerM as a = StateT (GraphHammer as) IO a
data Vertex = Vertex { vertexNode, vertexIndex :: !Int32 }
deriving (Eq, Ord, Show)
type VertexSet = IntMap IntSet
vertexSetEmpty :: forall a. IMap.IntMap a
vertexSetEmpty = IMap.empty
vertexSetIntersection :: IMap.IntMap ISet.IntSet
-> IMap.IntMap ISet.IntSet -> IMap.IntMap ISet.IntSet
vertexSetIntersection a b = IMap.filter (not . ISet.null) $
IMap.intersectionWith (ISet.intersection) a b
vertexSetUnion :: IMap.IntMap ISet.IntSet
-> IMap.IntMap ISet.IntSet -> IMap.IntMap ISet.IntSet
vertexSetUnion a b = IMap.unionWith (ISet.union) a b
vertexSetToList :: VertexSet -> [Vertex]
vertexSetToList set = concatMap (\(n,iset) -> map (Vertex n) $ ISet.toList iset) $
IMap.toList set
vertexToIndex :: (Integral b, Num a) => b -> Vertex -> a
vertexToIndex maxNodes vertex = fromIntegral (vertexNode vertex) +
fromIntegral maxNodes * fromIntegral (vertexIndex vertex)
indexToVertex :: (Integral b, Integral a) => a -> b -> Vertex
indexToVertex maxNodes idx = Vertex (fromIntegral nodeIndex) (fromIntegral localIndex)
where
(localIndex,nodeIndex) = divMod idx (fromIntegral maxNodes)
vertexSetMember :: Vertex -> VertexSet -> Bool
vertexSetMember vertex set' = case IMap.lookup (vertexNode vertex) set' of
Just set'' -> ISet.member (vertexIndex vertex) set''
Nothing -> False
vertexSetSingleton :: Vertex -> VertexSet
vertexSetSingleton (Vertex node idx) = IMap.singleton node (ISet.singleton idx)
vertexSetSize :: VertexSet -> Int
vertexSetSize set' = IMap.fold (+) 0 $ IMap.map ISet.size set'
graphHammerNew :: HLength as
=> Int
-> Int
-> Chan SendReceive
-> Array Int32 (Chan (Msg as))
-> IO (GraphHammer as)
graphHammerNew maxNodes nodeIndex countingChan chans = do
dummyAnalysisArrays <- liftM (array (0,0)) $ forM [0..0] $ \ai -> do
aArr <- graphHammerNewAnalysisSliceArray
return (ai,array (0,0) [(0,aArr)])
let forwardResult = GraphHammer maxNodes nodeIndex 0 IMap.empty dummyAnalysisArrays
ISet.empty IMap.empty chans countingChan (error "no portion edges!") IMap.empty IMap.empty
let analysisProjection :: HLength as' => GraphHammer as' -> as'
analysisProjection = error "analysisProjection result should be trated abstractly!"
let analysisCount = hLength (analysisProjection forwardResult)
let analysisHighIndex = analysisCount1
analysisArrays <- liftM (array (0,fromIntegral analysisHighIndex)) $ forM [0..fromIntegral analysisHighIndex] $ \ai -> do
aArr <- graphHammerNewAnalysisSliceArray
return (ai,array (0,0) [(0,aArr)])
let result = forwardResult { graphHammerAnalyses = analysisArrays }
return result
graphHammerCountReceived :: GraphHammerM as ()
graphHammerCountReceived = do
countChan <- liftM graphHammerSendReceiveChannel get
liftIO $ writeChan countChan $ Received 1
graphHammerCountSent :: Int -> GraphHammerM as ()
graphHammerCountSent count = do
nodeIndex <- liftM graphHammerNodeIndex get
countChan <- liftM graphHammerSendReceiveChannel get
liftIO $ writeChan countChan $ Sent nodeIndex count
graphHammerNewAnalysisSliceArray :: IO (IOUArray Int32 Int64)
graphHammerNewAnalysisSliceArray = newArray (0,fromIntegral analysisSliceSize1) 0
graphHammerFillPortionEdges :: [(Index,Index)] -> GraphHammerM as ()
graphHammerFillPortionEdges edges = do
nodeIndex <- liftM (fromIntegral . graphHammerNodeIndex) get
maxNodes <- liftM (fromIntegral . graphHammerMaxNodes) get
let len = length edges
let sets = scanl (update maxNodes nodeIndex) IMap.empty edges
let arr = listArray (0,len) sets
modify $! \st -> last sets `seq` st {
graphHammerPortionEdges = arr
, graphHammerOthersAnalyses = IMap.empty
}
where
update :: Int32 -> Int32 -> EdgeSet -> (Index,Index) -> EdgeSet
update maxNodes nodeIndex oldSet (fromI, toI)
| vertexNode fromV == nodeIndex && vertexNode toV == nodeIndex =
IMap.insertWith vertexSetUnion (vertexIndex fromV) (vertexSetSingleton toV) $!
IMap.insertWith vertexSetUnion (vertexIndex toV) (vertexSetSingleton fromV) $!
oldSet
| vertexNode fromV == nodeIndex =
IMap.insertWith vertexSetUnion (vertexIndex fromV) (vertexSetSingleton toV) $! oldSet
| vertexNode toV == nodeIndex =
IMap.insertWith vertexSetUnion (vertexIndex toV) (vertexSetSingleton fromV) $! oldSet
| otherwise = oldSet
where
fromV = indexToVertex maxNodes fromI
toV = indexToVertex maxNodes toI
graphHammerCommitNewPortion :: GraphHammerM as ()
graphHammerCommitNewPortion = do
st <- get
let portionEdges = graphHammerPortionEdges st
(_,highest) = bounds portionEdges
latestUpdates = portionEdges ! highest
put $! st {
graphHammerPortionEdges = error "graphHammerPortionEdges accessed outside of transaction."
, graphHammerEdges = IMap.unionWith vertexSetUnion latestUpdates $ graphHammerEdges st
, graphHammerContinuationGroups = IMap.empty
}
graphHammerSplitIndex :: Index -> GraphHammerM as Vertex
graphHammerSplitIndex idx = do
maxNodes <- liftM graphHammerMaxNodes get
return $ indexToVertex maxNodes idx
graphHammerVertexSetIntersection :: VertexSet -> VertexSet -> GraphHammerM as VertexSet
graphHammerVertexSetIntersection s1 s2 = return $ vertexSetIntersection s1 s2
graphHammerVertexSetIntersectionAsIndices :: VertexSet -> VertexSet -> GraphHammerM as [Index]
graphHammerVertexSetIntersectionAsIndices s1 s2 = do
maxNodes <- liftM graphHammerMaxNodes get
let isection = vertexSetIntersection s1 s2
return $ map (vertexToIndex maxNodes) $ vertexSetToList isection
graphHammerEdgeExists :: Int -> Vertex -> Vertex -> GraphHammerM as Bool
graphHammerEdgeExists edgeIndex start end
| start == end = return True
| otherwise = do
startIsLocal <- graphHammerLocalVertex start
r <- if startIsLocal
then do
es <- graphHammerGetEdgeSet edgeIndex start
return $ vertexSetMember end es
else do
es <- graphHammerGetEdgeSet edgeIndex end
return $ vertexSetMember start es
return r
graphHammerGetEdgeSet :: Int -> Vertex -> GraphHammerM as VertexSet
graphHammerGetEdgeSet edgeInPortion vertex = do
let localIndex = vertexIndex vertex
st <- get
let startEdges = IMap.findWithDefault IMap.empty localIndex $ graphHammerEdges st
let portionEdges = graphHammerPortionEdges st
let prevEdges = portionEdges ! edgeInPortion
let resultEdges = IMap.findWithDefault vertexSetEmpty localIndex prevEdges
return $ IMap.unionWith ISet.union startEdges resultEdges
graphHammerGrowAnalysisArrays :: Int32 -> GraphHammerM as ()
graphHammerGrowAnalysisArrays newMaxIndex = do
analyses <- liftM graphHammerAnalyses get
let (lowA, highA) = bounds analyses
analyses' <- forM [lowA..highA] $ \ai -> do
let analysisArrays = analyses ! ai
let (lowAA,highAA) = bounds analysisArrays
let incr = newMaxIndex highAA
addedArrays <- forM [0..incr1] $ \ii -> do
slice <- liftIO graphHammerNewAnalysisSliceArray
return (highAA+1+ii, slice)
return (ai,array (lowAA, newMaxIndex) (assocs analysisArrays ++ addedArrays))
modify $! \st -> st { graphHammerAnalyses = array (lowA, highA) analyses' }
graphHammerGetAnalysisArrayIndex :: Int32 -> Int32 -> GraphHammerM as (Int32,IOUArray Int32 Int64)
graphHammerGetAnalysisArrayIndex analysisIndex' localIndex = do
let indexOfSlice = shiftR localIndex analysisSliceSizeShift
analysisArrays <- liftM ((! analysisIndex') . graphHammerAnalyses) get
let (_,highestIndex) = bounds analysisArrays
if highestIndex < indexOfSlice
then do
graphHammerGrowAnalysisArrays (fromIntegral indexOfSlice)
graphHammerGetAnalysisArrayIndex analysisIndex' localIndex
else do
let sliceArray = analysisArrays ! indexOfSlice
return (localIndex .&. fromIntegral analysisSliceSizeMask, sliceArray)
graphHammerGetAnalysis :: Int -> Index -> GraphHammerM as Int64
graphHammerGetAnalysis analysisIndex' index' = do
void $ error "graphHammerGetAnalysis does not distinguish between local and not-local indices!!!"
localIndex <- graphHammerIndexToLocal index'
(sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') localIndex
liftIO $ readArray sliceArray sliceIndex
_graphHammerSetAnalysis :: Int -> Index -> Int64 -> GraphHammerM as ()
_graphHammerSetAnalysis analysisIndex' index' value = do
void $ error "graphHammerSetAnalysis does not distinguish between local and not-local indices!!!"
localIndex <- graphHammerIndexToLocal index'
(sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') localIndex
liftIO $ writeArray sliceArray sliceIndex value
graphHammerIncrementAnalysis :: Int -> Index -> Int64 -> GraphHammerM as ()
graphHammerIncrementAnalysis _analysisIndex _index 0 = return ()
graphHammerIncrementAnalysis analysisIndex' index' incr = do
local <- graphHammerIndexToLocal index'
isLocal <- graphHammerLocalIndex index'
if isLocal
then do
(sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') local
liftIO $ do
x <- readArray sliceArray sliceIndex
writeArray sliceArray sliceIndex (x + incr)
modify $! \st -> st {
graphHammerNodesAffected = ISet.insert local $ graphHammerNodesAffected st
}
else do
nodeIndex <- graphHammerIndexToNodeIndex index'
let joinAnalyses old new = IMap.unionWith (IMap.unionWith (+)) old new
modify $! \st -> st {
graphHammerOthersAnalyses = IMap.insertWith joinAnalyses nodeIndex
(IMap.singleton local (IMap.singleton (fromIntegral analysisIndex') incr)) $
graphHammerOthersAnalyses st
}
graphHammerBulkIncrementAnalysis :: Int -> VertexSet -> Int64 -> GraphHammerM as ()
graphHammerBulkIncrementAnalysis _analysisIndex _vertices 0 = return ()
graphHammerBulkIncrementAnalysis analysisIndex' vertices incr = do
thisNode <- liftM (fromIntegral . graphHammerNodeIndex) get
let (left,ours,right) = IMap.splitLookup thisNode vertices
case ours of
Just vertices' -> do
forM_ (ISet.toList vertices') $ \localIndex -> do
(sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') (fromIntegral localIndex)
liftIO $ do
x <- readArray sliceArray sliceIndex
writeArray sliceArray sliceIndex (x + incr)
modify $! \st -> st {
graphHammerNodesAffected = ISet.union vertices' $ graphHammerNodesAffected st
}
Nothing -> return ()
let joinAnalyses :: VertexSet -> OtherAnalyses -> OtherAnalyses
joinAnalyses new old = IMap.unionWith
(IMap.unionWith (IMap.unionWith (+)))
(IMap.map (flip IMap.mapFromSetValue $ IMap.singleton (fromIntegral analysisIndex') incr) new)
old
modify $! \st -> st {
graphHammerOthersAnalyses = joinAnalyses left $ joinAnalyses right $
graphHammerOthersAnalyses st
}
return ()
graphHammerGetOtherAnalyses :: GraphHammerM as [(Int32,AnalysesMap)]
graphHammerGetOtherAnalyses = do
liftM (IMap.toList . graphHammerOthersAnalyses) get
graphHammerIndexToLocal :: Index -> GraphHammerM as Int32
graphHammerIndexToLocal index' = do
maxNodes <- liftM graphHammerMaxNodes get
return $ fromIntegral $ index' `div` fromIntegral maxNodes
graphHammerIndexToNodeIndex :: Index -> GraphHammerM as Int32
graphHammerIndexToNodeIndex index' = do
maxNodes <- liftM graphHammerMaxNodes get
return $ fromIntegral $ index' `mod` fromIntegral maxNodes
graphHammerCurrentNodeIndex :: GraphHammerM as Int32
graphHammerCurrentNodeIndex = liftM (fromIntegral . graphHammerNodeIndex) get
graphHammerLocalIndex :: Index -> GraphHammerM as Bool
graphHammerLocalIndex index' = do
nodeIndex <- graphHammerIndexToNodeIndex index'
liftM (nodeIndex ==) graphHammerCurrentNodeIndex
graphHammerLocalVertex :: Vertex -> GraphHammerM as Bool
graphHammerLocalVertex vertex = do
liftM ((vertexNode vertex ==) . fromIntegral) graphHammerCurrentNodeIndex
graphHammerLocalJob :: Vertex -> Vertex -> GraphHammerM as Bool
graphHammerLocalJob v1' v2' = do
let randomDir = ((vertexIndex v1 `xor` vertexIndex v2) .&. 1) == 0
v1Local <- graphHammerLocalVertex v1
return $ (randomDir && not v1Local) || (not randomDir && v1Local)
where
v1 = min v1' v2'
v2 = max v1' v2'
graphHammerMergeIncrements :: AnalysesMap -> GraphHammerM as ()
graphHammerMergeIncrements increments = do
let flatIncrs = concatMap (\(i,as) -> map (\(ai,incr) -> (i,ai,incr)) $ IMap.toList as) $ IMap.toList increments
forM_ flatIncrs $ \(localIndex,analysisIndex',incr) -> do
(sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') (fromIntegral localIndex)
liftIO $ do
x <- readArray sliceArray sliceIndex
writeArray sliceArray sliceIndex (x+incr)
let _mergeIncs old new = IMap.unionWith (+) old new
modify $! \st -> st {
graphHammerNodesAffected = ISet.union (IMap.keysSet increments) $ graphHammerNodesAffected st
}
graphHammerSendToNode :: Int32 -> Msg as -> GraphHammerM as ()
graphHammerSendToNode nodeIndex msg = do
nodeChan <- liftM ((!nodeIndex) . graphHammerChannels) get
liftIO $ writeChan nodeChan msg
_graphHammerSendToNodeOfVertex :: Vertex -> Msg as -> GraphHammerM as ()
_graphHammerSendToNodeOfVertex vertex msg = do
graphHammerSendToNode (vertexNode vertex) msg
graphHammerGroupContinuations :: Vertex -> IntSt as -> GraphHammerM as ()
graphHammerGroupContinuations vertex contState = do
let _upd v = Just $ case v of
Just xs -> contState : xs
Nothing -> [contState]
modify $! \st -> st {
graphHammerContinuationGroups = IMap.alter
(\v -> fmap (contState:) v `mplus` return [contState])
(vertexNode vertex) $ graphHammerContinuationGroups st
}
graphHammerDistributeContinuations :: GraphHammerM as ()
graphHammerDistributeContinuations = do
nodesGroups <- liftM (IMap.toList . graphHammerContinuationGroups) get
forM_ nodesGroups $ \(n,g) -> graphHammerSendToNode n (ContinueIntersection g)
graphHammerGetAffectedAnalyses :: GraphHammerM as [(Index,VertexAnalyses)]
graphHammerGetAffectedAnalyses = do
st <- get
let affected = take 100 $ ISet.toList $ graphHammerNodesAffected st
let nodeIndex = fromIntegral $ graphHammerNodeIndex st
let maxNodes = fromIntegral $ graphHammerMaxNodes st
let toGlobal i = fromIntegral i * maxNodes + nodeIndex
forM affected $ \localIndex -> do
analyses <- liftM IMap.unions $ forM (assocs (graphHammerAnalyses st)) $ \(ai,_analysisSlices) -> do
(sliceIndex, slice) <- graphHammerGetAnalysisArrayIndex ai (fromIntegral localIndex)
x <- liftIO $ readArray slice sliceIndex
return (IMap.singleton (fromIntegral ai) x)
return (toGlobal localIndex, analyses)
graphHammerClearAffected :: GraphHammerM as ()
graphHammerClearAffected = modify $! \st -> st { graphHammerNodesAffected = ISet.empty }
runAnalysesStack :: (HLength as, EnabledAnalyses as as)
=> Integer
-> Int
-> IO (Maybe (UA.UArray Int Index))
-> Analysis as as
-> IO ()
runAnalysesStack threshold maxNodes receiveChanges analysesStack
| analysesParallelizable analysesStack = do
putStrLn $ "Max nodes "++show maxNodes
chans <- liftM (listArray (0,fromIntegral maxNodes1)) $ mapM (const newChan) [0..maxNodes 1]
sendReceiveCountChan <- newChan
forM_ [0..maxNodes1] $ \n -> do
forkIO $ workerThread analysesStack maxNodes n sendReceiveCountChan chans
startTime <- getCurrentTime
(computationSeconds,lastCompSeconds,lastCompCount, n) <-
runLoop 0 0 sendReceiveCountChan chans 0 0
endTime <- getCurrentTime
let timeDiff = diffUTCTime endTime startTime
let edgesPerSecond = fromIntegral n / timeDiff
putStrLn $ "Edges: "++show n
putStrLn $ "Edges per second for total time: "++show edgesPerSecond
putStrLn $ "Total time in seconds: "++show timeDiff
putStrLn $ "Edges per second for computation time: "++show (fromIntegral n / computationSeconds)
putStrLn $ "Edges per second for computation time of last "++show lastCompCount++" edges: "++show (fromIntegral lastCompCount / lastCompSeconds)
putStrLn $ "Computation time in seconds: "++show computationSeconds
return ()
where
gcThreshold = threshold 8000
runLoop time lastEdgesTime sendReceiveCountChan chans pn n = do
edges <- liftIO receiveChanges
case edges of
Nothing -> do
liftIO $ do
answer <- newChan
forM_ (elems chans) $ \ch -> do
writeChan ch (Stop answer)
forM_ (elems chans) $ \_ -> do
readChan answer
return (time,lastEdgesTime,nthreshold,n)
Just edges' -> do
start <- getCurrentTime
let (low,up) = UA.bounds edges'
let count = div (uplow+1) 2
if n >= gcThreshold && n < gcThreshold + fromIntegral count
then performGC >> putStrLn "Garbage collection."
else return ()
answer <- newChan
forM_ (elems chans) $ \ch -> writeChan ch (Portion pn edges' answer)
hFlush stdout
forM_ [0..maxNodes1] $ \_ ->
readChan answer
detectSilenceAndDumpState sendReceiveCountChan maxNodes (elems chans)
end <- getCurrentTime
let delta = diffUTCTime end start
let compTime = time + delta
let lastEdgesTime'
| n >= threshold = lastEdgesTime + delta
| otherwise = lastEdgesTime
runLoop compTime lastEdgesTime' sendReceiveCountChan chans (pn+1) (n+fromIntegral count)
detectSilence countChan nodesNotSent sentReceivedBalance
| nodesNotSent < 0 = error $ "nodesNotSent "++show nodesNotSent++"!!!"
| nodesNotSent > 0 = continue
| sentReceivedBalance < 0 = error $ "sentReceivedBalance "++show sentReceivedBalance++"!!!"
| sentReceivedBalance > 0 = continue
| otherwise = return ()
where
continue = do
msg <- readChan countChan
case msg of
Sent _ i -> detectSilence countChan
(nodesNotSent1)
(sentReceivedBalance + i)
Received n -> detectSilence countChan
nodesNotSent
(sentReceivedBalance n)
_gatherDumpAffected chans = do
putStrLn $ "Analyses of affected indices:"
answer <- newChan
forM_ chans $ \ch -> writeChan ch $ GetAffected answer
allAffected <- flip (flip foldM []) chans $ \totalAffected _ -> do
someAffected <- readChan answer
return $ totalAffected ++someAffected
let firstSome = take 10 $ sort allAffected
forM_ firstSome $ \(ix,analyses) -> do
putStrLn $ " Index "++show ix
forM_ (IMap.toList analyses) $ \(ai,a) -> do
putStrLn $ " Analysis["++show ai++"]: "++show a
detectSilenceAndDumpState countChan nNodes _chans = do
detectSilence countChan nNodes 0
_performInsertionAndAnalyses edgeList = do
insertAndAnalyzeSimpleSequential analysesStack edgeList
runAnalysesStack _threshold _maxNodes _receiveChanges _analysesStack = do
error "Non-parallelizable analyses aren't supported."
data Msg as =
Portion !Int !(UA.UArray Int Index) (Chan ())
| AtomicIncrement !Int !AnalysesMap
| ContinueIntersection ![IntSt as]
| GetAffected (Chan [(Index,IntMap Int64)])
| Stop (Chan Int)
data SendReceive =
Sent Int Int
| Received Int
type MsgChan as = Chan (Msg as)
_createMessageChannel :: IO (MsgChan as)
_createMessageChannel = newChan
type ChanArr as = Array Int32 (MsgChan as)
type MsgChanArr as = ChanArr as
workerThread :: (HLength as, EnabledAnalyses as as) => Analysis as as ->
Int -> Int -> Chan SendReceive -> MsgChanArr as -> IO ()
workerThread analysis maxNodes nodeIndex countingChan chans = do
let ourChan = chans ! fromIntegral nodeIndex
graphHammer <- graphHammerNew maxNodes nodeIndex countingChan chans
let
receiveLoop n
| n <= 0 = return ()
| otherwise = do
msg <- liftIO $ readChan ourChan
case msg of
AtomicIncrement _pn changes -> do
graphHammerMergeIncrements changes
graphHammerCountReceived
receiveLoop n
ContinueIntersection envs -> do
forM_ envs interpret
receiveLoop (nlength envs)
msg' -> do
liftIO $ writeChan ourChan msg'
receiveLoop n
let
mainLoop = do
msg <- liftIO $ readChan ourChan
case msg of
Portion pn edges answer -> do
let es = pairs $ UA.elems edges
graphHammerFillPortionEdges es
graphHammerClearAffected
let work n (i,(f,t)) = do
incr <- workOnEdge analysis i f t
return $! n + incr
count <- foldM work 0 $ zip [0..] es
graphHammerDistributeContinuations
receiveLoop count
sendOtherIncrements pn
graphHammerCommitNewPortion
liftIO $ writeChan answer ()
mainLoop
AtomicIncrement _pn changes' -> do
graphHammerMergeIncrements changes'
graphHammerCountReceived
mainLoop
Stop answer -> do
liftIO $ putStrLn $ "stopped "++show nodeIndex
liftIO $ writeChan answer nodeIndex
return ()
GetAffected answer -> do
affectedAnalysis <- graphHammerGetAffectedAnalyses
liftIO $ writeChan answer affectedAnalysis
mainLoop
msg' -> do
liftIO $ writeChan ourChan msg'
mainLoop
void $ flip runStateT graphHammer $ mainLoop
return ()
where
pairs (a:b:abs') = (a,b) : pairs abs'
pairs _ = []
sendOtherIncrements :: Int -> GraphHammerM as ()
sendOtherIncrements pn = do
increments <- graphHammerGetOtherAnalyses
forM_ increments $ \(node,incrs) ->
graphHammerSendToNode (fromIntegral node) (AtomicIncrement pn incrs)
graphHammerCountSent $ length increments
workOnEdge :: Analysis as as -> Int -> Index -> Index -> GraphHammerM as Int
workOnEdge analysis edgeIndex fromIndex toIndex = do
fromVertex <- graphHammerSplitIndex fromIndex
toVertex <- graphHammerSplitIndex toIndex
exists <- graphHammerEdgeExists edgeIndex fromVertex toVertex
isFromLocal <- graphHammerLocalVertex fromVertex
isToLocal <- graphHammerLocalVertex toVertex
localStart <- graphHammerLocalJob fromVertex toVertex
n <- case (isFromLocal, isToLocal, localStart, exists) of
(False, False, _, _) -> return 0
(True,True, _, False) -> do
runStack analysis edgeIndex fromIndex toIndex
return 0
(_,_,True, False) -> do
runStack analysis edgeIndex fromIndex toIndex
return 0
(_,_,False, False) -> return 1
(_,_,_, True) -> return 0
return n
insertAndAnalyzeSimpleSequential :: Analysis as' as -> [(Index, Index)] -> GraphHammerM as ()
insertAndAnalyzeSimpleSequential _stack _edges =
error "insertAndAnalyzeSimpleSequential!!!"
runStack :: Analysis as as -> Int -> Index -> Index -> GraphHammerM as ()
runStack (Analysis startV endV _ action) i start end = do
interpret (interpretInitialEnv i actionStatements)
where
actionStatements = ASAssign startV (cst start) : ASAssign endV (cst end) : action
analysesParallelizable :: Analysis as' as -> Bool
analysesParallelizable (Analysis _ _ _ _actions) = True
class AnalysisValue v where
toInt64 :: v -> Int64
fromInt64 :: Int64 -> v
instance AnalysisValue Bool where
toInt64 = fromIntegral . fromEnum
fromInt64 = toEnum . fromIntegral
instance AnalysisValue Int where
toInt64 = fromIntegral
fromInt64 = fromIntegral
instance AnalysisValue Int64 where
toInt64 = id
fromInt64 = id
data BulkOp as where
BulkIncr :: Int -> Value _a Index -> Value _b Index -> Value _c Int64 -> BulkOp as
CountIncr :: (Show a, Num a, AnalysisValue a) => Value Asgn a -> Value _c a -> BulkOp as
data AnStatement as where
ASAssign :: (Show a, AnalysisValue a) => Value Asgn a -> Value _a a -> AnStatement as
ASOnEdges :: Value _a Index -> Value Asgn Index -> AnStatList as -> AnStatement as
ASOnEdgesIntersection :: Value _a Index -> Value _b Index -> Value Asgn Index -> Value Asgn Index -> AnStatList as -> AnStatement as
ASAtomicIncr :: Int -> Value _a Index -> Value _b Int64 -> AnStatement as
ASIf :: Value _a Bool -> AnStatList as -> AnStatList as -> AnStatement as
ASSetAnalysisResult :: Int -> Value _a Index -> Value _b Int64 -> AnStatement as
ASFlagVertex :: Value _a Index -> AnStatement as
ASOnFlaggedVertices :: Value Asgn Index -> AnStatList as -> AnStatement as
ASIntersectionBulkOps :: Value _a Index -> Value _b Index -> [BulkOp as] -> AnStatement as
ASContinueEdgeIsect :: !VertexSet -> Value Asgn Index -> Value Asgn Index -> Vertex -> AnStatList as -> AnStatement as
ASContinueEdgeIsectBulk :: !VertexSet -> !Vertex -> [BulkOp as] -> AnStatement as
indentShow :: Show a => a -> String
indentShow = indent . show
indent :: String -> String
indent = (" "++)
indentShowStats :: Show a => [a] -> [String]
indentShowStats stats = map indent $ filter (not . null) $ concatMap (lines . show) stats
instance Show (AnStatement as) where
show (ASAssign dest what) = show dest ++ " := "++show what
show (ASOnEdges vertex var stats) = unlines $
("onEdges "++show vertex++"\\"++show var) : indentShowStats stats
show (ASOnEdgesIntersection a b aN bN stats) = unlines $
("onEdgesIntersection "++show (a,b)++"\\"++show (aN,bN)) : indentShowStats stats
show (ASAtomicIncr ai idx incr) = "analysisResult["++show ai++"]["++show idx++"] += "++show incr
show (ASIf cond thens elses) = unlines $
("if "++show cond) : "then" : indentShowStats thens ++ ("else" : map indentShow elses)
show (ASSetAnalysisResult ai idx val) = "analysisResult["++show ai++"]["++show idx++"] := "++show val
show (ASFlagVertex idx) = "flagVertex "++show idx
show (ASOnFlaggedVertices x ss) = unlines $ ("onFlaggedVertices \\"++show x ++" ->") : indentShowStats ss
show (ASIntersectionBulkOps _ _ _) = "ASIntersectionBulkOps"
show (ASContinueEdgeIsect _ _ _ _ _) = "ASContinueEdgeIsect"
show (ASContinueEdgeIsectBulk _ _ _) = "ASContinueEdgeIsectBulk"
showList xs = \s -> s ++ unlines (map show xs)
type AnStatList as = [AnStatement as]
data AnSt as = AnSt {
asValueIndex :: !Int32
, asStatements :: !(AnStatList as)
}
type AnM as a = State (AnSt as) a
addStatement :: AnStatement as -> AnM as ()
addStatement stat = modify $! \as -> as {
asStatements = asStatements as ++ [stat]
}
cutStatements :: AnM as r -> AnM as (AnStatList as, r)
cutStatements act = do
stats <- liftM asStatements get
modify $! \as -> as { asStatements = []}
r <- act
eStats <- liftM asStatements get
modify $! \as -> as { asStatements = stats }
return (eStats, r)
onEdges :: Value Composed Index -> (Value Composed Index -> AnM as r) -> AnM as r
onEdges vertex act = do
neighbor <- defineLocal
(eStats, r) <- cutStatements $ act $ ValueComposed neighbor
addStatement $ ASOnEdges vertex neighbor eStats
return r
anIf :: Value Composed Bool -> AnM as r -> AnM as r -> AnM as r
anIf cond th el = do
(thStats, r) <- cutStatements th
(elStats, _) <- cutStatements el
addStatement $ ASIf cond thStats elStats
return r
getEnabledAnalyses :: AnM as as
getEnabledAnalyses = return (error "value of getEnabledAnalyses should not be requested.")
getAnalysisIndex :: AnalysisIndex a as => a -> AnM as Int
getAnalysisIndex a = do
analyses <- getEnabledAnalyses
return $ analysisIndex a analyses
getAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> AnM as (Value Composed Int64)
getAnalysisResult analysis vertex = do
idx <- getAnalysisIndex analysis
return $ ValueComposed $ ValueAnalysisResult idx vertex
putAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> Value _b Int64 -> AnM as ()
putAnalysisResult analysis vertex value = do
idx <- getAnalysisIndex analysis
addStatement $ ASSetAnalysisResult idx vertex value
incrementAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> Value _b Int64 -> AnM as ()
incrementAnalysisResult analysis vertex incr = do
idx <- getAnalysisIndex analysis
addStatement $ ASAtomicIncr idx vertex incr
data Asgn
data Composed
data Value asgn v where
ValueArgument :: Int -> Value Composed v
ValueLocal :: AnalysisValue v => Int32 -> Value Asgn v
ValueConst :: v -> Value Composed v
ValueBin :: (Show l, Show r) => BinOp l r v -> Value _a l -> Value _b r -> Value Composed v
ValueUn :: UnOp a v -> Value _a a -> Value Composed v
ValueComposed :: Value _a v -> Value Composed v
ValueAnalysisResult :: Int -> Value _b Index -> Value Asgn Int64
data BinOp x y z where
Plus :: Num x => BinOp x x x
Minus :: Num x => BinOp x x x
Mul :: Num x => BinOp x x x
Div :: Integral x => BinOp x x x
Equal :: Eq x => BinOp x x Bool
instance Show v => Show (Value asgn v) where
show v = case v of
ValueArgument i -> "arg_"++show i
ValueLocal i -> "var_"++show i
ValueConst w -> show w
ValueBin op a b -> unwords ["(",show a,")", show op, "(",show b,")"]
ValueUn _op _a -> "unary"
ValueComposed w -> unwords ["as_composed(",show w,")"]
ValueAnalysisResult i ix -> "analysis "++show i++" result at "++show ix
instance Show (BinOp x y z) where
show op = case op of
Plus -> "+"
Minus -> "-"
Mul -> "*"
Div -> "/"
Equal -> "=="
data UnOp a r where
Not :: UnOp Bool Bool
Negate :: Num v => UnOp v v
defineLocal :: AnalysisValue v => AnM as (Value Asgn v)
defineLocal = do
modify $! \as -> as { asValueIndex = asValueIndex as + 1 }
liftM (ValueLocal . asValueIndex) get
localValue :: (Show v, AnalysisValue v) => v -> AnM as (Value Asgn v)
localValue def = do
v <- defineLocal
v $= cst def
return v
infixl 6 +., -.
(+.), (-.), (*.) :: (Show v, Num v) => Value _a v -> Value _b v -> Value Composed v
a +. b = ValueBin Plus a b
a -. b = ValueBin Minus a b
a *. b = ValueBin Mul a b
divV :: (Integral v, Show v) => Value _a v -> Value _b v -> Value Composed v
divV a b = ValueBin Div a b
(===), (=/=) :: (Show v, Eq v) => Value _a v -> Value _b v -> Value Composed Bool
a === b = ValueBin Equal a b
a =/= b = notV $ a === b
notV :: forall _a. Value _a Bool -> Value Composed Bool
notV = ValueUn Not
cst :: v -> Value Composed v
cst = ValueConst
infixr 1 $=
($=) :: (Show v, AnalysisValue v) => Value Asgn v -> Value _a v -> AnM as ()
dest $= expr = addStatement $ ASAssign dest expr
data IntSt as = IntSt {
istLocals :: !(IntMap Int64)
, isEdgeIndex :: !Int
, isConts :: ![AnStatList as]
}
type AIM as a = StateT (IntSt as) (StateT (GraphHammer as) IO) a
interpretInitialEnv :: Int -> AnStatList as -> IntSt as
interpretInitialEnv edgeIndex actions =
IntSt (IMap.empty) edgeIndex [actions]
interpret :: EnabledAnalyses as as => IntSt as -> GraphHammerM as ()
interpret env = flip evalStateT env $ do
interpretStatements
interpretStatements :: EnabledAnalyses as as => AIM as ()
interpretStatements = do
conts <- liftM isConts get
case conts of
[] -> return ()
([]:cs) -> do
modify $! \st -> st { isConts = cs }
interpretStatements
((s:ss):cs) -> do
modify $! \st -> st { isConts = ss:cs }
interpretStatement s
interpretStatements
interpretStatement :: EnabledAnalyses as as => AnStatement as -> AIM as ()
interpretStatement stat = case stat of
ASAssign dest what ->
assignValue dest what
ASOnEdges startVertex vertexToAssign stats -> do
interpretOnEdges startVertex vertexToAssign stats
ASAtomicIncr aIndex vIndex incr -> do
incr' <- interpretValue incr
vIndex' <- interpretValue vIndex
lift $ graphHammerIncrementAnalysis aIndex vIndex' incr'
ASIf cond thenStats elseStats -> do
c <- interpretValue cond
let stats = if c then thenStats else elseStats
modify $! \st -> st { isConts = stats : isConts st }
ASContinueEdgeIsect edgeSet a b thisNodeVertex onEdgeStats -> do
ei <- liftM isEdgeIndex get
thisEdgeSet <- lift $ graphHammerGetEdgeSet ei thisNodeVertex
isection <- lift $ graphHammerVertexSetIntersectionAsIndices edgeSet thisEdgeSet
let cont c = ASAssign a (cst c) : ASAssign b (cst c) : onEdgeStats
modify $! \st -> st { isConts = map cont isection ++ isConts st }
ASContinueEdgeIsectBulk edgeSet thisNodeVertex bulkOps -> do
ei <- liftM isEdgeIndex get
thisEdgeSet <- lift $ graphHammerGetEdgeSet ei thisNodeVertex
isection <- lift $ graphHammerVertexSetIntersection edgeSet thisEdgeSet
interpretBulkOps isection bulkOps
ASOnEdgesIntersection av bv aN bN stats -> do
interpretEdgesIntersection av bv aN bN stats
ASIntersectionBulkOps av bv bulkStats ->
interpretIntersectionBulkOps av bv bulkStats
ASSetAnalysisResult _ _ _ -> error "interpretStatement for ASSetAnalysisResult is not implemented yet"
ASFlagVertex _ -> error "interpretStatement for ASFlagVertex is not implemented yet"
ASOnFlaggedVertices _ _ -> error "interpretStatement for ASOnFlaggedVertices is not implemented yet"
assignValue :: Show v => Value Asgn v -> Value _b v -> AIM as ()
assignValue (ValueLocal idx) what = do
x <- interpretValue what
modify $! \ist -> ist { istLocals = IMap.insert idx (toInt64 x) $ istLocals ist }
assignValue (ValueAnalysisResult _ _) _ = error "it's not possible to assign to result"
interpretIntersectionBulkOps :: Value _a Index -> Value _b Index -> [BulkOp as] -> AIM as ()
interpretIntersectionBulkOps a b ops = do
ei <- liftM isEdgeIndex get
s1 <- interpretVertexValue a
s2 <- interpretVertexValue b
l1 <- lift $ graphHammerLocalVertex s1
l2 <- lift $ graphHammerLocalVertex s2
case (l1,l2) of
(False, False) -> error "completely non-local computation!"
(True, True) -> do
e1 <- lift $ graphHammerGetEdgeSet ei s1
e2 <- lift $ graphHammerGetEdgeSet ei s2
isection <- lift $ graphHammerVertexSetIntersection e1 e2
interpretBulkOps isection ops
(True, False) -> do
ourEdges <- lift $ graphHammerGetEdgeSet ei s1
sendAndStop s2 ourEdges
(False, True) -> do
ourEdges <- lift $ graphHammerGetEdgeSet ei s2
sendAndStop s1 ourEdges
where
sendAndStop destIndex ourEdges = do
st <- get
let continueStat = ASContinueEdgeIsectBulk ourEdges destIndex ops
let sendSt = continueStat `seq` st { isConts = [continueStat] : isConts st }
lift $ graphHammerGroupContinuations destIndex $! sendSt
modify $! \st1 -> st1 { isConts = [] }
interpretBulkOps :: VertexSet -> [BulkOp as] -> AIM as ()
interpretBulkOps _isection [] = return ()
interpretBulkOps isection (op:ops) = do
case op of
BulkIncr aindex _ _ incr -> do
v <- interpretValue incr
lift $ graphHammerBulkIncrementAnalysis aindex isection v
CountIncr v incr -> do
assignValue v (incr *. cst (fromIntegral $ vertexSetSize isection))
interpretBulkOps isection ops
interpretEdgesIntersection :: Value _a Index -> Value _b Index -> Value Asgn Index -> Value Asgn Index -> AnStatList as -> AIM as ()
interpretEdgesIntersection a b aN bN stats = do
ei <- liftM isEdgeIndex get
s1 <- interpretVertexValue a
s2 <- interpretVertexValue b
l1 <- lift $ graphHammerLocalVertex s1
l2 <- lift $ graphHammerLocalVertex s2
case (l1,l2) of
(False, False) -> error "completely non-local computation!"
(True,True) -> do
e1 <- lift $ graphHammerGetEdgeSet ei s1
e2 <- lift $ graphHammerGetEdgeSet ei s2
let cont c = ASAssign aN (cst c) :
ASAssign bN (cst c) :
stats
isection <- lift $ graphHammerVertexSetIntersectionAsIndices e1 e2
let conts = map cont isection
modify $! \st -> st { isConts = conts ++ isConts st }
(True,False) -> do
ourEdges <- lift $ graphHammerGetEdgeSet ei s1
sendAndStop s2 s1 ourEdges
(False,True) -> do
ourEdges <- lift $ graphHammerGetEdgeSet ei s2
sendAndStop s1 s2 ourEdges
where
sendAndStop destIndex _ourIndex ourEdges = do
st <- get
let continueStat = ASContinueEdgeIsect ourEdges aN bN destIndex stats
let sendSt = st { isConts = [continueStat] : isConts st }
lift $ graphHammerGroupContinuations destIndex sendSt
modify $! \st1 -> st1 { isConts = [] }
interpretOnEdges :: EnabledAnalyses as as => Value _a Index -> Value Asgn Index -> AnStatList as -> AIM as ()
interpretOnEdges startVertex1 vertexToAssign1@(ValueLocal i1)
[ASOnEdges startVertex2 vertexToAssign2@(ValueLocal i2) [ASIf (ValueBin Equal a b) thenStats []]]
| Just i3 <- uncompose a
, Just i4 <- uncompose b
, (i1 == i3 && i2 == i4) || (i1 == i4 && i2 == i3) =
interpretEdgesIntersection startVertex1 startVertex2 vertexToAssign1 vertexToAssign2 thenStats
interpretOnEdges _startVertex _vertexToAssign _stats = do
error "standalone onEdges is not supported right now!"
interpretValue :: Value _a v -> AIM as v
interpretValue value = case value of
ValueLocal index1 -> do
locals <- liftM istLocals get
case IMap.lookup index1 locals of
Just v -> return (fromInt64 v)
Nothing -> error $ "local variable #"++show index1++" not found in "++show locals++"."
ValueArgument _index -> error "interpreting ValueArgument!!!"
ValueConst v -> return v
ValueBin Plus l r -> interpretBin (+) l r
ValueBin Minus l r -> interpretBin () l r
ValueBin Mul l r -> interpretBin (*) l r
ValueBin Div l r -> interpretBin (div) l r
ValueBin Equal l r -> interpretBin (==) l r
ValueUn Not val -> liftM not $ interpretValue val
ValueUn Negate val -> liftM negate $ interpretValue val
ValueComposed v -> interpretValue v
ValueAnalysisResult analysisIndex1 vertex -> do
v <- interpretValue vertex
lift $ graphHammerGetAnalysis analysisIndex1 v
where
interpretBin :: (a -> b -> r) -> Value _a a -> Value _b b -> AIM as r
interpretBin f a b = liftM2 f (interpretValue a) (interpretValue b)
interpretVertexValue :: Value _a Index -> AIM as Vertex
interpretVertexValue value = do
i <- interpretValue value
lift $ graphHammerSplitIndex i
optimizeStatements :: AnStatList as -> AnStatList as
optimizeStatements [] = []
optimizeStatements (stat : stats)
| Just stats' <- recognizeOptimizeIntersection stat
= stats' ++ optimizeStatements stats
optimizeStatements (stat : stats) = stat : optimizeStatements stats
recognizeOptimizeIntersection :: AnStatement as ->
Maybe (AnStatList as)
recognizeOptimizeIntersection stat = do
isection <- recognizeIntersection stat
let isections = optimizeIntersection isection
return isections
optimizeIntersection :: AnStatement as -> [AnStatement as]
optimizeIntersection stat@(ASOnEdgesIntersection a b aN bN stats) = case stats of
[ASAtomicIncr anIx ix incr, ASAssign v (ValueBin Plus l r)]
| incrIsConst incr
, Just iix <- uncompose ix
, Just iaN <- uncompose aN
, Just ibN <- uncompose bN
, iix == iaN || iix == ibN
, Just iv <- uncompose v
, Just assignIncr <- uncomposeOne iv l r ->
[ ASIntersectionBulkOps a b [BulkIncr anIx a b incr, CountIncr v assignIncr]]
_ -> [stat]
where
uncomposeOne :: Int32 -> Value _a x -> Value _b x -> Maybe (Value Composed x)
uncomposeOne rq a1 b1 = do
i <- uncompose a1
if i == rq then return (castComposed b1) else mzero
`mplus` do
i <- uncompose b1
if i == rq then return (castComposed a1) else mzero
castComposed :: Value _a a -> Value Composed a
castComposed (ValueComposed v) = ValueComposed v
castComposed (ValueConst c) = ValueConst c
castComposed v = ValueComposed v
incrIsConst :: Value _a c -> Bool
incrIsConst (ValueConst _c) = True
incrIsConst _ = False
optimizeIntersection _ = error "Not an intersection interation operator."
uncompose :: Value _a x -> Maybe Int32
uncompose (ValueComposed a) = uncompose a
uncompose (ValueLocal i) = Just i
uncompose _ = Nothing
recognizeIntersection :: AnStatement as -> Maybe (AnStatement as)
recognizeIntersection (ASOnEdges a aN [ASOnEdges b bN [ASIf cond stats []]]) = do
_ <- case cond of
ValueBin Equal x y -> do
ix <- uncompose x
iy <- uncompose y
iaN <- uncompose aN
ibN <- uncompose bN
if (ix == iaN && iy == ibN) || (ix == ibN && iy == iaN)
then return undefined
else mzero
_ -> mzero
return $ ASOnEdgesIntersection a b aN bN stats
recognizeIntersection _ = mzero
type family RequiredAnalyses a
class EnabledAnalysis a as
instance EnabledAnalysis a (a :. as)
instance EnabledAnalysis a as => EnabledAnalysis a (a' :. as)
class EnabledAnalyses as eas
instance EnabledAnalyses Nil eas
instance (EnabledAnalyses as eas, EnabledAnalysis a eas) => EnabledAnalyses (a :. as) eas
data Analysis as wholeset where
Analysis :: (EnabledAnalyses (RequiredAnalyses a) as, EnabledAnalyses as wholeset, EnabledAnalyses (a :. as) wholeset) =>
Value Asgn Index -> Value Asgn Index -> Int32 ->
AnStatList (a :. as) -> Analysis (a :. as) wholeset
basicAnalysis :: ((RequiredAnalyses a) ~ Nil, EnabledAnalysis a wholeset) =>
a -> (a -> Value Composed Index -> Value Composed Index -> AnM (a :. Nil) ()) -> Analysis (a :. Nil) wholeset
basicAnalysis analysis edgeInsert =
Analysis sv ev i stats
where
i = asValueIndex env
stats = optimizeStatements $ asStatements env
((sv,ev),env) = flip runState (AnSt 0 []) $ do
sv1 <- defineLocal
ev1 <- defineLocal
edgeInsert analysis (ValueComposed sv1) (ValueComposed ev1)
return (sv1,ev1)
derivedAnalysis :: (EnabledAnalyses (RequiredAnalyses a) as, EnabledAnalyses as wholeset, EnabledAnalyses (a :. as) wholeset) =>
Analysis as wholeset -> a -> (a -> Value Composed Index -> Value Composed Index -> AnM (a :. as) ()) -> Analysis (a :. as) wholeset
derivedAnalysis (Analysis startV endV startI requiredActions) analysis edgeInsert =
Analysis startV endV i (map liftStatement requiredActions ++ currentActions)
where
initialState = AnSt startI []
liftStatement :: AnStatement as -> AnStatement (a :. as)
liftStatement stat = case stat of
ASAssign v e -> ASAssign v e
ASOnEdges i1 arg as -> ASOnEdges i1 arg (map liftStatement as)
ASAtomicIncr ai vi incr -> ASAtomicIncr ai vi incr
ASIf cond thens elses -> ASIf cond (map liftStatement thens) (map liftStatement elses)
ASSetAnalysisResult ai vi val -> ASSetAnalysisResult ai vi val
ASFlagVertex v -> ASFlagVertex v
ASOnFlaggedVertices arg stats -> ASOnFlaggedVertices arg $ map liftStatement stats
ASOnEdgesIntersection va vb ai bi stats -> ASOnEdgesIntersection va vb ai bi $ map liftStatement stats
ASIntersectionBulkOps _va _vb _ops -> error "derivedAnalysis over ASIntersectionBulkOps is not yet implemented"
ASContinueEdgeIsect vs ai bi v stats -> ASContinueEdgeIsect vs ai bi v $ map liftStatement stats
ASContinueEdgeIsectBulk _ _ _ -> error "derivedAnalysis over ASContinueEdgeIsectBulk is not yet implemented"
currentActions = optimizeStatements $ asStatements env
i = asValueIndex env
env = flip execState initialState $ do
edgeInsert analysis (ValueComposed startV) (ValueComposed endV)
class EnabledAnalysis a as => AnalysisIndex a as where
analysisIndex :: a -> as -> Int
instance AnalysisIndex a as => AnalysisIndex a (a' :. as) where
analysisIndex a list = analysisIndex a (hTail list)
instance HLength as => AnalysisIndex a (a :. as) where
analysisIndex _ list = hLength (hTail list)