|
1
|
1
|
{-# LANGUAGE RecursiveDo, GADTs, DeriveGeneric, StandaloneDeriving, ScopedTypeVariables,
|
|
2
|
2
|
GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, CPP,
|
|
3
|
3
|
NamedFieldPuns, PatternSynonyms, LambdaCase, TypeAbstractions, TypeApplications,
|
|
4
|
|
- LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections #-}
|
|
|
4
|
+ LinearTypes, RankNTypes, UnboxedTuples, BlockArguments, TupleSections, MagicHash #-}
|
|
5
|
5
|
{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-}
|
|
6
|
6
|
|
|
7
|
7
|
-- |
|
| ... |
... |
@@ -25,19 +25,18 @@ module GHCi.Message |
|
25
|
25
|
|
|
26
|
26
|
, Pipe, mkPipeFromHandles, mkPipeFromContinuations
|
|
27
|
27
|
, remoteCall, remoteTHCall
|
|
28
|
|
- , handleRemoteCall
|
|
|
28
|
+ , handleRemoteCall, handleRemoteTHCall
|
|
29
|
29
|
|
|
30
|
30
|
, BreakModule
|
|
31
|
31
|
, BreakUnitId
|
|
32
|
32
|
, LoadedDLL
|
|
33
|
33
|
|
|
34
|
|
- -- * Consume `reply` exactly once
|
|
35
|
|
- , WriteReply -- abstract
|
|
36
|
|
- , writeReply
|
|
37
|
|
-
|
|
38
|
34
|
-- * Low-level interface for async bidirectional RPC
|
|
39
|
35
|
, withAsyncReq
|
|
40
|
36
|
, withAsyncHandler
|
|
|
37
|
+ -- ** Consume `reply` exactly once
|
|
|
38
|
+ , WriteReply -- abstract
|
|
|
39
|
+ , writeReply
|
|
41
|
40
|
) where
|
|
42
|
41
|
|
|
43
|
42
|
import Prelude -- See note [Why do we import Prelude here?]
|
| ... |
... |
@@ -57,6 +56,7 @@ import qualified GHC.Exts.Heap as Heap |
|
57
|
56
|
import GHC.ForeignSrcLang
|
|
58
|
57
|
import GHC.Fingerprint
|
|
59
|
58
|
import GHC.Conc (pseq, par)
|
|
|
59
|
+import GHC.IO (IO(..))
|
|
60
|
60
|
import Control.Concurrent
|
|
61
|
61
|
import Control.DeepSeq
|
|
62
|
62
|
import Control.Exception
|
| ... |
... |
@@ -88,6 +88,8 @@ import System.IO.Error |
|
88
|
88
|
import Control.Monad
|
|
89
|
89
|
import Control.Concurrent.STM
|
|
90
|
90
|
import Data.Bifunctor
|
|
|
91
|
+import GHC.Base (State#)
|
|
|
92
|
+import GHC.Exts (RealWorld)
|
|
91
|
93
|
|
|
92
|
94
|
-- -----------------------------------------------------------------------------
|
|
93
|
95
|
-- The RPC protocol between GHC and the interactive server
|
| ... |
... |
@@ -774,12 +776,13 @@ remoteCall pipe msg = bimap fromSerializableException id . runGet get |
|
774
|
776
|
-- | Handle a single 'Message' request on the interpreter and reply to the host
|
|
775
|
777
|
handleRemoteCall :: Pipe
|
|
776
|
778
|
-> (Msg -> IO Msg) {-^ Msg hook -}
|
|
777
|
|
- -> (forall a. Binary a => WriteReply a %1 -> Message a -> IO r)
|
|
778
|
|
- -> IO r
|
|
|
779
|
+ -> (forall a. Binary a => Message a -> IO a)
|
|
|
780
|
+ -> IO ()
|
|
779
|
781
|
handleRemoteCall pipe hook k =
|
|
780
|
|
- withAsyncHandler pipe getMessage \(WriteReply reply) msg0 -> do
|
|
781
|
|
- hook msg0 >>= \(Msg @a msg) ->
|
|
782
|
|
- k (WriteReply (reply . fmap (put @a))) msg
|
|
|
782
|
+ withAsyncHandler pipe getMessage \writer msg0 -> IO \s0 ->
|
|
|
783
|
+ case hook msg0 |#> s0 of
|
|
|
784
|
+ (# s1, Msg msg #) -> case k msg |#> s1 of
|
|
|
785
|
+ (# s2, a #) -> writeReply writer (put a) |#> s2
|
|
783
|
786
|
|
|
784
|
787
|
-- | Send a 'THMessage' request to the host and wait for a reply from the host
|
|
785
|
788
|
-- to the interpreter
|
| ... |
... |
@@ -787,12 +790,13 @@ remoteTHCall :: Binary a => Pipe -> THMessage a -> IO (Either SomeException a) |
|
787
|
790
|
remoteTHCall pipe msg = bimap fromSerializableException id . runGet get
|
|
788
|
791
|
<$> withAsyncReq pipe (putTHMessage msg)
|
|
789
|
792
|
|
|
790
|
|
--- | Handle a 'THMessage' request on the host and reply to the interpreter
|
|
|
793
|
+-- | Handle a 'THMessage' request on the host and reply to the interpreter.
|
|
791
|
794
|
handleRemoteTHCall
|
|
792
|
|
- :: Pipe -> (forall a. Binary a => WriteReply a %1 -> Message a -> IO r) -> IO r
|
|
|
795
|
+ :: Pipe -> (forall a. Binary a => THMessage a -> IO a) -> IO ()
|
|
793
|
796
|
handleRemoteTHCall pipe k =
|
|
794
|
|
- withAsyncHandler pipe getMessage \(WriteReply reply) (Msg @a msg) -> do
|
|
795
|
|
- k (WriteReply (reply . fmap (put @a))) msg
|
|
|
797
|
+ withAsyncHandler pipe getTHMessage \writer (THMsg msg) -> IO \s0 ->
|
|
|
798
|
+ case k msg |#> s0 of
|
|
|
799
|
+ (# s1, a #) -> writeReply writer (put a) |#> s1
|
|
796
|
800
|
|
|
797
|
801
|
--------------------------------------------------------------------------------
|
|
798
|
802
|
-- * Matching requests with async replies
|
| ... |
... |
@@ -820,7 +824,8 @@ withAsyncReq pipe msg = do |
|
820
|
824
|
--
|
|
821
|
825
|
-- The handler receives as an argument the function to use to reply to the request.
|
|
822
|
826
|
-- It must be used exactly once (all requests expect a reply, and you can't
|
|
823
|
|
--- reply more than once). Linear types enforce this.
|
|
|
827
|
+-- reply more than once). Linear types enforce the handler replies in every
|
|
|
828
|
+-- branch, and if the handler otherwise throws, it is handled by 'withAsyncHandler'.
|
|
824
|
829
|
--
|
|
825
|
830
|
-- TODO: list of @a -> Bool@s or other proxy for which the handler runs in a
|
|
826
|
831
|
-- forked thread? better than linear forkIO that can be misleading or used
|
| ... |
... |
@@ -980,9 +985,12 @@ withLock Pipe{..} = bracket (takeMVar pipeLock) (putMVar pipeLock) . const |
|
980
|
985
|
|
|
981
|
986
|
-- | Every request should get exactly one reply.
|
|
982
|
987
|
data WriteReply a where
|
|
983
|
|
- WriteReply :: (Either SomeException a -> IO ()) -- unrestricted, but not exposed (for linearity safety)
|
|
984
|
|
- -> WriteReply a
|
|
|
988
|
+ WriteReply :: (Either SomeException a -> IO ()) %1 -> WriteReply a
|
|
985
|
989
|
|
|
986
|
990
|
-- | Write a reply exactly once (consuming the ability to write more replies)
|
|
987
|
991
|
writeReply :: WriteReply a %1 -> a -> IO ()
|
|
988
|
|
-writeReply (WriteReply r) = r . Right |
|
|
992
|
+writeReply (WriteReply r) = \x -> r (Right x)
|
|
|
993
|
+
|
|
|
994
|
+-- | Infix, linear, 'unIO'
|
|
|
995
|
+(|#>) :: IO a %1 -> State# RealWorld -> (# State# RealWorld, a #)
|
|
|
996
|
+(|#>) (IO fs) s = fs s |