import Panic
import UniqFM
import Maybes
+import ErrUtils
import Util
import SrcLoc
import BreakArray
| otherwise = False
let (ids, offsets) = unzip pointers
- hValues <- mapM (getIdValFromApStack apStack) offsets
- new_ids <- zipWithM mkNewId occs ids
+
+ -- It might be that getIdValFromApStack fails, because the AP_STACK
+ -- has been accidentally evaluated, or something else has gone wrong.
+ -- So that we don't fall over in a heap when this happens, just don't
+ -- bind any free variables instead, and we emit a warning.
+ mb_hValues <- mapM (getIdValFromApStack apStack) offsets
+ let filtered_ids = [ id | (id, Just _) <- zip ids mb_hValues ]
+ when (any isNothing mb_hValues) $
+ debugTraceMsg (hsc_dflags hsc_env) 1 $
+ text "Warning: _result has been evaluated, some bindings have been lost"
+
+ new_ids <- zipWithM mkNewId occs filtered_ids
let names = map idName new_ids
-- make an Id for _result. We use the Unique of the FastString "_result";
-- _result in scope at any time.
let result_fs = FSLIT("_result")
result_name = mkInternalName (getUnique result_fs)
- (mkVarOccFS result_fs) (srcSpanStart span)
+ (mkVarOccFS result_fs) span
result_id = Id.mkLocalId result_name result_ty
-- for each Id we're about to bind in the local envt:
let ictxt0 = hsc_IC hsc_env
ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars
- Linker.extendLinkEnv (zip names hValues)
+ Linker.extendLinkEnv [ (name,hval) | (name, Just hval) <- zip names mb_hValues ]
Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
return (hsc_env{ hsc_IC = ictxt1 }, result_name:names, span)
where
mkNewId :: OccName -> Id -> IO Id
mkNewId occ id = do
let uniq = idUnique id
- loc = nameSrcLoc (idName id)
+ loc = nameSrcSpan (idName id)
name = mkInternalName uniq occ loc
ty = idType id
new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
(SkolemTv RuntimeUnkSkol)
--- Todo: turn this into a primop, and provide special version(s) for
--- unboxed things
-foreign import ccall unsafe "rts_getApStackVal"
- getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: HValue -> Int -> IO HValue
-getIdValFromApStack apStack stackDepth = do
- apSptr <- newStablePtr apStack
- resultSptr <- getApStackVal apSptr (stackDepth - 1)
- result <- deRefStablePtr resultSptr
- freeStablePtr apSptr
- freeStablePtr resultSptr
- return (unsafeCoerce# result)
+getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)
+getIdValFromApStack apStack (I# stackDepth) = do
+ case getApStackVal# apStack (stackDepth +# 1#) of
+ -- The +1 is magic! I don't know where it comes
+ -- from, but this makes things line up. --SDM
+ (# ok, result #) ->
+ case ok of
+ 0# -> return Nothing -- AP_STACK not found
+ _ -> return (Just (unsafeCoerce# result))
pushResume :: HscEnv -> Resume -> HscEnv
pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }
resume = ic_resume ic
case resume of
[] -> return False
- _:rs -> do
+ r:rs -> do
writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = rs } }
+ abandon_ r
return True
abandonAll :: Session -> IO Bool
let ic = hsc_IC hsc_env
resume = ic_resume ic
case resume of
- [] -> return False
- _:rs -> do
+ [] -> return False
+ rs -> do
writeIORef ref hsc_env{ hsc_IC = ic { ic_resume = [] } }
+ mapM_ abandon_ rs
return True
+-- when abandoning a computation we have to
+-- (a) kill the thread with an async exception, so that the
+-- computation itself is stopped, and
+-- (b) fill in the MVar. This step is necessary because any
+-- thunks that were under evaluation will now be updated
+-- with the partial computation, which still ends in takeMVar,
+-- so any attempt to evaluate one of these thunks will block
+-- unless we fill in the MVar.
+-- See test break010.
+abandon_ :: Resume -> IO ()
+abandon_ r = do
+ killThread (resumeThreadId r)
+ putMVar (resumeBreakMVar r) ()
+
-- -----------------------------------------------------------------------------
-- Bounded list, optimised for repeated cons
toListBL (BL _ _ left right) = left ++ reverse right
-lenBL (BL len _ _ _) = len
+-- lenBL (BL len _ _ _) = len
-- -----------------------------------------------------------------------------
-- | Set the interactive evaluation context.
obtainTerm1 :: Session -> Bool -> Maybe Type -> a -> IO Term
obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc_env force mb_ty (unsafeCoerce# x)
-obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term)
+obtainTerm :: Session -> Bool -> Id -> IO Term
obtainTerm sess force id = withSession sess $ \hsc_env -> do
- mb_v <- Linker.getHValue (varName id)
- case mb_v of
- Just v -> fmap Just$ cvObtainTerm hsc_env force (Just$ idType id) v
- Nothing -> return Nothing
+ hv <- Linker.getHValue hsc_env (varName id)
+ cvObtainTerm hsc_env force (Just$ idType id) hv
#endif /* GHCI */
projects / ghc-hetmet.git / blobdiff