X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FGhciMonad.hs;h=d63dfb18eab42b5a699da4ef764be9bb79aa1879;hb=cb429c8ac482f3b294f709b5ba50423fdf1f35b0;hp=63c2af76f82a75b0afcba94ac785625c43c38e25;hpb=c3ea5e95aa2498f19f99848c85b9be2b517d9e7f;p=ghc-hetmet.git

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 63c2af7..d63dfb1 100644
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -11,16 +11,20 @@ module GhciMonad where
 #include "HsVersions.h"
 
 import qualified GHC
-import {-#SOURCE#-} Debugger
-import Breakpoints
-import Outputable
-import Panic hiding (showException)
+import Outputable       hiding (printForUser)
+import qualified Outputable
+import Panic            hiding (showException)
 import Util
+import DynFlags
+import HscTypes
+import SrcLoc
+import Module
 
 import Numeric
+import Control.Concurrent
 import Control.Exception as Exception
+import Data.Array
 import Data.Char
-import Data.Dynamic
 import Data.Int         ( Int64 )
 import Data.IORef
 import Data.List
@@ -39,19 +43,93 @@ data GHCiState = GHCiState
 	args	       :: [String],
         prompt         :: String,
 	editor         :: String,
+        stop           :: String,
 	session        :: GHC.Session,
 	options        :: [GHCiOption],
         prelude        :: GHC.Module,
-        bkptTable      :: IORef (BkptTable GHC.Module),
-	topLevel       :: Bool
+        resume         :: [(SrcSpan, ThreadId, GHC.ResumeHandle)],
+        breaks         :: !ActiveBreakPoints,
+        tickarrays     :: ModuleEnv TickArray
+                -- tickarrays caches the TickArray for loaded modules,
+                -- so that we don't rebuild it each time the user sets
+                -- a breakpoint.
      }
 
+type TickArray = Array Int [(BreakIndex,SrcSpan)]
+
 data GHCiOption 
 	= ShowTiming		-- show time/allocs after evaluation
 	| ShowType		-- show the type of expressions
 	| RevertCAFs		-- revert CAFs after every evaluation
 	deriving Eq
 
+data ActiveBreakPoints
+   = ActiveBreakPoints
+   { breakCounter   :: !Int
+   , breakLocations :: ![(Int, BreakLocation)]  -- break location uniquely numbered 
+   }
+
+instance Outputable ActiveBreakPoints where
+   ppr activeBrks = prettyLocations $ breakLocations activeBrks 
+
+emptyActiveBreakPoints :: ActiveBreakPoints
+emptyActiveBreakPoints 
+   = ActiveBreakPoints { breakCounter = 0, breakLocations = [] }
+
+data BreakLocation
+   = BreakLocation
+   { breakModule :: !GHC.Module
+   , breakLoc    :: !SrcSpan
+   , breakTick   :: {-# UNPACK #-} !Int
+   } 
+   deriving Eq
+
+prettyLocations :: [(Int, BreakLocation)] -> SDoc
+prettyLocations []   = text "No active breakpoints." 
+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
+
+instance Outputable BreakLocation where
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+
+getActiveBreakPoints :: GHCi ActiveBreakPoints
+getActiveBreakPoints = liftM breaks getGHCiState 
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       newActiveBreaks = oldActiveBreaks { breakLocations = [] } 
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st
+       oldLocations    = breakLocations oldActiveBreaks
+       newLocations    = filter (\loc -> fst loc /= identity) oldLocations
+       newActiveBreaks = oldActiveBreaks { breakLocations = newLocations }   
+   setGHCiState $ st { breaks = newActiveBreaks }
+
+recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
+recordBreak brkLoc = do
+   st <- getGHCiState
+   let oldActiveBreaks = breaks st 
+   let oldLocations    = breakLocations oldActiveBreaks
+   -- don't store the same break point twice
+   case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+     (nm:_) -> return (True, nm)
+     [] -> do
+      let oldCounter = breakCounter oldActiveBreaks 
+          newCounter = oldCounter + 1
+          newActiveBreaks = 
+             oldActiveBreaks 
+             { breakCounter   = newCounter 
+             , breakLocations = (oldCounter, brkLoc) : oldLocations 
+             }
+      setGHCiState $ st { breaks = newActiveBreaks }
+      return (False, oldCounter)
+
 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
 
 startGHCi :: GHCi a -> GHCiState -> IO a
@@ -103,40 +181,29 @@ unsetOption opt
 io :: IO a -> GHCi a
 io m = GHCi { unGHCi = \s -> m >>= return }
 
-isTopLevel :: GHCi Bool
-isTopLevel = getGHCiState >>= return . topLevel
-
-getBkptTable :: GHCi (BkptTable GHC.Module)
-getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
-                  io$ readIORef table_ref
-
-setBkptTable :: BkptTable GHC.Module -> GHCi ()
-setBkptTable new_table = do 
-    table_ref <- getGHCiState >>= return . bkptTable
-    io$ writeIORef table_ref new_table
-                  
-modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
-modifyBkptTable f = do 
-    bt <- getBkptTable
-    new_bt <- io . evaluate$ f bt 
-    setBkptTable new_bt
-
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
+popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))
+popResume = do
+   st <- getGHCiState 
+   case (resume st) of
+      []     -> return Nothing
+      (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)
+         
+pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
+pushResume span threadId resumeAction = do
+   st <- getGHCiState
+   let oldResume = resume st
+   setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
+
+discardResumeContext :: GHCi ()
+discardResumeContext = do
+   st <- getGHCiState
+   setGHCiState st { resume = [] }
+
+printForUser :: SDoc -> GHCi ()
+printForUser doc = do
   session <- getSession
   unqual <- io (GHC.getPrintUnqual session)
-  return $! showSDocForUser unqual doc
-
--- --------------------------------------------------------------------------
--- Inferior Sessions Exceptions (used by the debugger)
-
-data InfSessionException = 
-             StopChildSession -- A child session requests to be stopped
-           | StopParentSession -- A child session requests to be stopped 
-                               -- AND that the parent session quits after that
-           | ChildSessionStopped String  -- A child session has stopped
-  deriving Typeable
-
+  io $ Outputable.printForUser stdout unqual doc
 
 -- --------------------------------------------------------------------------
 -- timing & statistics
@@ -205,8 +272,14 @@ flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
 
 initInterpBuffering :: GHC.Session -> IO ()
 initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-	
+ = do -- we don't want to be fooled by any modules lying around in the current
+      -- directory when we compile these code fragments, so set the import
+      -- path to be empty while we compile them.
+      dflags <- GHC.getSessionDynFlags session
+      GHC.setSessionDynFlags session dflags{importPaths=[]}
+
+      maybe_hval <- GHC.compileExpr session no_buf_cmd
+
       case maybe_hval of
 	Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
 	other	  -> panic "interactiveUI:setBuffering"
@@ -216,6 +289,8 @@ initInterpBuffering session
 	Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
 	_         -> panic "interactiveUI:flush"
 
+      GHC.setSessionDynFlags session dflags
+      GHC.workingDirectoryChanged session
       return ()