X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FGHC.hs;h=3b1d91746b964be95fb332df5622f8d60d0ec47a;hb=4a8ca58413c836cc24f88c1b4753893598e9ff9c;hp=972004912b657250b8e7cba2951f12df9ad34bf4;hpb=0de47da80eaa9db8acd5c878983643b19431f1be;p=ghc-hetmet.git diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 9720049..3b1d917 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -87,6 +87,7 @@ module GHC ( obtainTerm, obtainTerm1, ModBreaks(..), BreakIndex, BreakInfo(breakInfo_number, breakInfo_module), + BreakArray, setBreakOn, setBreakOff, getBreak, modInfoModBreaks, #endif @@ -163,6 +164,14 @@ module GHC ( -- ** Source locations SrcLoc, pprDefnLoc, + mkSrcLoc, isGoodSrcLoc, + srcLocFile, srcLocLine, srcLocCol, + SrcSpan, + mkSrcSpan, srcLocSpan, + srcSpanStart, srcSpanEnd, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, -- * Exceptions GhcException(..), showGhcException, @@ -190,14 +199,15 @@ import GHC.Exts ( unsafeCoerce#, Ptr ) import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr ) import Foreign ( poke ) import qualified Linker +import Linker ( HValue ) import Data.Dynamic ( Dynamic ) -import Linker ( HValue, getHValue, extendLinkEnv ) import ByteCodeInstr import DebuggerTys import IdInfo import HscMain ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt ) +import BreakArray #endif import Packages @@ -2130,10 +2140,27 @@ data RunResult | RunBreak ThreadId [Name] BreakInfo ResumeHandle data Status - = Break HValue BreakInfo ThreadId ResumeHandle -- ^ the computation hit a breakpoint - | Complete (Either Exception [HValue]) -- ^ the computation completed with either an exception or a value - -data ResumeHandle = ResumeHandle (MVar ()) (MVar Status) [Name] + = Break HValue BreakInfo ThreadId + -- ^ the computation hit a breakpoint + | Complete (Either Exception [HValue]) + -- ^ the computation completed with either an exception or a value + +-- | This is a token given back to the client when runStmt stops at a +-- breakpoint. It allows the original computation to be resumed, restoring +-- the old interactive context. +data ResumeHandle + = ResumeHandle + (MVar ()) -- breakMVar + (MVar Status) -- statusMVar + [Name] -- [Name] to bind on completion + InteractiveContext -- IC on completion + InteractiveContext -- IC to restore on resumption + [Name] -- [Name] to remove from the link env + +-- We need to track two InteractiveContexts: +-- - the IC before runStmt, which is restored on each resume +-- - the IC binding the results of the original statement, which +-- will be the IC when runStmt returns with RunOk. -- | Run a statement in the current interactive context. Statement -- may bind multple values. @@ -2154,37 +2181,40 @@ runStmt (Session ref) expr case maybe_stuff of Nothing -> return RunFailed - Just (new_hsc_env, names, hval) -> do - writeIORef ref new_hsc_env + Just (new_IC, names, hval) -> do - let resume_handle = ResumeHandle breakMVar statusMVar names -- set the onBreakAction to be performed when we hit a -- breakpoint this is visible in the Byte Code -- Interpreter, thus it is a global variable, -- implemented with stable pointers - stablePtr <- setBreakAction resume_handle + stablePtr <- setBreakAction breakMVar statusMVar 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 names status + handleRunStatus ref new_IC names (hsc_IC hsc_env) + breakMVar statusMVar status -handleRunStatus ref names status = +handleRunStatus ref final_ic final_names resume_ic breakMVar statusMVar status = case status of -- did we hit a breakpoint or did we complete? - (Break apStack info tid res) -> do + (Break apStack info tid) -> do hsc_env <- readIORef ref (new_hsc_env, names) <- extendEnvironment hsc_env apStack (breakInfo_vars info) writeIORef ref new_hsc_env + let res = ResumeHandle breakMVar statusMVar final_names + final_ic resume_ic names return (RunBreak tid names info res) (Complete either_hvals) -> case either_hvals of Left e -> return (RunException e) Right hvals -> do - extendLinkEnv (zip names hvals) - return (RunOk names) - + hsc_env <- readIORef ref + writeIORef ref hsc_env{hsc_IC=final_ic} + Linker.extendLinkEnv (zip final_names hvals) + return (RunOk final_names) + -- this points to the IO action that is executed when a breakpoint is hit foreign import ccall "&breakPointIOAction" breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) @@ -2200,21 +2230,33 @@ sandboxIO statusMVar thing = do putMVar interruptTargetThread (child:ts) takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail) -setBreakAction res@(ResumeHandle breakMVar statusMVar names) = do +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 res) + putMVar statusMVar (Break apStack ids tid) takeMVar breakMVar resume :: Session -> ResumeHandle -> IO RunResult -resume (Session ref) res@(ResumeHandle breakMVar statusMVar names) = do - stablePtr <- setBreakAction res - putMVar breakMVar () - status <- takeMVar statusMVar - handleRunStatus ref names status +resume (Session ref) res@(ResumeHandle breakMVar statusMVar + final_names final_ic resume_ic names) + = do + -- restore the original interactive context. This is not entirely + -- satisfactory: any new bindings made since the breakpoint stopped + -- will be dropped from the interactive context, but not from the + -- linker's environment. + hsc_env <- readIORef ref + writeIORef ref hsc_env{ hsc_IC = resume_ic } + Linker.deleteFromLinkEnv names + + stablePtr <- setBreakAction breakMVar statusMVar + 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 {- -- This version of sandboxIO runs the expression in a completely new @@ -2284,7 +2326,7 @@ extendEnvironment hsc_env apStack idsOffsets = do new_type_env = extendTypeEnvWithIds filtered_type_env (typed_ids) new_ic = ictxt { ic_rn_local_env = new_rn_env, ic_type_env = new_type_env } - extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint + Linker.extendLinkEnv (zip names hValues) return (hsc_env{hsc_IC = new_ic}, names) where globaliseAndTidy :: Id -> Id @@ -2319,7 +2361,7 @@ obtainTerm1 sess force mb_ty x = withSession sess $ \hsc_env -> cvObtainTerm hsc obtainTerm :: Session -> Bool -> Id -> IO (Maybe Term) obtainTerm sess force id = withSession sess $ \hsc_env -> do - mb_v <- getHValue (varName id) + 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