Hotfix run each request in bound thread

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

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

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

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

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