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.

src/Copar/Algorithm.hs

@@ -52,10 +52,11 @@ refine :: forall f s.
      RefinementInterface f
   => Proxy f
   -> Encoding (Label f) (F1 f)
+  -> Bool
   -> ST s Partition
-refine Proxy encoding = do
+refine Proxy encoding enableOptimization = do
   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)
 
   _ <- processQueue queue state
@@ -70,10 +71,11 @@ refineWithStats
    . RefinementInterface f
   => Proxy f
   -> Encoding (Label f) (F1 f)
+  -> Bool
   -> IO (Partition, AlgoStatistics)
-refineWithStats Proxy encoding = do
+refineWithStats Proxy encoding enableOptimization = do
   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)
   let initialBlocks = length blocks
 

src/Copar/Algorithm/Initialize.hs

@@ -26,8 +26,9 @@ import qualified Data.RefinablePartition as Partition
 -- returns (initial queue content, algo state)
 initialize :: forall f s. RefinementInterface f
            => Encoding (Label f) (F1 f)
+           -> Bool
            -> ST s ([Block], AlgoState s f)
-initialize encoding = do
+initialize encoding enableOptimization = do
   toSub <- VM.replicate (size encoding) []
   lastW <- VM.new (numEdges encoding)
   predMutable <- VM.replicate (size encoding) []
@@ -56,5 +57,6 @@ initialize encoding = do
   blocks <- Partition.groupBy partition 0 (comparing (typeOf encoding))
 
   size1Count <- newSTRef 0
+  let size1Enabled = enableOptimization
 
   return (blocks, AlgoState {..})

src/Copar/Algorithm/Split.hs

@@ -162,11 +162,11 @@ collectTouchedBlocks blockS = do
 
     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.
       modifySTRef' (size1Count as) (+1)
 
-    unless (sizeOfB == 1) $ do
+    unless (sizeOfB == 1 && size1Enabled as) $ do
       unlessM (Partition.hasMarked (partition as) b) $ do
         wCx <- readSTRef =<< VM.read (lastW as) (fromEdgeRef e)
         let v0 = snd3 $ RI.update @f [] wCx

src/Copar/Algorithm/Types.hs

@@ -11,6 +11,7 @@ module Copar.Algorithm.Types
   , partitionL
   , f3CacheL
   , size1CountL
+  , size1EnabledL
   )
 where
 
@@ -34,6 +35,8 @@ data AlgoState s f = AlgoState
   -- | How often did we skip a block instead of calling update/splitBlock on it
   -- due to our size-1-optimization.
   , size1Count :: {-# UNPACK #-} (STRef s Int)
+  -- | Enable the 1-block optimization
+  , size1Enabled :: Bool
   }
 
 makeLensesFor
@@ -44,5 +47,6 @@ makeLensesFor
   , ( "partition", "partitionL")
   , ( "f3Cache", "f3CacheL")
   , ( "size1Count", "size1CountL")
+  , ( "size1Enabled", "size1EnabledL")
   ]
   ''AlgoState

src/main/Main.hs

@@ -105,6 +105,7 @@ data RefineOptions = RefineOptions
   , refineFunctor :: Maybe (FunctorExpression SomeFunctor Sort)
   , refineApplyTransformations :: Bool
   , refineEnableSanity :: Bool
+  , refineEnableOpt :: Bool
   , refineInputFile :: Maybe FilePath
   , refineOutputFile :: Maybe FilePath
   }
@@ -184,6 +185,12 @@ refineOptions = do
          \might speed up the parser but require the input to be absolutely \
          \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 { .. }
 
 data GraphOptions = GraphOptions
@@ -418,11 +425,11 @@ main = do
 
         partition <- case statsType stats of
           NoStats ->
-            withTimeStat stats "algorithm-duration" (stToIO (refine f encoding))
+            withTimeStat stats "algorithm-duration" (stToIO (refine f encoding (refineEnableOpt r)))
           _ -> do
             (part, algoStats) <-
               withTimeStat stats "algorithm-duration"
-                $ (refineWithStats f encoding)
+                $ (refineWithStats f encoding (refineEnableOpt r))
             logStat stats
                     "initial-partition-size"
                     (tshow (initialBlocks algoStats))
@@ -469,7 +476,7 @@ main = do
           Right res -> evaluate $ res
 
       part <- if graphDrawPartition r
-        then (Just <$> stToIO (refine f encoding))
+        then (Just <$> stToIO (refine f encoding True))
         else return Nothing
 
       let config = DotConfig { nodeLabels = graphDrawNodeLabels r