[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
Thu Dec 21 22:23:09 UTC 2023



Hassan Al-Awwadi pushed to branch wip/T24040-ghci-timeout-squashed at Glasgow Haskell Compiler / GHC


Commits:
d8f639cd by Hassan Al-Awwadi at 2023-12-21T23:22:48+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/d8f639cdaa8b881602e1247482a25f871485f9c7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8f639cdaa8b881602e1247482a25f871485f9c7
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/4f03854c/attachment-0001.html>


More information about the ghc-commits mailing list