X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FRtClosureInspect.hs;h=9db0a189ca43ef991b3885e88ccd3b4c920cbfd7;hb=f3e5a3add2e8b5f878be96d7b04ef52e3c39a211;hp=0624169178befafdf9cae8c42e9c341fa883823f;hpb=bd657baa7768442553f769721effe98a3c7e58a3;p=ghc-hetmet.git diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 0624169..9db0a18 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -66,7 +66,7 @@ import GHC.Word ( Word32(..), Word64(..) ) import Control.Monad import Data.Maybe import Data.Array.Base -import Data.List ( partition ) +import Data.List ( partition, nub ) import Foreign.Storable import IO @@ -168,6 +168,7 @@ readCType i | i == BLACKHOLE = Blackhole | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i) | fromIntegral i == aP_CODE = AP + | i == AP_STACK = AP | fromIntegral i == pAP_CODE = PAP | otherwise = Other (fromIntegral i) @@ -179,6 +180,11 @@ isIndirection (Indirection _) = True --isIndirection ThunkSelector = True isIndirection _ = False +isThunk (Thunk _) = True +isThunk ThunkSelector = True +isThunk AP = True +isThunk _ = False + isFullyEvaluated :: a -> IO Bool isFullyEvaluated a = do closure <- getClosureData a @@ -469,18 +475,25 @@ cvObtainTerm :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term cvObtainTerm hsc_env force mb_ty a = do -- Obtain the term and tidy the type before returning it term <- cvObtainTerm1 hsc_env force mb_ty a - return $ tidyTypes term - where - tidyTypes = foldTerm idTermFold { - fTerm = \ty dc hval tt -> Term (tidy ty) dc hval tt, - fSuspension = \ct mb_ty hval n -> - Suspension ct (fmap tidy mb_ty) hval n - } - tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv ty) ty - tidyVarEnv ty = mkVarEnv$ - [ (v, setTyVarName v (tyVarName tv)) - | (tv,v) <- zip alphaTyVars vars] - where vars = varSetElems$ tyVarsOfType ty + let term' = tidyTypes term + return term' + where allvars = nub . foldTerm TermFold { + fTerm = \ty _ _ tt -> + varEnvElts(tyVarsOfType ty) ++ concat tt, + fSuspension = \_ mb_ty _ _ -> + maybe [] (varEnvElts . tyVarsOfType) mb_ty, + fPrim = \ _ _ -> [] } + tidyTypes term = let + go = foldTerm idTermFold { + fTerm = \ty dc hval tt -> + Term (tidy ty) dc hval tt, + fSuspension = \ct mb_ty hval n -> + Suspension ct (fmap tidy mb_ty) hval n } + tidy ty = tidyType (emptyTidyOccEnv, tidyVarEnv) ty + tidyVarEnv = mkVarEnv$ + [ (v, alpha_tv `setTyVarUnique` varUnique v) + | (alpha_tv,v) <- zip alphaTyVars (allvars term)] + in go term cvObtainTerm1 :: HscEnv -> Bool -> Maybe Type -> HValue -> IO Term cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do @@ -489,7 +502,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do Nothing -> go tv tv hval Just ty | isMonomorphic ty -> go ty ty hval Just ty -> do - (ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty) + (ty',rev_subst) <- instScheme (sigmaType ty) addConstraint tv ty' term <- go tv tv hval --restore original Tyvars @@ -504,7 +517,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do clos <- trIO $ getClosureData a case tipe clos of -- Thunks we may want to force - Thunk _ | force -> seq a $ go tv ty a + t | isThunk t && force -> seq a $ go tv ty a -- We always follow indirections Indirection _ -> go tv ty $! (ptrs clos ! 0) -- The interesting case @@ -559,7 +572,8 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do , ptext SLIT("reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) head unpointed : reOrderTerms pointed (tail unpointed) tys -isMonomorphic = isEmptyVarSet . tyVarsOfType +isMonomorphic ty | isForAllTy ty = False +isMonomorphic ty = (isEmptyVarSet . tyVarsOfType) ty zonkTerm :: Term -> TcM Term zonkTerm = foldTerm idTermFoldM {