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

Commits:

16 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
    ... ... @@ -196,16 +196,16 @@ interpCmd interp msg = case interpInstance interp of
    196 196 
     #if defined(HAVE_INTERNAL_INTERPRETER)
    197 197 
       InternalInterp     -> run msg -- Just run it directly
    198 198 
     #endif
    199 
    -  ExternalInterp ext -> withExtInterp ext $ \inst ->
    200 
    -    uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd]
    201 
    -      sendMessage inst msg
    199 
    +  ExternalInterp ext -> withExtInterp interp ext $ \inst ->
    200 
    +    sendMessage inst msg
    202 201
    203 
    -
    204 
    -withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
    205 
    -withExtInterp ext action = case ext of
    202 
    +withExtInterp :: ExceptionMonad m => Interp -> ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
    203 
    +withExtInterp interp ext action = stopInterpOnPipeClosed $ case ext of
    206 204 
       ExtJS    i -> withJSInterp i action
    207 205 
       ExtWasm  i -> withWasmInterp i action
    208 206 
       ExtIServ i -> withIServ    i action
    207 
    +  where
    208 
    +    stopInterpOnPipeClosed = MC.handle $ \ (e :: PipeClosedException) -> liftIO (stopInterp interp) >> MC.throwM e
    209 209
    210 210 
     withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
    211 211 
     withExtInterpStatus ext action = case ext of
    ... ... @@ -213,15 +213,6 @@ withExtInterpStatus ext action = case ext of
    213 213 
       ExtWasm  i -> action $ interpStatus i
    214 214 
       ExtIServ i -> action (interpStatus i)
    215 215
    216 
    --- Note [uninterruptibleMask_ and interpCmd]
    217 
    --- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    218 
    --- If we receive an async exception, such as ^C, while communicating
    219 
    --- with the iserv process then we will be out-of-sync and not be able
    220 
    --- to recover.  Thus we use uninterruptibleMask_ during
    221 
    --- communication.  A ^C will be delivered to the iserv process (because
    222 
    --- signals get sent to the whole process group) which will interrupt
    223 
    --- the running computation and return an EvalException result.
    224 
    -
    225 216 
     -- | Grab a lock on the 'IServ' and do something with it.
    226 217 
     -- Overloaded because this is used from TcM as well as IO.
    227 218 
     withIServ
    ... ... @@ -480,11 +471,9 @@ lookupSymbol interp str = withSymbolCache interp str $
    480 471 
     #endif
    481 472 
         ExternalInterp ext -> case ext of
    482 473 
           ExtIServ i -> withIServ i $ \inst -> do
    483 
    -        uninterruptibleMask_ $
    484 474 
               sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
    485 475 
           ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
    486 476 
           ExtWasm i -> withWasmInterp i $ \inst -> do
    487 
    -        uninterruptibleMask_ $
    488 477 
               sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str)))
    489 478
    490 479 
     lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (RemotePtr ()))
    ... ... @@ -495,7 +484,6 @@ lookupSymbolInDLL interp dll str = withSymbolCache interp str $
    495 484 
     #endif
    496 485 
         ExternalInterp ext -> case ext of
    497 486 
           ExtIServ i -> withIServ i $ \inst -> do
    498 
    -        uninterruptibleMask_ $
    499 487 
               sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str)))
    500 488 
           ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
    501 489 
           -- wasm dyld doesn't track which symbol comes from which .so
    ... ... @@ -656,6 +644,9 @@ stopInterp interp = case interpInstance interp of
    656 644 
                    else sendMessage i Shutdown
    657 645 
                 -- We asked the server to shutdown, so we will also shutdown any communication.
    658 646 
                 closePipe (interpPipe (instProcess i))
    647 
    +            modifyMVar_ (loader_state (interpLoader interp)) (const $ pure Nothing)
    648 
    +            purgeInterpSymbolCache (interpSymbolCache interp)
    649 
    +            modifyMVar_ (interpStringCache interp) (const $ pure emptyFsEnv)
    659 650 
                 pure InterpPending
    660 651
    661 652 
     -- -----------------------------------------------------------------------------

  • 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
    ... ... @@ -64,7 +60,7 @@ sendTHComputation i msg reqHandler = mask $ \restore -> do
    64 60 
       where
    65 61 
         proc = instProcess i
    66 62 
         handleOne mbox doneRef = do
    67 
    -      handleRemoteTHCall (interpPipe proc) mbox $ \req -> do
    63 
    +      handleRemoteTHCall (interpPipe proc) mbox $ \_setCancel req -> do
    68 64 
             (stop, res) <- reqHandler req
    69 65 
             writeIORef doneRef stop
    70 66 
             return res
    ... ... @@ -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/Errors/Types.hs
    ... ... @@ -7091,6 +7091,7 @@ data SpliceFailReason
    7091 7091 
                        th/T5976
    7092 7092 
                        th/T7276a
    7093 7093 
                        th/T8987
    7094 
    +                   th/T8987b
    7094 7095 
                        th/TH_exn1
    7095 7096 
                        th/TH_exn2
    7096 7097 
                        th/TH_runIO

  • 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
    ... ... @@ -1472,11 +1472,9 @@ when showing an error message.
    1472 1472 
     To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
    1473 1473 
     -}
    1474 1474
    1475 
    --- 'msg' is forced to ensure exceptions don't escape,
    1476 
    --- see Note [Exceptions in TH]
    1477 1475 
     report :: Bool -> [Char] -> TcM ()
    1478 
    -report True msg  = seqList msg $ addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
    1479 
    -report False msg = seqList msg $ addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
    1476 
    +report True  msg = addErr        $ TcRnTHError $ ReportCustomQuasiError True  msg
    1477 
    +report False msg = addDiagnostic $ TcRnTHError $ ReportCustomQuasiError False msg
    1480 1478
    1481 1479 
     addTopDecls :: [TH.Dec] -> TcM ()
    1482 1480 
     addTopDecls thds = do
    ... ... @@ -1575,7 +1573,7 @@ metaHandlersTcM runInIO = TH.MetaHandlers {
    1575 1573 
                           ; let i = toInteger (getKey u)
    1576 1574 
                           ; return (TH.mkNameU s i) }
    1577 1575
    1578 
    -    , mReport = fmap runInIO . report
    1576 
    +    , mReport = \ b msg -> runInIO (report b msg)
    1579 1577
    1580 1578 
         , mLocation = runInIO location
    1581 1579
    ... ... @@ -1819,7 +1817,7 @@ runTH ty fhv = do
    1819 1817 
           return r
    1820 1818 
     #endif
    1821 1819
    1822 
    -    ExternalInterp ext -> withExtInterp ext $ \inst -> do
    1820 
    +    ExternalInterp ext -> withExtInterp interp ext $ \inst -> do
    1823 1821 
           -- Run it on the server.  For an overview of how TH works with
    1824 1822 
           -- Remote GHCi, see Note [Remote Template Haskell] in
    1825 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
    ... ... @@ -666,12 +666,12 @@ remoteCall pipe msg = either throwIO (pure . runGet get)
    666 666 
     -- | Handle a single 'Message' request on the interpreter and reply to the host
    667 667 
     handleRemoteCall :: Pipe
    668 668 
                      -> (Msg -> IO Msg) {-^ Msg hook -}
    669 
    -                 -> (forall a. (Show a, Binary a) => WriteReply a %1 -> Message a -> IO r)
    669 
    +                 -> (forall a. (Show a, Binary a) => WriteReply a %1 -> (IO () -> IO ()) -> Message a -> IO r)
    670 670 
                      -> IO r
    671 671 
     handleRemoteCall pipe hook k =
    672 
    -  handleAsyncReq pipe getMessage Nothing \(WriteReply writer) msg0 -> IO \s0 ->
    672 
    +  handleAsyncReq pipe getMessage Nothing \(WriteReply writer) sa msg0 -> IO \s0 ->
    673 673 
         case hook msg0 |#> s0 of -- unIO for linearity checking
    674 
    -      (# s1, Msg msg #) -> k (WriteReply \x -> writer (fmap put x)) msg |#> s1
    674 
    +      (# s1, Msg msg #) -> k (WriteReply \x -> writer (fmap put x)) sa msg |#> s1
    675 675
    676 676 
     -- | Send a 'THMessage' request to the host and wait for a reply from the host
    677 677 
     -- to the interpreter.
    ... ... @@ -687,9 +687,9 @@ remoteTHCall pipe ii msg = either throwIO (pure . runGet get)
    687 687 
     -- Symmterically to 'remoteTHCall', we always want to specify the 'InboxId' for
    688 688 
     -- RunTH "reverse requests"
    689 689 
     handleRemoteTHCall
    690 
    -  :: Pipe -> InboxId -> (forall a. (Show a, Binary a) => THMessage a -> IO a) -> IO ()
    690 
    +  :: Pipe -> InboxId -> (forall a. (Show a, Binary a) => (IO () -> IO ()) -> THMessage a -> IO a) -> IO ()
    691 691 
     handleRemoteTHCall pipe ii k =
    692 
    -  handleAsyncReq pipe getTHMessage (Just ii) \writer (THMsg msg) -> IO \s0 ->
    693 
    -    case k msg |#> s0 of -- unIO for linearity checking
    692 
    +  handleAsyncReq pipe getTHMessage (Just ii) \writer sa (THMsg msg) -> IO \s0 ->
    693 
    +    case k sa msg |#> s0 of -- unIO for linearity checking
    694 694 
           (# s1, a #) -> writeReply writer (put a) |#> s1
    695 695

  • 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
    ... ... @@ -77,6 +77,10 @@ data Pipe = Pipe
    77 77 
       , pipeReadClosed  :: !(TVar Bool)
    78 78 
         -- ^ After the pipe is closed, messages can no longer be received from the
    79 79 
         -- other end, but the 'AsyncManager' queues might not be empty yet.
    80 
    +  , pipeWriteClosed :: !(TVar Bool)
    81 
    +    -- ^ After the write end of the pipe is closed we can no longer submit
    82 
    +    -- requests or respond to ones we receive, but we might still receive
    83 
    +    -- replies.
    80 84 
       }
    81 85
    82 86 
     -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write.
    ... ... @@ -91,7 +95,13 @@ mkPipeFromHandles pipeRead pipeWrite = do
    91 95
    92 96 
     -- | Make a 'Pipe' from a reader function and a writer function.
    93 97 
     -- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'.
    94 
    -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ())
    98 
    +--
    99 
    +-- Arguments 'getSome' and 'putAll' should throw an `IOException` when communication fails
    100 
    +-- or is no longer possible.
    101 
    +mkPipeFromContinuations :: IO ByteString
    102 
    +                        -- ^ getSome
    103 
    +                        -> (B.Builder -> IO ())
    104 
    +                        -- ^ putAll
    95 105 
                             -> IO ()
    96 106 
                             -- ^ pipeCloseRead
    97 107 
                             -> IO ()
    ... ... @@ -101,6 +111,7 @@ mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo
    101 111 
       pipeLeftovers   <- newIORef Nothing
    102 112 
       pipeLock        <- newMVar ()
    103 113 
       pipeReadClosed  <- newTVarIO False
    114 
    +  pipeWriteClosed  <- newTVarIO False
    104 115 
       mdo
    105 116 
         pipeAsyncMngr <- newAsyncManager p
    106 117 
         let p = Pipe { .. }
    ... ... @@ -114,19 +125,33 @@ mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo
    114 125 
     -- write. Only then do we stop the drain thread, which closes the read end
    115 126 
     -- itself once its read has finished. On Windows its read can't be
    116 127 
     -- interrupted, so this waits for the other side to close its write end too.
    128 
    +-- Finally we stop the write thread, which could be blocked waiting for more to write.
    117 129 
     closePipe :: Pipe -> IO ()
    118 130 
     closePipe p@Pipe{..} = do
    119 131 
       readAlreadyClosed <- atomically $ do
    120 132 
         closed <- readTVar pipeReadClosed
    121 133 
         failPendingReplies p (toException PipeReadClosedException)
    122 134 
         pure closed
    123 
    -  withLock p pipeCloseWrite `finally`
    124 
    -    unless readAlreadyClosed
    125 
    -      (throwTo (asyncDrainTid pipeAsyncMngr) PipeReadClosedException)
    126 135
    127 
    --- | We've closed the pipe read end on this process
    128 
    -data PipeReadClosedException = PipeReadClosedException deriving Show
    129 
    -instance Exception PipeReadClosedException
    136 
    +  writeAlreadyClosed <- atomically $ do
    137 
    +    closed <- readTVar pipeWriteClosed
    138 
    +    failPendingWrites p (toException PipeWriteClosedException)
    139 
    +    pure closed
    140 
    +
    141 
    +  unless writeAlreadyClosed (withLock p pipeCloseWrite)
    142 
    +    `finally` do
    143 
    +      unless readAlreadyClosed
    144 
    +        (throwTo (asyncDrainTid pipeAsyncMngr) PipeReadClosedException)
    145 
    +      unless writeAlreadyClosed
    146 
    +        (throwTo (asyncFillTid pipeAsyncMngr) PipeWriteClosedException)
    147 
    +
    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
    154 
    +
    130 155
    131 156 
     --------------------------------------------------------------------------------
    132 157 
     -- ** Pipe thread-safe read/write
    ... ... @@ -135,7 +160,19 @@ instance Exception PipeReadClosedException
    135 160 
     -- and identify whether they are requests or replies.
    136 161
    137 162 
     writePipe :: Pipe -> IddMsg -> IO ()
    138 
    -writePipe p@Pipe{..} = withLock p . putAll . execPut . put
    163 
    +writePipe p msg = do
    164 
    +  var <- atomically $ writePipeAsync p msg
    165 
    +  either throwIO pure =<< atomically (takeTMVar var)
    166 
    +
    167 
    +writePipeAsync :: Pipe -> IddMsg -> STM (TMVar (Either SomeException ()))
    168 
    +writePipeAsync Pipe{..} msg = do
    169 
    +    var <- newEmptyTMVar
    170 
    +    readTVar pipeWriteClosed >>= \case
    171 
    +      True -> throwSTM PipeWriteClosedException
    172 
    +      False -> pure ()
    173 
    +    writeTQueue (writeQueue pipeAsyncMngr) (msg, var)
    174 
    +    pure var
    175 
    +
    139 176
    140 177 
     -- | Only the 'drainPipe' thread should read from the pipe directly. Other
    141 178 
     -- functions should wait for the matching reply to be delivered asynchronously.
    ... ... @@ -181,6 +218,8 @@ withLock Pipe{..} = bracket (takeMVar pipeLock) (putMVar pipeLock) . const
    181 218 
     --------------------------------------------------------------------------------
    182 219
    183 220 
     -- | Send an asynchronous request and block waiting for a matching reply
    221 
    +--
    222 
    +-- See Note [Exceptions during serialization] about exceptions the 'Put' argument might raise.
    184 223 
     remoteAsyncReq :: Pipe -> Put -> (Maybe InboxId) -> IO (Either SomeException LB.ByteString)
    185 224 
     remoteAsyncReq pipe msg ii = do
    186 225
    ... ... @@ -205,14 +244,18 @@ remoteAsyncReq pipe msg ii = do
    205 244 
       -- Write request
    206 245 
       writePipe pipe (Request uq ii (runPut msg))
    207 246 
         `onException`
    208 
    -      -- the req wasn't done, or no one will be reading the reply:
    209 
    -      -- in either case, drop it from the pending map.
    210 
    -      atomically (modifyTVar pendingReplies (IntMap.delete uq))
    247 
    +        -- the req wasn't done, or no one will be reading the reply:
    248 
    +        -- in either case, drop it from the pending map.
    249 
    +        atomically (modifyTVar pendingReplies (IntMap.delete uq))
    211 250
    212 251 
       -- Block waiting for reply
    213 252 
       atomically (takeTMVar wv)
    214 253 
         `onException`
    215 
    -      atomically (modifyTVar pendingReplies (IntMap.delete uq))
    254 
    +       atomically (do
    255 
    +         modifyTVar pendingReplies (IntMap.delete uq)
    256 
    +         -- we don't wait for Cancel to be written on the pipe,
    257 
    +         -- and won't get a reply: nowhere to report it anyway.
    258 
    +         writePipeAsync pipe (Cancel uq))
    216 259
    217 260 
     -- | Receive a single asynchronous request and send a matching reply
    218 261 
     -- asynchronously (the handler may fork a computation that eventually replies
    ... ... @@ -222,19 +265,25 @@ remoteAsyncReq pipe msg ii = do
    222 265 
     -- It must be used exactly once (all requests expect a reply, and you can't
    223 266 
     -- reply more than once). Linear types enforce the handler replies in every
    224 267 
     -- branch, and if the handler otherwise throws, it is handled by 'handleAsyncReq'.
    225 
    -handleAsyncReq :: Pipe -> Get a -> (Maybe InboxId) -> (WriteReply Put %1 -> a -> IO r) -> IO r
    268 
    +--
    269 
    +-- See Note [Exceptions during serialization] about exceptions the 'Put' argument might raise.
    270 
    +handleAsyncReq :: Pipe -> Get a -> (Maybe InboxId) -> (WriteReply Put %1 -> (IO () -> IO ()) -> a -> IO r) -> IO r
    226 271 
     handleAsyncReq pipe getit mii k = mask $ \restore -> do
    227 272 
       let am = pipeAsyncMngr pipe
    228 273 
       ack <- newEmptyMVar
    229 274
    230 275 
       -- Block waiting for request
    231 276 
       mbreq <- atomically $ do
    277 
    +    readTVar (pipeWriteClosed pipe) >>= \case
    278 
    +      -- We will not be able to write the reply, so no point in continuiting.
    279 
    +      True -> throwSTM PipeWriteClosedException
    280 
    +      False -> pure ()
    232 281 
         isClosed <- readTVar (pipeReadClosed pipe)
    233 282 
         taken <- case mii of
    234 283 
           Nothing -> tryReadTQueue  $  requestsQueue am
    235 284 
           Just ii -> tryReadTQueue =<< getMailbox am ii
    236 285 
         case taken of
    237 
    -      Just req -> pure (Just req)
    286 
    +      Just req@(uq,_) -> fetchedRequest am uq >> pure (Just req)
    238 287 
           Nothing  | isClosed  -> pure Nothing -- empty and closed
    239 288 
                    | otherwise -> retry -- wait for msg
    240 289
    ... ... @@ -242,9 +291,9 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do
    242 291 
         Nothing -> throwIO PipeReadClosedException -- can't expect reqs
    243 292 
         Just (uq, bs) -> do
    244 293 
           let reply p = do
    245 
    -            writePipe pipe (Reply uq (bimap toSerializableException runPut p))
    294 
    +            b <- atomically $ doneHandling am uq
    295 
    +            when b $ writePipe pipe (Reply uq (bimap toSerializableException runPut p))
    246 296 
                 putMVar ack ()
    247 
    -
    248 297 
           -- Run the continuation which must reply exactly once with 'writeReply'
    249 298 
           case runGetOrFail getit bs of
    250 299 
             Left (_, _, err) -> do
    ... ... @@ -252,7 +301,7 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do
    252 301 
               reply (Left (toException exc))
    253 302 
               throwIO exc
    254 303 
             Right (_, _, it) ->
    255 
    -          restore (k (WriteReply reply) it)
    304 
    +          restore (k (WriteReply reply) (setActive am uq) it)
    256 305
    257 306 
                 -- If there's an exception before the reply is sent, reply with an error instead.
    258 307 
                 `catch` \(e :: SomeException) -> do
    ... ... @@ -266,6 +315,7 @@ handleAsyncReq pipe getit mii k = mask $ \restore -> do
    266 315 
                         reply (Left e)
    267 316 
                         throwIO e
    268 317
    318 
    +
    269 319 
     -- | 'handleSyncReq' failed to decode an incoming request payload using the given @'Get' a@
    270 320 
     newtype DecodeAsyncReqException = DecodeAsyncReqException String deriving Show
    271 321 
     instance Exception DecodeAsyncReqException
    ... ... @@ -307,6 +357,28 @@ getMailbox am (InboxId ii) = do
    307 357
    308 358 
     -- ** Async matching "internals" -----------------------------------------------
    309 359
    360 
    +-- | Tracks handling status of a received 'Request'. The values are states of a
    361 
    +-- tiny state machine used to coordinate cancelations.
    362 
    +--
    363 
    +-- 'handleAsyncReq' will pop a request from the appropriate queue, setting the
    364 
    +-- status to `Fetched`. Then one of two things can happen first:
    365 
    +--  - we receive a 'Cancel', then status is set to `Canceling` so the cancel
    366 
    +--    action will run when set.
    367 
    +--  - handler sets a cancel action, then reception of a `Cancel` runs that
    368 
    +--    action and deletes the RequestStatus.
    369 
    +--
    370 
    +-- If RequestStatus is `Canceling` or absent, then a `Reply` won't be sent.
    371 
    +--
    372 
    +-- The two possible transition paths:
    373 
    +-- requestsQueue -> Fetched -> Active cancel -> gone
    374 
    +-- requestsQueue -> Fetched -> Canceling     -> gone
    375 
    +
    376 
    +data RequestStatus
    377 
    +  = Fetched        -- ^ 'Fetched' from a request queue, to pass to handler.
    378 
    +  | Active (IO ()) -- ^ Handler set a cancel action, and has not sent a reply
    379 
    +                   -- yet. The cancel action must not block.
    380 
    +  | Canceling      -- ^ `Cancel` received while status is still `Fetched`.
    381 
    +
    310 382 
     data AsyncManager = AsyncManager
    311 383 
       { pendingReply :: !(TVar (IntMap (TMVar (Either SomeException LB.ByteString))))
    312 384 
         -- ^ When a request is sent, keep track that we're expecting a reply. The
    ... ... @@ -317,10 +389,16 @@ data AsyncManager = AsyncManager
    317 389 
         -- /without/ a specific 'InboxId', queue it here. A request handler will
    318 390 
         -- pop the next request from it. (Nothing except the 'drainPipe' thread
    319 391 
         -- should read from the pipe). Read with @'handleAsyncReq' p get Nothing@.
    392 
    +  , cancelStatus :: !(TVar (IntMap RequestStatus))
    393 
    +    -- ^ When a `Cancel uq` is received, we lookup `uq` in this map and call the
    394 
    +    -- callback if present.
    320 395 
       , mailboxQueues :: !(TVar (IntMap (TQueue (CorrelationId, LB.ByteString))))
    321 396 
         -- ^ Requests for a specific 'InboxId' that can be read using
    322 397 
         -- @'handleAsyncReq' p get (Just <mailboxid>)@.
    398 
    +  , writeQueue    :: !(TQueue (IddMsg, TMVar (Either SomeException ())))
    399 
    +    -- ^ Messages to write on the pipe.
    323 400 
       , asyncDrainTid :: !ThreadId
    401 
    +  , asyncFillTid  :: !ThreadId
    324 402 
       , asyncFreshId  :: !(IORef Int)
    325 403 
       }
    326 404
    ... ... @@ -346,15 +424,21 @@ type CorrelationId = Int
    346 424 
     -- exclusively.
    347 425 
     data IddMsg  = Request !CorrelationId !(Maybe InboxId) LB.ByteString
    348 426 
                  | Reply   !CorrelationId (Either SerializableException LB.ByteString)
    427 
    +             | Cancel  !CorrelationId -- ^ Technically a Request, but no Reply
    428 
    +                                      -- is expected, the CorrelationId is the
    429 
    +                                      -- one of the Request being canceled.
    349 430
    350 431 
     instance Binary IddMsg where
    351 432 
       put (Request i ii bs) = putWord8 0 >> put i >> put ii >> put bs
    352 433 
       put (Reply i bs)      = putWord8 1 >> put i >> put bs
    434 
    +  put (Cancel i)        = putWord8 2 >> put i
    435 
    +
    353 436 
       get = do
    354 437 
         b <- getWord8
    355 438 
         case b of
    356 439 
           0 -> Request <$> get <*> get <*> get
    357 440 
           1 -> Reply   <$> get <*> get
    441 
    +      2 -> Cancel  <$> get
    358 442 
           _ -> fail $ "impossible: Binary IddMsg - " ++ show b
    359 443
    360 444 
     newAsyncManager :: Pipe -> IO AsyncManager
    ... ... @@ -362,11 +446,17 @@ newAsyncManager pipe = do
    362 446 
       asyncFreshId  <- newIORef 0
    363 447 
       pendingReply  <- newTVarIO IntMap.empty
    364 448 
       requestsQueue <- newTQueueIO
    449 
    +  cancelStatus  <- newTVarIO IntMap.empty
    365 450 
       mailboxQueues <- newTVarIO IntMap.empty
    451 
    +  writeQueue <- newTQueueIO
    366 452
    367 453 
       -- Fork thread to drain read end.
    368 454 
       -- (cleaned up on 'closePipe')
    369 
    -  asyncDrainTid <- forkIOWithUnmask (drainPipe pipe)
    455 
    +  asyncDrainTid <- mask_ $ forkIOWithUnmask (drainPipe pipe)
    456 
    +
    457 
    +  -- Fork thread to fill write end.
    458 
    +  -- (cleaned up on 'closePipe')
    459 
    +  asyncFillTid <- mask_ $ forkIOWithUnmask (fillPipe pipe)
    370 460
    371 461 
       let am = AsyncManager{..}
    372 462 
       pure am
    ... ... @@ -382,41 +472,134 @@ drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO ()
    382 472 
     drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings  where
    383 473 
       loop = do
    384 474 
         readPipe p >>= \case
    385 
    -      -- Receive a reply to a pending notification
    386 
    -      Just (Reply uq bs) -> do
    387 
    -        atomically $ do
    388 
    -          m <- readTVar (pendingReply am)
    389 
    -          case IntMap.lookup uq m of
    390 
    -            Nothing ->
    391 
    -              -- the req was dropped from pending bc there was an exception, and no
    392 
    -              -- one's listening any more. the reply is ignored
    393 
    -              pure ()
    394 
    -            Just wv -> do
    395 
    -              writeTVar (pendingReply am) (IntMap.delete uq m)
    396 
    -              -- signal matching request
    397 
    -              putTMVar wv (bimap (toException . RemoteProcessException) id bs)
    398 
    -        loop
    399 
    -      -- Receive a request and queue it
    400 
    -      Just (Request uq mbi bs) -> do
    401 
    -        atomically $ case mbi of
    402 
    -          Nothing ->
    403 
    -            -- "Global" request
    404 
    -            writeTQueue (requestsQueue am) (uq,bs)
    405 
    -          Just ii -> do
    406 
    -            -- "Specific mailbox" request
    407 
    -            q <- getMailbox am ii
    408 
    -            writeTQueue q (uq,bs)
    475 
    +      Just msg -> do
    476 
    +        handleMsg msg
    409 477 
             loop
    410 478 
           -- EOF on read handle
    411 479 
           Nothing -> do
    412 480 
             -- clean up pipe then exit loop
    413 481 
             replyToPendings (toException PipeReadClosedException)
    414 482 
             pure ()
    483 
    +  handleMsg = \case
    484 
    +    -- Receive a reply to a pending notification
    485 
    +    Reply uq bs -> do
    486 
    +      atomically $ do
    487 
    +        m <- readTVar (pendingReply am)
    488 
    +        case IntMap.lookup uq m of
    489 
    +          Nothing ->
    490 
    +            -- the req was dropped from pending bc there was an exception, and no
    491 
    +            -- one's listening any more. the reply is ignored
    492 
    +            pure ()
    493 
    +          Just wv -> do
    494 
    +            writeTVar (pendingReply am) (IntMap.delete uq m)
    495 
    +            -- signal matching request
    496 
    +            putTMVar wv (bimap (toException . RemoteProcessException) id bs)
    497 
    +    -- Receive a request and queue it
    498 
    +    Request uq mbi bs -> do
    499 
    +      atomically $ case mbi of
    500 
    +        Nothing ->
    501 
    +          -- "Global" request
    502 
    +          writeTQueue (requestsQueue am) (uq,bs)
    503 
    +        Just ii -> do
    504 
    +          -- "Specific mailbox" request
    505 
    +          q <- getMailbox am ii
    506 
    +          writeTQueue q (uq,bs)
    507 
    +    Cancel uq -> cancelRequest am uq
    415 508
    416 509 
       replyToPendings e = atomically $ failPendingReplies p e
    417 510
    418 511 
       am = pipeAsyncMngr p
    419 512
    513 
    +cancelRequest :: AsyncManager -> CorrelationId -> IO ()
    514 
    +cancelRequest am uq = join . atomically $ do
    515 
    +  cs <- readTVar (cancelStatus am)
    516 
    +  case IntMap.lookup uq cs of
    517 
    +    Nothing -> pure (pure ())
    518 
    +    Just Fetched -> writeTVar (cancelStatus am) (IntMap.insert uq Canceling cs) >> pure (pure ())
    519 
    +    Just (Active cancel) -> writeTVar (cancelStatus am) (IntMap.delete uq cs) >> pure cancel
    520 
    +    Just Canceling -> pure (pure ())
    521 
    +
    522 
    +-- | Returns @True@ when the handler should write its 'Reply'.
    523 
    +doneHandling :: AsyncManager -> CorrelationId -> STM Bool
    524 
    +doneHandling am uq = do
    525 
    +  cs <- readTVar (cancelStatus am)
    526 
    +  case IntMap.lookup uq cs of
    527 
    +    Nothing -> pure False
    528 
    +    Just s -> do
    529 
    +      writeTVar (cancelStatus am) $ IntMap.delete uq cs
    530 
    +      case s of
    531 
    +        Canceling -> pure False
    532 
    +        _         -> pure True
    533 
    +
    534 
    +setActive :: AsyncManager -> CorrelationId -> IO () -> IO ()
    535 
    +setActive am uq cancel = join . atomically $ do
    536 
    +  cs <- readTVar (cancelStatus am)
    537 
    +  case IntMap.lookup uq cs of
    538 
    +    Nothing -> pure (pure ()) -- reply already received.
    539 
    +    Just Fetched -> writeTVar (cancelStatus am) (IntMap.insert uq (Active cancel) cs) >> pure (pure ())
    540 
    +    Just (Active _) -> writeTVar (cancelStatus am) (IntMap.insert uq (Active cancel) cs) >> pure (pure ())
    541 
    +    Just Canceling -> pure cancel
    542 
    +
    543 
    +fetchedRequest :: AsyncManager -> CorrelationId -> STM ()
    544 
    +fetchedRequest am uq = do
    545 
    +  cs <- readTVar (cancelStatus am)
    546 
    +  case IntMap.lookup uq cs of
    547 
    +    Nothing -> writeTVar (cancelStatus am) (IntMap.insert uq Fetched cs)
    548 
    +    Just Fetched -> error "impossible"
    549 
    +    Just (Active _) -> error "impossible"
    550 
    +    Just Canceling -> error "impossible"
    551 
    +
    552 
    +
    553 
    +
    554 
    +{-
    555 
    +Note [Exceptions during serialization]
    556 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    557 
    +
    558 
    +For efficiency reasons, any `IddMsg` to be sent is forced only when already
    559 
    +writing onto the Pipe, so we cannot discern whether any raised exception
    560 
    +originated due to forcing during serialization or from interacting with the
    561 
    +Pipe.
    562 
    +
    563 
    +If the exceptions happen to be `SomeAsyncException` or `IOException` the write
    564 
    +end of the `Pipe` will be closed while rethrowing them, as those are likely to
    565 
    +indicate something is wrong with the `Pipe` itself. Same for
    566 
    +PipeWriteClosedException, used by `closePipe`.
    567 
    +
    568 
    +It is recommended to fully force messages at the source, to avoid needlessly
    569 
    +interrupting communication.
    570 
    +-}
    571 
    +
    572 
    +
    573 
    +-- | "Fill"s write end of the Pipe with queued messages.
    574 
    +--
    575 
    +-- Because Pipe is written to from this thread rather than 'writePipe', calls to
    576 
    +-- the latter can be interrupted without compromising the protocol.
    577 
    +--
    578 
    +-- Closes the Pipe write end when stopping, notifying any messages still queued to write.
    579 
    +fillPipe :: Pipe -> (forall x. IO x -> IO x) -> IO ()
    580 
    +fillPipe p unmask = catch (loop `finally` pipeCloseWrite p) (atomically . failPendingWrites p) where
    581 
    +  loop = do
    582 
    +    (msg,var) <- atomically $ readTQueue (writeQueue am)
    583 
    +    success <- handle (\ e -> atomically (putTMVar var (Left e)) >> rethrowIfPipeFatal e >> pure False) $ do
    584 
    +      unmask $ withLock p (putAll p . execPut . put $ msg)
    585 
    +      pure True
    586 
    +    when success $ atomically $ putTMVar var (Right ())
    587 
    +    loop
    588 
    +
    589 
    +  -- See Note [Exceptions during serialization]
    590 
    +  rethrowIfPipeFatal e
    591 
    +    | Just SomeAsyncException{}     <- fromException e = throwIO e
    592 
    +    | Just (_ :: IOException)       <- fromException e = throwIO e
    593 
    +    | Just PipeWriteClosedException <- fromException e = throwIO e
    594 
    +    | otherwise = pure ()
    595 
    +  am = pipeAsyncMngr p
    596 
    +
    597 
    +failPendingWrites :: Pipe -> SomeException -> STM ()
    598 
    +failPendingWrites p e = do
    599 
    +  writeTVar (pipeWriteClosed p) True
    600 
    +  writes <- flushTQueue (writeQueue (pipeAsyncMngr p))
    601 
    +  mapM_ (`writeTMVar` Left e) (map snd writes)
    602 
    +
    420 603 
     failPendingReplies :: Pipe -> SomeException -> STM ()
    421 604 
     failPendingReplies p e = do
    422 605 
       -- reqs are only added if pipe not closed;
    ... ... @@ -456,7 +639,7 @@ runWriteReply (WriteReply r) = r
    456 639 
     (|#>) (IO fs) s = fs s
    457 640
    458 641 
     (%>>=) :: (IO a) -> (a -> IO b) %1 -> IO b
    459 
    -(%>>=) = \ m f -> IO (\s0 ->
    642 
    +(%>>=) = \ m -> \ f -> IO (\s0 ->
    460 643 
             case m |#> s0 of -- unIO for linearity checking
    461 644 
               (# s1, x #) -> f x |#> s1)
    462 645 
     infixl 1 %>>=

  • libraries/ghci/GHCi/Server.hs
    ... ... @@ -66,13 +66,13 @@ servWithCustom
    66 66 
       -> IO ()
    67 67 
     servWithCustom verbose hook pipe restore customHandler = do
    68 68 
       ref <- newIORef False
    69 
    -  withThreadManager $ \mngr ->
    69 
    +  withThreadManager $ \mngr -> do
    70 70 
         loop ref mngr `finally` closePipe pipe
    71 71 
      where
    72 72 
       loop doneRef mngr = do
    73 73 
         when verbose $ trace "reading pipe..."
    74 74
    75 
    -    handleRemoteCall pipe hook $ \wr (msg :: Message a) ->
    75 
    +    handleRemoteCall pipe hook $ \wr setCancel (msg :: Message a) ->
    76 76
    77 77 
           discardCtrlC                                 %>>= \_ ->
    78 78 
           when verbose (trace ("msg: " ++ (show msg))) %>>= \_ ->
    ... ... @@ -83,8 +83,10 @@ servWithCustom verbose hook pipe restore customHandler = do
    83 83 
                                          reply ()                 %>>= writeReply wr
    84 84 
             RunTH ii st q ty loc      -> spawnFinally mngr         (runWriteReply wr)
    85 85 
                                          (wrapRunTH ii (runTH pipe ii st q ty loc))
    86 
    +                                     (setCancel . void . forkIO . killThread)
    86 87 
             RunModFinalizers ii st qs -> spawnFinally mngr         (runWriteReply wr)
    87 88 
                                          (wrapRunTH ii (runModFinalizerRefs pipe ii st qs))
    89 
    +                                     (setCancel . void . forkIO . killThread)
    88 90 
             _other                    -> run msg >>= reply        %>>= writeReply wr
    89 91
    90 92 
         isDone <- readIORef doneRef

  • libraries/ghci/GHCi/Server/Threads.hs
    ... ... @@ -41,8 +41,8 @@ withThreadManager k = do
    41 41
    42 42 
     -- | Linear and resource-safe because 'ThreadManager' is guaranteed to wait or
    43 43 
     -- cancel all threads.
    44 
    -spawnFinally :: ThreadManager -> (Either SomeException a -> IO ()) %1 -> IO a -> IO ()
    45 
    -spawnFinally ThreadManager{..} = unsafe_linear \fin -> \action -> void $
    44 
    +spawnFinally :: ThreadManager -> (Either SomeException a -> IO ()) %1 -> IO a -> (ThreadId -> IO b) -> IO b
    45 
    +spawnFinally ThreadManager{..} = unsafe_linear \fin -> \action -> \k ->
    46 46 
       forkFinally
    47 47 
         ( mask $ \unmask -> do
    48 48 
             tid <- myThreadId
    ... ... @@ -57,6 +57,7 @@ spawnFinally ThreadManager{..} = unsafe_linear \fin -> \action -> void $
    57 57 
               else throwIO ThreadKilled
    58 58 
         )
    59 59 
         ( \ea -> fin ea )
    60 
    +    >>= k
    60 61
    61 62 
     unsafe_linear :: (a -> b) %1 -> (a %1 -> b)
    62 63 
     unsafe_linear = Unsafe.unsafeCoerce (Unsafe.unsafeCoerce :: (a -> b) -> (a %1 -> b))

  • libraries/template-haskell/Language/Haskell/TH/Syntax.hs
    ... ... @@ -528,7 +528,9 @@ class (MonadIO m, MonadFail m) => Quasi m where
    528 528 
       -- | Report an error (True) or warning (False)
    529 529 
       -- ...but carry on; use 'fail' to stop. See 'report'.
    530 530 
       qReport  :: Bool -> String -> m ()
    531 
    -  qReport b s = qRunQ $ report b s
    531 
    +  -- 'msg' is forced to ensure exceptions don't escape,
    532 
    +  -- see Note [Exceptions in TH]
    533 
    +  qReport b msg = seqList msg $ qRunQ $ Internal.report b msg
    532 534
    533 535 
       -- | See 'recover'.
    534 536 
       qRecover :: m a -- ^ the error handler
    ... ... @@ -665,13 +667,18 @@ instance Quasi Q where
    665 667 
     -- | Report an error (True) or warning (False),
    666 668 
     -- but carry on; use 'fail' to stop.
    667 669 
     report  :: Bool -> String -> Q ()
    668 
    -report = Internal.report
    670 
    +report = qReport
    669 671 
     {-# DEPRECATED report "Use reportError or reportWarning instead" #-} -- deprecated in 7.6
    670 672
    671 673 
     -- | Report an error to the user, but allow the current splice's computation to carry on. To abort the computation, use 'fail'.
    672 674 
     reportError :: String -> Q ()
    673 
    -reportError = report True
    675 
    +reportError = qReport True
    674 676
    675 677 
     -- | Report a warning to the user, and carry on.
    676 678 
     reportWarning :: String -> Q ()
    677 
    -reportWarning = report False
    679 
    +reportWarning = qReport False
    680 
    +
    681 
    +-- | copied from GHC.Utils.Misc
    682 
    +seqList :: [a] -> b -> b
    683 
    +seqList [] b = b
    684 
    +seqList (x:xs) b = x `seq` seqList xs b

  • testsuite/tests/ghci/should_run/Makefile
    ... ... @@ -3,10 +3,20 @@ include $(TOP)/mk/boilerplate.mk
    3 3 
     include $(TOP)/mk/test.mk
    4 4
    5 5 
     # Test that threadDelay can be interrupted by ^C.
    6 
    -T3171:
    7 
    -	echo "do Control.Concurrent.threadDelay 3000000; putStrLn \"threadDelay was not interrupted\"" | \
    8 
    -	"$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) & \
    9 
    -	sleep 2; kill -INT $$!; wait
    6 
    +# Wait for the statement to start before interrupting (#15383), and signal
    7 
    +# the external interpreter too (the `pgrep -P $!`), as ^C in a terminal would.
    8 
    +#
    9 
    +# The ext interp tests both:
    10 
    +# 	- interrupting a remote request doesn't terminate the ext interpreter (#18852)
    11 
    +# 	- a ^C gets propagated to the thread evaluating the user request on the ext
    12 
    +# 	interpreter so that it gets interrupted
    13 
    +T3171ext: T3171_OPTS = -fexternal-interpreter
    14 
    +T3171 T3171ext:
    15 
    +	rm -f $@.started
    16 
    +	echo 'do { writeFile "$@.started" ""; (Control.Concurrent.threadDelay 100000000 >> putStrLn "threadDelay was not interrupted.") `Control.Exception.catch` \(e :: Control.Exception.SomeException) -> System.IO.hPutStrLn System.IO.stderr ("threadDelay was interrupted: " ++ show e) >> Control.Exception.throwIO e }' | \
    17 
    +	"$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) $(T3171_OPTS) & \
    18 
    +	while [ ! -e $@.started ] && kill -0 $$! 2>/dev/null; do sleep 0.1; done; \
    19 
    +	kill -INT $$! $$(pgrep -P $$!); wait
    10 20
    11 21 
     TopEnvIface:
    12 22 
     	"$(TEST_HC)" $(TEST_HC_OPTS_INTERACTIVE) TopEnvIface -v1 -fno-hide-source-paths -e "a" -e ":q" -fwrite-if-simplified-core -fwrite-interface

  • testsuite/tests/ghci/should_run/T3171.stdout
    1 
    +threadDelay was interrupted: user interrupt
    1 2 
     Interrupted.

  • testsuite/tests/ghci/should_run/T3171ext.stdout
    1 
    +threadDelay was interrupted: user interrupt
    2 
    +Interrupted.

  • testsuite/tests/ghci/should_run/all.T
    ... ... @@ -12,11 +12,17 @@ test('T27287', [just_ghci, combined_output], makefile_test, [])
    12 12
    13 13 
     test('T3171',
    14 14 
          [when(opsys('mingw32'),skip),
    15 
    -      fragile(15383),
    16 15 
           req_interp,
    17 16 
           combined_output],
    18 17 
          makefile_test, [])
    19 18
    19 
    +test('T3171ext',
    20 
    +     [when(opsys('mingw32'),skip),
    21 
    +      req_interp,
    22 
    +      unless(config.have_ext_interp, skip),
    23 
    +      combined_output],
    24 
    +     makefile_test, [])
    25 
    +
    20 26 
     test('ghcirun004', just_ghci, compile_and_run, [''])
    21 27 
     test('T8377',      just_ghci, compile_and_run, [''])
    22 28 
     test('T9914',      just_ghci, ghci_script, ['T9914.script'])

  • testsuite/tests/th/T8987b.hs
    1 
    +{-# LANGUAGE TemplateHaskell #-}
    2 
    +
    3 
    +module T8987b where
    4 
    +import Language.Haskell.TH
    5 
    +import System.IO.Error
    6 
    +import Control.Exception
    7 
    +
    8 
    +$(reportWarning ['1', throw (userError "IOError in warning")] >> return [])

  • testsuite/tests/th/T8987b.stderr
    1 
    +T8987b.hs:1:1: error: [GHC-87897]
    2 
    +    Exception when trying to run compile-time code:
    3 
    +      user error (IOError in warning)
    4 
    +    Code: (reportWarning ['1', throw (userError "IOError in warning")]
    5 
    +             >> return [])
    6 
    +

  • testsuite/tests/th/all.T
    ... ... @@ -306,6 +306,7 @@ test('T8884', normal, compile, ['-v0'])
    306 306 
     test('T8954', normal, compile, ['-v0'])
    307 307 
     test('T8932', normal, compile_fail, ['-v0'])
    308 308 
     test('T8987', normal, compile_fail, ['-v0'])
    309 
    +test('T8987b', normal, compile_fail, ['-v0'])
    309 310 
     test('T7241', normal, compile_fail, ['-v0'])
    310 311 
     test('T9262', normal, compile, ['-v0'])
    311 312 
     test('T9199', normal, compile, ['-v0'])

    • —
    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/-/compare/5be020df64ac8df323a83a0043fc42594f5fc47a...d16a4f364dba1536cba7974be3a79a7d50abced6 at 1793097662