[Git][ghc/ghc][wip/T24040-ghci-timeout-squashed] Adds timeout command to ghci. Resolves #24040
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Mon Feb 5 17:44:55 UTC 2024
Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout-squashed at Glasgow Haskell Compiler / GHC
Commits:
cb16c8d0 by Hassan Al-Awwadi at 2024-02-05T18:42:20+01:00
Adds timeout command to ghci. Resolves #24040
- - - - -
9 changed files:
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- + testsuite/tests/ghci/scripts/T24040.hs
- + testsuite/tests/ghci/scripts/T24040.script
- + testsuite/tests/ghci/scripts/T24040.stderr
- + testsuite/tests/ghci/scripts/T24040.stdout
- testsuite/tests/ghci/scripts/T8305.script
- testsuite/tests/ghci/scripts/T8305.stdout
- testsuite/tests/ghci/scripts/all.T
Changes:
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -111,13 +111,13 @@ import GHC.Types.Error
import System.Console.Haskeline as Haskeline
import Control.Applicative hiding (empty)
+import Control.Concurrent(myThreadId, killThread, forkIO, threadDelay)
import Control.DeepSeq (deepseq)
import Control.Monad as Monad
import Control.Monad.Catch as MC
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
-
import Data.Array
import qualified Data.ByteString.Char8 as BS
import Data.Char
@@ -246,6 +246,7 @@ ghciCommands = map mkCmd [
("steplocal", keepGoing stepLocalCmd, completeIdentifier),
("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
("type", keepGoingMulti' typeOfExpr, completeExpression),
+ ("timeout", keepGoing timeoutCmd, noCompletion),
("trace", keepGoing traceCmd, completeExpression),
("unadd", keepGoingPaths unAddModule, completeFilename),
("undef", keepGoing undefineMacro, completeMacro),
@@ -377,6 +378,7 @@ defFullHelpText =
" (!: defer type errors)\n" ++
" :run function [<arguments> ...] run the function with the given arguments\n" ++
" :script <file> run the script <file>\n" ++
+ " :timeout <int> set a maximum allowed time input lines are allowed to take before failing\n" ++
" :type <expr> show the type of <expr>\n" ++
" :type +d <expr> show the type of <expr>, defaulting type variables\n" ++
" :unadd <module> ... remove module(s) from the current target set\n" ++
@@ -568,6 +570,7 @@ interactiveUI config srcs maybe_exprs = do
editor = default_editor,
options = [],
multiMode = in_multi,
+ time_limit = Nothing,
localConfig = SourceLocalConfig,
-- We initialize line number as 0, not 1, because we use
-- current line number while reporting errors which is
@@ -1086,6 +1089,64 @@ runCommands' eh sourceErrorHandler gCmd = mask $ \unmask -> do
unless success $ maybe (return ()) lift sourceErrorHandler
unmask $ runCommands' eh sourceErrorHandler gCmd
+
+{-
+Note [Where to Time]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Annoyingly, its not immediately clear what actions within ghci
+should be wrapped with the withTimeLimit function. For a while
+I thought wrapping `runOneCommand`, called from `runCommands`
+and `scriptLoop` made the most sense. And indeed, wrapping
+that function does properly cause things to timeout. But
+it also caused ghci to timeout while idling...
+
+In the end it was `doCommand`, nested within `runOneCommand`
+that needed wrapping for the timeout to work as expected.
+Maybe that'll be enough for now and ever more, but if
+anything else ends up needing to be wrapped, be sure
+to add it to the Note!
+
+The current state does mean that if you call a script
+with ghci :script cmd, the timeout will apply to *individual*
+statements within that script, and not the script as a
+whole. Is that correct? Its a decision, anyway.
+-}
+
+data GhciTimedOut = GhciTimedOut deriving Show
+instance Exception GhciTimedOut
+
+-- | Wraps a single run input action into a timout action, if the timelimit field has been set.
+-- | Otherwise it just runs the action without doing anything.
+-- | See Note [Where to Time]
+withTimeLimit :: (MonadIO m, MonadCatch m, GhciMonad m) => a -> m a -> m a
+withTimeLimit time_out_value cmd = do
+ maybe_limit <- time_limit <$> getGHCiState
+ case maybe_limit of
+ Nothing -> cmd
+ Just limit -> do
+ result_or_timeout <- timeout limit cmd -- puts the IO action inside GhciMonad
+ let r = fromMaybe time_out_value result_or_timeout
+ pure r where
+
+ -- | transitively duping System.Timeout(timeout), because we need a lifted version
+ -- | transitively, because really this is a dupe of time-out's Control.Timeout(timeout)
+ -- | Luckily time-out is in Public Domain 😌
+ timeout :: (MonadIO m, MonadCatch m) => Int -> m a -> m (Maybe a)
+ timeout time action = do
+ tidMain <- liftIO myThreadId
+ -- | We might want to keep a single thread alive to reuse?
+ tidTemp <- liftIO $ forkIO $ delay time >> throwTo tidMain GhciTimedOut
+ result <- catchTimeout action `MC.onException` liftIO (killThread tidTemp)
+ when (isJust result) $ liftIO $ killThread tidTemp
+ return result
+ ms = maxBound `div` 1000000
+ catchTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)
+ catchTimeout action = catch (Just <$> action) $ \ GhciTimedOut -> return Nothing
+ delay t = if t <= 0
+ then pure ()
+ else threadDelay (1000000 * min t ms) >> delay (t - min t ms) -- ^ there has to be a better way.
+
+
-- | Evaluate a single line of user input (either :<command> or Haskell code).
-- A result of Nothing means there was no more input to process.
-- Otherwise the result is Just b where b is True if the command succeeded;
@@ -1105,7 +1166,7 @@ runOneCommand eh gCmd = do
st <- getGHCiState
ghciHandle (\e -> lift $ eh e >>= return . Just) $
handleSourceError printErrorAndFail $
- cmd_wrapper st $ doCommand c
+ withTimeLimit (Just False) $ cmd_wrapper st $ doCommand c -- ^ See Note [Where to Time]
-- source error's are handled by runStmt
-- is the handler necessary here?
where
@@ -2322,8 +2383,19 @@ exceptT :: Applicative m => Either e a -> ExceptT e m a
exceptT = ExceptT . pure
-----------------------------------------------------------------------------
--- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
+-- | @:timeout@ command.
+timeoutCmd :: GhciMonad m => String -> m ()
+timeoutCmd str = handleSourceError printErrAndMaybeExit $ set_time (readMaybe str) where
+ set_time (Just l)
+ | l == 1 = printForUser (text "setting timeout length to" <+> text (show l) <+> text "second")
+ *> modifyGHCiState (\st -> st{ time_limit = Just l })
+ | l > 0 = printForUser (text "setting timeout length to" <+> text (show l) <+> text "seconds")
+ *> modifyGHCiState (\st -> st{ time_limit = Just l })
+ set_time _ = printForUser (text "setting timeout to unbounded execution time")
+ *> modifyGHCiState (\st -> st{ time_limit = Nothing })
+-----------------------------------------------------------------------------
+-- | @:type@ command. See also Note [TcRnExprMode] in GHC.Tc.Module.
typeOfExpr :: GhciMonad m => String -> m ()
typeOfExpr str = handleSourceError printErrAndMaybeExit $
case break isSpace str of
@@ -4702,4 +4774,4 @@ combineModIdent :: String -> String -> String
combineModIdent mod ident
| null mod = ident
| null ident = mod
- | otherwise = mod ++ "." ++ ident
+ | otherwise = mod ++ "." ++ ident
\ No newline at end of file
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -95,6 +95,7 @@ data GHCiState = GHCiState
editor :: String,
stop :: String,
multiMode :: Bool,
+ time_limit :: Maybe Int, -- ^ terminate cmds that exceed some assigned number of seconds
localConfig :: LocalConfigBehaviour,
options :: [GHCiOption],
line_number :: !Int, -- ^ input line
@@ -572,4 +573,4 @@ runInternal =
)
compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
-compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.hs
=====================================
@@ -0,0 +1,5 @@
+module T24040 where
+import Control.Concurrent(threadDelay)
+
+delayNSeconds :: Int -> IO ()
+delayNSeconds n = threadDelay (n * 1000000) >> putStrLn ("Finished in: " ++ show n ++ " seconds")
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.script
=====================================
@@ -0,0 +1,11 @@
+:load T24040
+:timeout 5
+delayNSeconds 10
+delayNSeconds 2
+:timeout
+delayNSeconds 10
+:timeout 1
+delayNSeconds 5
+delayNSeconds 2
+:timeout
+delayNSeconds 5
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.stderr
=====================================
@@ -0,0 +1,3 @@
+*** Exception: GhciTimedOut
+*** Exception: GhciTimedOut
+*** Exception: GhciTimedOut
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.stdout
=====================================
@@ -0,0 +1,7 @@
+setting timeout length to 5 seconds
+Finished in: 2 seconds
+setting timeout to unbounded execution time
+Finished in: 10 seconds
+setting timeout length to 1 second
+setting timeout to unbounded execution time
+Finished in: 5 seconds
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T8305.script
=====================================
@@ -16,7 +16,7 @@
:def! ty (\e -> putStrLn "called :ty macro" >> return "")
:def! type (\e -> putStrLn "called :type macro" >> return "")
:def type2 (\e -> putStrLn "called :type2 macro" >> return "")
-:def time (\e -> putStrLn "called :time macro" >> return "")
+:def toys (\e -> putStrLn "called :toys macro" >> return "")
:def! ki (\e -> putStrLn "called :ki macro" >> return "")
:def kind2 (\e -> putStrLn "called :kind2 macro" >> return "")
@@ -36,4 +36,4 @@
:k ()
-- 5.
-:ti ()
+:to ()
=====================================
testsuite/tests/ghci/scripts/T8305.stdout
=====================================
@@ -2,4 +2,4 @@ called :type macro
() :: *
called :type macro
() :: *
-called :time macro
+called :toys macro
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -380,4 +380,5 @@ test('T22817', normal, ghci_script, ['T22817.script'])
test('T22908', normal, ghci_script, ['T22908.script'])
test('T23062', normal, ghci_script, ['T23062.script'])
test('T16468', normal, ghci_script, ['T16468.script'])
-test('T23686', normal, ghci_script, ['T23686.script'])
\ No newline at end of file
+test('T23686', normal, ghci_script, ['T23686.script'])
+test('T24040', normal, ghci_script, ['T24040.script'])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb16c8d0ca90b7ecce4e0a36761c247d2eea1b67
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb16c8d0ca90b7ecce4e0a36761c247d2eea1b67
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240205/ba8cd7aa/attachment-0001.html>
More information about the ghc-commits
mailing list