diff options
author | Simon Marlow <marlowsd@gmail.com> | 2018-07-16 19:58:31 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2018-07-16 19:59:08 -0400 |
commit | 3bdf0d01ff47977830ada30ce85f174098486e23 (patch) | |
tree | a7bcd3a6842b1cc793ce990e924d157a408f93f0 | |
parent | c4b8e719effe9b420b1c5cec0194134a44b26823 (diff) | |
download | haskell-3bdf0d01ff47977830ada30ce85f174098486e23.tar.gz |
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
-rw-r--r-- | compiler/ghc.cabal.in | 10 | ||||
-rw-r--r-- | compiler/ghci/Debugger.hs | 18 | ||||
-rw-r--r-- | compiler/ghci/GHCi.hs | 14 | ||||
-rw-r--r-- | compiler/ghci/RtClosureInspect.hs | 178 | ||||
-rw-r--r-- | compiler/main/InteractiveEval.hs | 14 | ||||
-rw-r--r-- | ghc.mk | 1 | ||||
-rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs | 5 | ||||
-rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/Closures.hs | 9 | ||||
-rw-r--r-- | libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc | 4 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Message.hs | 35 | ||||
-rw-r--r-- | libraries/ghci/GHCi/Run.hs | 7 | ||||
-rw-r--r-- | libraries/integer-gmp/src/GHC/Integer/Type.hs | 5 | ||||
-rw-r--r-- | rts/Heap.c | 11 | ||||
-rw-r--r-- | testsuite/tests/ghci.debugger/scripts/all.T | 8 |
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 @@ -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))], |