[Git][ghc/ghc][wip/T24040-ghci-timeout-squashed] Some feedback changes.
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Thu Feb 8 20:07:59 UTC 2024
Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout-squashed at Glasgow Haskell Compiler / GHC
Commits:
4e51d49d by Hassan Al-Awwadi at 2024-02-08T21:07:27+01:00
Some feedback changes.
Not done yet but hadrian is being difficult and I need to read a paper on liquid haskell now, so pushing this and finalising tomorrow... hopefully.
- - - - -
7 changed files:
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/ghci.rst
- ghc/GHCi/UI.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
Changes:
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -151,10 +151,10 @@ Compiler
GHCi
~~~~
-- Added the :set timeout <number> command. When called it will timeout ghci commands and expressions that
- take too long <number> is interpreted in seconds and needs to be a natural number.
- Can be unset by calling :unset timeout or :set timeout 0. See :ghc-ticket:`24040`.
-
+- Added the :set timeout <timelimit> command. Once the timeout is set, ghci will
+ timeout any command that takes more than <timelimit> seconds to evaluate. Note
+ that <timelimit> has to be a natural number.
+ Can be unset by calling :unset timeout.
Runtime system
~~~~~~~~~~~~~~
=====================================
docs/users_guide/ghci.rst
=====================================
@@ -2899,8 +2899,10 @@ commonly used commands.
.. ghci-cmd:: :set timeout; ⟨timelimit⟩
Makes all expressions and commands that take longer than ⟨timelimit⟩
- to evaluate throw a GhciTimedOut exception. The timelimit is interpreted
- in seconds.
+ to evaluate throw a GhciTimedOut exception. ⟨timelimit⟩ has to be a
+ natural and is interpreted in seconds.
+
+ Default: unlimited.
.. ghci-cmd:: :seti; [⟨option⟩ ...]
=====================================
ghc/GHCi/UI.hs
=====================================
@@ -1108,11 +1108,6 @@ 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
@@ -1121,33 +1116,32 @@ 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
+withTimeLimit :: (MonadIO m, MonadCatch m, GhciMonad m) => m (Maybe Bool) -> m (Maybe bool)
+withTimeLimit 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.
+ let r = fromMaybe (Just False) result_or_timeout
+ pure r
+ where
+ -- | A local dupe of System.Timeout because unlifting GHCIMonad into pure IO
+ -- would be pretty difficult.
+ 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).
@@ -1169,7 +1163,7 @@ runOneCommand eh gCmd = do
st <- getGHCiState
ghciHandle (\e -> lift $ eh e >>= return . Just) $
handleSourceError printErrorAndFail $
- withTimeLimit (Just False) $ cmd_wrapper st $ doCommand c -- See Note [Where to Time]
+ withTimeLimit $ cmd_wrapper st $ doCommand c -- See Note [Where to Time]
-- source error's are handled by runStmt
-- is the handler necessary here?
where
@@ -3189,11 +3183,12 @@ setParsedPromptString fSetPrompt s = do
fSetPrompt $ generatePromptFunctionFromString s
setTimeout :: GhciMonad m => String -> m ()
-setTimeout str = handleSourceError printErrAndMaybeExit $ set_time (readMaybe str) where
- set_time (Just l)
- | l > 0 = modifyGHCiState (\st -> st{ time_limit = Just l })
- | l == 0 = modifyGHCiState (\st -> st{ time_limit = Nothing })
- set_time _ = throwGhcException (CmdLineError "syntax: :set timeout <natural number>")
+setTimeout str = handleSourceError printErrAndMaybeExit $ set_time (readMaybe str)
+ where
+ set_time (Just l)
+ | l > 0 = modifyGHCiState (\st -> st{ time_limit = Just l })
+ | l == 0 = modifyGHCiState (\st -> st{ time_limit = Nothing })
+ set_time _ = throwGhcException (CmdLineError "syntax: :set timeout <natural number>")
setOptions wds =
do -- first, deal with the GHCi opts (+s, +t, etc.)
=====================================
testsuite/tests/ghci/scripts/T24040.hs
=====================================
@@ -1,5 +1,5 @@
module T24040 where
import Control.Concurrent(threadDelay)
-
+import System.IO(hPutStrLn, stderr)
delayNSeconds :: Int -> IO ()
-delayNSeconds n = threadDelay (n * 1000000) >> putStrLn ("Finished in: " ++ show n ++ " seconds")
\ No newline at end of file
+delayNSeconds n = threadDelay (n * 1000000) >> hPutStrLn stderr ("Finished in: " ++ show n ++ " seconds")
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.script
=====================================
@@ -1,16 +1,16 @@
:load T24040
-:set timeout 5
-delayNSeconds 10
-delayNSeconds 2
-:unset timeout
-delayNSeconds 10
:set timeout 1
-delayNSeconds 5
-delayNSeconds 2
-:unset timeout
+delayNSeconds 0
+delayNSeconds 3
+:unset timeout
delayNSeconds 5
:set timeout 5
+delayNSeconds 7
+delayNSeconds 9
+:unset timeout
+delayNSeconds 11
+:set timeout 7
:reload
-delayNSeconds 10
+delayNSeconds 13
delayNSeconds 2
:unset timeout
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.stderr
=====================================
@@ -1,4 +1,8 @@
+Finished in: 0 seconds
*** Exception: GhciTimedOut
+Finished in: 5 seconds
*** Exception: GhciTimedOut
*** Exception: GhciTimedOut
-*** Exception: GhciTimedOut
\ No newline at end of file
+Finished in: 11 seconds
+*** Exception: GhciTimedOut
+Finished in: 2 seconds
\ No newline at end of file
=====================================
testsuite/tests/ghci/scripts/T24040.stdout deleted
=====================================
@@ -1,4 +0,0 @@
-Finished in: 2 seconds
-Finished in: 10 seconds
-Finished in: 5 seconds
-Finished in: 2 seconds
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e51d49d858cedaea64b0c34b2e6ec74268645bf
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e51d49d858cedaea64b0c34b2e6ec74268645bf
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/20240208/10269c7b/attachment-0001.html>
More information about the ghc-commits
mailing list