From: Pepe Iborra Date: Tue, 4 Dec 2007 10:55:11 +0000 (+0000) Subject: Teach :print to follow references (STRefs and IORefs) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f4d6209d11ba41d3bfdd7e14e9859b890915abdb Teach :print to follow references (STRefs and IORefs) Prelude Data.IORef> :p l l = (_t4::Maybe Integer) : (_t5::[Maybe Integer]) Prelude Data.IORef> p <- newIORef l Prelude Data.IORef> :p p p = GHC.IOBase.IORef (GHC.STRef.STRef {((_t6::Maybe Integer) : (_t7::[Maybe Integer]))}) Prelude Data.IORef> :sp p p = GHC.IOBase.IORef (GHC.STRef.STRef {(_ : _)}) I used braces to denote the contents of a reference. Perhaps there is a more appropriate notation? --- diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index 1b1b2c9..72688dd 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -131,6 +131,9 @@ bindSuspensions cms@(Session ref) t = do \ty dc t -> do (term, names) <- t return (NewtypeWrap ty dc term, names) + , fRefWrap = \ty t -> do + (term, names) <- t + return (RefWrap ty term, names) } doSuspension freeNames ct mb_ty hval _name = do name <- atomicModifyIORef freeNames (\x->(tail x, head x)) @@ -173,7 +176,8 @@ showTerm cms@(Session ref) term = do GHC.setSessionDynFlags cms dflags cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = cPprShowable prec t{ty=new_ty} - cPprShowable _ _ = panic "cPprShowable - unreachable" + cPprShowable prec RefWrap{wrapped_term=t} = cPprShowable prec t + cPprShowable _ _ = return Nothing needsParens ('"':_) = False -- some simple heuristics to see whether parens -- are redundant in an arbitrary Show output diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 4a481f3..1abee57 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -14,6 +14,7 @@ module RtClosureInspect( isTerm, isSuspension, isPrim, + isNewtypeWrap, pprTerm, cPprTerm, cPprTermBase, @@ -74,6 +75,7 @@ import Panic import GHC.Arr ( Array(..) ) import GHC.Exts +import GHC.IOBase import Control.Monad import Data.Maybe @@ -119,6 +121,8 @@ data Term = Term { ty :: Type | NewtypeWrap{ ty :: Type , dc :: Either String DataCon , wrapped_term :: Term } + | RefWrap { ty :: Type + , wrapped_term :: Term } isTerm, isSuspension, isPrim, isNewtypeWrap :: Term -> Bool isTerm Term{} = True @@ -138,6 +142,7 @@ isFullyEvaluatedTerm :: Term -> Bool isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt isFullyEvaluatedTerm Prim {} = True isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t +isFullyEvaluatedTerm RefWrap{wrapped_term=t} = isFullyEvaluatedTerm t isFullyEvaluatedTerm _ = False instance Outputable (Term) where @@ -155,7 +160,8 @@ data ClosureType = Constr | AP | PAP | Indirection Int - | Other Int + | MutVar Int + | Other Int deriving (Show, Eq) data Closure = Closure { tipe :: ClosureType @@ -199,18 +205,20 @@ getClosureData a = return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) readCType :: Integral a => a -> ClosureType -readCType i +readCType i | i >= CONSTR && i <= CONSTR_NOCAF_STATIC = Constr | i >= FUN && i <= FUN_STATIC = Fun - | i >= THUNK && i < THUNK_SELECTOR = Thunk (fromIntegral i) + | i >= THUNK && i < THUNK_SELECTOR = Thunk i' | i == THUNK_SELECTOR = ThunkSelector | i == BLACKHOLE = Blackhole - | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i) - | fromIntegral i == aP_CODE = AP + | i >= IND && i <= IND_STATIC = Indirection i' + | i' == aP_CODE = AP | i == AP_STACK = AP - | fromIntegral i == pAP_CODE = PAP - | otherwise = Other (fromIntegral i) - + | i' == pAP_CODE = PAP + | i == MUT_VAR_CLEAN || i == MUT_VAR_DIRTY = MutVar i' + | otherwise = Other i' + where i' = fromIntegral i + isConstr, isIndirection, isThunk :: ClosureType -> Bool isConstr Constr = True isConstr _ = False @@ -274,12 +282,13 @@ sizeofTyCon = sizeofPrimRep . tyConPrimRep ----------------------------------- type TermProcessor a b = Type -> Either String DataCon -> HValue -> [a] -> b -data TermFold a = TermFold { fTerm :: TermProcessor a a - , fPrim :: Type -> [Word] -> a - , fSuspension :: ClosureType -> Maybe Type -> HValue +data TermFold a = TermFold { fTerm :: TermProcessor a a + , fPrim :: Type -> [Word] -> a + , fSuspension :: ClosureType -> Maybe Type -> HValue -> Maybe Name -> a , fNewtypeWrap :: Type -> Either String DataCon -> a -> a + , fRefWrap :: Type -> a -> a } foldTerm :: TermFold a -> Term -> a @@ -287,20 +296,23 @@ foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt) foldTerm tf (Prim ty v ) = fPrim tf ty v foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b foldTerm tf (NewtypeWrap ty dc t) = fNewtypeWrap tf ty dc (foldTerm tf t) +foldTerm tf (RefWrap ty t) = fRefWrap tf ty (foldTerm tf t) idTermFold :: TermFold Term idTermFold = TermFold { fTerm = Term, fPrim = Prim, fSuspension = Suspension, - fNewtypeWrap = NewtypeWrap + fNewtypeWrap = NewtypeWrap, + fRefWrap = RefWrap } idTermFoldM :: Monad m => TermFold (m Term) idTermFoldM = TermFold { fTerm = \ty dc v tt -> sequence tt >>= return . Term ty dc v, fPrim = (return.). Prim, fSuspension = (((return.).).). Suspension, - fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t + fNewtypeWrap= \ty dc t -> NewtypeWrap ty dc `liftM` t, + fRefWrap = \ty t -> RefWrap ty `liftM` t } mapTermType :: (Type -> Type) -> Term -> Term @@ -308,7 +320,8 @@ mapTermType f = foldTerm idTermFold { fTerm = \ty dc hval tt -> Term (f ty) dc hval tt, fSuspension = \ct mb_ty hval n -> Suspension ct (fmap f mb_ty) hval n, - fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t} + fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, + fRefWrap = \ty t -> RefWrap (f ty) t} termTyVars :: Term -> TyVarSet termTyVars = foldTerm TermFold { @@ -317,7 +330,8 @@ termTyVars = foldTerm TermFold { fSuspension = \_ mb_ty _ _ -> maybe emptyVarEnv tyVarsOfType mb_ty, fPrim = \ _ _ -> emptyVarEnv, - fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t} + fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t, + fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t} where concatVarEnv = foldr plusVarEnv emptyVarEnv ---------------------------------- @@ -340,9 +354,6 @@ pprTerm _ _ _ = panic "pprTerm" pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m pprTermM y p t = pprDeeper `liftM` ppr_termM y p t -pprTermM1, ppr_termM1 :: Monad m => Term -> m SDoc -pprTermM1 t = pprDeeper `liftM` ppr_termM1 t - ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do tt_docs <- mapM (y app_prec) tt return$ cparen (not(null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs) @@ -358,18 +369,21 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt} return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs) ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t - +ppr_termM y p RefWrap{wrapped_term=t} = braces `liftM` y p t ppr_termM _ _ t = ppr_termM1 t +ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty) words -ppr_termM1 Term{} = panic "ppr_termM1 - unreachable" ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_' ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n} | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("") - | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty -ppr_termM1 _ = panic "ppr_termM1" + | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty +ppr_termM1 Suspension{} = panic "ppr_termM1 - Suspension" +ppr_termM1 Term{} = panic "ppr_termM1 - Term" +ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" +ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap" pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} | Just (tc,_) <- splitNewTyConApp_maybe ty @@ -400,12 +414,11 @@ type CustomTermPrinter m = TermPrinterM m cPprTerm :: Monad m => CustomTermPrinter m -> Term -> m SDoc cPprTerm printers_ = go 0 where printers = printers_ go - go prec t | isTerm t || isNewtypeWrap t = do + go prec t = do let default_ = Just `liftM` pprTermM go prec t mb_customDocs = [pp prec t | pp <- printers] ++ [default_] Just doc <- firstJustM mb_customDocs return$ cparen (prec>app_prec+1) doc - go _ t = pprTermM1 t firstJustM (mb:mbs) = mb >>= maybe (firstJustM mbs) (return . Just) firstJustM [] = return Nothing @@ -592,6 +605,16 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do t | isThunk t && force -> seq a $ go (pred bound) tv ty a -- We always follow indirections Indirection _ -> go bound tv ty $! (ptrs clos ! 0) +-- We also follow references + MutVar _ | Just (tycon,[world,ty_contents]) <- splitTyConApp_maybe ty + -- , tycon == mutVarPrimTyCon + -> do + contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w + tv' <- newVar liftedTypeKind + addConstraint tv (mkTyConApp tycon [world,tv']) + x <- go bound tv' ty_contents contents + return (RefWrap ty x) + -- The interesting case Constr -> do Right dcname <- dataConInfoPtrToName (infoPtr clos) @@ -636,7 +659,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do (drop extra_args subTtypes) return (Term tv (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. - tipe_clos -> + tipe_clos -> return (Suspension tipe_clos (Just tv) a Nothing) matchSubTypes dc ty @@ -709,6 +732,13 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do clos <- trIO $ getClosureData a case tipe clos of Indirection _ -> go tv $! (ptrs clos ! 0) + MutVar _ -> do + contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w + tv' <- newVar liftedTypeKind + world <- newVar liftedTypeKind + addConstraint tv (mkTyConApp mutVarPrimTyCon [world,tv']) +-- x <- go tv' ty_contents contents + return [(tv', contents)] Constr -> do Right dcname <- dataConInfoPtrToName (infoPtr clos) (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)