[Git][ghc/ghc][wip/js-th] Cleanup

Sylvain Henry (@hsyl20) gitlab at gitlab.haskell.org
Thu Jan 19 16:25:24 UTC 2023



Sylvain Henry pushed to branch wip/js-th at Glasgow Haskell Compiler / GHC


Commits:
a337cdee by Sylvain Henry at 2023-01-19T17:29:10+01:00
Cleanup

- - - - -


5 changed files:

- compiler/GHC.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Runtime/Interpreter/JS.hs
- compiler/GHC/Runtime/Interpreter/Types.hs


Changes:

=====================================
compiler/GHC.hs
=====================================
@@ -693,7 +693,7 @@ setTopSessionDynFlags dflags = do
             }
          s <- liftIO $ newMVar InterpPending
          loader <- liftIO Loader.uninitializedLoader
-         return (Just (Interp (ExternalInterp (ExtIServ (IServ conf s))) loader))
+         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader))
 
     -- JavaScript interpreter
     | ArchJavaScript <- platformArch (targetPlatform dflags)
@@ -709,7 +709,7 @@ setTopSessionDynFlags dflags = do
               , jsInterpCodegenCfg = initStgToJSConfig dflags
               , jsInterpUnitEnv    = hsc_unit_env hsc_env
               }
-         return (Just (Interp (ExternalInterp (ExtJS (JSInterp cfg s))) loader))
+         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))
 
     -- Internal interpreter
     | otherwise


=====================================
compiler/GHC/Driver/Main.hs
=====================================
@@ -2579,18 +2579,16 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
       out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o"
       stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj
 
-      href <- withJSInterp i $ \inst -> do
-
-        -- link code containing binding "id_sym = expr", using id_sym as root
-        let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod
+      let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod
+      -- link code containing binding "id_sym = expr", using id_sym as root
+      withJSInterp i $ \inst -> do
         let roots = mkExportedModFuns this_mod [id_sym]
         jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots
 
-        -- look up "id_sym" closure and create a StablePtr/HeapRef from it
-        jsLookupClosure inst (unpackFS id_sym) >>= \case
-          Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
-          Just r  -> pure r
-
+      -- look up "id_sym" closure and create a StablePtr/HeapRef from it
+      href <- lookupClosure interp (unpackFS id_sym) >>= \case
+        Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)
+        Just r  -> pure r
 
       binding_fref <- mkFinalizedHeapRef href (freeHeapRef href)
 


=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -50,6 +50,7 @@ module GHC.Runtime.Interpreter
 
   , interpCmd
   , withExtInterp
+  , withExtInterpStatus
   , withIServ
   , withJSInterp
   , stopInterp
@@ -199,11 +200,16 @@ interpCmd interp msg = case interpInstance interp of
       sendMessage inst msg
 
 
-withExtInterp :: ExceptionMonad m => ExtInterp -> (forall i. ExtInterpInstance i -> m a) -> m a
+withExtInterp :: ExceptionMonad m => ExtInterp -> (forall d. ExtInterpInstance d -> m a) -> m a
 withExtInterp ext action = case ext of
   ExtJS    i -> withJSInterp i action
   ExtIServ i -> withIServ    i action
 
+withExtInterpStatus :: ExtInterp -> (forall d. ExtInterpStatusVar d -> m a) -> m a
+withExtInterpStatus ext action = case ext of
+  ExtJS    i -> action (interpStatus i)
+  ExtIServ i -> action (interpStatus i)
+
 -- Note [uninterruptibleMask_ and interpCmd]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 -- If we receive an async exception, such as ^C, while communicating
@@ -217,16 +223,16 @@ withExtInterp ext action = case ext of
 -- Overloaded because this is used from TcM as well as IO.
 withIServ
   :: (ExceptionMonad m)
-  => IServ -> (ExtInterpInstance IServInstance -> m a) -> m a
-withIServ (IServ cfg mstate) action = do
+  => IServ -> (ExtInterpInstance () -> m a) -> m a
+withIServ (ExtInterpState cfg mstate) action = do
   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
+withJSInterp :: ExceptionMonad m => JSInterp -> (ExtInterpInstance JSInterpExtra -> m a) -> m a
+withJSInterp (ExtInterpState cfg mstate) action = do
   inst <- spawnInterpMaybe cfg spawnJSInterp mstate
   action inst
 
@@ -236,7 +242,7 @@ withJSInterp (JSInterp cfg mstate) action = do
 --
 -- 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 :: ExceptionMonad m => cfg -> (cfg -> IO (ExtInterpInstance d)) -> ExtInterpStatusVar 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
@@ -255,20 +261,10 @@ spawnInterpMaybe cfg spawn mstatus = do
   -- run the inner action
   pure inst
 
--- FIXME: rename withExtInterpInterpMaybe
-withIServMaybe
+withExtInterpMaybe
   :: (ExceptionMonad m)
-  => IServ -> (ExtInterpInstance IServInstance -> m ()) -> m ()
-withIServMaybe (IServ _conf mstate) action = do
-  liftIO (readMVar mstate) >>= \case
-    InterpPending {}   -> pure () -- already shut down or never launched
-    InterpRunning inst -> action inst
-
--- FIXME: rename withExtInterpMaybe
-withJSInterpMaybe
-  :: (ExceptionMonad m)
-  => JSInterp -> (ExtInterpInstance JSInterpInstance -> m ()) -> m ()
-withJSInterpMaybe (JSInterp _conf mstate) action = do
+  => ExtInterp -> (forall d. ExtInterpInstance d -> m ()) -> m ()
+withExtInterpMaybe ext action = withExtInterpStatus ext $ \mstate -> do
   liftIO (readMVar mstate) >>= \case
     InterpPending {}   -> pure () -- already shut down or never launched
     InterpRunning inst -> action inst
@@ -481,7 +477,7 @@ lookupSymbol interp str = case interpInstance interp of
       -- making cross-process LookupSymbol calls, so I added a GHC-side
       -- cache which sped things up quite a lot.  We have to be careful
       -- to purge this cache when unloading code though.
-      cache <- readMVar (instLookupSymbolCache (instDetails inst))
+      cache <- readMVar (instLookupSymbolCache inst)
       case lookupUFM cache str of
         Just p -> return (Just p)
         Nothing -> do
@@ -492,7 +488,7 @@ lookupSymbol interp str = case interpInstance interp of
             Just r -> do
               let p        = fromRemotePtr r
                   cache'   = addToUFM cache str p
-              modifyMVar_ (instLookupSymbolCache (instDetails inst)) (const (pure cache'))
+              modifyMVar_ (instLookupSymbolCache inst) (const (pure cache'))
               return (Just p)
 
     ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str)
@@ -506,12 +502,8 @@ purgeLookupSymbolCache interp = case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
   InternalInterp -> pure ()
 #endif
-  ExternalInterp ext -> case ext of
-    ExtIServ i -> withIServMaybe i $ \inst -> do
-      modifyMVar_ (instLookupSymbolCache (instDetails inst)) (const (pure emptyUFM))
-
-    ExtJS {} -> error "purgeLookupSymbolCache"
-
+  ExternalInterp ext -> withExtInterpMaybe ext $ \inst ->
+    modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM))
 
 -- | loadDLL loads a dynamic library using the OS's native linker
 -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
@@ -565,7 +557,7 @@ findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)
 -- IServ specific calls and messages
 
 -- | Spawn an external interpreter
-spawnIServ :: IServConfig -> IO (ExtInterpInstance IServInstance)
+spawnIServ :: IServConfig -> IO (ExtInterpInstance ())
 spawnIServ conf = do
   iservConfTrace conf
   let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp
@@ -583,13 +575,11 @@ spawnIServ conf = do
 
   pending_frees <- newMVar []
   lookup_cache  <- newMVar emptyUFM
-  let details = IServInstance
-        { instLookupSymbolCache = lookup_cache
-        }
   let inst = ExtInterpInstance
         { instProcess           = process
         , instPendingFrees      = pending_frees
-        , instDetails           = details
+        , instLookupSymbolCache = lookup_cache
+        , instExtra             = ()
         }
   pure inst
 
@@ -599,8 +589,8 @@ stopInterp interp = case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
     InternalInterp -> pure ()
 #endif
-    ExternalInterp ext -> case ext of
-      ExtIServ (IServ _ mstate) -> MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
+    ExternalInterp ext -> withExtInterpStatus ext $ \mstate -> do
+      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
         case state of
           InterpPending    -> pure state -- already stopped
           InterpRunning i  -> do
@@ -610,23 +600,6 @@ stopInterp interp = case interpInstance interp of
                else sendMessage i Shutdown
             pure InterpPending
 
-      ExtJS (JSInterp _cfg mstate) -> MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do
-        case state of
-          InterpPending    -> pure state -- already stopped
-          InterpRunning i  -> do
-            let r = instProcess i
-            getProcessExitCode (interpHandle r) >>= \case
-              Just _  -> pure ()
-              Nothing -> do
-                -- FIXME: call remote shutdown instead of killing the process
-                cleanupProcess ( Just (pipeWrite (interpPipe r))
-                               , Nothing
-                               , Just (pipeRead (interpPipe r))
-                               , interpHandle r
-                               )
-            pure InterpPending
-
-
 -- -----------------------------------------------------------------------------
 {- Note [External GHCi pointers]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -663,17 +636,13 @@ principle it would probably be ok, but it seems less hairy this way.
 -- 'HeapRef' when it is no longer referenced.
 addHeapRefFinalizer :: Interp -> HeapRef a -> IO (FinalizedHeapRef a)
 addHeapRefFinalizer interp rref = do
-   free <- case interpInstance interp of
+   !free <- case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
-      InternalInterp             -> return (freeHeapRef rref)
+      InternalInterp     -> return (freeHeapRef rref)
 #endif
-      ExternalInterp interp      -> case interp of
-        ExtIServ i -> pure $ withIServMaybe i $ \inst ->
-          modifyMVar_ (instPendingFrees inst) (\xs -> pure (castHeapRef rref : xs))
-
-        ExtJS i -> pure $ withJSInterpMaybe i $ \inst ->
-          modifyMVar_ (instPendingFrees inst) (\xs -> pure (castHeapRef rref : xs))
-
+      ExternalInterp ext -> pure $ withExtInterpMaybe ext $ \inst ->
+        -- add to the list of HeapRefs to free
+        modifyMVar_ (instPendingFrees inst) (\xs -> pure (castHeapRef rref : xs))
 
    mkFinalizedHeapRef rref free
 
@@ -726,8 +695,8 @@ interpreterProfiled interp = case interpInstance interp of
   InternalInterp     -> hostIsProfiled
 #endif
   ExternalInterp ext -> case ext of
-    ExtIServ (IServ c _) -> iservConfProfiled c
-    ExtJS {}             -> False -- we don't support profiling yet in the JS backend
+    ExtIServ i -> iservConfProfiled (interpConfig i)
+    ExtJS {}   -> False -- we don't support profiling yet in the JS backend
 
 -- | Interpreter uses Dynamic way
 interpreterDynamic :: Interp -> Bool
@@ -736,5 +705,5 @@ interpreterDynamic interp = case interpInstance interp of
   InternalInterp     -> hostIsDynamic
 #endif
   ExternalInterp ext -> case ext of
-    ExtIServ (IServ c _) -> iservConfDynamic c
-    ExtJS {}             -> False -- dynamic doesn't make sense for JS
+    ExtIServ i -> iservConfDynamic (interpConfig i)
+    ExtJS {}   -> False -- dynamic doesn't make sense for JS


=====================================
compiler/GHC/Runtime/Interpreter/JS.hs
=====================================
@@ -5,15 +5,12 @@
 
 -- | JaveScript interpreter
 module GHC.Runtime.Interpreter.JS
-  ( startTHRunnerProcess
-  , spawnJSInterp
+  ( spawnJSInterp
   , jsLinkRts
   , jsLinkInterp
   , jsLinkObject
   , jsLoadFile
-  , jsLoadCode
   , jsRunServer
-  , jsLookupClosure
   -- * Reexported for convenience
   , mkExportedModFuns
   )
@@ -24,14 +21,10 @@ import GHC.Runtime.Interpreter.Types
 import GHC.Runtime.Interpreter.Process
 import GHC.Runtime.Utils
 import GHCi.Message
-import GHCi.RemoteTypes
-
-import GHC.JS.Syntax
 
 import GHC.StgToJS.Linker.Types
 import GHC.StgToJS.Linker.Linker
 import GHC.StgToJS.Types
-import GHC.StgToJS.Printer (pretty)
 import GHC.StgToJS.Object
 
 import GHC.Unit.Env
@@ -43,8 +36,8 @@ import GHC.Utils.TmpFs
 import GHC.Utils.Panic
 import GHC.Utils.Error (logInfo)
 import GHC.Utils.Outputable (text)
-import qualified GHC.Utils.Ppr as Ppr
 import GHC.Data.FastString 
+import GHC.Types.Unique.FM
 
 import Control.Concurrent
 import Control.Monad
@@ -102,7 +95,7 @@ startTHRunnerProcess topdir settings = do
 -- | Spawn a JS interpreter
 --
 -- Run NodeJS with thrunner.js and its deps (including the rts) loaded.
-spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpInstance)
+spawnJSInterp :: JSInterpConfig -> IO (ExtInterpInstance JSInterpExtra)
 spawnJSInterp cfg = do
 
   logInfo (jsInterpLogger cfg) (text "Spawning JS interpreter")
@@ -118,17 +111,18 @@ spawnJSInterp cfg = do
                 , jsServerStarted = False
                 })
 
-  let details = JSInterpInstance
+  let extra = JSInterpExtra
         { instStdIn        = std_in
-        , instConfig       = cfg
         , instJSState      = js_state
         }
 
   pending_frees <- newMVar []
+  lookup_cache  <- newMVar emptyUFM
   let inst = ExtInterpInstance
-        { instProcess      = proc
-        , instPendingFrees = pending_frees
-        , instDetails      = details
+        { instProcess           = proc
+        , instPendingFrees      = pending_frees
+        , instLookupSymbolCache = lookup_cache
+        , instExtra             = extra
         }
 
   -- link rts and its deps
@@ -149,7 +143,7 @@ spawnJSInterp cfg = do
 ---------------------------------------------------------
 
 -- | Link JS RTS
-jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpInstance -> IO ()
+jsLinkRts :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO ()
 jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do
 
   let link_cfg = JSLinkConfig
@@ -173,7 +167,7 @@ jsLinkRts logger tmpfs tmp_dir cfg unit_env inst = do
   jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan
 
 -- | Link JS interpreter
-jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpInstance -> IO ()
+jsLinkInterp :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> IO ()
 jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do
 
   let link_cfg = JSLinkConfig
@@ -208,7 +202,7 @@ jsLinkInterp logger tmpfs tmp_dir cfg unit_env inst = do
 
 
 -- | Link an object file using the given functions as roots
-jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpInstance -> FilePath -> [ExportedFun] -> IO ()
+jsLinkObject :: Logger -> TmpFs -> TempDir -> StgToJSConfig -> UnitEnv -> ExtInterpInstance JSInterpExtra -> FilePath -> [ExportedFun] -> IO ()
 jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
 
   let link_cfg = JSLinkConfig
@@ -243,13 +237,13 @@ jsLinkObject logger tmpfs tmp_dir cfg unit_env inst obj roots = do
 -- | Link the given link plan
 --
 -- Perform incremental linking by removing what is already linked from the plan
-jsLinkPlan :: Logger -> TmpFs -> TempDir -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpInstance -> LinkPlan -> IO ()
+jsLinkPlan :: Logger -> TmpFs -> TempDir -> JSLinkConfig -> StgToJSConfig -> ExtInterpInstance JSInterpExtra -> LinkPlan -> IO ()
 jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
   ----------------------------------------------------------------
   -- Get already linked stuff and compute incremental plan
   ----------------------------------------------------------------
 
-  old_plan <- jsLinkState <$> readMVar (instJSState (instDetails inst))
+  old_plan <- jsLinkState <$> readMVar (instJSState (instExtra inst))
 
   -- compute new plan discarding what's already linked
   let (diff_plan, total_plan) = incrementLinkPlan old_plan link_plan
@@ -291,7 +285,7 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
   --   JS server;
   -- - once the Haskell server is started, we send a LoadJS message to the
   --   Haskell server.
-  server_started <- jsServerStarted <$> readMVar (instJSState (instDetails inst))
+  server_started <- jsServerStarted <$> readMVar (instJSState (instExtra inst))
   if server_started
     then sendMessageNoResponse inst $ LoadJS all_js
     else jsSendCommand         inst $ LoadFile all_js
@@ -299,7 +293,7 @@ jsLinkPlan logger tmpfs tmp_dir link_cfg cfg inst link_plan = do
   ----------------------------------------------------------------
   -- update linker state
   ----------------------------------------------------------------
-  modifyMVar_ (instJSState (instDetails inst)) $ \state -> pure state { jsLinkState = total_plan }
+  modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsLinkState = total_plan }
 
 
 
@@ -310,11 +304,11 @@ data Command r where
   RunServer             :: Command () -- ^ Run GHCi.Server.defaultServer
 
 -- | Send a command to the JS interpreter
-jsSendCommand :: ExtInterpInstance JSInterpInstance -> Command r -> IO r
+jsSendCommand :: ExtInterpInstance JSInterpExtra -> Command r -> IO r
 jsSendCommand inst cmd = do
   let
-    details = instDetails inst
-    handle = instStdIn details
+    extra = instExtra inst
+    handle = instStdIn extra
 
     ptr :: forall a. Ptr a -> Int -> IO ()
     ptr p n = hPutBuf handle p n
@@ -347,33 +341,13 @@ jsSendCommand inst cmd = do
       flush
 
 -- | Load a JS file in the interpreter
-jsLoadFile :: ExtInterpInstance JSInterpInstance -> FilePath -> IO ()
+jsLoadFile :: ExtInterpInstance JSInterpExtra -> FilePath -> IO ()
 jsLoadFile inst path = jsSendCommand inst (LoadFile path)
 
--- | Load some JS code in the interpreter
-jsLoadCode :: ExtInterpInstance JSInterpInstance -> JStat -> IO ()
-jsLoadCode inst doc = do
-  let config  = instConfig (instDetails inst)
-  let logger  = jsInterpLogger config
-  let tmpfs   = jsInterpTmpFs config
-  let tmp_dir = jsInterpTmpDir config
-
-  -- dump code into file
-  out <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "js"
-  withBinaryFile out WriteMode \h ->
-    Ppr.printLeftRender h (pretty doc)
-
-  -- load file
-  jsLoadFile inst out
-
 -- | Run JS server
-jsRunServer :: ExtInterpInstance JSInterpInstance -> IO ()
+jsRunServer :: ExtInterpInstance JSInterpExtra -> IO ()
 jsRunServer inst = do
   jsSendCommand inst RunServer
 
   -- indicate that the Haskell server is now started
-  modifyMVar_ (instJSState (instDetails inst)) $ \state -> pure state { jsServerStarted = True }
-
--- | Lookup a closure
-jsLookupClosure :: ExtInterpInstance JSInterpInstance -> String -> IO (Maybe AnyHeapRef)
-jsLookupClosure inst str = sendMessage inst (LookupClosure str)
+  modifyMVar_ (instJSState (instExtra inst)) $ \state -> pure state { jsServerStarted = True }


=====================================
compiler/GHC/Runtime/Interpreter/Types.hs
=====================================
@@ -4,18 +4,18 @@
 module GHC.Runtime.Interpreter.Types
    ( Interp(..)
    , InterpInstance(..)
-   , InterpState(..)
    , InterpProcess (..)
    , ExtInterp (..)
-   , ExtInterpInstanceVar
+   , ExtInterpStatusVar
    , ExtInterpInstance (..)
+   , ExtInterpState (..)
+   , InterpStatus(..)
    -- * IServ
-   , IServ (..)
-   , IServInstance(..)
+   , IServ
    , IServConfig(..)
    -- * JSInterp
-   , JSInterp (..)
-   , JSInterpInstance (..)
+   , JSInterp
+   , JSInterpExtra (..)
    , JSInterpConfig (..)
    , JSState (..)
    , NodeJsSettings (..)
@@ -61,23 +61,28 @@ data ExtInterp
   = ExtIServ !IServ
   | ExtJS !JSInterp
 
-data IServ    = IServ !IServConfig !(ExtInterpInstanceVar (ExtInterpInstance IServInstance))
-data JSInterp = JSInterp !JSInterpConfig !(ExtInterpInstanceVar (ExtInterpInstance JSInterpInstance))
-
-data InterpProcess = InterpProcess
-  { interpPipe   :: !Pipe           -- ^ Pipe to communicate with the server
-  , interpHandle :: !ProcessHandle  -- ^ Process handle of the server
-  }
-
 -- | External interpreter
 --
 -- The external interpreter is spawned lazily (on first use) to avoid slowing
 -- down sessions that don't require it. The contents of the MVar reflects the
 -- state of the interpreter (running or not).
-type ExtInterpInstanceVar inst = MVar (InterpState inst)
+data ExtInterpState cfg details = ExtInterpState
+  { interpConfig :: !cfg
+  , interpStatus :: !(ExtInterpStatusVar details)
+  }
+
+type ExtInterpStatusVar d = MVar (InterpStatus (ExtInterpInstance d))
+
+type IServ    = ExtInterpState IServConfig    ()
+type JSInterp = ExtInterpState JSInterpConfig JSInterpExtra
 
--- | State of an external interpreter
-data InterpState inst
+data InterpProcess = InterpProcess
+  { interpPipe   :: !Pipe           -- ^ Pipe to communicate with the server
+  , interpHandle :: !ProcessHandle  -- ^ Process handle of the server
+  }
+
+-- | Status of an external interpreter
+data InterpStatus inst
    = InterpPending       -- ^ Not spawned yet
    | InterpRunning !inst -- ^ Running
 
@@ -101,24 +106,20 @@ data ExtInterpInstance c = ExtInterpInstance
       -- Threads can append values to this list asynchronously (by modifying the
       -- IServ state MVar).
 
-  , instDetails       :: !c
-      -- ^ Instance specific fields
-  }
-
--- | External interpreter instance
-data IServInstance = IServInstance
-  { instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
+  , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))
       -- ^ LookupSymbol cache
+
+  , instExtra             :: !c
+      -- ^ Instance specific extra fields
   }
 
 ------------------------
 -- JS Stuff
 ------------------------
 
-data JSInterpInstance = JSInterpInstance
-  { instStdIn        :: !Handle                       -- ^ Stdin for the process
-  , instConfig       :: !JSInterpConfig               -- ^ Config used by the interpreter
-  , instJSState      :: !(MVar JSState)                -- ^ Mutable state
+data JSInterpExtra = JSInterpExtra
+  { instStdIn        :: !Handle         -- ^ Stdin for the process
+  , instJSState      :: !(MVar JSState) -- ^ Mutable state
   }
 
 data JSState = JSState



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a337cdeeae9757e779b4a5898c241812eb009912

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a337cdeeae9757e779b4a5898c241812eb009912
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/372570f7/attachment-0001.html>


More information about the ghc-commits mailing list