Andrea Vezzosi pushed to branch wip/romes/async-rpc at Glasgow Haskell Compiler / GHC

Commits:

5 changed files:

Changes:

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -105,7 +105,7 @@ import GHCi.Run
    105 105 
     import Control.Concurrent
    106 106 
     import Control.Monad
    107 107 
     import Control.Monad.IO.Class
    108 
    -import Control.Monad.Catch as MC (mask)
    108 
    +import Control.Monad.Catch as MC (mask, handle, MonadThrow (..))
    109 109 
     import Data.Binary
    110 110 
     import Data.ByteString (ByteString)
    111 111 
     import qualified Data.ByteString.Short as SBS
    ... ... @@ -113,6 +113,7 @@ import qualified GHC.Exts.Heap as Heap
    113 113 
     import GHC.Stack.CCS (CostCentre,CostCentreStack)
    114 114 
     import System.Directory
    115 115 
     import System.Process
    116 
    +import System.Timeout (timeout)
    116 117 
     import qualified GHC.InfoProv as InfoProv
    117 118
    118 119 
     import GHC.Builtin.Modules( gHC_PRIM, gHC_PRIMOPWRAPPERS )
    ... ... @@ -196,14 +197,16 @@ interpCmd interp msg = case interpInstance interp of
    196 197 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    197 198 
       InternalInterp     -> run msg -- Just run it directly
    198 199 
     #endif
    199 
    -  ExternalInterp ext -> withExtInterp ext $ \inst ->
    200 
    +  ExternalInterp ext -> withExtInterp interp ext $ \inst ->
    200 201 
         sendMessage inst msg
    201 202
    202 
    -withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
    203 
    -withExtInterp ext action = case ext of
    203 
    +withExtInterp :: ExceptionMonad m => Interp -> ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
    204 
    +withExtInterp interp ext action = stopInterpOnPipeClosed $ case ext of
    204 205 
       ExtJS    i -> withJSInterp i action
    205 206 
       ExtWasm  i -> withWasmInterp i action
    206 207 
       ExtIServ i -> withIServ    i action
    208 
    +  where
    209 
    +    stopInterpOnPipeClosed = MC.handle $ \ (e :: PipeClosedException) -> liftIO (stopInterp interp) >> MC.throwM e
    207 210
    208 211 
     withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
    209 212 
     withExtInterpStatus ext action = case ext of
    ... ... @@ -631,18 +634,41 @@ stopInterp interp = case interpInstance interp of
    631 634 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    632 635 
         InternalInterp -> pure ()
    633 636 
     #endif
    634 
    -    ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do
    635 
    -      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
    637 
    +    ExternalInterp ext -> (maybe (pure ()) throwIO =<<) $ withExtInterpStatus ext $ \mstate -> do
    638 
    +      MC.mask $ \restore -> modifyMVar mstate $ \state -> do
    636 639 
             case state of
    637 
    -          InterpPending    -> pure state -- already stopped
    640 
    +          InterpPending    -> pure (state, Nothing) -- already stopped
    638 641 
               InterpRunning i  -> do
    639 642 
                 ex <- getProcessExitCode (interpHandle (instProcess i))
    640 
    -            if isJust ex
    641 
    -               then pure ()
    642 
    -               else sendMessage i Shutdown
    643 
    -            -- We asked the server to shutdown, so we will also shutdown any communication.
    644 
    -            closePipe (interpPipe (instProcess i))
    645 
    -            pure InterpPending
    643 
    +            e <- if isJust ex
    644 
    +                 then gracefulShutdown i restore
    645 
    +                 else closePipe (interpPipe (instProcess i)) >> pure Nothing
    646 
    +            modifyMVar_ (loader_state (interpLoader interp)) (const $ pure Nothing)
    647 
    +            purgeInterpSymbolCache (interpSymbolCache interp)
    648 
    +            modifyMVar_ (interpStringCache interp) (const $ pure emptyFsEnv)
    649 
    +            pure (InterpPending,e)
    650 
    +  where
    651 
    +    gracefulShutdown i restore = do
    652 
    +      x <- try (timeLimited restore $ sendMessage i Shutdown `finally` closePipe (interpPipe (instProcess i)))
    653 
    +      let ph = interpHandle (instProcess i)
    654 
    +      e <- case x of
    655 
    +        -- happy path: ext. interp. should be shutting down of its own accord.
    656 
    +        Right (Just ()) -> pure Nothing
    657 
    +        -- timeout: ext. interp. couldn't handle Shutdown in time.
    658 
    +        Right Nothing   -> do
    659 
    +          terminateProcess ph
    660 
    +          pure Nothing
    661 
    +        -- something went wrong, probably Pipe already closed.
    662 
    +        Left e -> do
    663 
    +          terminateProcess ph
    664 
    +          returnUnexpectedException e
    665 
    +      void $ timeLimited restore $ void $ waitForProcess ph
    666 
    +      pure e
    667 
    +    timeLimited restore m = timeout 1_000_000 (restore m)
    668 
    +    returnUnexpectedException e
    669 
    +      | Just (_ :: PipeClosedException) <- fromException e = return Nothing
    670 
    +      | Just (_ :: IOException) <- fromException e = return Nothing
    671 
    +      | otherwise = pure (Just e)
    646 672
    647 673 
     -- -----------------------------------------------------------------------------
    648 674 
     {- Note [External GHCi pointers]

  • compiler/GHC/Runtime/Interpreter/Process.hs
    ... ... @@ -12,13 +12,10 @@ import GHC.Prelude
    12 12 
     import GHC.Runtime.Interpreter.Types
    13 13 
     import GHCi.Message
    14 14
    15 
    -import GHC.IO (catchException)
    16 15 
     import GHC.Utils.Panic
    17 16 
     import GHC.Utils.Exception as Ex
    18 17
    19 18 
     import Data.Binary
    20 
    -import System.Exit
    21 
    -import System.Process
    22 19 
     import Control.Concurrent
    23 20 
     import Data.IORef
    24 21 
     import Control.Concurrent.STM
    ... ... @@ -34,7 +31,6 @@ import Control.Concurrent.STM
    34 31 
     sendMessage :: Binary a => ExtInterpInstance d -> Message a -> IO a
    35 32 
     sendMessage i msg =
    36 33 
       remoteCall (interpPipe proc) msg
    37 
    -    `catchException` \(e :: SomeException) -> handleInterpProcessFailure proc e
    38 34 
       where
    39 35 
         proc = instProcess i
    40 36
    ... ... @@ -77,18 +73,6 @@ sendTHComputation i msg reqHandler = mask $ \restore -> do
    77 73 
                           else loop
    78 74 
            in loop
    79 75
    80 
    -handleInterpProcessFailure :: InterpProcess -> SomeException -> IO a
    81 
    -handleInterpProcessFailure i e = do
    82 
    -  let hdl = interpHandle i
    83 
    -  ex <- getProcessExitCode hdl
    84 
    -  case ex of
    85 
    -    Just (ExitFailure n) ->
    86 
    -      throwIO (InstallationError ("External interpreter terminated (" ++ show n ++ ")"))
    87 
    -    _ -> do
    88 
    -      terminateProcess hdl
    89 
    -      _ <- waitForProcess hdl
    90 
    -      throw e
    91 
    -
    92 76 
     data CancelTHHandler = CancelTHHandler deriving Show
    93 77 
     instance Exception CancelTHHandler where
    94 78 
       fromException = asyncExceptionFromException

  • compiler/GHC/Tc/Gen/Splice.hs
    ... ... @@ -1160,7 +1160,7 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
    1160 1160 
           runQinTcM $ sequence_ qs
    1161 1161 
     #endif
    1162 1162
    1163 
    -    ExternalInterp ext -> withExtInterp ext $ \inst -> do
    1163 
    +    ExternalInterp ext -> withExtInterp interp ext $ \inst -> do
    1164 1164 
           tcg <- getGblEnv
    1165 1165 
           th_state <- readTcRef (tcg_th_remote_state tcg)
    1166 1166 
           case th_state of
    ... ... @@ -1817,7 +1817,7 @@ runTH ty fhv = do
    1817 1817 
           return r
    1818 1818 
     #endif
    1819 1819
    1820 
    -    ExternalInterp ext -> withExtInterp ext $ \inst -> do
    1820 
    +    ExternalInterp ext -> withExtInterp interp ext $ \inst -> do
    1821 1821 
           -- Run it on the server.  For an overview of how TH works with
    1822 1822 
           -- Remote GHCi, see Note [Remote Template Haskell] in
    1823 1823 
           -- libraries/ghci/GHCi/TH.hs.

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -27,7 +27,7 @@ module GHCi.Message
    27 27 
       , Pipe(..), mkPipeFromHandles, mkPipeFromContinuations, closePipe
    28 28 
       , remoteCall, remoteTHCall
    29 29 
       , handleRemoteCall, handleRemoteTHCall, writeReply
    30 
    -  , RemoteProcessException(..), PipeReadClosedException(..)
    30 
    +  , RemoteProcessException(..), PipeClosedException(..)
    31 31
    32 32 
       , InboxId(..)
    33 33 
       , newMailbox

  • libraries/ghci/GHCi/Message/Async.hs
    ... ... @@ -7,7 +7,7 @@ module GHCi.Message.Async
    7 7 
       (
    8 8 
         -- * Pipes
    9 9 
         Pipe(..), mkPipeFromHandles, mkPipeFromContinuations
    10 
    -  , closePipe, PipeReadClosedException(..)
    10 
    +  , closePipe, PipeClosedException(..)
    11 11
    12 12 
         -- * Interface for async bidirectional RPC
    13 13 
       , remoteAsyncReq, handleAsyncReq
    ... ... @@ -145,13 +145,13 @@ closePipe p@Pipe{..} = do
    145 145 
           unless writeAlreadyClosed
    146 146 
             (throwTo (asyncFillTid pipeAsyncMngr) PipeWriteClosedException)
    147 147
    148 
    --- | We've closed the pipe read end on this process
    149 
    -data PipeReadClosedException = PipeReadClosedException deriving Show
    150 
    -instance Exception PipeReadClosedException
    148 
    +data PipeClosedException
    149 
    +  = PipeReadClosedException -- ^ We've closed the pipe read end on this process
    150 
    +
    151 
    +  | PipeWriteClosedException -- ^ We've closed the pipe write end on this process
    152 
    +  deriving Show
    153 
    +instance Exception PipeClosedException
    151 154
    152 
    --- | We've closed the pipe write end on this process
    153 
    -data PipeWriteClosedException = PipeWriteClosedException deriving Show
    154 
    -instance Exception PipeWriteClosedException
    155 155
    156 156 
     --------------------------------------------------------------------------------
    157 157 
     -- ** Pipe thread-safe read/write

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/863e9a6a9a84c9b7626d441eeadca1549b55e85c at 1793135015