From 8314929db56f92177e573de57c64558f7153e4c1 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Tue, 4 Jun 2024 22:26:32 -0400 Subject: [PATCH] Add INLINEABLE annotations It turns out, these _appear_ to make a (modest) difference. In general, the INLINEABLE benchmarks use slightly less memory (file logging is the most significant, at 10% less allocated), and the benchmarks are _generally_ faster (though some are slightly slower). Might as well add these in. Our (extremely blunt) strategy is to add INLINEABLE to any function involving polymorphic monad m, to prevent polymorphic binds from blocking optimizations. --- benchmarks/baseline_9.8.2.csv | 12 ++-- benchmarks/baseline_9.8.2.svg | 70 +++++++++---------- src/Shrun.hs | 13 ++++ src/Shrun/Configuration.hs | 1 + .../Configuration/Data/CommandLogging.hs | 2 + .../Data/CommandLogging/PollInterval.hs | 1 + .../Data/CommandLogging/ReadSize.hs | 1 + .../Data/CommandLogging/ReadStrategy.hs | 1 + .../Configuration/Data/ConsoleLogging.hs | 1 + .../Data/ConsoleLogging/TimerFormat.hs | 1 + src/Shrun/Configuration/Data/Core.hs | 2 + src/Shrun/Configuration/Data/Core/Timeout.hs | 2 + src/Shrun/Configuration/Data/FileLogging.hs | 6 ++ .../Data/FileLogging/FileMode.hs | 1 + .../Data/FileLogging/FilePathDefault.hs | 1 + .../Data/FileLogging/FileSizeMode.hs | 1 + src/Shrun/Configuration/Data/Notify.hs | 2 + src/Shrun/Configuration/Data/Truncation.hs | 4 ++ src/Shrun/Configuration/Env.hs | 5 ++ src/Shrun/Configuration/Env/Types.hs | 2 + src/Shrun/IO.hs | 17 +++++ src/Shrun/IO/Types.hs | 22 ++++++ src/Shrun/Logging.hs | 3 + src/Shrun/Logging/Formatting.hs | 1 + src/Shrun/Notify.hs | 4 ++ src/Shrun/Notify/MonadAppleScript.hs | 3 + src/Shrun/Notify/MonadDBus.hs | 6 ++ src/Shrun/Notify/MonadNotifySend.hs | 3 + src/Shrun/Notify/Types.hs | 3 + src/Shrun/Prelude.hs | 4 ++ src/Shrun/ShellT.hs | 1 + src/Shrun/Utils.hs | 5 ++ tools/bench.sh | 2 +- 33 files changed, 161 insertions(+), 42 deletions(-) diff --git a/benchmarks/baseline_9.8.2.csv b/benchmarks/baseline_9.8.2.csv index 61867281..66e2ac90 100644 --- a/benchmarks/baseline_9.8.2.csv +++ b/benchmarks/baseline_9.8.2.csv @@ -1,7 +1,7 @@ Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory -All.Basic Logging.10_000,32054981100,2719280254,197767499,1491201,15728640 -All.Basic Logging.100_000,284949455400,3088076064,1921481603,12566747,22020096 -All.Command Logging.10_000,8675987087,358680480,7701613,170721,22020096 -All.Command Logging.100_000,818098265200,26302296974,427536247,2438572,22020096 -All.File Logging.10_000,28730622578,1775853462,20914526,638780,22020096 -All.File Logging.100_000,5507945763000,212603894328,2001917452,23482169,22020096 +All.Basic Logging.10_000,13994919850,788201886,164620558,1226940,14680064 +All.Basic Logging.100_000,134352162600,3092666264,1642240890,10696009,23068672 +All.Command Logging.10_000,10629656550,664104250,25934036,1142611,23068672 +All.Command Logging.100_000,141102413675,9240202760,290511672,12695602,23068672 +All.File Logging.10_000,67230350850,4015181822,114474577,6010048,23068672 +All.File Logging.100_000,1063772303400,41051284184,1801811732,93045236,23068672 diff --git a/benchmarks/baseline_9.8.2.svg b/benchmarks/baseline_9.8.2.svg index db0ef42c..6d7957e4 100644 --- a/benchmarks/baseline_9.8.2.svg +++ b/benchmarks/baseline_9.8.2.svg @@ -1,59 +1,59 @@ -Basic Logging.10_000 32.1 ms +Basic Logging.10_000 14.0 ms -32.1 ms ± 2.7 ms - - - - +14.0 ms ± 788 μs + + + + -Basic Logging.100_000 285 ms +Basic Logging.100_000 134 ms -285 ms ± 3.1 ms - - - - +134 ms ± 3.1 ms + + + + -Command Logging.10_000 8.68 ms +Command Logging.10_000 10.6 ms -8.68 ms ± 359 μs - - - - +10.6 ms ± 664 μs + + + + -Command Logging.100_000 818 ms +Command Logging.100_000 141 ms -818 ms ± 26 ms - - - - +141 ms ± 9.2 ms + + + + -File Logging.10_000 28.7 ms +File Logging.10_000 67.2 ms -28.7 ms ± 1.8 ms - - - - +67.2 ms ± 4.0 ms + + + + File Logging.100_000 -5.508 s +1.064 s -5.508 s ± 213 ms - - - +1.064 s ± 41 ms + + + diff --git a/src/Shrun.hs b/src/Shrun.hs index aefaaeb5..02d5b682 100644 --- a/src/Shrun.hs +++ b/src/Shrun.hs @@ -132,6 +132,7 @@ shrun = displayRegions $ do hFlush h where MkFileLogOpened h fileQueue = fileLogging ^. #file + {-# INLINEABLE runWithFileLogging #-} runCommands :: (HasCallStack) => m () runCommands = do @@ -141,6 +142,8 @@ shrun = displayRegions $ do (totalTime, result) <- withTiming $ tryAny actionsWithTimer printFinalResult totalTime result + {-# INLINEABLE runCommands #-} +{-# INLINEABLE shrun #-} runCommand :: forall m env. @@ -200,6 +203,7 @@ runCommand cmd = do Just NotifyAll -> Notify.sendNotif (formattedCmd <> " Finished") timeMsg urgency Just NotifyCommand -> Notify.sendNotif (formattedCmd <> " Finished") timeMsg urgency _ -> pure () +{-# INLINEABLE runCommand #-} printFinalResult :: forall m env e b. @@ -264,6 +268,7 @@ printFinalResult totalTime result = withRegion Linear $ \r -> do _ -> pure () Logging.putRegionLog r finalLog +{-# INLINEABLE printFinalResult #-} counter :: ( HasAnyError env, @@ -293,6 +298,7 @@ counter = do sleep 1 elapsed <- atomicModifyIORef' timer $ \t -> (t + 1, t + 1) logCounter r elapsed +{-# INLINEABLE counter #-} logCounter :: forall m env. @@ -317,6 +323,7 @@ logCounter region elapsed = do mode = LogModeSet } Logging.regionLogToConsoleQueue region lg +{-# INLINEABLE logCounter #-} keepRunning :: forall m env. @@ -365,6 +372,7 @@ keepRunning region timer mto = do } pure False else pure True +{-# INLINEABLE keepRunning #-} timedOut :: Natural -> Maybe Timeout -> Bool timedOut _ Nothing = False @@ -382,6 +390,7 @@ pollQueueToConsole :: pollQueueToConsole queue = do -- NOTE: Same masking behavior as pollQueueToFile. forever $ atomicReadWrite queue printConsoleLog +{-# INLINEABLE pollQueueToConsole #-} printConsoleLog :: ( HasCallStack, @@ -391,6 +400,7 @@ printConsoleLog :: m () printConsoleLog (LogNoRegion consoleLog) = logGlobal (consoleLog ^. #unConsoleLog) printConsoleLog (LogRegion m r consoleLog) = logRegion m r (consoleLog ^. #unConsoleLog) +{-# INLINEABLE printConsoleLog #-} pollQueueToFile :: ( HasCallStack, @@ -409,9 +419,11 @@ pollQueueToFile fileLogging = do atomicReadWrite queue (logFile h) where MkFileLogOpened h queue = fileLogging ^. #file +{-# INLINEABLE pollQueueToFile #-} logFile :: (HasCallStack, MonadHandleWriter m) => Handle -> FileLog -> m () logFile h = (\t -> hPutUtf8 h t *> hFlush h) . view #unFileLog +{-# INLINEABLE logFile #-} -- | Reads from a queue and applies the function, if we receive a value. -- Atomic in the sense that if a read is successful, then we will apply the @@ -428,3 +440,4 @@ atomicReadWrite :: m () atomicReadWrite queue logAction = mask $ \restore -> restore (readTBQueueA queue) >>= void . logAction +{-# INLINEABLE atomicReadWrite #-} diff --git a/src/Shrun/Configuration.hs b/src/Shrun/Configuration.hs index 71ddae23..724ca217 100644 --- a/src/Shrun/Configuration.hs +++ b/src/Shrun/Configuration.hs @@ -73,3 +73,4 @@ mergeConfig args mToml = do } where cmdsText = args ^. #commands +{-# INLINEABLE mergeConfig #-} diff --git a/src/Shrun/Configuration/Data/CommandLogging.hs b/src/Shrun/Configuration/Data/CommandLogging.hs index d6f7c8a1..4c01aab3 100644 --- a/src/Shrun/Configuration/Data/CommandLogging.hs +++ b/src/Shrun/Configuration/Data/CommandLogging.hs @@ -77,6 +77,7 @@ parseBufferLength getNat = do case convertIntegral n of Left err -> fail err Right x -> pure $ MkBufferLength x +{-# INLINEABLE parseBufferLength #-} newtype BufferTimeout = MkBufferTimeout Timeout deriving stock (Eq, Show) @@ -102,6 +103,7 @@ parseBufferTimeout :: f BufferTimeout parseBufferTimeout getNat getTxt = MkBufferTimeout <$> Timeout.parseTimeout getNat getTxt +{-# INLINEABLE parseBufferTimeout #-} -- | Switch for logging read errors data ReportReadErrorsSwitch diff --git a/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs b/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs index d77bd7c2..077fd04a 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/PollInterval.hs @@ -28,6 +28,7 @@ instance DecodeTOML PollInterval where parsePollInterval :: (Functor m) => m Natural -> m PollInterval parsePollInterval getNat = MkPollInterval <$> getNat +{-# INLINEABLE parsePollInterval #-} instance Default PollInterval where def = MkPollInterval 10_000 diff --git a/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs b/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs index cf5d08e9..a041d02d 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/ReadSize.hs @@ -119,3 +119,4 @@ parseReadSize getTxt = do case U.parseByteText byteTxt of Right b -> pure $ MkReadSize b Left err -> fail $ "Could not parse --command-log-read-size size: " <> unpack err +{-# INLINEABLE parseReadSize #-} diff --git a/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs b/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs index 227a7e6d..273d9929 100644 --- a/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs +++ b/src/Shrun/Configuration/Data/CommandLogging/ReadStrategy.hs @@ -42,6 +42,7 @@ parseReadStrategy getTxt = "'. Expected one of ", readStrategyStr ] +{-# INLINEABLE parseReadStrategy #-} -- | Available 'ReadStrategy' strings. readStrategyStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/ConsoleLogging.hs b/src/Shrun/Configuration/Data/ConsoleLogging.hs index 45a56949..dbcedf41 100644 --- a/src/Shrun/Configuration/Data/ConsoleLogging.hs +++ b/src/Shrun/Configuration/Data/ConsoleLogging.hs @@ -297,6 +297,7 @@ mergeConsoleLogging args mToml = do argsCommandLogging = args ^. #commandLogging $> True toml = fromMaybe def mToml +{-# INLINEABLE mergeConsoleLogging #-} instance DecodeTOML ConsoleLoggingToml where tomlDecoder = diff --git a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs index 16fc9f65..a74e8a06 100644 --- a/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs +++ b/src/Shrun/Configuration/Data/ConsoleLogging/TimerFormat.hs @@ -52,6 +52,7 @@ parseTimerFormat getTxt = "prose_compact" -> pure ProseCompact "prose_full" -> pure ProseFull bad -> fail $ "Unrecognized timer-format: " <> unpack bad +{-# INLINEABLE parseTimerFormat #-} -- | Available 'TimerFormat' strings. timerFormatStr :: (IsString a) => a diff --git a/src/Shrun/Configuration/Data/Core.hs b/src/Shrun/Configuration/Data/Core.hs index 72e22e9c..b4d64d6e 100644 --- a/src/Shrun/Configuration/Data/Core.hs +++ b/src/Shrun/Configuration/Data/Core.hs @@ -364,6 +364,7 @@ mergeCoreConfig args mToml = do } where toml = fromMaybe def mToml +{-# INLINEABLE mergeCoreConfig #-} -- | Given a merged CoreConfig, constructs a ConfigEnv and calls the -- continuation. @@ -402,6 +403,7 @@ withCoreEnv cmds merged onCoreConfigEnv = do notify } in onCoreConfigEnv coreConfigEnv +{-# INLINEABLE withCoreEnv #-} instance ( Default (ConfigPhaseMaybeF p Text), diff --git a/src/Shrun/Configuration/Data/Core/Timeout.hs b/src/Shrun/Configuration/Data/Core/Timeout.hs index 9c1f25e8..459bb077 100644 --- a/src/Shrun/Configuration/Data/Core/Timeout.hs +++ b/src/Shrun/Configuration/Data/Core/Timeout.hs @@ -40,6 +40,7 @@ instance DecodeTOML Timeout where parseTimeout :: (Alternative f, MonadFail f) => f Natural -> f Text -> f Timeout parseTimeout getNat getTxt = (MkTimeout <$> getNat) <|> (getTxt >>= parseTimeoutStr) +{-# INLINEABLE parseTimeout #-} parseTimeoutStr :: (MonadFail f) => Text -> f Timeout parseTimeoutStr txt = case RT.fromString str of @@ -47,3 +48,4 @@ parseTimeoutStr txt = case RT.fromString str of Left err -> fail $ "Error reading time string: " <> err where str = unpack txt +{-# INLINEABLE parseTimeoutStr #-} diff --git a/src/Shrun/Configuration/Data/FileLogging.hs b/src/Shrun/Configuration/Data/FileLogging.hs index 2423c55f..d234283e 100644 --- a/src/Shrun/Configuration/Data/FileLogging.hs +++ b/src/Shrun/Configuration/Data/FileLogging.hs @@ -543,6 +543,7 @@ mergeFileLogging args mToml = for mPath $ \path -> do (Without, Nothing) -> Nothing (With p, _) -> Just p (_, Just toml) -> Just $ toml ^. #file % #path +{-# INLINEABLE mergeFileLogging #-} instance DecodeTOML FileLoggingToml where tomlDecoder = @@ -594,6 +595,7 @@ withFileLoggingEnv mFileLogging onFileLoggingEnv = do } withMLogging mFileLogging (onFileLoggingEnv . mkEnv) +{-# INLINEABLE withFileLoggingEnv #-} withMLogging :: forall m a. @@ -640,6 +642,7 @@ withMLogging (Just fileLogging) onLogging = do $ removeFileIfExists fp pure result +{-# INLINEABLE withMLogging #-} handleLogFileSize :: ( HasCallStack, @@ -684,6 +687,7 @@ handleLogFileSize fileSizeMode fp = do toDouble :: Integer -> Double toDouble = fromInteger +{-# INLINEABLE handleLogFileSize #-} ensureFileExists :: ( HasCallStack, @@ -695,9 +699,11 @@ ensureFileExists :: ensureFileExists fp = do exists <- doesFileExist fp unless exists $ writeFileUtf8 fp "" +{-# INLINEABLE ensureFileExists #-} getShrunXdgState :: (HasCallStack, MonadPathReader m) => m OsPath getShrunXdgState = getXdgState [osp|shrun|] +{-# INLINEABLE getShrunXdgState #-} defaultToml :: FilePathDefault -> FileLoggingToml defaultToml path = diff --git a/src/Shrun/Configuration/Data/FileLogging/FileMode.hs b/src/Shrun/Configuration/Data/FileLogging/FileMode.hs index 7f29b7c3..02fdf2ab 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FileMode.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FileMode.hs @@ -22,6 +22,7 @@ parseFileMode getTxt = "append" -> pure FileModeAppend "write" -> pure FileModeWrite bad -> fail $ "Unrecognized file-mode: " <> unpack bad +{-# INLINEABLE parseFileMode #-} instance Default FileMode where def = FileModeWrite diff --git a/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs b/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs index 9c9bf6cf..6e9c2774 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FilePathDefault.hs @@ -24,3 +24,4 @@ parseFilePathDefault getTxt = "default" -> pure FPDefault "" -> fail "Empty path given for --file-log" other -> FPManual <$> FsUtils.encodeFpToOsFail (T.unpack other) +{-# INLINEABLE parseFilePathDefault #-} diff --git a/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs b/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs index 2e7c9a15..99ab5ddd 100644 --- a/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs +++ b/src/Shrun/Configuration/Data/FileLogging/FileSizeMode.hs @@ -49,6 +49,7 @@ parseFileSizeMode getTxt = do case U.parseByteText byteTxt of Right b -> pure $ cons b Left err -> fail $ "Could not parse --file-log-size-mode size: " <> unpack err +{-# INLINEABLE parseFileSizeMode #-} instance Default FileSizeMode where def = FileSizeModeWarn $ convert (Proxy @B) defBytes diff --git a/src/Shrun/Configuration/Data/Notify.hs b/src/Shrun/Configuration/Data/Notify.hs index c15bfbfc..f85ac9c2 100644 --- a/src/Shrun/Configuration/Data/Notify.hs +++ b/src/Shrun/Configuration/Data/Notify.hs @@ -208,6 +208,8 @@ toEnv notifyMerged = case systemMerged of #endif +{-# INLINEABLE toEnv #-} + mkNotify :: NotifyMerged -> NotifySystemEnv -> NotifyEnv mkNotify notifyToml systemP2 = MkNotifyP diff --git a/src/Shrun/Configuration/Data/Truncation.hs b/src/Shrun/Configuration/Data/Truncation.hs index 7cd99279..117cca95 100644 --- a/src/Shrun/Configuration/Data/Truncation.hs +++ b/src/Shrun/Configuration/Data/Truncation.hs @@ -56,6 +56,7 @@ parseTruncation getNat = do case convertIntegral n of Left err -> fail err Right x -> pure $ MkTruncation x +{-# INLINEABLE parseTruncation #-} -- | Determines command log line truncation behavior. We need a separate -- type from 'Truncation' to add a third option, to detect the terminal size @@ -77,12 +78,14 @@ parseLineTruncation getNat getTxt = Undetected <$> parseTruncation getNat <|> parseDetected getTxt +{-# INLINEABLE parseLineTruncation #-} parseDetected :: (MonadFail m) => m Text -> m LineTruncation parseDetected getTxt = getTxt >>= \case "detect" -> pure Detected other -> fail $ "Wanted other, received: " <> unpack other +{-# INLINEABLE parseDetected #-} decodeCommandNameTrunc :: Decoder (Maybe (Truncation TruncCommandName)) decodeCommandNameTrunc = getFieldOptWith tomlDecoder "command-name-trunc" @@ -101,3 +104,4 @@ configToLineTrunc Disabled = pure Nothing configToLineTrunc Without = pure Nothing configToLineTrunc (With Detected) = Just . MkTruncation <$> getTerminalWidth configToLineTrunc (With (Undetected x)) = pure $ Just x +{-# INLINEABLE configToLineTrunc #-} diff --git a/src/Shrun/Configuration/Env.hs b/src/Shrun/Configuration/Env.hs index b0882ced..d1a610dc 100644 --- a/src/Shrun/Configuration/Env.hs +++ b/src/Shrun/Configuration/Env.hs @@ -71,6 +71,7 @@ makeEnvAndShrun :: ) => m () makeEnvAndShrun = withEnv @m @r (runShellT shrun) +{-# INLINEABLE makeEnvAndShrun #-} -- | Creates an 'Env' from CLI args and TOML config to run with a monadic -- action. @@ -91,6 +92,7 @@ withEnv :: (Env r -> m a) -> m a withEnv onEnv = getMergedConfig >>= flip fromMergedConfig onEnv +{-# INLINEABLE withEnv #-} -- | Creates a 'MergedConfig' from CLI args and TOML config. getMergedConfig :: @@ -136,6 +138,7 @@ getMergedConfig = do case decode contents of Right cfg -> pure cfg Left tomlErr -> throwM tomlErr +{-# INLINEABLE getMergedConfig #-} fromMergedConfig :: ( HasCallStack, @@ -169,6 +172,8 @@ fromMergedConfig cfg onEnv = do onEnv env where commands = cfg ^. #commands +{-# INLINEABLE fromMergedConfig #-} getShrunXdgConfig :: (HasCallStack, MonadPathReader m) => m OsPath getShrunXdgConfig = getXdgConfig [osp|shrun|] +{-# INLINEABLE getShrunXdgConfig #-} diff --git a/src/Shrun/Configuration/Env/Types.hs b/src/Shrun/Configuration/Env/Types.hs index a300bf47..02b12950 100644 --- a/src/Shrun/Configuration/Env/Types.hs +++ b/src/Shrun/Configuration/Env/Types.hs @@ -258,6 +258,7 @@ prependCompletedCommand :: prependCompletedCommand command = do completedCommands <- asks getCompletedCommands modifyTVarA' completedCommands (command :<|) +{-# INLINEABLE prependCompletedCommand #-} instance HasAnyError (Env r) where getAnyError = view #anyError @@ -271,6 +272,7 @@ setAnyErrorTrue :: ) => m () setAnyErrorTrue = asks getAnyError >>= \ref -> writeTVarA ref True +{-# INLINEABLE setAnyErrorTrue #-} -- | Class for retrieving the notify config. class HasNotifyConfig env where diff --git a/src/Shrun/IO.hs b/src/Shrun/IO.hs index d776d9d3..8cbdee6e 100644 --- a/src/Shrun/IO.hs +++ b/src/Shrun/IO.hs @@ -76,6 +76,7 @@ shExitCode cmd = do pure (exitCode, wrap (MkStderr . ShrunText.fromText) stderr) where wrap f = f . decodeUtf8Lenient . BSL.toStrict +{-# INLINEABLE shExitCode #-} -- | Version of 'shExitCode' that returns 'Left' 'Stderr' if there is a failure, -- 'Right' 'Stdout' otherwise. @@ -91,6 +92,7 @@ tryShExitCode cmd = shExitCode cmd <&> \case (ExitSuccess, _) -> Nothing (ExitFailure _, stderr) -> Just stderr +{-# INLINEABLE tryShExitCode #-} -- | Runs the command, returning the time elapsed along with a possible -- error. @@ -148,6 +150,7 @@ tryCommandLogging command = do (ConsoleLogCmdOn, Nothing) -> \cmd -> withRegion Linear $ \region -> do let logFn = logConsole keyHide consoleLogQueue region consoleLogging + {-# INLINEABLE logFn #-} logFn hello @@ -157,6 +160,7 @@ tryCommandLogging command = do (ConsoleLogCmdOff, Just fileLogging) -> \cmd -> do let logFn :: Log -> m () logFn = logFile keyHide fileLogging + {-# INLINEABLE logFn #-} logFn hello @@ -168,10 +172,12 @@ tryCommandLogging command = do let logFn log = do logConsole keyHide consoleLogQueue region consoleLogging log logFile keyHide fileLogging log + {-# INLINEABLE logFn #-} logFn hello tryCommandStream logFn cmd + {-# INLINEABLE cmdFn #-} withTiming (cmdFn command) >>= \case (rt, Nothing) -> do @@ -191,10 +197,12 @@ tryCommandLogging command = do logConsole keyHide consoleQueue region consoleLogging log = do let formatted = formatConsoleLog keyHide consoleLogging log writeTBQueueA consoleQueue (LogRegion (log ^. #mode) region formatted) + {-# INLINEABLE logConsole #-} logFile keyHide fileLogging log = do formatted <- formatFileLog keyHide fileLogging log writeTBQueueA (fileLogging ^. #file % #queue) formatted + {-# INLINEABLE logFile #-} hello = MkLog @@ -203,6 +211,7 @@ tryCommandLogging command = do lvl = LevelCommand, mode = LogModeSet } +{-# INLINEABLE tryCommandLogging #-} -- | Similar to 'tryCommand' except we attempt to stream the commands' output -- instead of the usual swallowing. @@ -241,6 +250,7 @@ tryCommandStream logFn cmd = do pure $ case exitCode of ExitSuccess -> Nothing ExitFailure _ -> Just $ IO.Types.readHandleResultToStderr finalData +{-# INLINEABLE tryCommandStream #-} -- NOTE: This was an attempt to set the buffering so that we could use -- hGetLine. Unfortunately that failed, see Note @@ -300,6 +310,7 @@ streamOutput logFn cmd p = do sleepFn :: m () sleepFn = when (pollInterval /= 0) (microsleep pollInterval) + {-# INLINEABLE sleepFn #-} blockSize :: Int blockSize = @@ -320,6 +331,8 @@ streamOutput logFn cmd p = do in ( IO.Types.readHandle (Just outBufferParams) blockSize (P.getStdout p), IO.Types.readHandle (Just errBufferParams) blockSize (P.getStderr p) ) + {-# INLINEABLE readBlockOut #-} + {-# INLINEABLE readBlockErr #-} exitCode <- U.untilJust $ do -- We need to read from both stdout and stderr -- regardless of if we @@ -359,6 +372,7 @@ streamOutput logFn cmd p = do -- here, but it seems minor. Left _ -> IO.Types.readAndUpdateRefFinal ref "" Right bs -> IO.Types.readAndUpdateRefFinal ref bs + {-# INLINEABLE readRemaining #-} (,) <$> readRemaining P.getStdout prevReadOutRef @@ -395,6 +409,7 @@ streamOutput logFn cmd p = do ] pure (exitCode, finalData) +{-# INLINEABLE streamOutput #-} -- We occasionally get invalid reads here -- usually when the command -- exits -- likely due to a race condition. It would be nice to @@ -424,6 +439,7 @@ writeLog logFn reportReadErrors cmd lastReadRef r@(ReadErrSuccess errs successes writeLogHelper logFn cmd lastReadRef r successes writeLog logFn _ cmd lastReadRef r@(ReadSuccess messages) = writeLogHelper logFn cmd lastReadRef r messages +{-# INLINEABLE writeLog #-} writeLogHelper :: ( HasCallStack, @@ -445,3 +461,4 @@ writeLogHelper logFn cmd lastReadRef handleResult messages = do lvl = LevelCommand, mode = LogModeSet } +{-# INLINEABLE writeLogHelper #-} diff --git a/src/Shrun/IO/Types.hs b/src/Shrun/IO/Types.hs index 833e3b3b..0934ed81 100644 --- a/src/Shrun/IO/Types.hs +++ b/src/Shrun/IO/Types.hs @@ -163,6 +163,7 @@ readHandle mBufferParams blockSize handle = do "" -> ReadNoData cs -> ReadSuccess (ShrunText.fromText $ decodeUtf8Lenient cs) Just bufferParams -> readAndUpdateRef bufferParams bs +{-# INLINEABLE readHandle #-} -- | Attempts to read from the handle. Returns Left error or Right -- success. @@ -197,6 +198,7 @@ readHandleRaw blockSize handle = do -- should be large enough that we are not likely to cut off a line -- prematurely, but obviously this is best-effort. Right <$> hGetNonBlocking handle blockSize + {-# INLINEABLE readHandle' #-} nothingIfReady = do -- NOTE: This somewhat torturous logic exists for a reason. We want to @@ -220,6 +222,8 @@ readHandleRaw blockSize handle = do if not isReadable then pure $ Just "Handle is not readable" else pure Nothing + {-# INLINEABLE nothingIfReady #-} +{-# INLINEABLE readHandleRaw #-} -- NOTE: [EOF / blocking error] We would like to check hIsEOF (definitely -- causes errors at the end) and probably hReady as well, but these both @@ -250,6 +254,7 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) Just prevRead -> maybeToReadHandleResult <$> prepareSendIfExceedsThresholds (const (pure ())) prevRead + {-# INLINEABLE onNoData #-} onPartialRead :: UnlinedText -> m ReadHandleResult onPartialRead finalPartialRead = @@ -261,6 +266,7 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) let combinedRead = prevRead <> finalPartialRead maybeToReadHandleResult <$> prepareSendIfExceedsThresholds updateRef combinedRead + {-# INLINEABLE onPartialRead #-} onCompletedAndPartialRead :: List UnlinedText -> UnlinedText -> m ReadHandleResult onCompletedAndPartialRead completedReads finalPartialRead = do @@ -275,6 +281,7 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) Nothing -> completedReads' Just finalRead -> completedReads' ++ [finalRead] pure $ ReadSuccess totalRead + {-# INLINEABLE onCompletedAndPartialRead #-} -- Turns this text into ReadSuccess iff the buffer thresholds are -- exceeded. @@ -297,12 +304,14 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) else do onNoSend readData pure Nothing + {-# INLINEABLE prepareSendIfExceedsThresholds #-} exceedsThreshold :: UnlinedText -> m Bool exceedsThreshold t = if bufferExceedsLength t then pure True else bufferExceedsTime + {-# INLINEABLE exceedsThreshold #-} bufferExceedsLength :: UnlinedText -> Bool bufferExceedsLength t = tLen > bufLen @@ -320,13 +329,18 @@ readAndUpdateRef (prevReadRef, bufferLength, bufferTimeout, bufferWriteTimeRef) pure $ diffTime > bufTimeout where bufTimeout = bufferTimeout ^. #unBufferTimeout % #unTimeout + {-# INLINEABLE bufferExceedsTime #-} resetPrevReadRef' = resetPrevReadRef prevReadRef + {-# INLINEABLE resetPrevReadRef' #-} updateRef = writeIORef prevReadRef . Just + {-# INLINEABLE updateRef #-} maybeToReadHandleResult Nothing = ReadNoData maybeToReadHandleResult (Just read) = ReadSuccess [read] + {-# INLINEABLE maybeToReadHandleResult #-} +{-# INLINEABLE readAndUpdateRef #-} -- | Intended for a final read that handles previous read data. readAndUpdateRefFinal :: @@ -349,19 +363,24 @@ readAndUpdateRefFinal prevReadRef = readIORef prevReadRef >>= \case Nothing -> resetPrevReadRef' $> ReadNoData Just prevRead -> resetPrevReadRef' $> ReadSuccess [prevRead] + {-# INLINEABLE onNoData #-} onPartialRead :: UnlinedText -> m ReadHandleResult onPartialRead finalPartialRead = do readIORef prevReadRef >>= \case Nothing -> resetPrevReadRef' $> ReadSuccess [finalPartialRead] Just prevRead -> resetPrevReadRef' $> ReadSuccess [prevRead <> finalPartialRead] + {-# INLINEABLE onPartialRead #-} onCompletedAndPartialRead :: List UnlinedText -> UnlinedText -> m ReadHandleResult onCompletedAndPartialRead completedReads finalPartialRead = do completedReads' <- mPrependPrevRead prevReadRef completedReads pure $ ReadSuccess $ completedReads' ++ [finalPartialRead] + {-# INLINEABLE onCompletedAndPartialRead #-} resetPrevReadRef' = resetPrevReadRef prevReadRef + {-# INLINEABLE resetPrevReadRef' #-} +{-# INLINEABLE readAndUpdateRefFinal #-} mPrependPrevRead :: (HasCallStack, MonadIORef m) => @@ -378,6 +397,7 @@ mPrependPrevRead ref cr = (r : rs) -> resetPrevReadRef' $> prevRead <> r : rs where resetPrevReadRef' = resetPrevReadRef ref +{-# INLINEABLE mPrependPrevRead #-} -- | Helper for reading a bytestring and handling a previous, partial read. readByteStringPrevHandler :: @@ -411,6 +431,7 @@ readByteStringPrevHandler (Nothing, Just finalPartialRead) -> onPartialRead finalPartialRead (Just completedReads, Just finalPartialRead) -> onCompletedAndPartialRead completedReads finalPartialRead +{-# INLINEABLE readByteStringPrevHandler #-} -- | Reads a bytestring, distinguishing between _complete_ and _partial_ -- reads. A bytestring is considered _complete_ iff it is terminated with a @@ -444,6 +465,7 @@ readByteString bs = case BS.unsnoc bs of resetPrevReadRef :: (HasCallStack, MonadIORef m) => IORef (Maybe a) -> m () resetPrevReadRef prevReadRef = writeIORef prevReadRef Nothing +{-# INLINEABLE resetPrevReadRef #-} -- TODO: Remove once we are past GHC 9.6 unsnoc :: List a -> Maybe (List a, a) diff --git a/src/Shrun/Logging.hs b/src/Shrun/Logging.hs index ae681e9d..708509ed 100644 --- a/src/Shrun/Logging.hs +++ b/src/Shrun/Logging.hs @@ -62,6 +62,7 @@ putRegionLog region lg = do regionLogToConsoleQueue region lg for_ mFileLogging (\fl -> logToFileQueue keyHide fl lg) +{-# INLINEABLE putRegionLog #-} -- | Writes the log to the console queue. regionLogToConsoleQueue :: @@ -83,6 +84,7 @@ regionLogToConsoleQueue region log = do let formatted = formatConsoleLog keyHide consoleLogging log writeTBQueueA queue (LogRegion (log ^. #mode) region formatted) +{-# INLINEABLE regionLogToConsoleQueue #-} -- | Writes the log to the file queue. logToFileQueue :: @@ -100,3 +102,4 @@ logToFileQueue :: logToFileQueue keyHide fileLogging log = do formatted <- formatFileLog keyHide fileLogging log writeTBQueueA (fileLogging ^. #file % #queue) formatted +{-# INLINEABLE logToFileQueue #-} diff --git a/src/Shrun/Logging/Formatting.hs b/src/Shrun/Logging/Formatting.hs index 9c591f99..9447660d 100644 --- a/src/Shrun/Logging/Formatting.hs +++ b/src/Shrun/Logging/Formatting.hs @@ -124,6 +124,7 @@ formatFileLog keyHide fileLogging log = do ] pure $ UnsafeFileLog withTimestamp +{-# INLINEABLE formatFileLog #-} -- | Core formatting, shared by console and file logs. Basic idea: -- diff --git a/src/Shrun/Notify.hs b/src/Shrun/Notify.hs index 195f25ce..42ac10f4 100644 --- a/src/Shrun/Notify.hs +++ b/src/Shrun/Notify.hs @@ -58,6 +58,7 @@ sendNotif summary body urgency = do notify (mkNote timeout) >>= \case Nothing -> pure () Just notifyEx -> withRegion Linear (logEx notifyEx) + {-# INLINEABLE notifyWithErrorLogging #-} logEx ex r = do -- set exit code @@ -71,6 +72,8 @@ sendNotif summary body urgency = do lvl = LevelError, mode = LogModeFinish } + {-# INLINEABLE logEx #-} + mkNote timeout = MkShrunNote { summary, @@ -78,3 +81,4 @@ sendNotif summary body urgency = do urgency, timeout } + {-# INLINEABLE mkNote #-} diff --git a/src/Shrun/Notify/MonadAppleScript.hs b/src/Shrun/Notify/MonadAppleScript.hs index a3e45864..07a64ce8 100644 --- a/src/Shrun/Notify/MonadAppleScript.hs +++ b/src/Shrun/Notify/MonadAppleScript.hs @@ -26,9 +26,11 @@ instance MonadAppleScript IO where . P.readProcessStderr . P.shell . T.unpack + {-# INLINEABLE notify #-} instance (MonadAppleScript m) => MonadAppleScript (ReaderT env m) where notify = lift . notify + {-# INLINEABLE notify #-} notifyAppleScript :: ( HasCallStack, @@ -39,6 +41,7 @@ notifyAppleScript :: notifyAppleScript note = notify (shrunToAppleScript note) <<&>> \stderr -> MkNotifyException note AppleScript (decodeUtf8Lenient stderr) +{-# INLINEABLE notifyAppleScript #-} shrunToAppleScript :: ShrunNote -> Text shrunToAppleScript shrunNote = txt diff --git a/src/Shrun/Notify/MonadDBus.hs b/src/Shrun/Notify/MonadDBus.hs index dabcb266..5e6f5915 100644 --- a/src/Shrun/Notify/MonadDBus.hs +++ b/src/Shrun/Notify/MonadDBus.hs @@ -30,14 +30,19 @@ class (Monad m) => MonadDBus m where instance MonadDBus IO where connectSession = DBusC.connectSession + {-# INLINEABLE connectSession #-} + notify client note = tryAny (DBusN.notify client note) <&> \case Left err -> Just err Right _ -> Nothing + {-# INLINEABLE notify #-} instance (MonadDBus m) => MonadDBus (ReaderT env m) where connectSession = lift connectSession + {-# INLINEABLE connectSession #-} notify c = lift . notify c + {-# INLINEABLE notify #-} notifyDBus :: ( HasCallStack, @@ -49,6 +54,7 @@ notifyDBus :: notifyDBus client note = notify client (shrunToDBus note) <<&>> \stderr -> MkNotifyException note (DBus ()) (T.pack $ displayException stderr) +{-# INLINEABLE notifyDBus #-} shrunToDBus :: ShrunNote -> Note shrunToDBus shrunNote = diff --git a/src/Shrun/Notify/MonadNotifySend.hs b/src/Shrun/Notify/MonadNotifySend.hs index 420b6ba0..c84605df 100644 --- a/src/Shrun/Notify/MonadNotifySend.hs +++ b/src/Shrun/Notify/MonadNotifySend.hs @@ -34,9 +34,11 @@ instance MonadNotifySend IO where . P.readProcessStderr . P.shell . T.unpack + {-# INLINEABLE notify #-} instance (MonadNotifySend m) => MonadNotifySend (ReaderT env m) where notify = lift . notify + {-# INLINEABLE notify #-} notifyNotifySend :: ( HasCallStack, @@ -47,6 +49,7 @@ notifyNotifySend :: notifyNotifySend note = notify (shrunToNotifySend note) <<&>> \stderr -> MkNotifyException note NotifySend (decodeUtf8Lenient stderr) +{-# INLINEABLE notifyNotifySend #-} shrunToNotifySend :: ShrunNote -> Text shrunToNotifySend shrunNote = txt diff --git a/src/Shrun/Notify/Types.hs b/src/Shrun/Notify/Types.hs index 2576931f..3760a09f 100644 --- a/src/Shrun/Notify/Types.hs +++ b/src/Shrun/Notify/Types.hs @@ -82,6 +82,7 @@ parseNotifyAction getTxt = "'. Expected one of ", notifyActionStr ] +{-# INLINEABLE parseNotifyAction #-} -- | Available 'NotifyAction' strings. notifyActionStr :: (IsString a) => a @@ -170,6 +171,7 @@ parseNotifySystem getTxt = "'. Expected one of ", notifySystemStr ] +{-# INLINEABLE parseNotifySystem #-} -- | Available 'NotifySystem' strings. notifySystemStr :: (IsString a) => a @@ -219,6 +221,7 @@ parseNotifyTimeout getTxt = getTxt >>= \case "never" -> pure NotifyTimeoutNever other -> NotifyTimeoutSeconds <$> U.readStripUnderscores other +{-# INLINEABLE parseNotifyTimeout #-} -- | Available 'NotifyTimeout' strings. notifyTimeoutStr :: (IsString a) => a diff --git a/src/Shrun/Prelude.hs b/src/Shrun/Prelude.hs index c3987ac7..cc5ea28a 100644 --- a/src/Shrun/Prelude.hs +++ b/src/Shrun/Prelude.hs @@ -322,6 +322,7 @@ headMaybe = foldr (\x _ -> Just x) Nothing -- | From foldable. fromFoldable :: (Foldable f) => a -> f a -> a fromFoldable x = fromMaybe x . headMaybe +{-# INLINEABLE fromFoldable #-} -- | Lifted fmap. -- @@ -332,9 +333,12 @@ fromFoldable x = fromMaybe x . headMaybe infixl 4 <<$>> +{-# INLINE (<<$>>) #-} + -- | Flipped '(<<$>>)'; lifted `(<&>)`. (<<&>>) :: (Functor f, Functor g) => f (g a) -> (a -> b) -> f (g b) (<<&>>) = flip (<<$>>) +{-# INLINE (<<&>>) #-} -- | Flipped '(.)' (.>) :: (a -> b) -> (b -> c) -> a -> c diff --git a/src/Shrun/ShellT.hs b/src/Shrun/ShellT.hs index 195d777a..963b3a84 100644 --- a/src/Shrun/ShellT.hs +++ b/src/Shrun/ShellT.hs @@ -76,3 +76,4 @@ instance sendNote (DBus client) = MonadDBus.notifyDBus client note sendNote NotifySend = MonadNotifySend.notifyNotifySend note sendNote AppleScript = MonadAppleScript.notifyAppleScript note + {-# INLINEABLE notify #-} diff --git a/src/Shrun/Utils.hs b/src/Shrun/Utils.hs index 2c941e31..3efbeff8 100644 --- a/src/Shrun/Utils.hs +++ b/src/Shrun/Utils.hs @@ -82,6 +82,7 @@ timeSpecToRelTime = fromSeconds . view #sec -- 1 :| [2,3,4] foldMap1 :: (Foldable f, Semigroup s) => (a -> s) -> a -> f a -> s foldMap1 f x xs = foldr (\b g y -> f y <> g b) f xs x +{-# INLINEABLE foldMap1 #-} -- | Wrapper for 'Text'\'s 'T.breakOn' that differs in that: -- @@ -265,6 +266,7 @@ parseByteText txt = -- | Runs the action when it is 'Left'. whenLeft :: (Applicative f) => Either a b -> (a -> f ()) -> f () whenLeft e action = either action (const (pure ())) e +{-# INLINEABLE whenLeft #-} -- | @whileM_ mb ma@ executes @ma@ as long as @mb@ returns 'True'. whileM_ :: (Monad m) => m Bool -> m a -> m () @@ -274,6 +276,7 @@ whileM_ mb ma = go mb >>= \case True -> ma *> go False -> pure () +{-# INLINEABLE whileM_ #-} -- | Executes the monadic action until we receive a 'Just', returning the -- value. @@ -284,6 +287,7 @@ untilJust m = go m >>= \case Nothing -> go Just x -> pure x +{-# INLINEABLE untilJust #-} {- HLINT ignore unsafeListToNESeq "Redundant bracket" -} @@ -315,3 +319,4 @@ readStripUnderscores t = case TR.readEither s of where noUnderscores = T.replace "_" "" t s = T.unpack noUnderscores +{-# INLINEABLE readStripUnderscores #-} diff --git a/tools/bench.sh b/tools/bench.sh index bc14beee..e590814c 100755 --- a/tools/bench.sh +++ b/tools/bench.sh @@ -3,4 +3,4 @@ set -e export LANG="C.UTF-8" cabal bench --benchmark-options \ - '+RTS -T -RTS --csv benchmarks/bench.csv --svg benchmarks/bench.svg' \ No newline at end of file + '+RTS -T -RTS --csv benchmarks/bench.csv --svg benchmarks/bench.svg --baseline benchmarks/baseline_9.8.2.csv' \ No newline at end of file