[Git][ghc/ghc][wip/js-th] More factorization
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Thu Jan 19 10:13:23 UTC 2023
Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC
Commits:
5ef27ac0 by Sylvain Henry at 2023-01-19T11:17:32+01:00
More factorization
- - - - -
3 changed files:
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Tc/Gen/Splice.hs
Changes:
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -4,6 +4,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
-- | Interacting with the interpreter, whether it is running on an
-- external process or in the current process.
@@ -48,7 +49,9 @@ module GHC.Runtime.Interpreter
, findSystemLibrary
, interpCmd
+ , withExtInterp
, withIServ
+ , withJSInterp
, stopInterp
, purgeLookupSymbolCache
, freeHeapRefs
@@ -191,15 +194,15 @@ interpCmd interp msg = case interpInstance interp of
#if defined(HAVE_INTERNAL_INTERPRETER)
InternalInterp -> run msg -- Just run it directly
#endif
- ExternalInterp ext -> case ext of
- ExtIServ i -> withIServ i $ \inst ->
- uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd]
- sendMessage inst msg
+ ExternalInterp ext -> withExtInterp ext $ \inst ->
+ uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd]
+ sendMessage inst msg
- ExtJS i -> withJSInterp i $ \inst ->
- uninterruptibleMask_ $ -- Note [uninterruptibleMask_ and interpCmd]
- sendMessage inst msg
+withExtInterp :: ExceptionMonad m => ExtInterp -> (forall i. ExtInterpInstance i -> m a) -> m a
+withExtInterp ext action = case ext of
+ ExtJS i -> withJSInterp i action
+ ExtIServ i -> withIServ i action
-- Note [uninterruptibleMask_ and interpCmd]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -216,10 +219,29 @@ withIServ
:: (ExceptionMonad m)
=> IServ -> (ExtInterpInstance IServInstance -> m a) -> m a
withIServ (IServ cfg mstate) action = do
- inst <- liftIO $ modifyMVarMasked mstate $ \case
+ inst <- spawnInterpMaybe cfg spawnIServ mstate
+ action inst
+
+-- | Spawn JS interpreter if it isn't already done and execute the given action
+--
+-- Update the interpreter state.
+withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpInstance -> m a) -> m a
+withJSInterp (JSInterp cfg mstate) action = do
+ inst <- spawnInterpMaybe cfg spawnJSInterp mstate
+ action inst
+
+-- | Spawn an interpreter if not already done according to the status in the
+-- MVar. Update the status, free pending heap references, and return the
+-- interpreter instance.
+--
+-- This function is generic to support both the native external interpreter and
+-- the JS one.
+spawnInterpMaybe :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpInstanceVar (ExtInterpInstance d) -> m (ExtInterpInstance d)
+spawnInterpMaybe cfg spawn mstatus = do
+ inst <- liftIO $ modifyMVarMasked mstatus $ \case
-- start the external iserv process if we haven't done so yet
InterpPending -> do
- inst <- spawnIServ cfg
+ inst <- spawn cfg
pure (InterpRunning inst, inst)
InterpRunning inst -> do
@@ -231,7 +253,7 @@ withIServ (IServ cfg mstate) action = do
sendMessage inst (FreeHeapRefs pending_frees)
-- run the inner action
- action inst
+ pure inst
-- FIXME: rename withExtInterpInterpMaybe
withIServMaybe
=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -7,8 +7,6 @@
module GHC.Runtime.Interpreter.JS
( startTHRunnerProcess
, spawnJSInterp
- , withJSInterp
- , jsInterpCmd
, jsLinkRts
, jsLinkInterp
, jsLinkObject
@@ -42,7 +40,6 @@ import GHC.Unit.State
import GHC.Utils.Logger
import GHC.Utils.TmpFs
-import GHC.Utils.Exception
import GHC.Utils.Panic
import GHC.Utils.Error (logInfo)
import GHC.Utils.Outputable (text)
@@ -51,7 +48,6 @@ import GHC.Data.FastString
import Control.Concurrent
import Control.Monad
-import Control.Monad.IO.Class
import System.Process
import System.IO
@@ -147,28 +143,6 @@ spawnJSInterp cfg = do
pure inst
--- | Spawn JS interpreter if it isn't already done and execute the given action
---
--- Update the interpreter state.
-withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpInstance -> m a) -> m a
-withJSInterp (JSInterp cfg mstate) action = do
- inst <- liftIO $ modifyMVarMasked mstate $ \case
- -- start the external node process if we haven't done so yet
- InterpPending -> do
- inst <- spawnJSInterp cfg
- pure (InterpRunning inst, inst)
-
- InterpRunning inst -> do
- pure (InterpRunning inst, inst)
-
-
- -- free any FinalizedHeapRef that have been garbage collected.
- pending_frees <- liftIO $ swapMVar (instPendingFrees inst) []
- liftIO $ when (not (null (pending_frees))) $
- sendMessage inst (FreeHeapRefs pending_frees)
-
- -- run the inner action
- action inst
---------------------------------------------------------
-- Interpreter commands
@@ -372,72 +346,6 @@ jsSendCommand inst cmd = do
put_cmd 99
flush
-jsInterpCmd :: Binary a => ExtInterpInstance JSInterpInstance -> Message a -> IO a
-jsInterpCmd inst msg = do
- let
- trace_msg :: IO ()
- trace_msg = pprTraceM "jsInterpCmd" (text (show msg))
-
- case msg of
- Shutdown -> do
- jsSendCommand inst ExitSuccess
-
- RtsRevertCAFs -> do
- trace_msg
- pure ()
-
- -------------------------------------
- -- linker
-
- InitLinker -> pure ()
-
- LookupSymbol _s -> do
- trace_msg
- pure Nothing
-
- LookupClosure _s -> do
- trace_msg
- pure Nothing
-
- LoadDLL _ -> do
- trace_msg
- pure Nothing
-
- LoadArchive _ -> do
- trace_msg
- pure ()
-
- LoadObj _ -> do
- trace_msg
- pure ()
-
- UnloadObj _ -> do
- trace_msg
- pure ()
-
- AddLibrarySearchPath _ -> do
- trace_msg
- pure (RemotePtr 0) -- dummy pointer
-
- RemoveLibrarySearchPath _ -> do
- trace_msg
- pure True -- True = success
-
- ResolveObjs -> pure True
-
- FindSystemLibrary _ -> do
- trace_msg
- pure Nothing
-
- -------------------------------------
- -- interpreter
-
- -- commands that are passed through to the interpreter
- RunTH {} -> sendMessage inst msg
- LoadJS {} -> sendMessage inst msg
-
- _ -> error ("jsInterpCmd: " ++ show msg)
-
-- | Load a JS file in the interpreter
jsLoadFile :: ExtInterpInstance JSInterpInstance -> FilePath -> IO ()
jsLoadFile inst path = jsSendCommand inst (LoadFile path)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -78,7 +78,6 @@ import GHC.Iface.Load
import GHCi.Message
import GHCi.RemoteTypes
import GHC.Runtime.Interpreter
-import GHC.Runtime.Interpreter.JS
import GHC.Rename.Splice( traceSplice, SpliceInfo(..))
import GHC.Rename.Expr
@@ -1067,33 +1066,18 @@ runRemoteModFinalizers (ThModFinalizers finRefs) = do
runQuasi $ sequence_ qs
#endif
- ExternalInterp ext -> case ext of
- ExtIServ iserv -> withIServ iserv $ \inst -> do
- tcg <- getGblEnv
- th_state <- readTcRef (tcg_th_remote_state tcg)
- case th_state of
- Nothing -> return () -- TH was not started, nothing to do
- Just fhv -> do
- r <- liftIO $ withFinalizedHeapRef fhv $ \st ->
- withFinalizedHeapRefs finRefs $ \qrefs ->
- sendMessageDelayedResponse inst (RunModFinalizers st qrefs)
- () <- runRemoteTH inst []
- qr <- liftIO $ receiveDelayedResponse inst r
- checkQResult qr
-
- -- FIXME: deduplicate this code
- ExtJS i -> withJSInterp i $ \inst -> do
- tcg <- getGblEnv
- th_state <- readTcRef (tcg_th_remote_state tcg)
- case th_state of
- Nothing -> return () -- TH was not started, nothing to do
- Just fhv -> do
- r <- liftIO $ withFinalizedHeapRef fhv $ \st ->
- withFinalizedHeapRefs finRefs $ \qrefs ->
- sendMessageDelayedResponse inst (RunModFinalizers st qrefs)
- () <- runRemoteTH inst []
- qr <- liftIO $ receiveDelayedResponse inst r
- checkQResult qr
+ ExternalInterp ext -> withExtInterp ext $ \inst -> do
+ tcg <- getGblEnv
+ th_state <- readTcRef (tcg_th_remote_state tcg)
+ case th_state of
+ Nothing -> return () -- TH was not started, nothing to do
+ Just fhv -> do
+ r <- liftIO $ withFinalizedHeapRef fhv $ \st ->
+ withFinalizedHeapRefs finRefs $ \qrefs ->
+ sendMessageDelayedResponse inst (RunModFinalizers st qrefs)
+ () <- runRemoteTH inst []
+ qr <- liftIO $ receiveDelayedResponse inst r
+ checkQResult qr
runQResult
:: (a -> String)
@@ -1709,39 +1693,23 @@ runTH ty fhv = do
return r
#endif
- ExternalInterp ext -> case ext of
+ ExternalInterp ext -> withExtInterp ext $ \inst -> do
-- Run it on the server. For an overview of how TH works with
-- Remote GHCi, see Note [Remote Template Haskell] in
-- libraries/ghci/GHCi/TH.hs.
- ExtIServ iserv -> withIServ iserv $ \inst -> do
- rstate <- getTHState inst
- loc <- TH.qLocation
- -- run a remote TH request
- r <- liftIO $
- withFinalizedHeapRef rstate $ \state_hv ->
- withFinalizedHeapRef fhv $ \q_hv ->
- sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc))
- -- respond to requests from the interpreter
- runRemoteTH inst []
- -- get the final result
- qr <- liftIO $ receiveDelayedResponse inst r
- bs <- checkQResult qr
- return $! runGet get (LB.fromStrict bs)
-
- ExtJS i -> withJSInterp i $ \inst -> do
- rstate <- getTHState inst
- loc <- TH.qLocation
- -- run a remote TH request
- r <- liftIO $
- withFinalizedHeapRef rstate $ \state_hv ->
- withFinalizedHeapRef fhv $ \q_hv ->
- sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc))
- -- respond to requests from the interpreter
- runRemoteTH inst []
- -- get the final result
- qr <- liftIO $ receiveDelayedResponse inst r
- bs <- checkQResult qr
- return $! runGet get (LB.fromStrict bs)
+ rstate <- getTHState inst
+ loc <- TH.qLocation
+ -- run a remote TH request
+ r <- liftIO $
+ withFinalizedHeapRef rstate $ \state_hv ->
+ withFinalizedHeapRef fhv $ \q_hv ->
+ sendMessageDelayedResponse inst (RunTH state_hv q_hv ty (Just loc))
+ -- respond to requests from the interpreter
+ runRemoteTH inst []
+ -- get the final result
+ qr <- liftIO $ receiveDelayedResponse inst r
+ bs <- checkQResult qr
+ return $! runGet get (LB.fromStrict bs)
-- | communicate with a remotely-running TH computation until it finishes.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ef27ac0c66990611cf105ef86caf56e57af0c58
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5ef27ac0c66990611cf105ef86caf56e57af0c58
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230119/0febe12a/attachment-0001.html>
More information about the ghc-commits
mailing list