summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghc.cabal.in10
-rw-r--r--compiler/ghci/Debugger.hs18
-rw-r--r--compiler/ghci/GHCi.hs14
-rw-r--r--compiler/ghci/RtClosureInspect.hs178
-rw-r--r--compiler/main/InteractiveEval.hs14
-rw-r--r--ghc.mk1
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs5
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/Closures.hs9
-rw-r--r--libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc4
-rw-r--r--libraries/ghci/GHCi/Message.hs35
-rw-r--r--libraries/ghci/GHCi/Run.hs7
-rw-r--r--libraries/integer-gmp/src/GHC/Integer/Type.hs5
-rw-r--r--rts/Heap.c11
-rw-r--r--testsuite/tests/ghci.debugger/scripts/all.T8
14 files changed, 241 insertions, 78 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index d4a1dc3c6e..5c9d88f8cc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -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
diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 0db74cb5cb..5942715c12 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -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)
diff --git a/compiler/ghci/GHCi.hs b/compiler/ghci/GHCi.hs
index 472f0857cb..579053999f 100644
--- a/compiler/ghci/GHCi.hs
+++ b/compiler/ghci/GHCi.hs
@@ -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
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index d540983139..b7614078e6 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -27,6 +27,7 @@ module RtClosureInspect(
import GhcPrelude
+import GHCi
import GHCi.RemoteTypes
import HscTypes
@@ -62,8 +63,12 @@ import GHC.IO ( IO(..) )
import SMRep ( roundUpTo )
import Control.Monad
+import Data.Array.Base
import Data.Maybe
import Data.List
+#if defined(INTEGER_GMP)
+import GHC.Integer.GMP.Internals
+#endif
import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..))
import Foreign
@@ -79,7 +84,7 @@ data Term = Term { ty :: RttiType
-- Carries a text representation if the datacon is
-- not exported by the .hi file, which is the case
-- for private constructors in -O0 compiled libraries
- , val :: HValue
+ , val :: ForeignHValue
, subTerms :: [Term] }
| Prim { ty :: RttiType
@@ -87,7 +92,7 @@ data Term = Term { ty :: RttiType
| Suspension { ctype :: ClosureType
, ty :: RttiType
- , val :: HValue
+ , val :: ForeignHValue
, bound_to :: Maybe Name -- Useful for printing
}
| NewtypeWrap{ -- At runtime there are no newtypes, and hence no
@@ -126,22 +131,22 @@ isThunk APStackClosure{} = True
isThunk _ = False
-- Lookup the name in a constructor closure
-constrClosToName :: HscEnv -> Closure -> IO (Either String Name)
+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)
constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
let occName = mkOccName OccName.dataName occ
modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
Right `fmap` lookupOrigIO hsc_env modName occName
constrClosToName _hsc_env clos =
- return (Left ("conClosToName: Expected ConstrClosure, got " ++ show clos))
+ return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))
-----------------------------------
-- * Traversals for Terms
-----------------------------------
-type TermProcessor a b = RttiType -> Either String DataCon -> HValue -> [a] -> b
+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b
data TermFold a = TermFold { fTerm :: TermProcessor a a
, fPrim :: RttiType -> [Word] -> a
- , fSuspension :: ClosureType -> RttiType -> HValue
+ , fSuspension :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> a
, fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a
@@ -152,7 +157,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a
data TermFoldM m a =
TermFoldM {fTermM :: TermProcessor a (m a)
, fPrimM :: RttiType -> [Word] -> m a
- , fSuspensionM :: ClosureType -> RttiType -> HValue
+ , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> m a
, fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a
@@ -317,19 +322,26 @@ cPprTermBase y =
. subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
ppr_list
- , ifTerm (isTyCon intTyCon . ty) ppr_int
- , ifTerm (isTyCon charTyCon . ty) ppr_char
- , ifTerm (isTyCon floatTyCon . ty) ppr_float
- , ifTerm (isTyCon doubleTyCon . ty) ppr_double
- , ifTerm (isIntegerTy . ty) ppr_integer
+ , ifTerm' (isTyCon intTyCon . ty) ppr_int
+ , ifTerm' (isTyCon charTyCon . ty) ppr_char
+ , ifTerm' (isTyCon floatTyCon . ty) ppr_float
+ , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
+#if defined(INTEGER_GMP)
+ , ifTerm' (isIntegerTy . ty) ppr_integer
+#endif
]
where
ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc)
- ifTerm pred f prec t@Term{}
- | pred t = Just `liftM` f prec t
- ifTerm _ _ _ _ = return Nothing
+ ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
+
+ ifTerm' :: (Term -> Bool)
+ -> (Precedence -> Term -> m (Maybe SDoc))
+ -> Precedence -> Term -> m (Maybe SDoc)
+ ifTerm' pred f prec t@Term{}
+ | pred t = f prec t
+ ifTerm' _ _ _ _ = return Nothing
isTupleTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty
@@ -343,13 +355,67 @@ cPprTermBase y =
(tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName)
- ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer
- :: Precedence -> Term -> m SDoc
- ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v)))
- ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
- ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v)))
- ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
- ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+ ppr_int, ppr_char, ppr_float, ppr_double
+ :: Precedence -> Term -> m (Maybe SDoc)
+ ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
+ return (Just (Ppr.int (fromIntegral w)))
+ ppr_int _ _ = return Nothing
+
+ ppr_char _ Term{subTerms=[Prim{valRaw=[w]}]} =
+ return (Just (Ppr.pprHsChar (chr (fromIntegral w))))
+ ppr_char _ _ = return Nothing
+
+ ppr_float _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> poke p w >> peek (castPtr p)
+ return (Just (Ppr.float f))
+ ppr_float _ _ = return Nothing
+
+ ppr_double _ Term{subTerms=[Prim{valRaw=[w]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> poke p w >> peek (castPtr p)
+ return (Just (Ppr.double f))
+ -- let's assume that if we get two words, we're on a 32-bit
+ -- machine. There's no good way to get a DynFlags to check the word
+ -- size here.
+ ppr_double _ Term{subTerms=[Prim{valRaw=[w1,w2]}]} = do
+ let f = unsafeDupablePerformIO $
+ alloca $ \p -> do
+ poke p (fromIntegral w1 :: Word32)
+ poke (p `plusPtr` 4) (fromIntegral w2 :: Word32)
+ peek (castPtr p)
+ return (Just (Ppr.double f))
+ ppr_double _ _ = return Nothing
+
+ ppr_integer :: Precedence -> Term -> m (Maybe SDoc)
+#if defined(INTEGER_GMP)
+ -- Reconstructing Integers is a bit of a pain. This depends deeply
+ -- on the integer-gmp representation, so it'll break if that
+ -- changes (but there are several tests in
+ -- tests/ghci.debugger/scripts that will tell us if this is wrong).
+ --
+ -- data Integer
+ -- = S# Int#
+ -- | Jp# {-# UNPACK #-} !BigNat
+ -- | Jn# {-# UNPACK #-} !BigNat
+ --
+ -- data BigNat = BN# ByteArray#
+ --
+ ppr_integer _ Term{subTerms=[Prim{valRaw=[W# w]}]} =
+ return (Just (Ppr.integer (S# (word2Int# w))))
+ ppr_integer _ Term{dc=Right con,
+ subTerms=[Term{subTerms=[Prim{valRaw=ws}]}]} = do
+ -- We don't need to worry about sizes that are not an integral
+ -- number of words, because luckily GMP uses arrays of words
+ -- (see GMP_LIMB_SHIFT).
+ let
+ !(UArray _ _ _ arr#) = listArray (0,length ws-1) ws
+ constr
+ | "Jp#" <- occNameString (nameOccName (dataConName con)) = Jp#
+ | otherwise = Jn#
+ return (Just (Ppr.integer (constr (BN# arr#))))
+#endif
+ ppr_integer _ _ = return Nothing
--Note pprinting of list terms is not lazy
ppr_list :: Precedence -> Term -> m SDoc
@@ -357,10 +423,12 @@ cPprTermBase y =
let elems = h : getListTerms t
isConsLast = not (termType (last elems) `eqType` termType h)
is_string = all (isCharTy . ty) elems
+ chars = [ chr (fromIntegral w)
+ | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
print_elems <- mapM (y cons_prec) elems
if is_string
- then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+ then return (Ppr.doubleQuotes (Ppr.text chars))
else if isConsLast
then return $ cparen (p >= cons_prec)
$ pprDeeperList fsep
@@ -553,7 +621,7 @@ cvObtainTerm
-> Int -- ^ How many times to recurse for subterms
-> Bool -- ^ Force thunks
-> RttiType -- ^ Type of the object to reconstruct
- -> HValue -- ^ Object to reconstruct
+ -> ForeignHValue -- ^ Object to reconstruct
-> IO Term
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- we quantify existential tyvars as universal,
@@ -599,7 +667,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Type obtained: " <> ppr (termType term))
return term
where
- go :: Int -> Type -> Type -> HValue -> TcM Term
+ go :: Int -> Type -> Type -> ForeignHValue -> TcM Term
-- I believe that my_ty should not have any enclosing
-- foralls, nor any free RuntimeUnk skolems;
-- that is partly what the quantifyType stuff achieved
@@ -609,29 +677,31 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps")
- clos <- trIO $ getClosureData a
+ clos <- trIO $ GHCi.getClosure hsc_env a
return (Suspension (tipe (info clos)) my_ty a Nothing)
go !max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv
- clos <- trIO $ getClosureData a
+ clos <- trIO $ GHCi.getClosure hsc_env a
case clos of
-- Thunks we may want to force
- t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >>
- seq a (go (pred max_depth) my_ty old_ty a)
+ t | isThunk t && force -> do
+ traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))
+ liftIO $ GHCi.seqHValue hsc_env a
+ go (pred max_depth) my_ty old_ty a
-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we
-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
-- showing '_' which is what we want.
BlackholeClosure{indirectee=ind} -> do
traceTR (text "Following a BLACKHOLE")
- (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
+ go max_depth my_ty old_ty ind
-- We always follow indirections
IndClosure{indirectee=ind} -> do
traceTR (text "Following an indirection" )
- (\(Box x) -> go max_depth my_ty old_ty (HValue x)) ind
+ go max_depth my_ty old_ty ind
-- We also follow references
- MutVarClosure{}
+ MutVarClosure{var=contents}
| Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
-> do
-- Deal with the MutVar# primitive
@@ -640,7 +710,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- MutVar# :: contents_ty -> MutVar# s contents_ty
traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind
- contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
ASSERT(isUnliftedType my_ty) return ()
(mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
contents_ty (mkTyConApp tycon [world,contents_ty])
@@ -649,8 +718,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
return (RefWrap my_ty x)
-- The interesting case
- ConstrClosure{ptrArgs=pArgs} -> do
- traceTR (text "entering a constructor " <>
+ ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
+ traceTR (text "entering a constructor " <> ppr dArgs <+>
if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty)
@@ -667,8 +736,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
tag = showPpr dflags dcname
vars <- replicateM (length pArgs)
(newVar liftedTypeKind)
- subTerms <- sequence $ zipWith (\(Box x) tv ->
- go (pred max_depth) tv tv (HValue x)) pArgs vars
+ subTerms <- sequence $ zipWith (\x tv ->
+ go (pred max_depth) tv tv x) pArgs vars
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do
traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty))
@@ -676,9 +745,17 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms)
+ -- This is to support printing of Integers. It's not a general
+ -- mechanism by any means; in particular we lose the size in
+ -- bytes of the array.
+ ArrWordsClosure{bytes=b, arrWords=ws} -> do
+ traceTR (text "ByteArray# closure, size " <> ppr b)
+ return (Term my_ty (Left "ByteArray#") a [Prim my_ty ws])
+
-- The otherwise case: can be a Thunk,AP,PAP,etc.
_ -> do
- traceTR (text "Unknown closure:" <+> text (show clos))
+ traceTR (text "Unknown closure:" <+>
+ text (show (fmap (const ()) clos)))
return (Suspension (tipe (info clos)) my_ty a Nothing)
-- insert NewtypeWraps around newtypes
@@ -698,8 +775,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
| otherwise = Suspension ct ty hval n
-extractSubTerms :: (Type -> HValue -> TcM Term)
- -> Closure -> [Type] -> TcM [Term]
+extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
+ -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
extractSubTerms recurse clos = liftM thdOf3 . go 0 0
where
array = dataArgs clos
@@ -733,7 +810,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
go_rep ptr_i arr_i ty rep
| isGcPtrRep rep = do
- t <- (\(Box x) -> recurse ty (HValue x)) $ (ptrArgs clos)!!ptr_i
+ t <- recurse ty $ (ptrArgs clos)!!ptr_i
return (ptr_i + 1, arr_i, t)
| otherwise = do
-- This is a bit involved since we allow packing multiple fields
@@ -805,7 +882,7 @@ cvReconstructType
:: HscEnv
-> Int -- ^ How many times to recurse for subterms
-> GhciType -- ^ Type to refine
- -> HValue -- ^ Refine the type using this value
+ -> ForeignHValue -- ^ Refine the type using this value
-> IO (Maybe Type)
cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI started with initial type " <> ppr old_ty)
@@ -845,15 +922,14 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
-- returns unification tasks,since we are going to want a breadth-first search
- go :: Type -> HValue -> TR [(Type, HValue)]
+ go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]
go my_ty a = do
traceTR (text "go" <+> ppr my_ty)
- clos <- trIO $ getClosureData a
+ clos <- trIO $ GHCi.getClosure hsc_env a
case clos of
- BlackholeClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
- IndClosure{indirectee=ind} -> (\(Box x) -> go my_ty (HValue x)) ind
- MutVarClosure{} -> do
- contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
+ BlackholeClosure{indirectee=ind} -> go my_ty ind
+ IndClosure{indirectee=ind} -> go my_ty ind
+ MutVarClosure{var=contents} -> do
tv' <- newVar liftedTypeKind
world <- newVar liftedTypeKind
addConstraint my_ty (mkTyConApp mutVarPrimTyCon [world,tv'])
@@ -864,15 +940,15 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
- forM pArgs $ \(Box x) -> do
+ forM pArgs $ \x -> do
tv <- newVar liftedTypeKind
- return (tv, HValue x)
+ return (tv, x)
Just dc -> do
arg_tys <- getDataConArgTys dc my_ty
(_, itys) <- findPtrTyss 0 arg_tys
traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
- return $ zipWith (\(_,ty) (Box x) -> (ty, HValue x)) itys pArgs
+ return $ zipWith (\(_,ty) x -> (ty, x)) itys pArgs
_ -> return []
findPtrTys :: Int -- Current pointer index
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 3f2309e7f5..bec52e6001 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -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
diff --git a/ghc.mk b/ghc.mk
index eed172e48f..e0d5837a26 100644
--- a/ghc.mk
+++ b/ghc.mk
@@ -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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
index 7cd85fe99e..677e3b64e7 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
@@ -1,10 +1,13 @@
{-# 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
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
index 09a94a0f3f..bdfac8bf8b 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
+++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
@@ -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]
diff --git a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
index d8666d6b1d..0ba535d039 100644
--- a/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
+++ b/libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc
@@ -1,3 +1,4 @@
+{-# 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)
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 3f0bad9888..9b6740cc51 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -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
diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs
index 2988ec202a..8ec7659abe 100644
--- a/libraries/ghci/GHCi/Run.hs
+++ b/libraries/ghci/GHCi/Run.hs
@@ -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])
diff --git a/libraries/integer-gmp/src/GHC/Integer/Type.hs b/libraries/integer-gmp/src/GHC/Integer/Type.hs
index 9636b9f443..3434df29c4 100644
--- a/libraries/integer-gmp/src/GHC/Integer/Type.hs
+++ b/libraries/integer-gmp/src/GHC/Integer/Type.hs
@@ -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
diff --git a/rts/Heap.c b/rts/Heap.c
index 7ab628d2da..dfd32aff0c 100644
--- a/rts/Heap.c
+++ b/rts/Heap.c
@@ -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:
diff --git a/testsuite/tests/ghci.debugger/scripts/all.T b/testsuite/tests/ghci.debugger/scripts/all.T
index f2e2658d49..496c637fc6 100644
--- a/testsuite/tests/ghci.debugger/scripts/all.T
+++ b/testsuite/tests/ghci.debugger/scripts/all.T
@@ -1,4 +1,5 @@
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))],
View Lorry Controller Status