Commit b090cb5a authored by Hans-Peter Deifel's avatar Hans-Peter Deifel 🐢

Add CLI flag to disable optimizations

This allows to disable the 1-elem-block optimization to be able to compare the
running times with and with out it.
parent 4ac6cc5b
...@@ -52,10 +52,11 @@ refine :: forall f s. ...@@ -52,10 +52,11 @@ refine :: forall f s.
RefinementInterface f RefinementInterface f
=> Proxy f => Proxy f
-> Encoding (Label f) (F1 f) -> Encoding (Label f) (F1 f)
-> Bool
-> ST s Partition -> ST s Partition
refine Proxy encoding = do refine Proxy encoding enableOptimization = do
queue <- Queue.empty (size encoding) queue <- Queue.empty (size encoding)
(blocks, state) <- initialize @f encoding (blocks, state) <- initialize @f encoding enableOptimization
deleteLargestM (Partition.blockSize (partition state)) blocks >>= mapM_ (Queue.enqueue queue) deleteLargestM (Partition.blockSize (partition state)) blocks >>= mapM_ (Queue.enqueue queue)
_ <- processQueue queue state _ <- processQueue queue state
...@@ -70,10 +71,11 @@ refineWithStats ...@@ -70,10 +71,11 @@ refineWithStats
. RefinementInterface f . RefinementInterface f
=> Proxy f => Proxy f
-> Encoding (Label f) (F1 f) -> Encoding (Label f) (F1 f)
-> Bool
-> IO (Partition, AlgoStatistics) -> IO (Partition, AlgoStatistics)
refineWithStats Proxy encoding = do refineWithStats Proxy encoding enableOptimization = do
queue <- stToIO $ Queue.empty (size encoding) queue <- stToIO $ Queue.empty (size encoding)
(initTime, (blocks, state)) <- withTime (stToIO $ initialize @f encoding) (initTime, (blocks, state)) <- withTime (stToIO $ initialize @f encoding enableOptimization)
deleteLargestM (stToIO . Partition.blockSize (partition state)) blocks >>= mapM_ (stToIO . Queue.enqueue queue) deleteLargestM (stToIO . Partition.blockSize (partition state)) blocks >>= mapM_ (stToIO . Queue.enqueue queue)
let initialBlocks = length blocks let initialBlocks = length blocks
......
...@@ -26,8 +26,9 @@ import qualified Data.RefinablePartition as Partition ...@@ -26,8 +26,9 @@ import qualified Data.RefinablePartition as Partition
-- returns (initial queue content, algo state) -- returns (initial queue content, algo state)
initialize :: forall f s. RefinementInterface f initialize :: forall f s. RefinementInterface f
=> Encoding (Label f) (F1 f) => Encoding (Label f) (F1 f)
-> Bool
-> ST s ([Block], AlgoState s f) -> ST s ([Block], AlgoState s f)
initialize encoding = do initialize encoding enableOptimization = do
toSub <- VM.replicate (size encoding) [] toSub <- VM.replicate (size encoding) []
lastW <- VM.new (numEdges encoding) lastW <- VM.new (numEdges encoding)
predMutable <- VM.replicate (size encoding) [] predMutable <- VM.replicate (size encoding) []
...@@ -56,5 +57,6 @@ initialize encoding = do ...@@ -56,5 +57,6 @@ initialize encoding = do
blocks <- Partition.groupBy partition 0 (comparing (typeOf encoding)) blocks <- Partition.groupBy partition 0 (comparing (typeOf encoding))
size1Count <- newSTRef 0 size1Count <- newSTRef 0
let size1Enabled = enableOptimization
return (blocks, AlgoState {..}) return (blocks, AlgoState {..})
...@@ -162,11 +162,11 @@ collectTouchedBlocks blockS = do ...@@ -162,11 +162,11 @@ collectTouchedBlocks blockS = do
sizeOfB <- Partition.blockSize (partition as) b sizeOfB <- Partition.blockSize (partition as) b
when (sizeOfB == 1) $ when (sizeOfB == 1 && size1Enabled as) $
-- We found an edge with an outgoing block that has only one state. -- We found an edge with an outgoing block that has only one state.
modifySTRef' (size1Count as) (+1) modifySTRef' (size1Count as) (+1)
unless (sizeOfB == 1) $ do unless (sizeOfB == 1 && size1Enabled as) $ do
unlessM (Partition.hasMarked (partition as) b) $ do unlessM (Partition.hasMarked (partition as) b) $ do
wCx <- readSTRef =<< VM.read (lastW as) (fromEdgeRef e) wCx <- readSTRef =<< VM.read (lastW as) (fromEdgeRef e)
let v0 = snd3 $ RI.update @f [] wCx let v0 = snd3 $ RI.update @f [] wCx
......
...@@ -11,6 +11,7 @@ module Copar.Algorithm.Types ...@@ -11,6 +11,7 @@ module Copar.Algorithm.Types
, partitionL , partitionL
, f3CacheL , f3CacheL
, size1CountL , size1CountL
, size1EnabledL
) )
where where
...@@ -34,6 +35,8 @@ data AlgoState s f = AlgoState ...@@ -34,6 +35,8 @@ data AlgoState s f = AlgoState
-- | How often did we skip a block instead of calling update/splitBlock on it -- | How often did we skip a block instead of calling update/splitBlock on it
-- due to our size-1-optimization. -- due to our size-1-optimization.
, size1Count :: {-# UNPACK #-} (STRef s Int) , size1Count :: {-# UNPACK #-} (STRef s Int)
-- | Enable the 1-block optimization
, size1Enabled :: Bool
} }
makeLensesFor makeLensesFor
...@@ -44,5 +47,6 @@ makeLensesFor ...@@ -44,5 +47,6 @@ makeLensesFor
, ( "partition", "partitionL") , ( "partition", "partitionL")
, ( "f3Cache", "f3CacheL") , ( "f3Cache", "f3CacheL")
, ( "size1Count", "size1CountL") , ( "size1Count", "size1CountL")
, ( "size1Enabled", "size1EnabledL")
] ]
''AlgoState ''AlgoState
...@@ -105,6 +105,7 @@ data RefineOptions = RefineOptions ...@@ -105,6 +105,7 @@ data RefineOptions = RefineOptions
, refineFunctor :: Maybe (FunctorExpression SomeFunctor Sort) , refineFunctor :: Maybe (FunctorExpression SomeFunctor Sort)
, refineApplyTransformations :: Bool , refineApplyTransformations :: Bool
, refineEnableSanity :: Bool , refineEnableSanity :: Bool
, refineEnableOpt :: Bool
, refineInputFile :: Maybe FilePath , refineInputFile :: Maybe FilePath
, refineOutputFile :: Maybe FilePath , refineOutputFile :: Maybe FilePath
} }
...@@ -184,6 +185,12 @@ refineOptions = do ...@@ -184,6 +185,12 @@ refineOptions = do
\might speed up the parser but require the input to be absolutely \ \might speed up the parser but require the input to be absolutely \
\correct. Otherwise, nasal demons might be created." \correct. Otherwise, nasal demons might be created."
) )
refineEnableOpt <- not <$> switch
( long "disable-optimizations"
<> help "Disable some optimizations. Currently, this is just the \
\one-element optimization. Obviously, this will reduce \
\performance."
)
pure RefineOptions { .. } pure RefineOptions { .. }
data GraphOptions = GraphOptions data GraphOptions = GraphOptions
...@@ -418,11 +425,11 @@ main = do ...@@ -418,11 +425,11 @@ main = do
partition <- case statsType stats of partition <- case statsType stats of
NoStats -> NoStats ->
withTimeStat stats "algorithm-duration" (stToIO (refine f encoding)) withTimeStat stats "algorithm-duration" (stToIO (refine f encoding (refineEnableOpt r)))
_ -> do _ -> do
(part, algoStats) <- (part, algoStats) <-
withTimeStat stats "algorithm-duration" withTimeStat stats "algorithm-duration"
$ (refineWithStats f encoding) $ (refineWithStats f encoding (refineEnableOpt r))
logStat stats logStat stats
"initial-partition-size" "initial-partition-size"
(tshow (initialBlocks algoStats)) (tshow (initialBlocks algoStats))
...@@ -469,7 +476,7 @@ main = do ...@@ -469,7 +476,7 @@ main = do
Right res -> evaluate $ res Right res -> evaluate $ res
part <- if graphDrawPartition r part <- if graphDrawPartition r
then (Just <$> stToIO (refine f encoding)) then (Just <$> stToIO (refine f encoding True))
else return Nothing else return Nothing
let config = DotConfig { nodeLabels = graphDrawNodeLabels r let config = DotConfig { nodeLabels = graphDrawNodeLabels r
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment