X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=95ae5acd02a4942c4bb9cbf7d4830a7181ddcf84;hb=af5a8f955fffa6c3d6b5c7f6552cee191e02c4d8;hp=94e6f08215d2290c8447c34080052a364b452f19;hpb=840554d7c158dd8759139f247f7f46c1f643d5a4;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 94e6f08..95ae5ac 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 @@ -53,13 +54,18 @@ import TysWiredIn import DynFlags import Outputable import FastString -import Panic +-- import Panic 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 @@ -68,11 +74,10 @@ import Data.Ix import Data.List import qualified Data.Sequence as Seq import Data.Monoid -import Data.Sequence hiding (null, length, index, take, drop, splitAt, reverse) +import Data.Sequence (viewl, ViewL(..)) import Foreign -import System.IO.Unsafe +-- import System.IO.Unsafe -import System.IO --------------------------------------------- -- * A representation of semi evaluated Terms --------------------------------------------- @@ -160,7 +165,7 @@ data Closure = Closure { tipe :: ClosureType instance Outputable ClosureType where ppr = text . show -#include "../includes/ClosureTypes.h" +#include "../includes/rts/storage/ClosureTypes.h" aP_CODE, pAP_CODE :: Int aP_CODE = AP @@ -376,12 +381,12 @@ 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) + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" ------------------------------------------------------- @@ -432,10 +437,6 @@ cPprTermBase y = | 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) @@ -444,6 +445,10 @@ cPprTermBase y = (tc,_) <- tcSplitTyConApp_maybe ty return (a_tc == tc) + isIntegerTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (tyConName tc == integerTyConName) + coerceShow f _p = return . text . show . f . unsafeCoerce# . val --Note pprinting of list terms is not lazy @@ -710,7 +715,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 +842,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 +854,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 +873,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 +1098,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 +1117,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