summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoland Senn <rsx@bluewin.ch>2021-01-01 14:01:41 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2021-01-07 00:12:09 -0500
commit1de2050edd8a2647e89a9269278a79b61892b59e (patch)
tree2c902e80f7b030d42ddc38770b878a5db1315e48
parent06982b6cc886d65aa325475ddfb4ad38c69b2d96 (diff)
downloadhaskell-1de2050edd8a2647e89a9269278a79b61892b59e.tar.gz
GHCi: Fill field `DynFlags.dumpPrefix`. (Fixes #17500)
For interactive evaluations set the field `DynFlags.dumpPrefix` to the GHCi internal module name. The GHCi module name for an interactive evaluation is something like `Ghci9`. To avoid user confusion, don't dump any data for GHCi internal evaluations. Extend the comment for `DynFlags.dumpPrefix` and fix a little typo in a comment about the GHCi internal module names.
-rw-r--r--compiler/GHC/Builtin/Names.hs2
-rw-r--r--compiler/GHC/Driver/Session.hs7
-rw-r--r--ghc/GHCi/UI.hs13
-rw-r--r--ghc/GHCi/UI/Monad.hs7
-rw-r--r--testsuite/tests/ghci/scripts/T17500.hs8
-rw-r--r--testsuite/tests/ghci/scripts/T17500.script10
-rw-r--r--testsuite/tests/ghci/scripts/T17500.stdout3
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
8 files changed, 45 insertions, 6 deletions
diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs
index cf0f72c50f..5cf4753a45 100644
--- a/compiler/GHC/Builtin/Names.hs
+++ b/compiler/GHC/Builtin/Names.hs
@@ -612,7 +612,7 @@ rOOT_MAIN :: Module
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
mkInteractiveModule :: Int -> Module
--- (mkInteractiveMoudule 9) makes module 'interactive:M9'
+-- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9'
mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))
pRELUDE_NAME, mAIN_NAME :: ModuleName
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 3bbd049144..109d854526 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -529,11 +529,12 @@ data DynFlags = DynFlags {
-- used to query the appropriate fields
-- (outputFile/dynOutputFile, ways, etc.)
- -- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where
- -- its output is going.
+ -- | This is set by 'GHC.Driver.Pipeline.runPipeline'
+ -- or 'ghc.GHCi.UI.runStmt' based on where its output is going.
dumpPrefix :: Maybe FilePath,
- -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'.
+ -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'
+ -- or 'ghc.GHCi.UI.runStmt'.
-- Set by @-ddump-file-prefix@
dumpPrefixForce :: Maybe FilePath,
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 4a1b91a9fc..5beca7882d 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -458,7 +458,7 @@ interactiveUI config srcs maybe_exprs = do
_ <- liftIO $ newStablePtr stderr
-- Initialise buffering for the *interpreted* I/O system
- (nobuffering, flush) <- initInterpBuffering
+ (nobuffering, flush) <- runInternal initInterpBuffering
-- The initial set of DynFlags used for interactive evaluation is the same
-- as the global DynFlags, plus -XExtendedDefaultRules and
@@ -1215,6 +1215,10 @@ runStmt input step = do
-- and should therefore not be used here.
| otherwise -> do
hsc_env <- GHC.getSession
+ let !ic = hsc_IC hsc_env -- Bang-pattern to avoid space leaks
+ setDumpFilePrefix ic
+ -- `-ddump-to-file` must work for normal GHCi compilations /
+ -- evaluations. (#17500)
decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)
run_decls decls
where
@@ -1270,6 +1274,13 @@ runStmt input step = do
l = L loc
in l (LetStmt noExtField (l (HsValBinds noExtField (ValBinds noExtField (unitBag (l bind)) []))))
+ setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500
+ setDumpFilePrefix ic = do
+ dflags <- GHC.getInteractiveDynFlags
+ GHC.setInteractiveDynFlags dflags { dumpPrefix = Just (modStr ++ ".") }
+ where
+ modStr = moduleNameString $ moduleName $ icInteractiveModule $ ic
+
-- | Clean up the GHCi environment after a statement has run
afterRunStmt :: GhciMonad m
=> (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 87de1a83cb..b371a9b8b4 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -31,6 +31,7 @@ module GHCi.UI.Monad (
initInterpBuffering,
turnOffBuffering, turnOffBuffering_,
flushInterpBuffers,
+ runInternal,
mkEvalWrapper
) where
@@ -74,6 +75,7 @@ import Control.Monad.Trans.Reader
import Control.Monad.IO.Class
import Data.Map.Strict (Map)
import qualified Data.IntMap.Strict as IntMap
+import qualified GHC.Data.EnumSet as EnumSet
import qualified GHC.LanguageExtensions as LangExt
-----------------------------------------------------------------------------
@@ -519,7 +521,10 @@ runInternal =
-- Running GHCi's internal expression is incompatible with -XSafe.
-- We temporarily disable any Safe Haskell settings while running
-- GHCi internal expressions. (see #12509)
- safeHaskell = Sf_None
+ safeHaskell = Sf_None,
+ -- Disable dumping of any data during evaluation of GHCi's internal
+ -- expressions. (#17500)
+ dumpFlags = EnumSet.empty
}
-- RebindableSyntax can wreak havoc with GHCi in several ways
-- (see #13385 and #14342 for examples), so we temporarily
diff --git a/testsuite/tests/ghci/scripts/T17500.hs b/testsuite/tests/ghci/scripts/T17500.hs
new file mode 100644
index 0000000000..a3e05741a7
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T17500.hs
@@ -0,0 +1,8 @@
+module T17500 where
+
+import Data.List ( isInfixOf )
+
+isBCOsFile :: String -> IO Bool
+isBCOsFile fname = do
+ content <- readFile fname
+ pure $ "== Proto-BCOs ==" `isInfixOf` content -- Check title line
diff --git a/testsuite/tests/ghci/scripts/T17500.script b/testsuite/tests/ghci/scripts/T17500.script
new file mode 100644
index 0000000000..f8ea5e9166
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T17500.script
@@ -0,0 +1,10 @@
+:l T17500
+b = 42
+:{
+fac :: Integer -> Integer
+fac 0 = 1
+fac n = n * fac (n - 1)
+:}
+isBCOsFile "T17500.dump-BCOs"
+isBCOsFile "Ghci1.dump-BCOs"
+isBCOsFile "Ghci2.dump-BCOs"
diff --git a/testsuite/tests/ghci/scripts/T17500.stdout b/testsuite/tests/ghci/scripts/T17500.stdout
new file mode 100644
index 0000000000..b8ca7e7ef0
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T17500.stdout
@@ -0,0 +1,3 @@
+True
+True
+True
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 6fec18bd92..b9b534ca9e 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -319,6 +319,7 @@ test('T17345', normal, ghci_script, ['T17345.script'])
test('T17384', normal, ghci_script, ['T17384.script'])
test('T17403', normal, ghci_script, ['T17403.script'])
test('T17431', normal, ghci_script, ['T17431.script'])
+test('T17500', [extra_run_opts('-ddump-to-file -ddump-bcos')], ghci_script, ['T17500.script'])
test('T17549', normal, ghci_script, ['T17549.script'])
test('T17669', [extra_run_opts('-fexternal-interpreter -fobject-code'), expect_broken(17669)], ghci_script, ['T17669.script'])
test('T18501', normal, ghci_script, ['T18501.script'])