Commit 3bdf0d01 authored by Simon Marlow's avatar Simon Marlow Committed by Ben Gamari

Support the GHCi debugger with -fexternal-interpreter

* All the tests in tests/ghci.debugger now pass with
  -fexternal-interpreter. These tests are now run with the ghci-ext way
  in addition to the normal way so we won't break it in the future.

* I removed all the unsafeCoerce# calls from RtClosureInspect. Yay!

The main changes are:

* New messages: GetClosure and Seq.  GetClosure is a remote interface to
  GHC.Exts.Heap.getClosureData, which required Binary instances for
  various datatypes. Fortunately this wasn't too painful thanks to
  DeriveGeneric.

* No cheating by unsafeCoercing values when printing them. Now we have
  to turn the Closure representation back into the native representation
  when printing Int, Float, Double, Integer and Char. Of these, Integer
  was the most painful - we now have a dependency on integer-gmp due to
  needing access to the representation.

* Fixed a bug in rts/Heap.c - it was bogusly returning stack content as
  pointers for an AP_STACK closure.

Test Plan:
* `cd testsuite/tests/ghci.debugger && make`
* validate

Reviewers: bgamari, patrickdoc, nomeata, angerman, hvr, erikd, goldfire

Subscribers: alpmestan, snowleopard, rwbarton, thomie, carter

GHC Trac Issues: #13184

Differential Revision: https://phabricator.haskell.org/D4955
parent c4b8e719
......@@ -45,6 +45,11 @@ Flag terminfo
Default: True
Manual: True
Flag integer-gmp
Description: Use integer-gmp
Manual: True
Default: False
Library
Default-Language: Haskell2010
Exposed: False
......@@ -84,6 +89,11 @@ Library
CPP-Options: -DGHCI
Include-Dirs: ../rts/dist/build @FFIIncludeDir@
-- gmp internals are used by the GHCi debugger if available
if flag(integer-gmp)
CPP-Options: -DINTEGER_GMP
build-depends: integer-gmp >= 1.0.2
Other-Extensions:
BangPatterns
CPP
......
......@@ -44,8 +44,6 @@ import Data.List
import Data.Maybe
import Data.IORef
import GHC.Exts
-------------------------------------
-- | The :print & friends commands
-------------------------------------
......@@ -120,11 +118,10 @@ bindSuspensions t = do
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t
let (names, tys, hvals) = unzip3 stuff
let (names, tys, fhvs) = unzip3 stuff
let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids
fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
liftIO $ extendLinkEnv (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic }
return t'
......@@ -132,7 +129,7 @@ bindSuspensions t = do
-- Processing suspensions. Give names and recopilate info
nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
-> TermFold (IO (Term, [(Name,Type,HValue)]))
-> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
{
fSuspension = doSuspension hsc_env freeNames
......@@ -163,7 +160,7 @@ showTerm term = do
then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
else cPprTerm cPprTermBase term
where
cPprShowable prec t@Term{ty=ty, val=val} =
cPprShowable prec t@Term{ty=ty, val=fhv} =
if not (isFullyEvaluatedTerm t)
then return Nothing
else do
......@@ -176,13 +173,14 @@ showTerm term = do
-- does this still do what it is intended to do
-- with the changed error handling and logging?
let noop_log _ _ _ _ _ _ = return ()
expr = "show " ++ showPpr dflags bname
expr = "Prelude.return (Prelude.show " ++
showPpr dflags bname ++
") :: Prelude.IO Prelude.String"
_ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
txt_ <- withExtendedLinkEnv [(bname, fhv)]
(GHC.compileExpr expr)
(GHC.compileExprRemote expr)
let myprec = 10 -- application precedence. TODO Infix constructors
let txt = unsafeCoerce# txt_ :: [a]
txt <- liftIO $ evalString hsc_env txt_
if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt)
......
......@@ -21,6 +21,8 @@ module GHCi
, enableBreakpoint
, breakpointStatus
, getBreakpointVar
, getClosure
, seqHValue
-- * The object-code linker
, initObjLinker
......@@ -77,6 +79,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB
import Data.IORef
import Foreign hiding (void)
import GHC.Exts.Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit
import Data.Maybe
......@@ -350,6 +353,17 @@ getBreakpointVar hsc_env ref ix =
mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
mapM (mkFinalizedHValue hsc_env) mb
getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)
getClosure hsc_env ref =
withForeignRef ref $ \hval -> do
mb <- iservCmd hsc_env (GetClosure hval)
mapM (mkFinalizedHValue hsc_env) mb
seqHValue :: HscEnv -> ForeignHValue -> IO ()
seqHValue hsc_env ref =
withForeignRef ref $ \hval ->
iservCmd hsc_env (Seq hval) >>= fromEvalResult
-- -----------------------------------------------------------------------------
-- Interface to the object-code linker
......
This diff is collapsed.
......@@ -990,20 +990,22 @@ moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->
-- RTTI primitives
obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term
obtainTermFromVal hsc_env bound force ty x =
cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
obtainTermFromVal hsc_env bound force ty x
| gopt Opt_ExternalInterpreter (hsc_dflags hsc_env)
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
| otherwise
= cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
let dflags = hsc_dflags hsc_env
hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
hv <- Linker.getHValue hsc_env (varName id)
cvObtainTerm hsc_env bound force (idType id) hv
-- Uses RTTI to reconstruct the type of an Id, making it less polymorphic
reconstructType :: HscEnv -> Int -> Id -> IO (Maybe Type)
reconstructType hsc_env bound id = do
let dflags = hsc_dflags hsc_env
hv <- Linker.getHValue hsc_env (varName id) >>= wormhole dflags
hv <- Linker.getHValue hsc_env (varName id)
cvReconstructType hsc_env bound (idType id) hv
mkRuntimeUnkTyVar :: Name -> Kind -> TyVar
......
......@@ -616,6 +616,7 @@ libraries/ghc-prim_dist-install_EXTRA_HADDOCK_SRCS = libraries/ghc-prim/dist-ins
ifneq "$(CLEANING)" "YES"
ifeq "$(INTEGER_LIBRARY)" "integer-gmp"
libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-gmp
compiler_stage2_CONFIGURE_OPTS += --flags=integer-gmp
else ifeq "$(INTEGER_LIBRARY)" "integer-simple"
libraries/base_dist-install_CONFIGURE_OPTS += --flags=integer-simple
else
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
module GHC.Exts.Heap.ClosureTypes
( ClosureType(..)
, closureTypeHeaderSize
) where
import GHC.Generics
{- ---------------------------------------------
-- Enum representing closure types
-- This is a mirror of:
......@@ -77,7 +80,7 @@ data ClosureType
| SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
| COMPACT_NFDATA
| N_CLOSURE_TYPES
deriving (Enum, Eq, Ord, Show)
deriving (Enum, Eq, Ord, Show, Generic)
-- | Return the size of the closures header in words
closureTypeHeaderSize :: ClosureType -> Int
......
......@@ -4,6 +4,8 @@
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UnliftedFFITypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
module GHC.Exts.Heap.Closures (
-- * Closures
......@@ -35,6 +37,7 @@ import Data.Bits
import Data.Int
import Data.Word
import GHC.Exts
import GHC.Generics
import Numeric
------------------------------------------------------------------------
......@@ -222,7 +225,7 @@ data GenClosure b
-- | A @MutVar#@
| MutVarClosure
{ info :: !StgInfoTable
, var :: !b -- ^ Pointer to closure
, var :: !b -- ^ Pointer to contents
}
-- | An STM blocking queue.
......@@ -285,7 +288,7 @@ data GenClosure b
| UnsupportedClosure
{ info :: !StgInfoTable
}
deriving (Show)
deriving (Show, Generic, Functor, Foldable, Traversable)
data PrimType
......@@ -296,7 +299,7 @@ data PrimType
| PAddr
| PFloat
| PDouble
deriving (Eq, Show)
deriving (Eq, Show, Generic)
-- | For generic code, this function returns all referenced closures.
allClosures :: GenClosure b -> [b]
......
{-# LANGUAGE DeriveGeneric #-}
module GHC.Exts.Heap.InfoTable.Types
( StgInfoTable(..)
, EntryFunPtr
......@@ -7,6 +8,7 @@ module GHC.Exts.Heap.InfoTable.Types
#include "Rts.h"
import GHC.Generics
import GHC.Exts.Heap.ClosureTypes
import Foreign
......@@ -34,4 +36,4 @@ data StgInfoTable = StgInfoTable {
tipe :: ClosureType,
srtlen :: HalfWord,
code :: Maybe ItblCodes -- Just <=> ghciTablesNextToCode
} deriving (Show)
} deriving (Show, Generic)
......@@ -43,6 +43,7 @@ import Data.Dynamic
import Data.Typeable (TypeRep)
import Data.IORef
import Data.Map (Map)
import Foreign
import GHC.Generics
import GHC.Stack.CCS
import qualified Language.Haskell.TH as TH
......@@ -202,6 +203,18 @@ data Message a where
-> [RemoteRef (TH.Q ())]
-> Message (QResult ())
-- | Remote interface to GHC.Exts.Heap.getClosureData. This is used by
-- the GHCi debugger to inspect values in the heap for :print and
-- type reconstruction.
GetClosure
:: HValueRef
-> Message (GenClosure HValueRef)
-- | Evaluate something. This is used to support :force in GHCi.
Seq
:: HValueRef
-> Message (EvalResult ())
deriving instance Show (Message a)
......@@ -410,6 +423,22 @@ data QState = QState
}
instance Show QState where show _ = "<QState>"
-- Orphan instances of Binary for Ptr / FunPtr by conversion to Word64.
-- This is to support Binary StgInfoTable which includes these.
instance Binary (Ptr a) where
put p = put (fromIntegral (ptrToWordPtr p) :: Word64)
get = (wordPtrToPtr . fromIntegral) <$> (get :: Get Word64)
instance Binary (FunPtr a) where
put = put . castFunPtrToPtr
get = castPtrToFunPtr <$> get
-- Binary instances to support the GetClosure message
instance Binary StgInfoTable
instance Binary ClosureType
instance Binary PrimType
instance Binary a => Binary (GenClosure a)
data Msg = forall a . (Binary a, Show a) => Msg (Message a)
getMessage :: Get Msg
......@@ -450,7 +479,9 @@ getMessage = do
31 -> Msg <$> return StartTH
32 -> Msg <$> (RunModFinalizers <$> get <*> get)
33 -> Msg <$> (AddSptEntry <$> get <*> get)
_ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
34 -> Msg <$> (RunTH <$> get <*> get <*> get <*> get)
35 -> Msg <$> (GetClosure <$> get)
_ -> Msg <$> (Seq <$> get)
putMessage :: Message a -> Put
putMessage m = case m of
......@@ -489,6 +520,8 @@ putMessage m = case m of
RunModFinalizers a b -> putWord8 32 >> put a >> put b
AddSptEntry a b -> putWord8 33 >> put a >> put b
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
-- -----------------------------------------------------------------------------
-- Reading/writing messages
......
......@@ -31,8 +31,9 @@ import Data.Binary.Get
import Data.ByteString (ByteString)
import qualified Data.ByteString.Unsafe as B
import GHC.Exts
import GHC.Exts.Heap
import GHC.Stack
import Foreign
import Foreign hiding (void)
import Foreign.C
import GHC.Conc.Sync
import GHC.IO hiding ( bracket )
......@@ -86,6 +87,10 @@ run m = case m of
MkConInfoTable ptrs nptrs tag ptrtag desc ->
toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc
StartTH -> startTH
GetClosure ref -> do
clos <- getClosureData =<< localRef ref
mapM (\(Box x) -> mkRemoteRef (HValue x)) clos
Seq ref -> tryEval (void $ evaluate =<< localRef ref)
_other -> error "GHCi.Run.run"
evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])
......
......@@ -150,6 +150,11 @@ data Integer = S# !Int#
| Jn# {-# UNPACK #-} !BigNat
-- ^ iff value in @]-inf, minBound::'Int'[@ range
-- NOTE: the above representation is baked into the GHCi debugger in
-- compiler/ghci/RtClosureInspect.hs. If you change it here, fixes
-- will be required over there too. Tests for this are in
-- testsuite/tests/ghci.debugger.
-- TODO: experiment with different constructor-ordering
instance Eq Integer where
......
......@@ -162,9 +162,14 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
case AP_STACK:
ptrs[nptrs++] = ((StgAP_STACK *)closure)->fun;
for (i = 0; i < ((StgAP_STACK *)closure)->size; ++i) {
ptrs[nptrs++] = ((StgAP_STACK *)closure)->payload[i];
}
/*
The payload is a stack, which consists of a mixture of pointers
and non-pointers. We can't simply pretend it's all pointers,
because that will cause crashes in the GC later. We could
traverse the stack and extract pointers and non-pointers, but that
would be complicated, so let's just ignore the payload for now.
See #15375.
*/
break;
case BCO:
......
setTestOpts([extra_run_opts('-ignore-dot-ghci'),
extra_ways(['ghci-ext']), # test with -fexternal-interpreter
normalise_slashes])
test('print001', normal, ghci_script, ['print001.script'])
......@@ -19,7 +20,12 @@ test('print016', extra_files(['../Test.hs']), ghci_script, ['print016.script'])
test('print017', extra_files(['../Test.hs']), ghci_script, ['print017.script'])
test('print018', extra_files(['../Test.hs']), ghci_script, ['print018.script'])
test('print019', extra_files(['../Test.hs']), ghci_script, ['print019.script'])
test('print020', extra_files(['../HappyTest.hs']), ghci_script, ['print020.script'])
# The ghci-ext way emits messages in a slightly different order due to
# printing from two processes, so let's just skip it.
test('print020', [extra_files(['../HappyTest.hs']),
omit_ways(['ghci-ext'])], ghci_script, ['print020.script'])
test('print021', normal, ghci_script, ['print021.script'])
test('print022',
[when(arch('powerpc64'), expect_broken(14455))],
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment