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 ...@@ -45,6 +45,11 @@ Flag terminfo
Default: True Default: True
Manual: True Manual: True
Flag integer-gmp
Description: Use integer-gmp
Manual: True
Default: False
Library Library
Default-Language: Haskell2010 Default-Language: Haskell2010
Exposed: False Exposed: False
...@@ -84,6 +89,11 @@ Library ...@@ -84,6 +89,11 @@ Library
CPP-Options: -DGHCI CPP-Options: -DGHCI
Include-Dirs: ../rts/dist/build @FFIIncludeDir@ 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: Other-Extensions:
BangPatterns BangPatterns
CPP CPP
......
...@@ -44,8 +44,6 @@ import Data.List ...@@ -44,8 +44,6 @@ import Data.List
import Data.Maybe import Data.Maybe
import Data.IORef import Data.IORef
import GHC.Exts
------------------------------------- -------------------------------------
-- | The :print & friends commands -- | The :print & friends commands
------------------------------------- -------------------------------------
...@@ -120,11 +118,10 @@ bindSuspensions t = do ...@@ -120,11 +118,10 @@ bindSuspensions t = do
availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames availNames = map ((prefix++) . show) [(1::Int)..] \\ alreadyUsedNames
availNames_var <- liftIO $ newIORef availNames availNames_var <- liftIO $ newIORef availNames
(t', stuff) <- liftIO $ foldTerm (nameSuspensionsAndGetInfos hsc_env availNames_var) t (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 let ids = [ mkVanillaGlobal name ty
| (name,ty) <- zip names tys] | (name,ty) <- zip names tys]
new_ic = extendInteractiveContextWithIds ictxt ids new_ic = extendInteractiveContextWithIds ictxt ids
fhvs <- liftIO $ mapM (mkFinalizedHValue hsc_env <=< mkRemoteRef) hvals
liftIO $ extendLinkEnv (zip names fhvs) liftIO $ extendLinkEnv (zip names fhvs)
setSession hsc_env {hsc_IC = new_ic } setSession hsc_env {hsc_IC = new_ic }
return t' return t'
...@@ -132,7 +129,7 @@ bindSuspensions t = do ...@@ -132,7 +129,7 @@ bindSuspensions t = do
-- Processing suspensions. Give names and recopilate info -- Processing suspensions. Give names and recopilate info
nameSuspensionsAndGetInfos :: HscEnv -> IORef [String] nameSuspensionsAndGetInfos :: HscEnv -> IORef [String]
-> TermFold (IO (Term, [(Name,Type,HValue)])) -> TermFold (IO (Term, [(Name,Type,ForeignHValue)]))
nameSuspensionsAndGetInfos hsc_env freeNames = TermFold nameSuspensionsAndGetInfos hsc_env freeNames = TermFold
{ {
fSuspension = doSuspension hsc_env freeNames fSuspension = doSuspension hsc_env freeNames
...@@ -163,7 +160,7 @@ showTerm term = do ...@@ -163,7 +160,7 @@ showTerm term = do
then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term then cPprTerm (liftM2 (++) (\_y->[cPprShowable]) cPprTermBase) term
else cPprTerm cPprTermBase term else cPprTerm cPprTermBase term
where where
cPprShowable prec t@Term{ty=ty, val=val} = cPprShowable prec t@Term{ty=ty, val=fhv} =
if not (isFullyEvaluatedTerm t) if not (isFullyEvaluatedTerm t)
then return Nothing then return Nothing
else do else do
...@@ -176,13 +173,14 @@ showTerm term = do ...@@ -176,13 +173,14 @@ showTerm term = do
-- does this still do what it is intended to do -- does this still do what it is intended to do
-- with the changed error handling and logging? -- with the changed error handling and logging?
let noop_log _ _ _ _ _ _ = return () 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} _ <- GHC.setSessionDynFlags dflags{log_action=noop_log}
fhv <- liftIO $ mkFinalizedHValue hsc_env =<< mkRemoteRef val
txt_ <- withExtendedLinkEnv [(bname, fhv)] txt_ <- withExtendedLinkEnv [(bname, fhv)]
(GHC.compileExpr expr) (GHC.compileExprRemote expr)
let myprec = 10 -- application precedence. TODO Infix constructors let myprec = 10 -- application precedence. TODO Infix constructors
let txt = unsafeCoerce# txt_ :: [a] txt <- liftIO $ evalString hsc_env txt_
if not (null txt) then if not (null txt) then
return $ Just $ cparen (prec >= myprec && needsParens txt) return $ Just $ cparen (prec >= myprec && needsParens txt)
(text txt) (text txt)
......
...@@ -21,6 +21,8 @@ module GHCi ...@@ -21,6 +21,8 @@ module GHCi
, enableBreakpoint , enableBreakpoint
, breakpointStatus , breakpointStatus
, getBreakpointVar , getBreakpointVar
, getClosure
, seqHValue
-- * The object-code linker -- * The object-code linker
, initObjLinker , initObjLinker
...@@ -77,6 +79,7 @@ import Data.ByteString (ByteString) ...@@ -77,6 +79,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as LB import qualified Data.ByteString.Lazy as LB
import Data.IORef import Data.IORef
import Foreign hiding (void) import Foreign hiding (void)
import GHC.Exts.Heap
import GHC.Stack.CCS (CostCentre,CostCentreStack) import GHC.Stack.CCS (CostCentre,CostCentreStack)
import System.Exit import System.Exit
import Data.Maybe import Data.Maybe
...@@ -350,6 +353,17 @@ getBreakpointVar hsc_env ref ix = ...@@ -350,6 +353,17 @@ getBreakpointVar hsc_env ref ix =
mb <- iservCmd hsc_env (GetBreakpointVar apStack ix) mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)
mapM (mkFinalizedHValue hsc_env) mb 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 -- Interface to the object-code linker
......
...@@ -27,6 +27,7 @@ module RtClosureInspect( ...@@ -27,6 +27,7 @@ module RtClosureInspect(
import GhcPrelude import GhcPrelude
import GHCi
import GHCi.RemoteTypes import GHCi.RemoteTypes
import HscTypes import HscTypes
...@@ -62,8 +63,12 @@ import GHC.IO ( IO(..) ) ...@@ -62,8 +63,12 @@ import GHC.IO ( IO(..) )
import SMRep ( roundUpTo ) import SMRep ( roundUpTo )
import Control.Monad import Control.Monad
import Data.Array.Base
import Data.Maybe import Data.Maybe
import Data.List import Data.List
#if defined(INTEGER_GMP)
import GHC.Integer.GMP.Internals
#endif
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Sequence (viewl, ViewL(..)) import Data.Sequence (viewl, ViewL(..))
import Foreign import Foreign
...@@ -79,7 +84,7 @@ data Term = Term { ty :: RttiType ...@@ -79,7 +84,7 @@ data Term = Term { ty :: RttiType
-- Carries a text representation if the datacon is -- Carries a text representation if the datacon is
-- not exported by the .hi file, which is the case -- not exported by the .hi file, which is the case
-- for private constructors in -O0 compiled libraries -- for private constructors in -O0 compiled libraries
, val :: HValue , val :: ForeignHValue
, subTerms :: [Term] } , subTerms :: [Term] }
| Prim { ty :: RttiType | Prim { ty :: RttiType
...@@ -87,7 +92,7 @@ data Term = Term { ty :: RttiType ...@@ -87,7 +92,7 @@ data Term = Term { ty :: RttiType
| Suspension { ctype :: ClosureType | Suspension { ctype :: ClosureType
, ty :: RttiType , ty :: RttiType
, val :: HValue , val :: ForeignHValue
, bound_to :: Maybe Name -- Useful for printing , bound_to :: Maybe Name -- Useful for printing
} }
| NewtypeWrap{ -- At runtime there are no newtypes, and hence no | NewtypeWrap{ -- At runtime there are no newtypes, and hence no
...@@ -126,22 +131,22 @@ isThunk APStackClosure{} = True ...@@ -126,22 +131,22 @@ isThunk APStackClosure{} = True
isThunk _ = False isThunk _ = False
-- Lookup the name in a constructor closure -- 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 constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do
let occName = mkOccName OccName.dataName occ let occName = mkOccName OccName.dataName occ
modName = mkModule (stringToUnitId pkg) (mkModuleName mod) modName = mkModule (stringToUnitId pkg) (mkModuleName mod)
Right `fmap` lookupOrigIO hsc_env modName occName Right `fmap` lookupOrigIO hsc_env modName occName
constrClosToName _hsc_env clos = 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 -- * 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 data TermFold a = TermFold { fTerm :: TermProcessor a a
, fPrim :: RttiType -> [Word] -> a , fPrim :: RttiType -> [Word] -> a
, fSuspension :: ClosureType -> RttiType -> HValue , fSuspension :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> a -> Maybe Name -> a
, fNewtypeWrap :: RttiType -> Either String DataCon , fNewtypeWrap :: RttiType -> Either String DataCon
-> a -> a -> a -> a
...@@ -152,7 +157,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a ...@@ -152,7 +157,7 @@ data TermFold a = TermFold { fTerm :: TermProcessor a a
data TermFoldM m a = data TermFoldM m a =
TermFoldM {fTermM :: TermProcessor a (m a) TermFoldM {fTermM :: TermProcessor a (m a)
, fPrimM :: RttiType -> [Word] -> m a , fPrimM :: RttiType -> [Word] -> m a
, fSuspensionM :: ClosureType -> RttiType -> HValue , fSuspensionM :: ClosureType -> RttiType -> ForeignHValue
-> Maybe Name -> m a -> Maybe Name -> m a
, fNewtypeWrapM :: RttiType -> Either String DataCon , fNewtypeWrapM :: RttiType -> Either String DataCon
-> a -> m a -> a -> m a
...@@ -317,19 +322,26 @@ cPprTermBase y = ...@@ -317,19 +322,26 @@ cPprTermBase y =
. subTerms) . subTerms)
, ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
ppr_list ppr_list
, ifTerm (isTyCon intTyCon . ty) ppr_int , ifTerm' (isTyCon intTyCon . ty) ppr_int
, ifTerm (isTyCon charTyCon . ty) ppr_char , ifTerm' (isTyCon charTyCon . ty) ppr_char
, ifTerm (isTyCon floatTyCon . ty) ppr_float , ifTerm' (isTyCon floatTyCon . ty) ppr_float
, ifTerm (isTyCon doubleTyCon . ty) ppr_double , ifTerm' (isTyCon doubleTyCon . ty) ppr_double
, ifTerm (isIntegerTy . ty) ppr_integer #if defined(INTEGER_GMP)
, ifTerm' (isIntegerTy . ty) ppr_integer
#endif
] ]
where where
ifTerm :: (Term -> Bool) ifTerm :: (Term -> Bool)
-> (Precedence -> Term -> m SDoc) -> (Precedence -> Term -> m SDoc)
-> Precedence -> Term -> m (Maybe SDoc) -> Precedence -> Term -> m (Maybe SDoc)
ifTerm pred f prec t@Term{} ifTerm pred f = ifTerm' pred (\prec t -> Just <$> f prec t)
| pred t = Just `liftM` f prec t
ifTerm _ _ _ _ = return Nothing 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 isTupleTy ty = fromMaybe False $ do
(tc,_) <- tcSplitTyConApp_maybe ty (tc,_) <- tcSplitTyConApp_maybe ty
...@@ -343,13 +355,67 @@ cPprTermBase y = ...@@ -343,13 +355,67 @@ cPprTermBase y =
(tc,_) <- tcSplitTyConApp_maybe ty (tc,_) <- tcSplitTyConApp_maybe ty
return (tyConName tc == integerTyConName) return (tyConName tc == integerTyConName)
ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer ppr_int, ppr_char, ppr_float, ppr_double
:: Precedence -> Term -> m SDoc :: Precedence -> Term -> m (Maybe SDoc)
ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) ppr_int _ Term{subTerms=[Prim{valRaw=[w]}]} =
ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') return (Just (Ppr.int (fromIntegral w)))
ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v))) ppr_int _ _ = return Nothing
ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v)))
ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v))) 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 --Note pprinting of list terms is not lazy
ppr_list :: Precedence -> Term -> m SDoc ppr_list :: Precedence -> Term -> m SDoc
...@@ -357,10 +423,12 @@ cPprTermBase y = ...@@ -357,10 +423,12 @@ cPprTermBase y =
let elems = h : getListTerms t let elems = h : getListTerms t
isConsLast = not (termType (last elems) `eqType` termType h) isConsLast = not (termType (last elems) `eqType` termType h)
is_string = all (isCharTy . ty) elems is_string = all (isCharTy . ty) elems
chars = [ chr (fromIntegral w)
| Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]
print_elems <- mapM (y cons_prec) elems print_elems <- mapM (y cons_prec) elems
if is_string if is_string
then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) then return (Ppr.doubleQuotes (Ppr.text chars))
else if isConsLast else if isConsLast
then return $ cparen (p >= cons_prec) then return $ cparen (p >= cons_prec)
$ pprDeeperList fsep $ pprDeeperList fsep
...@@ -553,7 +621,7 @@ cvObtainTerm ...@@ -553,7 +621,7 @@ cvObtainTerm
-> Int -- ^ How many times to recurse for subterms -> Int -- ^ How many times to recurse for subterms
-> Bool -- ^ Force thunks -> Bool -- ^ Force thunks
-> RttiType -- ^ Type of the object to reconstruct -> RttiType -- ^ Type of the object to reconstruct
-> HValue -- ^ Object to reconstruct -> ForeignHValue -- ^ Object to reconstruct
-> IO Term -> IO Term
cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- we quantify existential tyvars as universal, -- we quantify existential tyvars as universal,
...@@ -599,7 +667,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -599,7 +667,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
text "Type obtained: " <> ppr (termType term)) text "Type obtained: " <> ppr (termType term))
return term return term
where 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 -- I believe that my_ty should not have any enclosing
-- foralls, nor any free RuntimeUnk skolems; -- foralls, nor any free RuntimeUnk skolems;
-- that is partly what the quantifyType stuff achieved -- 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 ...@@ -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 go 0 my_ty _old_ty a = do
traceTR (text "Gave up reconstructing a term after" <> traceTR (text "Gave up reconstructing a term after" <>
int max_depth <> text " steps") 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) return (Suspension (tipe (info clos)) my_ty a Nothing)
go !max_depth my_ty old_ty a = do go !max_depth my_ty old_ty a = do
let monomorphic = not(isTyVarTy my_ty) let monomorphic = not(isTyVarTy my_ty)
-- This ^^^ is a convention. The ancestor tests for -- This ^^^ is a convention. The ancestor tests for
-- monomorphism and passes a type instead of a tv -- monomorphism and passes a type instead of a tv
clos <- trIO $ getClosureData a clos <- trIO $ GHCi.getClosure hsc_env a
case clos of case clos of
-- Thunks we may want to force -- Thunks we may want to force
t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> t | isThunk t && force -> do
seq a (go (pred max_depth) my_ty old_ty a) 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 -- 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 -- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up
-- showing '_' which is what we want. -- showing '_' which is what we want.
BlackholeClosure{indirectee=ind} -> do BlackholeClosure{indirectee=ind} -> do
traceTR (text "Following a BLACKHOLE") 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 -- We always follow indirections
IndClosure{indirectee=ind} -> do IndClosure{indirectee=ind} -> do
traceTR (text "Following an indirection" ) 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 -- We also follow references
MutVarClosure{} MutVarClosure{var=contents}
| Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty | Just (tycon,[world,contents_ty]) <- tcSplitTyConApp_maybe old_ty
-> do -> do
-- Deal with the MutVar# primitive -- Deal with the MutVar# primitive
...@@ -640,7 +710,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -640,7 +710,6 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
-- MutVar# :: contents_ty -> MutVar# s contents_ty -- MutVar# :: contents_ty -> MutVar# s contents_ty
traceTR (text "Following a MutVar") traceTR (text "Following a MutVar")
contents_tv <- newVar liftedTypeKind contents_tv <- newVar liftedTypeKind
contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w
ASSERT(isUnliftedType my_ty) return () ASSERT(isUnliftedType my_ty) return ()
(mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy (mutvar_ty,_) <- instScheme $ quantifyType $ mkFunTy
contents_ty (mkTyConApp tycon [world,contents_ty]) contents_ty (mkTyConApp tycon [world,contents_ty])
...@@ -649,8 +718,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -649,8 +718,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
return (RefWrap my_ty x) return (RefWrap my_ty x)
-- The interesting case -- The interesting case
ConstrClosure{ptrArgs=pArgs} -> do ConstrClosure{ptrArgs=pArgs,dataArgs=dArgs} -> do
traceTR (text "entering a constructor " <> traceTR (text "entering a constructor " <> ppr dArgs <+>
if monomorphic if monomorphic
then parens (text "already monomorphic: " <> ppr my_ty) then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty) else Ppr.empty)
...@@ -667,8 +736,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -667,8 +736,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
tag = showPpr dflags dcname tag = showPpr dflags dcname
vars <- replicateM (length pArgs) vars <- replicateM (length pArgs)
(newVar liftedTypeKind) (newVar liftedTypeKind)
subTerms <- sequence $ zipWith (\(Box x) tv -> subTerms <- sequence $ zipWith (\x tv ->
go (pred max_depth) tv tv (HValue x)) pArgs vars go (pred max_depth) tv tv x) pArgs vars
return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
Just dc -> do Just dc -> do
traceTR (text "Is constructor" <+> (ppr dc $$ ppr my_ty)) 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 ...@@ -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 subTerms <- extractSubTerms (\ty -> go (pred max_depth) ty ty) clos subTtypes
return (Term my_ty (Right dc) a subTerms) 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. -- The otherwise case: can be a Thunk,AP,PAP,etc.
_ -> do _ -> 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) return (Suspension (tipe (info clos)) my_ty a Nothing)
-- insert NewtypeWraps around newtypes -- insert NewtypeWraps around newtypes
...@@ -698,8 +775,8 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do ...@@ -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 worker ct ty hval n | isFunTy ty = Suspension ct (dictsView ty) hval n
| otherwise = Suspension ct ty hval n | otherwise = Suspension ct ty hval n
extractSubTerms :: (Type -> HValue -> TcM Term) extractSubTerms :: (Type -> ForeignHValue -> TcM Term)
-> Closure -> [Type] -> TcM [Term] -> GenClosure ForeignHValue -> [Type] -> TcM [Term]
extractSubTerms recurse clos = liftM thdOf3 . go 0 0 extractSubTerms recurse clos = liftM thdOf3 . go 0 0
where where
array = dataArgs clos array = dataArgs clos
...@@ -733,7 +810,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0 ...@@ -733,7 +810,7 @@ extractSubTerms recurse clos = liftM thdOf3 . go 0 0
go_rep ptr_i arr_i ty rep go_rep ptr_i arr_i ty rep
| isGcPtrRep rep = do | 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) return (ptr_i + 1, arr_i, t)
| otherwise = do | otherwise = do
-- This is a bit involved since we allow packing multiple fields -- This is a bit involved since we allow packing multiple fields
...@@ -805,7 +882,7 @@ cvReconstructType ...@@ -805,7 +882,7 @@ cvReconstructType
:: HscEnv :: HscEnv
-> Int -- ^ How many times to recurse for subterms -> Int -- ^ How many times to recurse for subterms
-> GhciType -- ^ Type to refine -> GhciType -- ^ Type to refine
-> HValue -- ^ Refine the type using this value -> ForeignHValue -- ^ Refine the type using this value
-> IO (Maybe Type) -> IO (Maybe Type)
cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
traceTR (text "RTTI started with initial type " <> ppr old_ty) 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 ...@@ -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) search stop expand (xx `mappend` Seq.fromList new) $! (pred d)
-- returns unification tasks,since we are going to want a breadth-first search