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

Commits:

3 changed files:

Changes:

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -654,6 +654,8 @@ stopInterp interp = case interpInstance interp of
    654 654 
                 if isJust ex
    655 655 
                    then pure ()
    656 656 
                    else sendMessage i Shutdown
    657 
    +            -- We asked the server to shutdown, so we will also shutdown any communication.
    658 
    +            closePipe (interpPipe (instProcess i))
    657 659 
                 pure InterpPending
    658 660
    659 661 
     -- -----------------------------------------------------------------------------

  • libraries/ghci/GHCi/Message/Async.hs
    ... ... @@ -70,8 +70,13 @@ data Pipe = Pipe
    70 70 
       , pipeLeftovers   :: !(IORef (Maybe ByteString))
    71 71 
       , pipeLock        :: !(MVar ()) -- ^ Lock to prevent concurrent writes to the stream
    72 72 
       , pipeAsyncMngr   :: !AsyncManager
    73 
    +  , pipeCloseRead   :: !(IO ())
    74 
    +  -- ^ closes read end of the pipe
    75 
    +  , pipeCloseWrite  :: !(IO ())
    76 
    +  -- ^ closes write end of the pipe
    73 77 
       , pipeIsClosed    :: !(TVar Bool)
    74 
    -    -- ^ After the pipe is closed, requests can no longer be received nor sent
    78 
    +    -- ^ After the pipe is closed, messages can no longer be received from the
    79 
    +    -- other end, but the 'AsyncManager' queues might not be empty yet.
    75 80 
       }
    76 81
    77 82 
     -- | Make a 'Pipe' from a 'Handle' to read and a 'Handle' to write.
    ... ... @@ -82,12 +87,17 @@ mkPipeFromHandles pipeRead pipeWrite = do
    82 87 
           putAll b = do
    83 88 
             B.hPutBuilder pipeWrite b
    84 89 
             hFlush pipeWrite
    85 
    -  mkPipeFromContinuations getSome putAll
    90 
    +  mkPipeFromContinuations getSome putAll (hClose pipeRead) (hClose pipeWrite)
    86 91
    87 92 
     -- | Make a 'Pipe' from a reader function and a writer function.
    88 
    --- The pipe should be closed with 'closePipe'.
    89 
    -mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ()) -> IO Pipe
    90 
    -mkPipeFromContinuations getSome putAll = mdo
    93 
    +-- The pipe should be closed with 'closePipe', which will call 'pipeCloseRead' and 'pipeCloseWrite'.
    94 
    +mkPipeFromContinuations :: IO ByteString -> (B.Builder -> IO ())
    95 
    +                        -> IO ()
    96 
    +                        -- ^ pipeCloseRead
    97 
    +                        -> IO ()
    98 
    +                        -- ^ pipeCloseWrite
    99 
    +                        -> IO Pipe
    100 
    +mkPipeFromContinuations getSome putAll pipeCloseRead pipeCloseWrite = mdo
    91 101 
       pipeLeftovers   <- newIORef Nothing
    92 102 
       pipeLock        <- newMVar ()
    93 103 
       pipeIsClosed    <- newTVarIO False
    ... ... @@ -96,18 +106,16 @@ mkPipeFromContinuations getSome putAll = mdo
    96 106 
         let p = Pipe { .. }
    97 107 
         pure p
    98 108
    99 
    --- | Cleanly close our end of the Pipe, terminating the async manager's
    100 
    --- drain-read-end thread. Calling 'closePipe' on an already closed pipe is a no-op.
    109 
    +-- | Cleanly close our ends of the Pipe, terminating the async manager's
    110 
    +-- drain-read-end thread. Also calls 'pipeCloseRead' and 'pipeCloseWrite', in that order.
    101 111 
     --
    102 
    --- If the pipe was created using 'mkPipeFromHandles', the handles must only by
    103 
    --- closed after calling 'closePipe'.
    112 
    +-- If the pipe was created using 'mkPipeFromHandles', the handles are also closed.
    104 113 
     --
    105 114 
     -- The requests we've sent that are pending are all canceled with
    106 115 
     -- 'PipeClosedException' by ourselves.
    107 116 
     --
    108 
    --- The remote process does not necessarily detect that this end of the pipe was
    109 
    --- closed, but it must handle cleanly and clean up after exceptions caused from
    110 
    --- it such as a handle being closed.
    117 
    +-- No special notification is sent to the remote process, a message to that
    118 
    +-- effect should be sent ahead of time if one is needed (see 'Shutdown').
    111 119 
     closePipe :: Pipe -> IO ()
    112 120 
     closePipe Pipe{..} = do
    113 121
    ... ... @@ -119,6 +127,8 @@ closePipe Pipe{..} = do
    119 127 
         -- pending request with 'PipeClosedException'.
    120 128 
         throwTo (asyncDrainTid pipeAsyncMngr) PipeClosedException
    121 129
    130 
    +  pipeCloseWrite
    131 
    +
    122 132 
     -- | We've closed the pipe on our end and we terminate all pending requests with this.
    123 133 
     data PipeClosedException = PipeClosedException deriving Show
    124 134 
     instance Exception PipeClosedException
    ... ... @@ -369,7 +379,7 @@ newAsyncManager pipe = do
    369 379 
     -- 'Pipe' and a thread draining the read end of the interpreter's 'Pipe', since
    370 380 
     -- both processes construct a 'Pipe' and send and receive messages
    371 381 
     drainPipe :: Pipe -> (forall x. IO x -> IO x) -> IO ()
    372 
    -drainPipe p unmask = catch (unmask loop) replyToPendings where
    382 
    +drainPipe p unmask = catch (unmask $ loop `finally` pipeCloseRead p) replyToPendings  where
    373 383 
       loop = do
    374 384 
         readPipe p >>= \case
    375 385 
           -- Receive a reply to a pending notification

  • libraries/ghci/GHCi/Server.hs
    ... ... @@ -78,6 +78,9 @@ servWithCustom verbose hook pipe restore customHandler = newIORef False >>= loop
    78 78 
             RunModFinalizers ii st qrefs -> wrapRunTH ii $ runModFinalizerRefs pipe ii st qrefs
    79 79 
             _other -> run msg >>= reply
    80 80
    81 
    +    -- closePipe here will wait until every active pipeWrite pipe exits, but
    82 
    +    -- they should never block for long, as the host process is either reading
    83 
    +    -- or has called pipeCloseRead.
    81 84 
         isDone <- readIORef doneRef
    82 85 
         if isDone then closePipe pipe
    83 86 
                   else loop doneRef
    ... ... @@ -184,7 +187,7 @@ defaultServerWithCustom customHandler = do
    184 187 
     #if defined(wasm32_HOST_ARCH)
    185 188 
       -- See Note [wasm ghci signal handlers] for details
    186 189 
       installSignalHandlers $ js_register_signal_handler cb_sig
    187 
    -  pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send)
    190 
    +  pipe <- mkPipeFromContinuations (recv_buf cb_recv) (send_buf cb_send) (pure ()) (pure ())
    188 191 
     #else
    189 192 
       when verbose $
    190 193 
         printf "GHC iserv starting (in: %s; out: %s)\n" (show inh) (show outh)

    • —
    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/14f03672c3eeadcdea77560aeae3b233bbace6ad at 1792051381