From 463f566a6504f193e4602299be5f2400ca10d21a Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sat, 8 Dec 2007 19:52:22 +0000 Subject: [PATCH] Refactoring only Suspensions in the Term datatype used for RTTI always get assigned a Type, so there is no reason to juggle around with a (Maybe Type) anymore. --- compiler/ghci/Debugger.hs | 9 ++++----- compiler/ghci/RtClosureInspect.hs | 36 +++++++++++++++--------------------- 2 files changed, 19 insertions(+), 26 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index c53a739..e13b8a8 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -74,13 +74,13 @@ pprintClosureCommand session bindThings force str = do term_ <- GHC.obtainTerm cms force id term <- tidyTermTyVars cms term_ term' <- if bindThings && - Just False == isUnliftedTypeKind `fmap` termType term + False == isUnliftedTypeKind (termType term) then bindSuspensions cms term else return term -- Before leaving, we compare the type obtained to see if it's more specific -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. - let Just reconstructed_type = termType term + let reconstructed_type = termType term subst = unifyRTTI (idType id) (reconstructed_type) return (term',subst) @@ -137,11 +137,10 @@ bindSuspensions cms@(Session ref) t = do (term, names) <- t return (RefWrap ty term, names) } - doSuspension freeNames ct mb_ty hval _name = do + doSuspension freeNames ct ty hval _name = do name <- atomicModifyIORef freeNames (\x->(tail x, head x)) n <- newGrimName name - let ty' = fromMaybe (error "unexpected") mb_ty - return (Suspension ct mb_ty hval (Just n), [(n,ty',hval)]) + return (Suspension ct ty hval (Just n), [(n,ty,hval)]) -- A custom Term printer to enable the use of Show instances diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 585ca1c..de672a1 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -70,7 +70,6 @@ import TysWiredIn import Constants import Outputable -import Maybes import Panic import GHC.Arr ( Array(..) ) @@ -114,7 +113,7 @@ data Term = Term { ty :: Type , value :: [Word] } | Suspension { ctype :: ClosureType - , mb_ty :: Maybe Type + , ty :: Type , val :: HValue , bound_to :: Maybe Name -- Useful for printing } @@ -134,9 +133,8 @@ isPrim _ = False isNewtypeWrap NewtypeWrap{} = True isNewtypeWrap _ = False -termType :: Term -> Maybe Type -termType t@(Suspension {}) = mb_ty t -termType t = Just$ ty t +termType :: Term -> Type +termType t = ty t isFullyEvaluatedTerm :: Term -> Bool isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt @@ -284,8 +282,8 @@ 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 - -> Maybe Name -> a + , fSuspension :: ClosureType -> Type -> HValue + -> Maybe Name -> a , fNewtypeWrap :: Type -> Either String DataCon -> a -> a , fRefWrap :: Type -> a -> a @@ -318,8 +316,8 @@ idTermFoldM = TermFold { mapTermType :: (Type -> Type) -> Term -> Term 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, + fSuspension = \ct ty hval n -> + Suspension ct (f ty) hval n, fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t, fRefWrap = \ty t -> RefWrap (f ty) t} @@ -327,8 +325,7 @@ termTyVars :: Term -> TyVarSet termTyVars = foldTerm TermFold { fTerm = \ty _ _ tt -> tyVarsOfType ty `plusVarEnv` concatVarEnv tt, - fSuspension = \_ mb_ty _ _ -> - maybe emptyVarEnv tyVarsOfType mb_ty, + fSuspension = \_ ty _ _ -> tyVarsOfType ty, fPrim = \ _ _ -> emptyVarEnv, fNewtypeWrap= \ty _ t -> tyVarsOfType ty `plusVarEnv` t, fRefWrap = \ty t -> tyVarsOfType ty `plusVarEnv` t} @@ -369,7 +366,7 @@ 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, ty=ty} = do +ppr_termM y p RefWrap{wrapped_term=t} = do contents <- y app_prec t return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents) -- The constructor name is wired in here ^^^ for the sake of simplicity. @@ -384,10 +381,9 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{value=words, ty=ty} = return$ text$ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{bound_to=Nothing} = return$ char '_' -ppr_termM1 Suspension{mb_ty=Just ty, bound_to=Just n} +ppr_termM1 Suspension{ty=ty, bound_to=Just n} | Just _ <- splitFunTy_maybe ty = return$ ptext SLIT("") | 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" @@ -465,7 +461,7 @@ cPprTermBase y = --Note pprinting of list terms is not lazy doList p h t = do let elems = h : getListTerms t - isConsLast = termType(last elems) /= termType h + isConsLast = not(termType(last elems) `coreEqType` termType h) print_elems <- mapM (y cons_prec) elems return$ if isConsLast then cparen (p >= cons_prec) @@ -475,9 +471,7 @@ cPprTermBase y = else brackets (pprDeeperList fcat$ punctuate comma print_elems) - where Just a /= Just b = not (a `coreEqType` b) - _ /= _ = True - getListTerms Term{subTerms=[h,t]} = h : getListTerms t + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t getListTerms Term{subTerms=[]} = [] getListTerms t@Suspension{} = [t] getListTerms t = pprPanic "getListTerms" (ppr t) @@ -598,7 +592,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do go bound _ _ _ | seq bound False = undefined go 0 tv _ty a = do clos <- trIO $ getClosureData a - return (Suspension (tipe clos) (Just tv) a Nothing) + return (Suspension (tipe clos) tv a Nothing) go bound tv ty a = do let monomorphic = not(isTyVarTy tv) -- This ^^^ is a convention. The ancestor tests for @@ -667,7 +661,7 @@ cvObtainTerm hsc_env bound force mb_ty hval = runTR hsc_env $ do return (Term tv (Right dc) a subTerms) -- The otherwise case: can be a Thunk,AP,PAP,etc. tipe_clos -> - return (Suspension tipe_clos (Just tv) a Nothing) + return (Suspension tipe_clos tv a Nothing) matchSubTypes dc ty | Just (_,ty_args) <- splitTyConApp_maybe (repType ty) @@ -894,7 +888,7 @@ zonkTerm = foldTerm idTermFoldM { fTerm = \ty dc v tt -> sequence tt >>= \tt -> zonkTcType ty >>= \ty' -> return (Term ty' dc v tt) - ,fSuspension = \ct ty v b -> fmapMMaybe zonkTcType ty >>= \ty -> + ,fSuspension = \ct ty v b -> zonkTcType ty >>= \ty -> return (Suspension ct ty v b) ,fNewtypeWrap= \ty dc t -> return NewtypeWrap `ap` zonkTcType ty `ap` return dc `ap` t} -- 1.7.10.4