From 40739684494d88dde2efad64f15be2acbcc884a2 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 13 Nov 2007 17:01:13 +0000 Subject: [PATCH] Fix Trac 1865: GHCi debugger crashes with :print --- compiler/ghci/Debugger.hs | 2 +- compiler/ghci/RtClosureInspect.hs | 18 +++++++++++------- compiler/main/InteractiveEval.hs | 2 +- compiler/types/Type.lhs | 24 +++++++++++++----------- 4 files changed, 26 insertions(+), 20 deletions(-) diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs index d31d4d6..9fbee36 100644 --- a/compiler/ghci/Debugger.hs +++ b/compiler/ghci/Debugger.hs @@ -81,7 +81,7 @@ pprintClosureCommand session bindThings force str = do -- Then, we extract a substitution, -- mapping the old tyvars to the reconstructed types. let Just reconstructed_type = termType term - Just subst = computeRTTIsubst (idType id) (reconstructed_type) + subst = computeRTTIsubst (idType id) (reconstructed_type) return (term',subst) tidyTermTyVars :: Session -> Term -> IO Term diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index b9fd192..d772eb3 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -736,16 +736,20 @@ cvReconstructType hsc_env max_depth mb_ty hval = runTR_maybe hsc_env $ do -- improved rtti_t computed by RTTI -- The main difference between RTTI types and their normal counterparts -- is that the former are _not_ polymorphic, thus polymorphism must - -- be stripped. Syntactically, forall's must be stripped -computeRTTIsubst :: Type -> Type -> Maybe TvSubst + -- be stripped. Syntactically, forall's must be stripped. + -- We also remove predicates. +computeRTTIsubst :: Type -> Type -> TvSubst computeRTTIsubst ty rtti_ty = + case mb_subst of + Just subst -> subst + Nothing -> pprPanic "Failed to compute a RTTI substitution" + (ppr (ty, rtti_ty)) -- In addition, we strip newtypes too, since the reconstructed type might -- not have recovered them all - tcUnifyTys (const BindMe) - [repType' $ dropForAlls$ ty] - [repType' $ rtti_ty] --- TODO stripping newtypes shouldn't be necessary, test - + -- TODO stripping newtypes shouldn't be necessary, test + where mb_subst = tcUnifyTys (const BindMe) + [rttiView ty] + [rttiView rtti_ty] -- Dealing with newtypes {- diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 9187f1a..bf7c7b4 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -609,7 +609,7 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do let substs = [computeRTTIsubst ty ty' | (ty, Just ty') <- zip (map idType incompletelyTypedIds) tys] ic' = foldr (flip substInteractiveContext) ic - (map skolemiseSubst $ catMaybes substs) + (map skolemiseSubst substs) return hsc_env{hsc_IC=ic'} skolemiseSubst subst = subst `setTvSubstEnv` diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index ab47c4c..662dd6f 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -55,7 +55,7 @@ module Type ( splitTyConApp_maybe, splitTyConApp, splitNewTyConApp_maybe, splitNewTyConApp, - repType, repType', typePrimRep, coreView, tcView, kindView, + repType, typePrimRep, coreView, tcView, kindView, rttiView, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, dropForAlls, @@ -190,6 +190,18 @@ tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys tcView ty = Nothing ----------------------------------------------- +rttiView :: Type -> Type +-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism +rttiView (ForAllTy _ ty) = rttiView ty +rttiView (NoteTy _ ty) = rttiView ty +rttiView (FunTy PredTy{} ty) = rttiView ty +rttiView (FunTy NoteTy{} ty) = rttiView ty +rttiView ty@TyConApp{} | Just ty' <- coreView ty + = rttiView ty' +rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys) +rttiView ty = ty + +----------------------------------------------- {-# INLINE kindView #-} kindView :: Kind -> Maybe Kind -- C.f. coreView, tcView @@ -483,16 +495,6 @@ repType (TyConApp tc tys) repType ty = ty --- repType' aims to be a more thorough version of repType --- For now it simply looks through the TyConApp args too -repType' ty -- | pprTrace "repType'" (ppr ty $$ ppr (go1 ty)) False = undefined - | otherwise = go1 ty - where - go1 = go . repType - go (TyConApp tc tys) = mkTyConApp tc (map repType' tys) - go ty = ty - - -- ToDo: this could be moved to the code generator, using splitTyConApp instead -- of inspecting the type directly. typePrimRep :: Type -> PrimRep -- 1.7.10.4