[Git][ghc/ghc][master] 5 commits: ghci: Don't rely on resolution of System.IO to base module
Ben Gamari
gitlab at gitlab.haskell.org
Sun Jun 23 14:47:15 UTC 2019
Ben Gamari pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
655c6e26 by Ben Gamari at 2019-06-22T14:06:05Z
ghci: Don't rely on resolution of System.IO to base module
Previously we would hackily evaluate a textual code snippet to compute
actions to disable I/O buffering and flush the stdout/stderr handles.
This broke in a number of ways (#15336, #16563).
Instead we now ship a module (`GHC.GHCi.Helpers`) with `base` containing
the needed actions. We can then easily refer to these via `Orig` names.
- - - - -
8f8fc31b by Ben Gamari at 2019-06-22T14:06:05Z
testsuite: Add test for #16563
- - - - -
22e721c1 by Ben Gamari at 2019-06-22T14:06:05Z
testsuite: Mark T5611 as broken in ghci way
As described in #16845.
- - - - -
b0d6bf2a by Ben Gamari at 2019-06-22T14:06:05Z
rts: Reset STATIC_LINK field of reverted CAFs
When we revert a CAF we must reset the STATIC_LINK field lest the GC
might ignore the CAF (e.g. as it carries the STATIC_FLAG_LIST flag) and
will consequently overlook references to object code that we are trying
to unload. This would result in the reachable object code being
unloaded. See Note [CAF lists] and Note [STATIC_LINK fields].
This fixes #16842.
Idea-due-to: Phuong Trinh <lolotp at fb.com>
- - - - -
1f2fff89 by Ben Gamari at 2019-06-22T14:06:05Z
testsuite: Add caf_crash testcase
- - - - -
24 changed files:
- compiler/prelude/PrelNames.hs
- ghc/GHCi/UI/Monad.hs
- + libraries/base/GHC/GHCi/Helpers.hs
- libraries/base/base.cabal
- rts/sm/GCAux.c
- testsuite/tests/concurrent/should_run/all.T
- testsuite/tests/ghci.debugger/scripts/break006.stdout
- testsuite/tests/ghci.debugger/scripts/break013.stdout
- testsuite/tests/ghci.debugger/scripts/hist001.stdout
- testsuite/tests/ghci.debugger/scripts/hist002.stdout
- + testsuite/tests/ghci/caf_crash/A.hs
- + testsuite/tests/ghci/caf_crash/B.hs
- + testsuite/tests/ghci/caf_crash/D.hs
- + testsuite/tests/ghci/caf_crash/all.T
- + testsuite/tests/ghci/caf_crash/caf_crash.script
- + testsuite/tests/ghci/caf_crash/caf_crash.stdout
- + testsuite/tests/ghci/scripts/T16563.script
- + testsuite/tests/ghci/scripts/T16563.stdout
- testsuite/tests/ghci/scripts/T4175.stdout
- testsuite/tests/ghci/scripts/T7627.stdout
- testsuite/tests/ghci/scripts/T8469.stdout
- testsuite/tests/ghci/scripts/all.T
- testsuite/tests/ghci/scripts/ghci011.stdout
- testsuite/tests/ghci/scripts/ghci064.stdout
Changes:
=====================================
compiler/prelude/PrelNames.hs
=====================================
@@ -498,7 +498,7 @@ pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
- gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
+ gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,
gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
dATA_FOLDABLE, dATA_TRAVERSABLE,
@@ -520,6 +520,7 @@ gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes")
gHC_BASE = mkBaseModule (fsLit "GHC.Base")
gHC_ENUM = mkBaseModule (fsLit "GHC.Enum")
gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi")
+gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers")
gHC_SHOW = mkBaseModule (fsLit "GHC.Show")
gHC_READ = mkBaseModule (fsLit "GHC.Read")
gHC_NUM = mkBaseModule (fsLit "GHC.Num")
=====================================
ghc/GHCi/UI/Monad.hs
=====================================
@@ -41,14 +41,18 @@ import qualified GHC
import GhcMonad hiding (liftIO)
import Outputable hiding (printForUser, printForUserPartWay)
import qualified Outputable
+import OccName
import DynFlags
import FastString
import HscTypes
import SrcLoc
import Module
+import RdrName (mkOrig)
+import PrelNames (gHC_GHCI_HELPERS)
import GHCi
import GHCi.RemoteTypes
import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)
+import HsUtils
import Util
import Exception
@@ -488,13 +492,12 @@ revertCAFs = do
-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly
initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)
initInterpBuffering = do
- nobuf <- compileGHCiExpr $
- "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " ++
- " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " ++
- " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"
- flush <- compileGHCiExpr $
- "do { System.IO.hFlush System.IO.stdout; " ++
- " System.IO.hFlush System.IO.stderr }"
+ let mkHelperExpr :: OccName -> Ghc ForeignHValue
+ mkHelperExpr occ =
+ GHC.compileParsedExprRemote
+ $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ
+ nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"
+ flush <- mkHelperExpr $ mkVarOcc "flushAll"
return (nobuf, flush)
-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter
@@ -517,13 +520,18 @@ turnOffBuffering_ fhv = do
mkEvalWrapper :: GhcMonad m => String -> [String] -> m ForeignHValue
mkEvalWrapper progname args =
- compileGHCiExpr $
- "\\m -> System.Environment.withProgName " ++ show progname ++
- "(System.Environment.withArgs " ++ show args ++ " m)"
-
-compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
-compileGHCiExpr expr =
- withTempSession mkTempSession $ GHC.compileExprRemote expr
+ runInternal $ GHC.compileParsedExprRemote
+ $ evalWrapper `GHC.mkHsApp` nlHsString progname
+ `GHC.mkHsApp` nlList (map nlHsString args)
+ where
+ nlHsString = nlHsLit . mkHsString
+ evalWrapper =
+ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper")
+
+-- | Run a 'GhcMonad' action to compile an expression for internal usage.
+runInternal :: GhcMonad m => m a -> m a
+runInternal =
+ withTempSession mkTempSession
where
mkTempSession hsc_env = hsc_env
{ hsc_dflags = (hsc_dflags hsc_env) {
@@ -540,3 +548,6 @@ compileGHCiExpr expr =
-- with fully qualified names without imports.
`gopt_set` Opt_ImplicitImportQualified
}
+
+compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue
+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr
=====================================
libraries/base/GHC/GHCi/Helpers.hs
=====================================
@@ -0,0 +1,36 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.GHCi.Helpers
+-- Copyright : (c) The GHC Developers
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc at haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- Various helpers used by the GHCi shell.
+--
+-----------------------------------------------------------------------------
+
+module GHC.GHCi.Helpers
+ ( disableBuffering, flushAll
+ , evalWrapper
+ ) where
+
+import System.IO
+import System.Environment
+
+disableBuffering :: IO ()
+disableBuffering = do
+ hSetBuffering stdin NoBuffering
+ hSetBuffering stdout NoBuffering
+ hSetBuffering stderr NoBuffering
+
+flushAll :: IO ()
+flushAll = do
+ hFlush stdout
+ hFlush stderr
+
+evalWrapper :: String -> [String] -> IO a -> IO a
+evalWrapper progName args m =
+ withProgName progName (withArgs args m)
=====================================
libraries/base/base.cabal
=====================================
@@ -230,6 +230,7 @@ Library
GHC.Foreign
GHC.ForeignPtr
GHC.GHCi
+ GHC.GHCi.Helpers
GHC.Generics
GHC.IO
GHC.IO.Buffer
=====================================
rts/sm/GCAux.c
=====================================
@@ -114,16 +114,21 @@ isAlive(StgClosure *p)
void
revertCAFs( void )
{
- StgIndStatic *c;
+ StgIndStatic *c = revertible_caf_list;
- for (c = revertible_caf_list;
- c != (StgIndStatic *)END_OF_CAF_LIST;
- c = (StgIndStatic *)c->static_link)
- {
+ while (c != (StgIndStatic *) END_OF_CAF_LIST) {
c = (StgIndStatic *)UNTAG_STATIC_LIST_PTR(c);
+ StgIndStatic *next = (StgIndStatic *) c->static_link;
+
SET_INFO((StgClosure *)c, c->saved_info);
c->saved_info = NULL;
- // could, but not necessary: c->static_link = NULL;
+ // We must reset static_link lest the major GC finds that
+ // static_flag==3 and will consequently ignore references
+ // into code that we are trying to unload. This would result
+ // in reachable object code being unloaded prematurely.
+ // See #16842.
+ c->static_link = NULL;
+ c = next;
}
revertible_caf_list = (StgIndStatic*)END_OF_CAF_LIST;
}
=====================================
testsuite/tests/concurrent/should_run/all.T
=====================================
@@ -74,7 +74,10 @@ test('T5558',
compile_and_run, [''])
test('T5421', normal, compile_and_run, [''])
-test('T5611', when(opsys('darwin'), fragile(12751)) , compile_and_run, [''])
+test('T5611',
+ [expect_broken_for(16845, ['ghci']),
+ when(opsys('darwin'), fragile(12751))],
+ compile_and_run, [''])
test('T5238', normal, compile_and_run, [''])
test('T5866', exit_code(1), compile_and_run, [''])
=====================================
testsuite/tests/ghci.debugger/scripts/break006.stdout
=====================================
@@ -4,14 +4,14 @@ f :: Int -> a = _
x :: Int = 1
xs :: [Int] = [2,3]
xs :: [Int] = [2,3]
-f :: Int -> a = _
x :: Int = 1
+f :: Int -> a = _
_result :: [a] = _
y = (_t1::a)
y = 2
xs :: [Int] = [2,3]
-f :: Int -> Int = _
x :: Int = 1
+f :: Int -> Int = _
_result :: [Int] = _
y :: Int = 2
_t1 :: Int = 2
=====================================
testsuite/tests/ghci.debugger/scripts/break013.stdout
=====================================
@@ -3,7 +3,7 @@ _result :: (Bool, Bool, ()) = _
a :: Bool = _
b :: Bool = _
c :: () = _
-b :: Bool = _
c :: () = _
+b :: Bool = _
a :: Bool = _
_result :: (Bool, Bool, ()) = _
=====================================
testsuite/tests/ghci.debugger/scripts/hist001.stdout
=====================================
@@ -20,8 +20,8 @@ _result :: a
f :: Integer -> a
x :: Integer
xs :: [t] = []
-f :: Integer -> a = _
x :: Integer = 2
+f :: Integer -> a = _
_result :: a = _
_result = 3
Logged breakpoint at Test3.hs:2:18-31
=====================================
testsuite/tests/ghci.debugger/scripts/hist002.stdout
=====================================
@@ -20,8 +20,8 @@ _result :: a
f :: Integer -> a
x :: Integer
xs :: [t] = []
-f :: Integer -> a = _
x :: Integer = 2
+f :: Integer -> a = _
_result :: a = _
_result = 3
Logged breakpoint at Test3.hs:2:18-31
=====================================
testsuite/tests/ghci/caf_crash/A.hs
=====================================
@@ -0,0 +1,18 @@
+module A (caf, mainx, square) where
+
+import B (idd)
+
+caf :: Int
+caf = 23423
+
+mainx :: IO ()
+mainx = do
+ putStrLn $ show (caf + idd)
+ putStrLn "Hello"
+ putStrLn "World"
+
+square :: IO Int
+square = do
+ let ss = "I'm a square"
+ putStrLn $ ss
+ return $ length ss
=====================================
testsuite/tests/ghci/caf_crash/B.hs
=====================================
@@ -0,0 +1,5 @@
+module B (idd) where
+
+idd :: Int
+idd = 100000242418429
+
=====================================
testsuite/tests/ghci/caf_crash/D.hs
=====================================
@@ -0,0 +1,22 @@
+module D where
+
+import A
+
+data MyFunc = MyFunc String (IO Int)
+
+funcCaf :: [MyFunc]
+funcCaf = [MyFunc "square" square]
+
+f1 :: MyFunc -> String
+f1 (MyFunc s _) = s
+
+f2 :: MyFunc -> IO Int
+f2 (MyFunc s d) = d
+
+main :: IO ()
+main = do
+ mainx
+ putStrLn $ show $ length funcCaf
+ putStrLn $ show $ f1 $ head funcCaf
+ yay <- f2 $ head funcCaf
+ print yay
=====================================
testsuite/tests/ghci/caf_crash/all.T
=====================================
@@ -0,0 +1,6 @@
+test('caf_crash',
+ [extra_files(['A.hs', 'B.hs', 'D.hs', ]),
+ when(ghc_dynamic(), skip),
+ extra_ways(['ghci-ext']),
+ omit_ways(['ghci']), ],
+ ghci_script, ['caf_crash.script'])
=====================================
testsuite/tests/ghci/caf_crash/caf_crash.script
=====================================
@@ -0,0 +1,9 @@
+:set -fobject-code
+:l D.hs
+:set -fbyte-code
+:add *D
+main
+:l []
+System.Mem.performGC
+System.Mem.performGC
+3+4
=====================================
testsuite/tests/ghci/caf_crash/caf_crash.stdout
=====================================
@@ -0,0 +1,7 @@
+100000242441852
+Hello
+World
+1
+"square"
+I'm a square
+12
=====================================
testsuite/tests/ghci/scripts/T16563.script
=====================================
@@ -0,0 +1 @@
+putStrLn "hello world"
=====================================
testsuite/tests/ghci/scripts/T16563.stdout
=====================================
@@ -0,0 +1,2 @@
+hello world
+
=====================================
testsuite/tests/ghci/scripts/T4175.stdout
=====================================
@@ -21,9 +21,9 @@ instance Eq () -- Defined in ‘GHC.Classes’
instance Monoid () -- Defined in ‘GHC.Base’
instance Ord () -- Defined in ‘GHC.Classes’
instance Semigroup () -- Defined in ‘GHC.Base’
+instance Enum () -- Defined in ‘GHC.Enum’
instance Show () -- Defined in ‘GHC.Show’
instance Read () -- Defined in ‘GHC.Read’
-instance Enum () -- Defined in ‘GHC.Enum’
instance Bounded () -- Defined in ‘GHC.Enum’
type instance D () () = Bool -- Defined at T4175.hs:22:10
type instance D Int () = String -- Defined at T4175.hs:19:10
@@ -38,8 +38,8 @@ instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’
instance Semigroup a => Semigroup (Maybe a)
-- Defined in ‘GHC.Base’
instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
-instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’
instance MonadFail Maybe -- Defined in ‘Control.Monad.Fail’
+instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’
instance Foldable Maybe -- Defined in ‘Data.Foldable’
instance Traversable Maybe -- Defined in ‘Data.Traversable’
type instance A (Maybe a) a = a -- Defined at T4175.hs:9:15
@@ -47,11 +47,11 @@ data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’
instance [safe] C Int -- Defined at T4175.hs:18:10
instance Eq Int -- Defined in ‘GHC.Classes’
instance Ord Int -- Defined in ‘GHC.Classes’
-instance Show Int -- Defined in ‘GHC.Show’
-instance Read Int -- Defined in ‘GHC.Read’
instance Enum Int -- Defined in ‘GHC.Enum’
instance Num Int -- Defined in ‘GHC.Num’
instance Real Int -- Defined in ‘GHC.Real’
+instance Show Int -- Defined in ‘GHC.Show’
+instance Read Int -- Defined in ‘GHC.Read’
instance Bounded Int -- Defined in ‘GHC.Enum’
instance Integral Int -- Defined in ‘GHC.Real’
type instance D Int () = String -- Defined at T4175.hs:19:10
=====================================
testsuite/tests/ghci/scripts/T7627.stdout
=====================================
@@ -3,9 +3,9 @@ instance Eq () -- Defined in ‘GHC.Classes’
instance Monoid () -- Defined in ‘GHC.Base’
instance Ord () -- Defined in ‘GHC.Classes’
instance Semigroup () -- Defined in ‘GHC.Base’
+instance Enum () -- Defined in ‘GHC.Enum’
instance Show () -- Defined in ‘GHC.Show’
instance Read () -- Defined in ‘GHC.Read’
-instance Enum () -- Defined in ‘GHC.Enum’
instance Bounded () -- Defined in ‘GHC.Enum’
data (##) = (##) -- Defined in ‘GHC.Prim’
() :: ()
=====================================
testsuite/tests/ghci/scripts/T8469.stdout
=====================================
@@ -1,10 +1,10 @@
data Int = GHC.Types.I# GHC.Prim.Int# -- Defined in ‘GHC.Types’
instance Eq Int -- Defined in ‘GHC.Classes’
instance Ord Int -- Defined in ‘GHC.Classes’
-instance Show Int -- Defined in ‘GHC.Show’
-instance Read Int -- Defined in ‘GHC.Read’
instance Enum Int -- Defined in ‘GHC.Enum’
instance Num Int -- Defined in ‘GHC.Num’
instance Real Int -- Defined in ‘GHC.Real’
+instance Show Int -- Defined in ‘GHC.Show’
+instance Read Int -- Defined in ‘GHC.Read’
instance Bounded Int -- Defined in ‘GHC.Enum’
instance Integral Int -- Defined in ‘GHC.Real’
=====================================
testsuite/tests/ghci/scripts/all.T
=====================================
@@ -296,5 +296,6 @@ test('T16089', normal, ghci_script, ['T16089.script'])
test('T14828', normal, ghci_script, ['T14828.script'])
test('T16376', normal, ghci_script, ['T16376.script'])
test('T16527', normal, ghci_script, ['T16527.script'])
+test('T16563', extra_hc_opts("-clear-package-db -global-package-db"), ghci_script, ['T16563.script'])
test('T16569', normal, ghci_script, ['T16569.script'])
test('T16767', normal, ghci_script, ['T16767.script'])
=====================================
testsuite/tests/ghci/scripts/ghci011.stdout
=====================================
@@ -7,8 +7,8 @@ instance Monoid [a] -- Defined in ‘GHC.Base’
instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’
instance Semigroup [a] -- Defined in ‘GHC.Base’
instance Show a => Show [a] -- Defined in ‘GHC.Show’
-instance Read a => Read [a] -- Defined in ‘GHC.Read’
instance MonadFail [] -- Defined in ‘Control.Monad.Fail’
+instance Read a => Read [a] -- Defined in ‘GHC.Read’
instance Foldable [] -- Defined in ‘Data.Foldable’
instance Traversable [] -- Defined in ‘Data.Traversable’
data () = () -- Defined in ‘GHC.Tuple’
@@ -16,9 +16,9 @@ instance Eq () -- Defined in ‘GHC.Classes’
instance Monoid () -- Defined in ‘GHC.Base’
instance Ord () -- Defined in ‘GHC.Classes’
instance Semigroup () -- Defined in ‘GHC.Base’
+instance Enum () -- Defined in ‘GHC.Enum’
instance Show () -- Defined in ‘GHC.Show’
instance Read () -- Defined in ‘GHC.Read’
-instance Enum () -- Defined in ‘GHC.Enum’
instance Bounded () -- Defined in ‘GHC.Enum’
data (,) a b = (,) a b -- Defined in ‘GHC.Tuple’
instance Monoid a => Applicative ((,) a) -- Defined in ‘GHC.Base’
=====================================
testsuite/tests/ghci/scripts/ghci064.stdout
=====================================
@@ -9,13 +9,11 @@ instance Ord _ => Ord (Maybe _) -- Defined in ‘GHC.Maybe’
instance Semigroup _ => Semigroup (Maybe _)
-- Defined in ‘GHC.Base’
instance Show _ => Show (Maybe _) -- Defined in ‘GHC.Show’
-instance Read _ => Read (Maybe _) -- Defined in ‘GHC.Read’
instance Eq _ => Eq [_] -- Defined in ‘GHC.Classes’
instance Monoid [_] -- Defined in ‘GHC.Base’
instance Ord _ => Ord [_] -- Defined in ‘GHC.Classes’
instance Semigroup [_] -- Defined in ‘GHC.Base’
instance Show _ => Show [_] -- Defined in ‘GHC.Show’
-instance Read _ => Read [_] -- Defined in ‘GHC.Read’
instance [safe] MyShow _ => MyShow [_]
-- Defined at ghci064.hs:7:10
instance Monoid [T] -- Defined in ‘GHC.Base’
@@ -24,12 +22,8 @@ instance [safe] MyShow [T] -- Defined at ghci064.hs:7:10
instance [safe] MyShow [T] -- Defined at ghci064.hs:15:10
instance Eq Bool -- Defined in ‘GHC.Classes’
instance Ord Bool -- Defined in ‘GHC.Classes’
-instance Show Bool -- Defined in ‘GHC.Show’
-instance Read Bool -- Defined in ‘GHC.Read’
instance Enum Bool -- Defined in ‘GHC.Enum’
+instance Show Bool -- Defined in ‘GHC.Show’
instance Bounded Bool -- Defined in ‘GHC.Enum’
-instance Data.Bits.Bits Bool -- Defined in ‘Data.Bits’
-instance Data.Bits.FiniteBits Bool -- Defined in ‘Data.Bits’
-instance GHC.Arr.Ix Bool -- Defined in ‘GHC.Arr’
instance Functor ((,) Int) -- Defined in ‘GHC.Base’
instance Foldable ((,) Int) -- Defined in ‘Data.Foldable’
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/e0595d22ce5bc19699079abdb47377b5707cdbbc...1f2fff89afebb065b27eba0f6e1f89e25c1c158d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/e0595d22ce5bc19699079abdb47377b5707cdbbc...1f2fff89afebb065b27eba0f6e1f89e25c1c158d
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/20190623/66e24b39/attachment-0001.html>
More information about the ghc-commits
mailing list