X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=2a373d51d57f07e4acd1870daba28154859ec92c;hb=37d2269b4402882ea82e07d4f51b1a8a1854b91a;hp=9c7dbafe02dff88fc8aa0d922ce72392a4319647;hpb=77fc291cdb0cb1af5c42c20d48e1e39b0b5f328b;p=ghc-hetmet.git

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 9c7dbaf..2a373d5 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -257,6 +257,7 @@ import HaddockParse
 import HaddockLex       ( tokenise )
 import Unique
 
+import System.IO.Unsafe
 import Data.Array
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )
@@ -2159,6 +2160,7 @@ data Status
 -- the old interactive context.
 data ResumeHandle
   = ResumeHandle
+        ThreadId                -- thread running the computation
         (MVar ())               -- breakMVar
         (MVar Status)           -- statusMVar
         [Name]                  -- [Name] to bind on completion
@@ -2196,11 +2198,10 @@ runStmt (Session ref) expr
               -- breakpoint this is visible in the Byte Code
               -- Interpreter, thus it is a global variable,
               -- implemented with stable pointers
-              stablePtr <- setBreakAction breakMVar statusMVar
+              withBreakAction breakMVar statusMVar $ do
 
               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
               status <- sandboxIO statusMVar thing_to_run
-              freeStablePtr stablePtr -- be careful not to leak stable pointers!
               handleRunStatus ref new_IC names (hsc_IC hsc_env) 
                               breakMVar statusMVar status
 
@@ -2245,14 +2246,25 @@ sandboxIO statusMVar thing = do
   putMVar interruptTargetThread (child:ts)
   takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
 
-setBreakAction breakMVar statusMVar = do 
-  stablePtr <- newStablePtr onBreak
-  poke breakPointIOAction stablePtr
-  return stablePtr
-  where onBreak ids apStack = do
-                tid <- myThreadId
-                putMVar statusMVar (Break apStack ids tid)
-                takeMVar breakMVar
+withBreakAction breakMVar statusMVar io
+ = bracket setBreakAction resetBreakAction (\_ -> io)
+ where
+   setBreakAction = do
+     stablePtr <- newStablePtr onBreak
+     poke breakPointIOAction stablePtr
+     return stablePtr
+
+   onBreak info apStack = do
+     tid <- myThreadId
+     putMVar statusMVar (Break apStack info tid)
+     takeMVar breakMVar
+
+   resetBreakAction stablePtr = do
+     poke breakPointIOAction noBreakStablePtr
+     freeStablePtr stablePtr
+
+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
+noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
 
 resume :: Session -> ResumeHandle -> IO RunResult
 resume (Session ref) res@(ResumeHandle breakMVar statusMVar 
@@ -2266,10 +2278,9 @@ resume (Session ref) res@(ResumeHandle breakMVar statusMVar
    writeIORef ref hsc_env{ hsc_IC = resume_ic }
    Linker.deleteFromLinkEnv names
 
-   stablePtr <- setBreakAction breakMVar statusMVar
+   withBreakAction breakMVar statusMVar $ do
    putMVar breakMVar ()                 -- this awakens the stopped thread...
    status <- takeMVar statusMVar        -- and wait for the result
-   freeStablePtr stablePtr -- be careful not to leak stable pointers!
    handleRunStatus ref final_ic final_names resume_ic 
                    breakMVar statusMVar status