diff --git a/copar.cabal b/copar.cabal index 11832c0949832f6c55b6f16ffe57ff4a857a81af..27879e008a1a673c7e4f62942cff2b0c50db2872 100644 --- a/copar.cabal +++ b/copar.cabal @@ -64,6 +64,7 @@ library , Copar.Dot , Copar.PrettyShow , Copar.RewriteFunctors + , Copar.Timing default-extensions: GADTs , StandaloneDeriving , DeriveFunctor @@ -96,6 +97,7 @@ library , deriving-compat , ieee754 >= 0.8.0 && <0.9 , vector-th-unbox >= 0.2 && <0.3 + , scientific >= 0.3.6 && < 0.4 ghc-options: -Wall -Wno-name-shadowing if flag(release) cpp-options: -DRELEASE @@ -113,7 +115,7 @@ executable copar , deepseq , optparse-applicative , json - , scientific + , scientific >= 0.3.6 && < 0.4 , prettyprinter , prettyprinter-ansi-terminal , prettyprinter-convert-ansi-wl-pprint diff --git a/src/Copar/Algorithm.hs b/src/Copar/Algorithm.hs index 8619356d60db53d4de1794cf223cb2de0bf0408d..1b794bac34256c44f4910d0214007160b077b073 100644 --- a/src/Copar/Algorithm.hs +++ b/src/Copar/Algorithm.hs @@ -7,8 +7,6 @@ module Copar.Algorithm import Control.Monad.ST import Data.STRef import Data.Proxy -import Data.Bifunctor (second) -import Data.Maybe (fromJust) import Control.Monad.Extra (whileM) import Control.Monad.Reader @@ -23,11 +21,16 @@ import Copar.Coalgebra.RefinementTypes import Copar.Algorithm.Types import Copar.Algorithm.Initialize import Copar.Algorithm.Split +import Copar.Timing -- | Metrics about the algorithm's execution. data AlgoStatistics = AlgoStatistics { initialBlocks :: Int -- ^ Size of the initial partition , splitCount :: Int -- ^ Overall count of 'split' operations + , initTime :: Integer -- ^ Time in picoseconds spend in the initialize + -- procedure + , refineTime :: Integer -- ^ Time in picoseconds spend in the rest of the + -- algorithm (calling split until the queue is empty) } -- | Returns the count of 'split' calls @@ -47,37 +50,34 @@ refine :: forall f s. => Proxy f -> Encoding (Label f) (F1 f) -> ST s Partition -refine Proxy = fmap fst . refineImpl False (Proxy @f) +refine Proxy encoding = do + queue <- Queue.empty (size encoding) + (blocks, state) <- initialize @f encoding + mapM_ (Queue.enqueue queue) blocks + + _ <- processQueue queue state + + Partition.freeze (partition state) + -- | Seme as 'refine', but also reports some statistics about the algorithm's -- execution. -refineWithStats :: forall f s. - RefinementInterface f +refineWithStats + :: forall f + . RefinementInterface f => Proxy f -> Encoding (Label f) (F1 f) - -> ST s (Partition, AlgoStatistics) -refineWithStats Proxy = - fmap (second fromJust) . refineImpl True (Proxy @f) - -refineImpl :: forall f s. - RefinementInterface f - => Bool - -> Proxy f - -> Encoding (Label f) (F1 f) - -> ST s (Partition, Maybe AlgoStatistics) -refineImpl collectStats Proxy encoding = do - queue <- Queue.empty (size encoding) - (blocks, state) <- initialize @f encoding - mapM_ (Queue.enqueue queue) blocks + -> IO (Partition, AlgoStatistics) +refineWithStats Proxy encoding = do + queue <- stToIO $ Queue.empty (size encoding) + (initTime, (blocks, state)) <- withTime (stToIO $ initialize @f encoding) + mapM_ (stToIO . Queue.enqueue queue) blocks let initialBlocks = length blocks - splitCount <- processQueue queue state + (refineTime, splitCount) <- withTime (stToIO $ processQueue queue state) - part <- Partition.freeze (partition state) + part <- stToIO $ Partition.freeze (partition state) - let stats = - if collectStats - then Just (AlgoStatistics initialBlocks splitCount) - else Nothing + let stats = (AlgoStatistics initialBlocks splitCount initTime refineTime) return (part, stats) diff --git a/src/Copar/Timing.hs b/src/Copar/Timing.hs new file mode 100644 index 0000000000000000000000000000000000000000..1bf33a8d247ad499f2ed41ffc561e9a725acb8c0 --- /dev/null +++ b/src/Copar/Timing.hs @@ -0,0 +1,21 @@ +module Copar.Timing (withTime, showTimeDiff) where + +import System.CPUTime + +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.Scientific + +-- | Run an IO action and return its result together with its execution time in +-- picoseconds. +withTime :: IO a -> IO (Integer, a) +withTime action = do + time1 <- getCPUTime + res <- action + time2 <- getCPUTime + return (time2 - time1, res) + +-- | Return the time as seconds +showTimeDiff :: Integer -> Text +showTimeDiff picoseconds = + T.pack (formatScientific Fixed (Just 10) (scientific picoseconds (-12))) diff --git a/src/main/Main.hs b/src/main/Main.hs index 4ced26b932be10bdcf2f776604763357b40b4a1e..77f0a011ba28c1bb1d66ed76db7343908d260160 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -48,6 +48,7 @@ import Copar.Functors.SomeFunctor (SomeFunctor) import Copar.FunctorExpression.Type (FunctorExpression) import Copar.Dot import Copar.RewriteFunctors +import Copar.Timing ---------------------------------------------------------------------- -- CLI Options @@ -327,30 +328,31 @@ outputPartition (Just file) = writePartition file main :: IO () main = do termColumns <- flip fmap (lookupEnv "COLUMNS") $ \case - Nothing -> 120 + Nothing -> 120 Just val -> min (read val) 120 let optionParserPrefs = prefs (showHelpOnEmpty <> columns termColumns) - params <- customExecParser optionParserPrefs $ - info (options <**> helper) fullDesc + params <- customExecParser optionParserPrefs + $ info (options <**> helper) fullDesc case optCommand params of - (HelpCommand f) -> printHelp f + (HelpCommand f) -> printHelp f (RefineCommand r) -> do stats <- initStats (refineStats r) (refineStatsJson r) - withTime stats "overall-duration" $ do - (f, (symbolTable, encoding)) <- withTime stats "parse-duration" $ do + withTimeStat stats "overall-duration" $ do + (f, (symbolTable, encoding)) <- withTimeStat stats "parse-duration" $ do let transPolicy = if (refineApplyTransformations r) then ApplyTransformations else DontApplyTransformations - readCoalgebra (refineFunctor r) transPolicy (refineInputFile r) >>= \case - Left err -> hPutStrLn stderr err >> exitFailure - Right res -> evaluate $ res + readCoalgebra (refineFunctor r) transPolicy (refineInputFile r) + >>= \case + Left err -> hPutStrLn stderr err >> exitFailure + Right res -> evaluate $ res logStat stats "states" (tshow (Encoding.size encoding)) - logStat stats "edges" (tshow (Encoding.numEdges encoding)) + logStat stats "edges" (tshow (Encoding.numEdges encoding)) let isFirstSort x = sortedSort x == 1 logStat @@ -359,31 +361,35 @@ main = do (tshow (length (V.filter isFirstSort (Encoding.structure encoding)))) partition <- case statsType stats of - NoStats -> withTime stats "refine-duration" (stToIO (refine f encoding)) + NoStats -> + withTimeStat stats "algorithm-duration" (stToIO (refine f encoding)) _ -> do - (part, algoStats) <- withTime stats "refine-duration" $ - (stToIO (refineWithStats f encoding)) - logStat - stats - "initial-partition-size" - (tshow (initialBlocks algoStats)) - logStat - stats - "split-operation-count" - (tshow (splitCount algoStats)) + (part, algoStats) <- + withTimeStat stats "algorithm-duration" + $ (refineWithStats f encoding) + logStat stats + "initial-partition-size" + (tshow (initialBlocks algoStats)) + logStat stats + "initialize-duration" + (showTimeDiff (initTime algoStats)) + logStat stats "split-operation-count" (tshow (splitCount algoStats)) + logStat stats + "refine-duration" + (showTimeDiff (refineTime algoStats)) return part - logStat - stats - "final-partition-size" - (tshow (Partition.numBlocks partition)) + logStat stats + "final-partition-size" + (tshow (Partition.numBlocks partition)) - logStat - stats - "explicit-final-partition-size" - (tshow (length (restrictPartitionToSort1 encoding partition))) + logStat stats + "explicit-final-partition-size" + (tshow (length (restrictPartitionToSort1 encoding partition))) - withTime stats "output-duration" + withTimeStat + stats + "output-duration" (outputPartition (refineOutputFile r) encoding symbolTable partition) finalizeStats stats @@ -395,27 +401,25 @@ main = do else DontApplyTransformations readCoalgebra (graphFunctor r) transPolicy (graphInputFile r) >>= \case - Left err -> hPutStrLn stderr err >> exitFailure + Left err -> hPutStrLn stderr err >> exitFailure Right res -> evaluate $ res - part <- - if graphDrawPartition r - then (Just <$> stToIO (refine f encoding)) - else return Nothing + part <- if graphDrawPartition r + then (Just <$> stToIO (refine f encoding)) + else return Nothing - let config = DotConfig - { nodeLabels = graphDrawNodeLabels r - , edgeLabels = graphDrawEdgeLabels r - } + let config = DotConfig { nodeLabels = graphDrawNodeLabels r + , edgeLabels = graphDrawEdgeLabels r + } case graphOutputFile r of - Nothing -> printDot config symbolTable encoding part - Just "-" -> printDot config symbolTable encoding part + Nothing -> printDot config symbolTable encoding part + Just "-" -> printDot config symbolTable encoding part Just file -> writeDot file config symbolTable encoding part DebugCommand (DebugFunctor applyTrans f) | applyTrans -> pPrint (applyFunctorRewrites f) - | otherwise -> pPrint f + | otherwise -> pPrint f printHelp :: HelpCommand -> IO () @@ -434,21 +438,13 @@ tabularize table = do T.putStr "\n" -withTime :: Stats -> Text -> IO a -> IO a -withTime stats name action = case statsType stats of +withTimeStat :: Stats -> Text -> IO a -> IO a +withTimeStat stats name action = case statsType stats of NoStats -> action _ -> do - time1 <- getCPUTime - res <- action - time2 <- getCPUTime - - logStat stats name (showTimeDiff (time2 - time1)) - + (duration, res) <- withTime action + logStat stats name (showTimeDiff duration) return res --- | Output the time as seconds -showTimeDiff :: Integer -> Text -showTimeDiff picoseconds = T.pack (formatScientific Fixed (Just 10) (scientific picoseconds (-12))) - tshow :: Show a => a -> Text tshow = T.pack . show