X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=6075cbaecc026fa2743b2d4c1decb86bdb2bb682;hb=6bf61003d2843cbe1c187882e19a8a996b437c12;hp=76ef9be1f7c8f50c0ecdc75f5f9cddd9324a750c;hpb=d436c70d43fb905c63220040168295e473f4b90a;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 76ef9be..6075cba 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -74,9 +74,9 @@ 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 Foreign --- import System.IO.Unsafe +import Data.Sequence (viewl, ViewL(..)) +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe --------------------------------------------- -- * A representation of semi evaluated Terms @@ -165,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 @@ -385,10 +385,8 @@ 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 - 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) + real_term <- y max_prec t + return $ cparen (p >= app_prec) (ppr new_dc <+> real_term) pprNewtypeWrap _ _ _ = panic "pprNewtypeWrap" ------------------------------------------------------- @@ -428,11 +426,12 @@ cPprTermBase y = . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - (\ p Term{subTerms=[h,t]} -> doList p h t) + (\ p t -> doList p t) , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a) , 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 @@ -446,10 +445,14 @@ 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 - doList p h t = do + doList p (Term{subTerms=[h,t]}) = do let elems = h : getListTerms t isConsLast = not(termType(last elems) `coreEqType` termType h) print_elems <- mapM (y cons_prec) elems @@ -465,6 +468,7 @@ cPprTermBase y = getListTerms Term{subTerms=[]} = [] getListTerms t@Suspension{} = [t] getListTerms t = pprPanic "getListTerms" (ppr t) + doList _ _ = panic "doList" repPrim :: TyCon -> [Word] -> String @@ -566,13 +570,13 @@ liftTcM :: TcM a -> TR a liftTcM = id newVar :: Kind -> TR TcType -newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar +newVar = liftTcM . newFlexiTyVarTy -- | Returns the instantiated type scheme ty', and the substitution sigma -- such that sigma(ty') = ty instScheme :: Type -> TR (TcType, TvSubst) instScheme ty = liftTcM$ do - (tvs, _, _) <- tcInstType return ty + (tvs, _, _) <- tcInstType return ty (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs)) @@ -587,7 +591,7 @@ addConstraint actual expected = do recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual, text "with", ppr expected]) (congruenceNewtypes actual expected >>= - (getLIE . uncurry boxyUnify) >> return ()) + (captureConstraints . uncurry unifyType) >> return ()) -- TOMDO: what about the coercion? -- we should consider family instances @@ -651,11 +655,13 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do clos <- trIO $ getClosureData a case tipe clos of -- Thunks we may want to force --- NB. this won't attempt to force a BLACKHOLE. Even with :force, we never --- force blackholes, because it would almost certainly result in deadlock, --- and showing the '_' is more useful. t | isThunk t && force -> traceTR (text "Forcing a " <> text (show t)) >> seq a (go (pred max_depth) my_ty old_ty a) +-- Blackholes are indirections iff the payload is not TSO or BLOCKING_QUEUE. So we +-- treat them like indirections; if the payload is TSO or BLOCKING_QUEUE, we'll end up +-- showing '_' which is what we want. + Blackhole -> do traceTR (text "Following a BLACKHOLE") + appArr (go max_depth my_ty old_ty) (ptrs clos) 0 -- We always follow indirections Indirection i -> do traceTR (text "Following an indirection" <> parens (int i) ) go max_depth my_ty old_ty $! (ptrs clos ! 0) @@ -814,6 +820,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do go my_ty a = do clos <- trIO $ getClosureData a case tipe clos of + Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO Indirection _ -> go my_ty $! (ptrs clos ! 0) MutVar _ -> do contents <- trIO$ IO$ \w -> readMutVar# (unsafeCoerce# a) w @@ -855,7 +862,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do (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') + _ <- captureConstraints (unifyType rtti_ty' ty') tvs1_contents <- zonkTcTyVars ty_tvs' let subst = (uncurry zipTopTvSubst . unzip) [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents @@ -1095,7 +1102,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 (unifyType ty (repType ty')) -- assumes that reptype doesn't ^^^^ touch tyconApp args return ty'