[Git][ghc/ghc][wip/T24040-ghci-timeout-squashed] Deleted 1 commit: Adds timeout command to ghci. Resolves #24040
Hassan Al-Awwadi (@hassan.awwadi)
gitlab at gitlab.haskell.org
Thu Dec 21 22:17:30 UTC 2023
Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout-squashed at Glasgow Haskell Compiler / GHC
WARNING: The push did not contain any new commits, but force pushed to delete the commits and changes below.
Deleted commits:
d65ecf0c by Hassan Al-Awwadi at 2023-12-21T22:52:27+01:00
Adds timeout command to ghci. Resolves #24040
- - - - -
2 changed files:
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
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
+
+ -- | transiently duping System.Timeout(timeout), because we need a lifted version
+ -- | transiently, because really this is a dupe of time-out's Control.Timeout(timeout)
+ -- | Luckily time-out is 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,23 @@ 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 $ if null str
+ then unbounded
+ else (case readMaybe str of
+ (Just lim) -> if lim > 0
+ then set_time lim
+ else unbounded
+ Nothing -> unbounded) where
+ unbounded = printForUser (text "Resetting timeout to unbounded execution time")
+ *> modifyGHCiState (\st -> st{ time_limit = Nothing })
+ set_time l = printForUser (text "setting timeout length to" <+> text (show l) <+> text "seconds")
+ *> modifyGHCiState (\st -> st{ time_limit = Just l })
+
+-----------------------------------------------------------------------------
+-- | @: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 +4778,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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d65ecf0c87211ed7228d026a17b9f1f258ff3373
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d65ecf0c87211ed7228d026a17b9f1f258ff3373
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/20231221/3896a655/attachment-0001.html>
More information about the ghc-commits
mailing list