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