[Git][ghc/ghc][wip/js-th] Don't use Interp when we already have an interp instance

[Sylvain Henry (@hsyl20)]

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


Commits:
4e6f2205 by Sylvain Henry at 2023-01-20T11:33:54+01:00
Don't use Interp when we already have an interp instance

- - - - -


2 changed files:

- compiler/GHC/Runtime/Interpreter.hs
- compiler/GHC/Tc/Gen/Splice.hs


Changes:

=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -55,6 +55,7 @@ module GHC.Runtime.Interpreter
   , withJSInterp
   , stopInterp
   , purgeLookupSymbolCache
+  , freeRemoteHeapRef
   , freeHeapRefs
   , addHeapRefFinalizer
   , wormhole, wormholeRef
@@ -263,11 +264,11 @@ spawnInterpMaybe cfg spawn mstatus = do
 
 withExtInterpMaybe
   :: (ExceptionMonad m)
-  => ExtInterp -> (forall d. ExtInterpInstance d -> m ()) -> m ()
+  => ExtInterp -> (forall d. Maybe (ExtInterpInstance d) -> m a) -> m a
 withExtInterpMaybe ext action = withExtInterpStatus ext $ \mstate -> do
   liftIO (readMVar mstate) >>= \case
-    InterpPending {}   -> pure () -- already shut down or never launched
-    InterpRunning inst -> action inst
+    InterpPending {}   -> action Nothing -- already shut down or never launched
+    InterpRunning inst -> action (Just inst)
 
 -- -----------------------------------------------------------------------------
 -- Wrappers around messages
@@ -502,8 +503,9 @@ purgeLookupSymbolCache interp = case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
   InternalInterp -> pure ()
 #endif
-  ExternalInterp ext -> withExtInterpMaybe ext $ \inst ->
-    modifyMVar_ (instLookupSymbolCache inst) (const (pure emptyUFM))
+  ExternalInterp ext -> withExtInterpMaybe ext $ \case
+    Nothing   -> pure () -- interpreter stopped, nothing to do
+    Just 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
@@ -636,15 +638,18 @@ 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
+  case interpInstance interp of
 #if defined(HAVE_INTERNAL_INTERPRETER)
-      InternalInterp     -> return (freeHeapRef rref)
+    InternalInterp     -> mkFinalizedHeapRef rref (freeHeapRef rref)
 #endif
-      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
+    ExternalInterp ext -> withExtInterpMaybe ext $ \case
+      Nothing   -> mkFinalizedHeapRef rref (pure ()) -- nothing to do, interpreter already stopped
+      Just inst -> mkFinalizedHeapRef rref (freeRemoteHeapRef inst rref)
+
+freeRemoteHeapRef :: ExtInterpInstance d -> HeapRef a -> IO ()
+freeRemoteHeapRef inst rref =
+  -- add to the list of HeapRefs to free
+  modifyMVar_ (instPendingFrees inst) (\xs -> pure (castHeapRef rref : xs))
 
 
 freeHeapRefs :: Interp -> [AnyHeapRef] -> IO ()


=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -155,6 +155,7 @@ import qualified Data.Map as Map
 import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )
 import Data.Data (Data)
 import Data.Proxy    ( Proxy (..) )
+import Data.IORef
 import GHC.Parser.HaddockLex (lexHsDoc)
 import GHC.Parser (parseIdentifier)
 import GHC.Rename.Doc (rnHsDoc)
@@ -1794,15 +1795,16 @@ Back in GHC, when we receive:
 --
 getTHState :: ExtInterpInstance d -> TcM (FinalizedHeapRef (IORef QState))
 getTHState inst = do
-  tcg <- getGblEnv
-  th_state <- readTcRef (tcg_th_remote_state tcg)
-  case th_state of
-    Just rhv -> return rhv
-    Nothing -> do
-      interp <- tcGetInterp
-      fhv <- liftIO $ addHeapRefFinalizer interp =<< sendMessage inst StartTH
-      writeTcRef (tcg_th_remote_state tcg) (Just fhv)
-      return fhv
+  th_state_var <- tcg_th_remote_state <$> getGblEnv
+  liftIO $ do
+    th_state <- readIORef th_state_var
+    case th_state of
+      Just rhv -> return rhv
+      Nothing -> do
+        rref <- sendMessage inst StartTH
+        fhv <- mkFinalizedHeapRef rref (freeRemoteHeapRef inst rref)
+        writeIORef th_state_var (Just fhv)
+        return fhv
 
 wrapTHResult :: TcM a -> TcM (THResult a)
 wrapTHResult tcm = do



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/4e6f22059167b79dfe06ce731abfc61bdbed7a17
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/20230120/25ba6167/attachment-0001.html>