X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=84bdfecf7814fbf01f2510cbd50b6df6fd783c49;hb=9d0c8f842e35dde3d570580cf62a32779f66a6de;hp=94e6f08215d2290c8447c34080052a364b452f19;hpb=840554d7c158dd8759139f247f7f46c1f643d5a4;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 94e6f08..84bdfec 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -46,6 +46,7 @@ import TyCon import Name import VarEnv import Util +import ListSetOps import VarSet import TysPrim import PrelNames @@ -59,7 +60,12 @@ import Constants ( wORD_SIZE ) import GHC.Arr ( Array(..) ) import GHC.Exts -import GHC.IOBase ( IO(IO) ) + +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO ( IO(..) ) +#else +import GHC.IOBase ( IO(..) ) +#endif import Control.Monad import Data.Maybe @@ -376,12 +382,14 @@ 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} +pprNewtypeWrap y p NewtypeWrap{ty=ty, wrapped_term=t} | Just (tc,_) <- tcSplitTyConApp_maybe ty , ASSERT(isNewTyCon tc) True , Just new_dc <- tyConSingleDataCon_maybe tc = do - real_term <- y max_prec t - return$ cparen (p >= app_prec) (ppr new_dc <+> real_term) + if integerDataConName == dataConName new_dc + then return $ text $ show $ (unsafeCoerce# $ val t :: Integer) + else do real_term <- y max_prec t + return$ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" ------------------------------------------------------- @@ -426,16 +434,11 @@ cPprTermBase y = , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a) , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a) , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a) - , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a) ] where ifTerm pred f prec t@Term{} | pred t = Just `liftM` f prec t ifTerm _ _ _ _ = return Nothing - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - isTupleTy ty = fromMaybe False $ do (tc,_) <- tcSplitTyConApp_maybe ty return (isBoxedTupleTyCon tc) @@ -710,7 +713,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do -- to subterms is already being done via matching. when (not monomorphic) $ do let myType = mkFunTys subTermTvs my_ty - (signatureType,_) <- instScheme (rttiView $ dataConUserType dc) + (signatureType,_) <- instScheme (mydataConType dc) -- It is vital for newtype reconstruction that the unification step -- is done right here, _before_ the subterms are RTTI reconstructed addConstraint myType signatureType @@ -837,7 +840,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do -- It is vital for newtype reconstruction that the unification step -- is done right here, _before_ the subterms are RTTI reconstructed let myType = mkFunTys subTtypes my_ty - (signatureType,_) <- instScheme(rttiView $ dataConUserType dc) + (signatureType,_) <- instScheme(mydataConType dc) addConstraint myType signatureType return $ [ appArr (\e->(t,e)) (ptrs clos) i | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)] @@ -849,11 +852,11 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do -- In particular, we want them to unify with things. improveRTTIType :: HscEnv -> RttiType -> RttiType -> IO (Maybe TvSubst) improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do - traceTR $ fsep [text "improveRttiType", ppr _ty, ppr rtti_ty] + traceTR (text "improveRttiType" <+> fsep [ppr _ty, ppr rtti_ty]) (ty_tvs, _, _) <- tcInstType return ty (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty (_, _, rtti_ty') <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty) - getLIE(boxyUnify rtti_ty' ty') + _ <- getLIE(boxyUnify rtti_ty' ty') tvs1_contents <- zonkTcTyVars ty_tvs' let subst = (uncurry zipTopTvSubst . unzip) [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents @@ -868,6 +871,24 @@ myDataConInstArgTys dc args | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args | otherwise = dataConRepArgTys dc +mydataConType :: DataCon -> Type +-- ^ Custom version of DataCon.dataConUserType where we +-- - remove the equality constraints +-- - use the representation types for arguments, including dictionaries +-- - keep the original result type +mydataConType dc + = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ + mkFunTys arg_tys $ + res_ty + where univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyVars dc + eq_spec = dataConEqSpec dc + arg_tys = [case a of + PredTy p -> predTypeRep p + _ -> a + | a <- dataConRepArgTys dc] + res_ty = dataConOrigResTy dc + isRefType :: Type -> Bool isRefType ty | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc @@ -1075,7 +1096,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs') text " in presence of newtype evidence " <> ppr new_tycon) vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars - liftTcM (boxyUnify ty (repType ty')) + _ <- liftTcM (boxyUnify ty (repType ty')) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty' @@ -1094,13 +1115,6 @@ zonkTerm = foldTermM TermFoldM{ } -------------------------------------------------------------------------------- --- representation types for thetas -rttiView :: Type -> Type -rttiView ty | Just ty' <- coreView ty = rttiView ty' -rttiView ty - | (tvs, theta, tau) <- tcSplitSigmaTy ty - = mkForAllTys tvs (mkFunTys [predTypeRep p | p <- theta, isClassPred p] tau) - -- Restore Class predicates out of a representation type dictsView :: Type -> Type -- dictsView ty = ty