[commit: ghc] master: Fix #16392: revertCAFs in external interpreter when necessary (7a68254)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/7a68254a7284db5bf8f1fa82aba4a6825d8f050a/ghc

>---------------------------------------------------------------

commit 7a68254a7284db5bf8f1fa82aba4a6825d8f050a
Author: Phuong Trinh <lolotp at fb.com>
Date:   Tue Mar 5 15:48:46 2019 +0000

    Fix #16392: revertCAFs in external interpreter when necessary
    
    We revert CAFs when loading/adding modules in ghci (presumably to refresh
    execution states and to allow for object code to be unloaded from the runtime).
    However, with `-fexternal-interpreter` enabled, we are only doing it in the
    ghci process instead of the external interpreter process where the cafs are
    allocated and computed. This makes sure that revertCAFs is done in the
    appropriate process no matter if that flag is present or not.


>---------------------------------------------------------------

7a68254a7284db5bf8f1fa82aba4a6825d8f050a
 ghc/GHCi/UI/Monad.hs                                          |  5 ++---
 libraries/ghci/GHCi/Message.hs                                |  6 +++++-
 libraries/ghci/GHCi/Run.hs                                    |  4 ++++
 testsuite/tests/ghci/T16392/A.hs                              | 11 +++++++++++
 testsuite/tests/ghci/T16392/T16392.script                     |  5 +++++
 testsuite/tests/ghci/T16392/T16392.stderr                     |  2 ++
 .../tests/{boxy/T2193.stdout => ghci/T16392/T16392.stdout}    |  1 +
 testsuite/tests/ghci/T16392/all.T                             |  4 ++++
 8 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 51f1366..fb88727 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -456,14 +456,13 @@ printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}
 
 revertCAFs :: GhciMonad m => m ()
 revertCAFs = do
-  liftIO rts_revertCAFs
+  hsc_env <- GHC.getSession
+  liftIO $ iservCmd hsc_env RtsRevertCAFs
   s <- getGHCiState
   when (not (ghc_e s)) turnOffBuffering
      -- Have to turn off buffering again, because we just
      -- reverted stdout, stderr & stdin to their defaults.
 
-foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
-        -- Make it "safe", just in case
 
 -----------------------------------------------------------------------------
 -- To flush buffers for the *interpreted* computation we need
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 959942e..319eebd 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -61,6 +61,7 @@ import System.IO.Error
 data Message a where
   -- | Exit the iserv process
   Shutdown :: Message ()
+  RtsRevertCAFs :: Message ()
 
   -- RTS Linker -------------------------------------------
 
@@ -485,7 +486,9 @@ getMessage = do
       33 -> Msg <$> (AddSptEntry <$> get <*> get)
       34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
       35 -> Msg <$> (GetClosure <$> get)
-      _  -> Msg <$> (Seq <$> get)
+      36 -> Msg <$> (Seq <$> get)
+      37 -> Msg <$> return RtsRevertCAFs
+      _  -> error $ "Unknown Message code " ++ (show b)
 
 putMessage :: Message a -> Put
 putMessage m = case m of
@@ -526,6 +529,7 @@ putMessage m = case m of
   RunTH st q loc ty           -> putWord8 34 >> put st >> put q >> put loc >> put ty
   GetClosure a                -> putWord8 35 >> put a
   Seq a                       -> putWord8 36 >> put a
+  RtsRevertCAFs               -> putWord8 37
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 72099b2..a931e62 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -44,9 +44,13 @@ import Unsafe.Coerce
 -- -----------------------------------------------------------------------------
 -- Implement messages
 
+foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()
+        -- Make it "safe", just in case
+
 run :: Message a -> IO a
 run m = case m of
   InitLinker -> initObjLinker RetainCAFs
+  RtsRevertCAFs -> rts_revertCAFs
   LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str
   LookupClosure str -> lookupClosure str
   LoadDLL str -> loadDLL str
diff --git a/testsuite/tests/ghci/T16392/A.hs b/testsuite/tests/ghci/T16392/A.hs
new file mode 100644
index 0000000..31bfb7f
--- /dev/null
+++ b/testsuite/tests/ghci/T16392/A.hs
@@ -0,0 +1,11 @@
+module A (caf, c_two) where
+
+import Debug.Trace (trace)
+
+data C = C Int Int
+
+caf :: C
+caf = C 3 (trace "value forced" 4)
+
+c_two :: C -> Int
+c_two (C _ b) = b
diff --git a/testsuite/tests/ghci/T16392/T16392.script b/testsuite/tests/ghci/T16392/T16392.script
new file mode 100644
index 0000000..5fdcb17
--- /dev/null
+++ b/testsuite/tests/ghci/T16392/T16392.script
@@ -0,0 +1,5 @@
+:set -fobject-code
+:load A.hs
+c_two caf
+:load A.hs
+c_two caf
diff --git a/testsuite/tests/ghci/T16392/T16392.stderr b/testsuite/tests/ghci/T16392/T16392.stderr
new file mode 100644
index 0000000..3473a38
--- /dev/null
+++ b/testsuite/tests/ghci/T16392/T16392.stderr
@@ -0,0 +1,2 @@
+value forced
+value forced
diff --git a/testsuite/tests/boxy/T2193.stdout b/testsuite/tests/ghci/T16392/T16392.stdout
similarity index 50%
copy from testsuite/tests/boxy/T2193.stdout
copy to testsuite/tests/ghci/T16392/T16392.stdout
index b8626c4..7290ba8 100644
--- a/testsuite/tests/boxy/T2193.stdout
+++ b/testsuite/tests/ghci/T16392/T16392.stdout
@@ -1 +1,2 @@
 4
+4
diff --git a/testsuite/tests/ghci/T16392/all.T b/testsuite/tests/ghci/T16392/all.T
new file mode 100644
index 0000000..a77e0fd
--- /dev/null
+++ b/testsuite/tests/ghci/T16392/all.T
@@ -0,0 +1,4 @@
+test('T16392',
+     [extra_files(['A.hs']),
+      extra_ways(['ghci-ext'])],
+     ghci_script, ['T16392.script'])