Commit b5986072 authored by Simon Marlow's avatar Simon Marlow

force APs, AP_STACKs and ThunkSelectors in :force

parent 7ba2a2ea
...@@ -168,6 +168,7 @@ readCType i ...@@ -168,6 +168,7 @@ readCType i
| i == BLACKHOLE = Blackhole | i == BLACKHOLE = Blackhole
| i >= IND && i <= IND_STATIC = Indirection (fromIntegral i) | i >= IND && i <= IND_STATIC = Indirection (fromIntegral i)
| fromIntegral i == aP_CODE = AP | fromIntegral i == aP_CODE = AP
| i == AP_STACK = AP
| fromIntegral i == pAP_CODE = PAP | fromIntegral i == pAP_CODE = PAP
| otherwise = Other (fromIntegral i) | otherwise = Other (fromIntegral i)
...@@ -179,6 +180,11 @@ isIndirection (Indirection _) = True ...@@ -179,6 +180,11 @@ isIndirection (Indirection _) = True
--isIndirection ThunkSelector = True --isIndirection ThunkSelector = True
isIndirection _ = False isIndirection _ = False
isThunk (Thunk _) = True
isThunk ThunkSelector = True
isThunk AP = True
isThunk _ = False
isFullyEvaluated :: a -> IO Bool isFullyEvaluated :: a -> IO Bool
isFullyEvaluated a = do isFullyEvaluated a = do
closure <- getClosureData a closure <- getClosureData a
...@@ -489,7 +495,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do ...@@ -489,7 +495,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
Nothing -> go tv tv hval Nothing -> go tv tv hval
Just ty | isMonomorphic ty -> go ty ty hval Just ty | isMonomorphic ty -> go ty ty hval
Just ty -> do Just ty -> do
(ty',rev_subst) <- instScheme (sigmaType$ fromJust mb_ty) (ty',rev_subst) <- instScheme (sigmaType ty)
addConstraint tv ty' addConstraint tv ty'
term <- go tv tv hval term <- go tv tv hval
--restore original Tyvars --restore original Tyvars
...@@ -504,7 +510,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do ...@@ -504,7 +510,7 @@ cvObtainTerm1 hsc_env force mb_ty hval = runTR hsc_env $ do
clos <- trIO $ getClosureData a clos <- trIO $ getClosureData a
case tipe clos of case tipe clos of
-- Thunks we may want to force -- 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 -- We always follow indirections
Indirection _ -> go tv ty $! (ptrs clos ! 0) Indirection _ -> go tv ty $! (ptrs clos ! 0)
-- The interesting case -- The interesting case
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment