diff options
author | Phuong Trinh <lolotp@fb.com> | 2019-03-05 15:48:46 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2019-03-07 14:01:42 -0500 |
commit | 7a68254a7284db5bf8f1fa82aba4a6825d8f050a (patch) | |
tree | f5c7e7a51f305514376f4ff09b63465b93621e96 | |
parent | 25c3dd39f7d446f66b5c967be81f80cd7facb509 (diff) | |
download | haskell-7a68254a7284db5bf8f1fa82aba4a6825d8f050a.tar.gz |
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.
-rw-r--r-- | ghc/GHCi/UI/Monad.hs | 5 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Message.hs | 6 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Run.hs | 4 | ||||
-rw-r--r-- | testsuite/tests/ghci/T16392/A.hs | 11 | ||||
-rw-r--r-- | testsuite/tests/ghci/T16392/T16392.script | 5 | ||||
-rw-r--r-- | testsuite/tests/ghci/T16392/T16392.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/ghci/T16392/T16392.stdout | 2 | ||||
-rw-r--r-- | testsuite/tests/ghci/T16392/all.T | 4 |
8 files changed, 35 insertions, 4 deletions
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index 51f13663ea..fb887275d7 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 959942e858..319eebdfc0 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 72099b205f..a931e620cc 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 0000000000..31bfb7f075 --- /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 0000000000..5fdcb17dc0 --- /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 0000000000..3473a386b5 --- /dev/null +++ b/testsuite/tests/ghci/T16392/T16392.stderr @@ -0,0 +1,2 @@ +value forced +value forced diff --git a/testsuite/tests/ghci/T16392/T16392.stdout b/testsuite/tests/ghci/T16392/T16392.stdout new file mode 100644 index 0000000000..7290ba859f --- /dev/null +++ b/testsuite/tests/ghci/T16392/T16392.stdout @@ -0,0 +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 0000000000..a77e0fd994 --- /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']) |