diff --git a/booster/tools/booster/Server.hs b/booster/tools/booster/Server.hs index c007532e94..2848a184ca 100644 --- a/booster/tools/booster/Server.hs +++ b/booster/tools/booster/Server.hs @@ -334,6 +334,7 @@ main = do server = jsonRpcServer srvSettings + (isJust mLlvmLibrary) -- run with bound threads if LLVM API in use ( \rawReq req -> let reqId = getReqId rawReq in runBoosterLogger $ do diff --git a/dev-tools/booster-dev/Server.hs b/dev-tools/booster-dev/Server.hs index 3921086175..1a29fcaad2 100644 --- a/dev-tools/booster-dev/Server.hs +++ b/dev-tools/booster-dev/Server.hs @@ -17,7 +17,7 @@ import Control.Monad.Trans.Reader (runReaderT) import Data.Conduit.Network (serverSettings) import Data.Map (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe, isNothing) +import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Text (Text, unpack) import Data.Text.Encoding qualified as Text import Options.Applicative @@ -163,6 +163,7 @@ runServer port definitions defaultMain mLlvmLibrary rewriteOpts logFile mSMTOpti } jsonRpcServer (serverSettings port "*") + (isJust mLlvmLibrary) -- run in bound threads if LLVM library in use ( \rawReq req -> flip runReaderT (filteredBoosterContextLogger, toModifiersRep prettyPrintOptions) . Booster.Log.unLoggerT diff --git a/dev-tools/kore-rpc-dev/Server.hs b/dev-tools/kore-rpc-dev/Server.hs index 84a8ebf2b7..d8758b3b37 100644 --- a/dev-tools/kore-rpc-dev/Server.hs +++ b/dev-tools/kore-rpc-dev/Server.hs @@ -240,6 +240,7 @@ main = do server = jsonRpcServer srvSettings + False -- no bound threads (\rawReq -> runBoosterLogger . respond (koreRespond $ getReqId rawReq)) [Kore.handleDecidePredicateUnknown, handleErrorCall, handleSomeException] interruptHandler _ = do diff --git a/kore-rpc-types/src/Kore/JsonRpc/Server.hs b/kore-rpc-types/src/Kore/JsonRpc/Server.hs index 0abcf2b8ae..1b220ca3c9 100644 --- a/kore-rpc-types/src/Kore/JsonRpc/Server.hs +++ b/kore-rpc-types/src/Kore/JsonRpc/Server.hs @@ -14,7 +14,7 @@ module Kore.JsonRpc.Server ( JsonRpcHandler (..), ) where -import Control.Concurrent (forkIO, throwTo) +import Control.Concurrent (forkIO, runInBoundThread, throwTo) import Control.Concurrent.STM.TChan (newTChan, readTChan, writeTChan) import Control.Exception (Exception (fromException), catch, mask, throw) import Control.Monad (forever) @@ -78,11 +78,14 @@ jsonRpcServer :: (MonadUnliftIO m, FromRequestCancellable q, ToJSON r) => -- | Connection settings ServerSettings -> + -- | run workers in bound threads (required if worker below uses + -- foreign calls with thread-local state) + Bool -> -- | Action to perform on connecting client thread (Request -> Respond q IO r) -> [JsonRpcHandler] -> m a -jsonRpcServer serverSettings respond handlers = +jsonRpcServer serverSettings runBound respond handlers = runGeneralTCPServer serverSettings $ \cl -> Log.runNoLoggingT $ runJSONRPCT @@ -93,17 +96,18 @@ jsonRpcServer serverSettings respond handlers = False (appSink cl) (appSource cl) - (srv respond handlers) + (srv runBound respond handlers) data JsonRpcHandler = forall e. Exception e => JsonRpcHandler (e -> IO ErrorObj) srv :: forall m q r. (MonadLoggerIO m, FromRequestCancellable q, ToJSON r) => + Bool -> (Request -> Respond q IO r) -> [JsonRpcHandler] -> JSONRPCT m () -srv respond handlers = do +srv runBound respond handlers = do reqQueue <- liftIO $ atomically newTChan let mainLoop tid = let loop = @@ -131,7 +135,10 @@ srv respond handlers = do sendResponses r = Log.runNoLoggingT $ flip runReaderT rpcSession $ sendBatchResponse r respondTo :: Request -> IO (Maybe Response) - respondTo req = buildResponse (respond req) req + respondTo req + | runBound = runInBoundThread $ buildResponse (respond req) req + | otherwise = buildResponse (respond req) req + -- workers should run in bound threads (to secure foreign calls) when flagged cancelReq :: ErrorObj -> BatchRequest -> IO () cancelReq err = \case diff --git a/kore/src/Kore/JsonRpc.hs b/kore/src/Kore/JsonRpc.hs index 31eeed710b..feb6a84427 100644 --- a/kore/src/Kore/JsonRpc.hs +++ b/kore/src/Kore/JsonRpc.hs @@ -731,6 +731,7 @@ runServer port serverState mainModule runSMT Log.LoggerEnv{logAction} = do flip runLoggingT logFun $ jsonRpcServer srvSettings + False -- no bound threads ( \req parsed -> log (InfoJsonRpcProcessRequest (getReqId req) parsed) >> respond (fromId $ getReqId req) serverState mainModule runSMT parsed