From: Simon Marlow Date: Wed, 25 Apr 2007 14:29:45 +0000 (+0000) Subject: force APs, AP_STACKs and ThunkSelectors in :force X-Git-Tag: 2007-05-06~104 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b5986072833796acb374e22f18cef8ab839a3419 force APs, AP_STACKs and ThunkSelectors in :force --- diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 0624169..45c5b0f 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -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 @@ -489,7 +495,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 +510,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