X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FInteractiveEval.hs;h=42f0922370d4e0278935232d3700814dc274ff91;hb=485b80f9c422e49a441ec0b175c39799630171da;hp=7ed6fac6291e82913e1f1197c98da7a3268c1758;hpb=e1b8996040150d5b4027ebd50c2df1f24d79a531;p=ghc-hetmet.git

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 7ed6fac..42f0922 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -58,6 +58,7 @@ import Module
 import Panic
 import UniqFM
 import Maybes
+import ErrUtils
 import Util
 import SrcLoc
 import BreakArray
@@ -431,8 +432,18 @@ bindLocalsAtBreakpoint hsc_env apStack info = do
                     | 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";
@@ -460,7 +471,7 @@ bindLocalsAtBreakpoint hsc_env apStack info = do
    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
@@ -485,19 +496,15 @@ skolemiseTyVar :: TyVar -> TyVar
 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 }
@@ -515,8 +522,9 @@ abandon (Session ref) = do
        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
@@ -525,11 +533,26 @@ abandonAll (Session ref) = do
    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
 
@@ -549,7 +572,7 @@ consBL a (BL len bound left right)
 
 toListBL (BL _ _ left right) = left ++ reverse right
 
-lenBL (BL len _ _ _) = len
+-- lenBL (BL len _ _ _) = len
 
 -- -----------------------------------------------------------------------------
 -- | Set the interactive evaluation context.
@@ -761,11 +784,9 @@ isModuleInterpreted s mod_summary = withSession s $ \hsc_env ->
 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 */