Add history/trace functionality to the GHCi debugger

The debugger can now log each step of the evaluation without actually
stopping, keeping a history of the recent steps (currently 50).  When
a (real) breakpoint is hit, you can examine previous steps in the
history (and their free variables) using the :history, :back and
:forward commands.

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 5086022..d380463 100644 (file)
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -21,7 +21,6 @@ import SrcLoc
 import Module
 
 import Numeric
 import Module
 
 import Numeric

-import Control.Concurrent

 import Control.Exception as Exception
 import Data.Array
 import Data.Char
 import Control.Exception as Exception
 import Data.Array
 import Data.Char

@@ -47,7 +46,8 @@ data GHCiState = GHCiState
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: GHC.Module,
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: GHC.Module,

-        breaks         :: !ActiveBreakPoints,
+        break_ctr      :: !Int,
+        breaks         :: ![(Int, BreakLocation)],

         tickarrays     :: ModuleEnv TickArray
                 -- tickarrays caches the TickArray for loaded modules,
                 -- so that we don't rebuild it each time the user sets
         tickarrays     :: ModuleEnv TickArray
                 -- tickarrays caches the TickArray for loaded modules,
                 -- so that we don't rebuild it each time the user sets

@@ -62,19 +62,6 @@ data GHCiOption
        | RevertCAFs            -- revert CAFs after every evaluation
        deriving Eq
 
        | 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
 data BreakLocation
    = BreakLocation
    { breakModule :: !GHC.Module

@@ -90,43 +77,19 @@ prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $
 instance Outputable BreakLocation where
    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
 
 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 
 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
    -- don't store the same break point twice

-   case [ nm | (nm, loc) <- oldLocations, loc == brkLoc ] of
+   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of

      (nm:_) -> return (True, nm)
      [] -> do
      (nm:_) -> return (True, nm)
      [] -> do

-      let oldCounter = breakCounter oldActiveBreaks 
+      let oldCounter = break_ctr st

           newCounter = oldCounter + 1
           newCounter = oldCounter + 1

-          newActiveBreaks = 
-             oldActiveBreaks 
-             { breakCounter   = newCounter 
-             , breakLocations = (oldCounter, brkLoc) : oldLocations 
-             }
-      setGHCiState $ st { breaks = newActiveBreaks }
+      setGHCiState $ st { break_ctr = newCounter,
+                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
+                        }

       return (False, oldCounter)
 
 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
       return (False, oldCounter)
 
 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index fc4f30d..ad708f5 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -21,7 +21,7 @@ import Debugger
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
                           Type, Module, ModuleName, TyThing(..), Phase,

-                          BreakIndex, Name, SrcSpan, Resume )
+                          BreakIndex, Name, SrcSpan, Resume, SingleStep )

 import DynFlags
 import Packages
 import PackageConfig
 import DynFlags
 import Packages
 import PackageConfig

@@ -104,6 +104,7 @@ builtin_commands = [
   ("add",      keepGoingPaths addModule,       False, completeFilename),
   ("abandon",   keepGoing abandonCmd,           False, completeNone),
   ("break",     keepGoing breakCmd,             False, completeIdentifier),
   ("add",      keepGoingPaths addModule,       False, completeFilename),
   ("abandon",   keepGoing abandonCmd,           False, completeNone),
   ("break",     keepGoing breakCmd,             False, completeIdentifier),

+  ("back",      keepGoing backCmd,              False, completeNone),

   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("check",    keepGoing checkModule,          False, completeHomeModule),
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("cd",       keepGoing changeDirectory,      False, completeFilename),
   ("check",    keepGoing checkModule,          False, completeHomeModule),

@@ -115,7 +116,9 @@ builtin_commands = [
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("force",     keepGoing forceCmd,             False, completeIdentifier),
   ("edit",     keepGoing editFile,             False, completeFilename),
   ("etags",    keepGoing createETagsFileCmd,   False, completeFilename),
   ("force",     keepGoing forceCmd,             False, completeIdentifier),

+  ("forward",   keepGoing forwardCmd,           False, completeNone),

   ("help",     keepGoing help,                 False, completeNone),
   ("help",     keepGoing help,                 False, completeNone),

+  ("history",   keepGoing historyCmd,           False, completeNone), 

   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("load",     keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("load",     keepGoingPaths loadModule_,     False, completeHomeModuleOrFile),

@@ -130,6 +133,7 @@ builtin_commands = [
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),
   ("sprint",    keepGoing sprintCmd,            False, completeIdentifier),
   ("step",      stepCmd,                        False, completeIdentifier), 
   ("type",     keepGoing typeOfExpr,           False, completeIdentifier),

+  ("trace",     traceCmd,                       False, completeIdentifier), 

   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ]
   ("undef",     keepGoing undefineMacro,       False, completeMacro),
   ("unset",    keepGoing unsetOptions,         True,  completeSetOptions)
   ]

@@ -268,7 +272,8 @@ interactiveUI session srcs maybe_expr = do
                   session = session,
                   options = [],
                    prelude = prel_mod,
                   session = session,
                   options = [],
                    prelude = prel_mod,

-                   breaks = emptyActiveBreakPoints,
+                   break_ctr = 0,
+                   breaks = [],

                    tickarrays = emptyModuleEnv
                  }
 
                    tickarrays = emptyModuleEnv
                  }
 

@@ -412,11 +417,9 @@ checkPerms name =
 
 fileLoop :: Handle -> Bool -> GHCi ()
 fileLoop hdl show_prompt = do
 
 fileLoop :: Handle -> Bool -> GHCi ()
 fileLoop hdl show_prompt = do

-   session <- getSession
-   (mod,imports) <- io (GHC.getContext session)
-   st <- getGHCiState
-   resumes <- io $ GHC.getResumeContext session
-   when show_prompt (io (putStr (mkPrompt mod imports resumes (prompt st))))
+   when show_prompt $ do
+        prompt <- mkPrompt
+        (io (putStr prompt))

    l <- io (IO.try (hGetLine hdl))
    case l of
        Left e | isEOFError e              -> return ()
    l <- io (IO.try (hGetLine hdl))
    case l of
        Left e | isEOFError e              -> return ()

@@ -441,25 +444,40 @@ stringLoop (s:ss) = do
        l  -> do quit <- runCommand l
                  if quit then return True else stringLoop ss
 
        l  -> do quit <- runCommand l
                  if quit then return True else stringLoop ss
 

-mkPrompt toplevs exports resumes prompt
-  = showSDoc $ f prompt
-    where
-        f ('%':'s':xs) = perc_s <> f xs
-        f ('%':'%':xs) = char '%' <> f xs
-        f (x:xs) = char x <> f xs
-        f [] = empty
-    
-        perc_s
-          | eval:rest <- resumes 
-          = (if not (null rest) then text "... " else empty)
-            <> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt
-          | otherwise
-          = modules_prompt
-
-        modules_prompt = 
+mkPrompt = do
+  session <- getSession
+  (toplevs,exports) <- io (GHC.getContext session)
+  resumes <- io $ GHC.getResumeContext session
+
+  context_bit <-
+        case resumes of
+            [] -> return empty
+            r:rs -> do
+                let ix = GHC.resumeHistoryIx r
+                if ix == 0
+                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)
+                   else do
+                        let hist = GHC.resumeHistory r !! (ix-1)
+                        span <- io $ GHC.getHistorySpan session hist
+                        return (brackets (ppr (negate ix) <> char ':' 
+                                          <+> ppr span) <> space)
+  let
+        dots | r:rs <- resumes, not (null rs) = text "... "
+             | otherwise = empty
+
+        modules_bit = 

              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
              hsep (map (ppr . GHC.moduleName) exports)
 
              hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
              hsep (map (ppr . GHC.moduleName) exports)
 

+        deflt_prompt = dots <> context_bit <> modules_bit
+
+        f ('%':'s':xs) = deflt_prompt <> f xs
+        f ('%':'%':xs) = char '%' <> f xs
+        f (x:xs) = char x <> f xs
+        f [] = empty
+   --
+  st <- getGHCiState
+  return (showSDoc (f (prompt st)))

 
 
 #ifdef USE_READLINE
 
 
 #ifdef USE_READLINE

@@ -470,9 +488,9 @@ readlineLoop = do
    io yield
    saveSession -- for use by completion
    st <- getGHCiState
    io yield
    saveSession -- for use by completion
    st <- getGHCiState

-   resumes <- io $ GHC.getResumeContext session
-   l <- io (readline (mkPrompt mod imports resumes (prompt st))
-               `finally` setNonBlockingFD 0)
+   mb_span <- getCurrentBreakSpan
+   prompt <- mkPrompt
+   l <- io (readline prompt `finally` setNonBlockingFD 0)

                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library
    splatSavedSession
                -- readline sometimes puts stdin into blocking mode,
                -- so we need to put it back for the IO library
    splatSavedSession

@@ -492,7 +510,7 @@ runCommand c = ghciHandle handler (doCommand c)
   where 
     doCommand (':' : command) = specialCommand command
     doCommand stmt
   where 
     doCommand (':' : command) = specialCommand command
     doCommand stmt

-       = do timeIt $ runStmt stmt
+       = do timeIt $ runStmt stmt GHC.RunToCompletion

             return False
 
 -- This version is for the GHC command-line option -e.  The only difference
             return False
 
 -- This version is for the GHC command-line option -e.  The only difference

@@ -506,20 +524,20 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
 
     doCommand (':' : command) = specialCommand command
     doCommand stmt
 
     doCommand (':' : command) = specialCommand command
     doCommand stmt

-       = do r <- runStmt stmt
+       = do r <- runStmt stmt GHC.RunToCompletion

            case r of 
                False -> io (exitWith (ExitFailure 1))
                  -- failure to run the command causes exit(1) for ghc -e.
                _       -> return True
 
            case r of 
                False -> io (exitWith (ExitFailure 1))
                  -- failure to run the command causes exit(1) for ghc -e.
                _       -> return True
 

-runStmt :: String -> GHCi Bool
-runStmt stmt
+runStmt :: String -> SingleStep -> GHCi Bool
+runStmt stmt step

  | null (filter (not.isSpace) stmt) = return False
  | otherwise
  = do st <- getGHCiState
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $
  | null (filter (not.isSpace) stmt) = return False
  | otherwise
  = do st <- getGHCiState
       session <- getSession
       result <- io $ withProgName (progname st) $ withArgs (args st) $

-                    GHC.runStmt session stmt
+                    GHC.runStmt session stmt step

       afterRunStmt result
       return False
 
       afterRunStmt result
       return False
 

@@ -527,7 +545,6 @@ runStmt stmt
 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 afterRunStmt run_result = do
   mb_result <- switchOnRunResult run_result
 afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
 afterRunStmt run_result = do
   mb_result <- switchOnRunResult run_result

-

   -- possibly print the type and revert CAFs after evaluating an expression
   show_types <- isOptionSet ShowType
   session <- getSession
   -- possibly print the type and revert CAFs after evaluating an expression
   show_types <- isOptionSet ShowType
   session <- getSession

@@ -593,9 +610,29 @@ lookupCommand str = do
                [] -> return Nothing
                c:_ -> return (Just c)
 
                [] -> return Nothing
                c:_ -> return (Just c)
 

+
+getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
+getCurrentBreakSpan = do
+  session <- getSession
+  resumes <- io $ GHC.getResumeContext session
+  case resumes of
+    [] -> return Nothing
+    (r:rs) -> do
+        let ix = GHC.resumeHistoryIx r
+        if ix == 0
+           then return (Just (GHC.resumeSpan r))
+           else do
+                let hist = GHC.resumeHistory r !! (ix-1)
+                span <- io $ GHC.getHistorySpan session hist
+                return (Just span)
+

 -----------------------------------------------------------------------------
 -- Commands
 
 -----------------------------------------------------------------------------
 -- Commands
 

+noArgs :: GHCi () -> String -> GHCi ()
+noArgs m "" = m
+noArgs m _ = io $ putStrLn "This command takes no arguments"
+

 help :: String -> GHCi ()
 help _ = io (putStr helpText)
 
 help :: String -> GHCi ()
 help _ = io (putStr helpText)
 

@@ -1149,8 +1186,8 @@ cleanType ty = do
 
 showBkptTable :: GHCi ()
 showBkptTable = do
 
 showBkptTable :: GHCi ()
 showBkptTable = do

-   activeBreaks <- getActiveBreakPoints 
-   printForUser $ ppr activeBreaks 
+  st <- getGHCiState
+  printForUser $ prettyLocations (breaks st)

 
 showContext :: GHCi ()
 showContext = do
 
 showContext :: GHCi ()
 showContext = do

@@ -1375,33 +1412,32 @@ pprintCommand bind force str = do
   io $ pprintClosureCommand session bind force str
 
 stepCmd :: String -> GHCi Bool
   io $ pprintClosureCommand session bind force str
 
 stepCmd :: String -> GHCi Bool

-stepCmd [] = doContinue True
-stepCmd expression = do
-   runCommand expression
+stepCmd []         = doContinue GHC.SingleStep
+stepCmd expression = runStmt expression GHC.SingleStep
+
+traceCmd :: String -> GHCi Bool
+traceCmd []         = doContinue GHC.RunAndLogSteps
+traceCmd expression = runStmt expression GHC.RunAndLogSteps

 
 continueCmd :: String -> GHCi Bool
 
 continueCmd :: String -> GHCi Bool

-continueCmd [] = doContinue False
+continueCmd [] = doContinue GHC.RunToCompletion

 continueCmd other = do
    io $ putStrLn "The continue command accepts no arguments."
    return False
 
 continueCmd other = do
    io $ putStrLn "The continue command accepts no arguments."
    return False
 

-doContinue :: Bool -> GHCi Bool
+doContinue :: SingleStep -> GHCi Bool

 doContinue step = do 
   session <- getSession
 doContinue step = do 
   session <- getSession

-  let resume | step      = GHC.stepResume
-             | otherwise = GHC.resume
-  runResult <- io $ resume session
+  runResult <- io $ GHC.resume session step

   afterRunStmt runResult
   return False
 
 abandonCmd :: String -> GHCi ()
   afterRunStmt runResult
   return False
 
 abandonCmd :: String -> GHCi ()

-abandonCmd "" = do
+abandonCmd = noArgs $ do

   s <- getSession
   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
   when (not b) $ io $ putStrLn "There is no computation running."
   return ()
   s <- getSession
   b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
   when (not b) $ io $ putStrLn "There is no computation running."
   return ()

-abandonCmd _ = do
-   io $ putStrLn "The abandon command accepts no arguments."

 
 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do
 
 deleteCmd :: String -> GHCi ()
 deleteCmd argLine = do

@@ -1420,6 +1456,41 @@ deleteCmd argLine = do
          | all isDigit str = deleteBreak (read str)
          | otherwise = return ()
 
          | all isDigit str = deleteBreak (read str)
          | otherwise = return ()
 

+historyCmd :: String -> GHCi ()
+historyCmd = noArgs $ do
+  s <- getSession
+  resumes <- io $ GHC.getResumeContext s
+  case resumes of
+    [] -> io $ putStrLn "Not stopped at a breakpoint"
+    (r:rs) -> do
+      let hist = GHC.resumeHistory r
+      spans <- mapM (io . GHC.getHistorySpan s) hist
+      printForUser (vcat (map ppr spans))
+
+backCmd :: String -> GHCi ()
+backCmd = noArgs $ do
+  s <- getSession
+  (names, ix, span) <- io $ GHC.back s
+  printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
+  mapM_ (showTypeOfName s) names
+   -- run the command set with ":set stop <cmd>"
+  st <- getGHCiState
+  runCommand (stop st)
+  return ()
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ do
+  s <- getSession
+  (names, ix, span) <- io $ GHC.forward s
+  printForUser $ (if (ix == 0)
+                    then ptext SLIT("Stopped at")
+                    else ptext SLIT("Logged breakpoint at")) <+> ppr span
+  mapM_ (showTypeOfName s) names
+   -- run the command set with ":set stop <cmd>"
+  st <- getGHCiState
+  runCommand (stop st)
+  return ()
+

 -- handle the "break" command
 breakCmd :: String -> GHCi ()
 breakCmd argLine = do
 -- handle the "break" command
 breakCmd :: String -> GHCi ()
 breakCmd argLine = do

@@ -1566,11 +1637,10 @@ end_bold   = BS.pack "\ESC[0m"
 
 listCmd :: String -> GHCi ()
 listCmd str = do
 
 listCmd :: String -> GHCi ()
 listCmd str = do

-   session <- getSession
-   resumes <- io $ GHC.getResumeContext session
-   case resumes of
-      []  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
-      eval:_ -> io $ listAround (GHC.resumeSpan eval) True
+   mb_span <- getCurrentBreakSpan
+   case mb_span of
+      Nothing  -> printForUser $ text "not stopped at a breakpoint; nothing to list"
+      Just span -> io $ listAround span True

 
 -- | list a section of a source file around a particular SrcSpan.
 -- If the highlight flag is True, also highlight the span using
 
 -- | list a section of a source file around a particular SrcSpan.
 -- If the highlight flag is True, also highlight the span using

@@ -1646,6 +1716,33 @@ mkTickArray ticks
         srcSpanLines span = [ GHC.srcSpanStartLine span .. 
                               GHC.srcSpanEndLine span ]
 
         srcSpanLines span = [ GHC.srcSpanStartLine span .. 
                               GHC.srcSpanEndLine span ]
 

+lookupModule :: Session -> String -> GHCi Module
+lookupModule session modName
+   = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+   st <- getGHCiState
+   mapM (turnOffBreak.snd) (breaks st)
+   setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+   st <- getGHCiState
+   let oldLocations    = breaks st
+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations
+   if null this 
+      then printForUser (text "Breakpoint" <+> ppr identity <+>
+                         text "does not exist")
+      else do
+           mapM (turnOffBreak.snd) this
+           setGHCiState $ st { breaks = rest }
+
+turnOffBreak loc = do
+  (arr, _) <- getModBreak (breakModule loc)
+  io $ setBreakFlag False arr (breakTick loc)
+

 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
 getModBreak mod = do
    session <- getSession
 getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
 getModBreak mod = do
    session <- getSession

@@ -1655,28 +1752,8 @@ getModBreak mod = do
    let ticks      = GHC.modBreaks_locs  modBreaks
    return (array, ticks)
 
    let ticks      = GHC.modBreaks_locs  modBreaks
    return (array, ticks)
 

-lookupModule :: Session -> String -> GHCi Module
-lookupModule session modName
-   = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-

 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool 
 setBreakFlag toggle array index
    | toggle    = GHC.setBreakOn array index 
    | otherwise = GHC.setBreakOff array index
 
 setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool 
 setBreakFlag toggle array index
    | toggle    = GHC.setBreakOn array index 
    | otherwise = GHC.setBreakOff array index
 

-
-{- these should probably go to the GHC API at some point -}
-enableBreakPoint  :: Session -> Module -> Int -> IO ()
-enableBreakPoint session mod index = return ()
-
-disableBreakPoint :: Session -> Module -> Int -> IO ()
-disableBreakPoint session mod index = return ()
-
-activeBreakPoints :: Session -> IO [(Module,Int)]
-activeBreakPoints session = return []
-
-enableSingleStep  :: Session -> IO ()
-enableSingleStep session = return ()
-
-disableSingleStep :: Session -> IO ()
-disableSingleStep session = return ()

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 97d21fc..af1a817 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -78,11 +78,15 @@ module GHC (
        typeKind,
        parseName,
        RunResult(..),  
        typeKind,
        parseName,
        RunResult(..),  

-       runStmt, stepStmt, -- traceStmt,
-        resume,  stepResume, -- traceResume,
-        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan),
+       runStmt, SingleStep(..),
+        resume,
+        Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
+               resumeHistory, resumeHistoryIx),
+        History(historyBreakInfo), getHistorySpan,

         getResumeContext,
         abandon, abandonAll,
         getResumeContext,
         abandon, abandonAll,

+        InteractiveEval.back,
+        InteractiveEval.forward,

        showModule,
         isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,
        showModule,
         isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,

diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index ef9e5af..7ed6fac 100644 (file)
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -8,11 +8,13 @@
 
 module InteractiveEval (
 #ifdef GHCI
 
 module InteractiveEval (
 #ifdef GHCI

-        RunResult(..), Status(..), Resume(..),
-       runStmt, stepStmt, -- traceStmt,
-        resume,  stepResume, -- traceResume,
+        RunResult(..), Status(..), Resume(..), History(..),
+       runStmt, SingleStep(..),
+        resume,

         abandon, abandonAll,
         getResumeContext,
         abandon, abandonAll,
         getResumeContext,

+        getHistorySpan,
+        back, forward,

        setContext, getContext, 
         nameSetToGlobalRdrEnv,
        getNamesInScope,
        setContext, getContext, 
         nameSetToGlobalRdrEnv,
        getNamesInScope,

@@ -58,6 +60,7 @@ import UniqFM
 import Maybes
 import Util
 import SrcLoc
 import Maybes
 import Util
 import SrcLoc

+import BreakArray

 import RtClosureInspect
 import Packages
 import BasicTypes
 import RtClosureInspect
 import Packages
 import BasicTypes

@@ -99,9 +102,11 @@ data Resume
        resumeApStack   :: HValue,       -- The object from which we can get
                                         -- value of the free variables.
        resumeBreakInfo :: BreakInfo,    -- the breakpoint we stopped at.
        resumeApStack   :: HValue,       -- The object from which we can get
                                         -- value of the free variables.
        resumeBreakInfo :: BreakInfo,    -- the breakpoint we stopped at.

-       resumeSpan      :: SrcSpan       -- just a cache, otherwise it's a pain
+       resumeSpan      :: SrcSpan,      -- just a cache, otherwise it's a pain

                                         -- to fetch the ModDetails & ModBreaks
                                         -- to get this.
                                         -- to fetch the ModDetails & ModBreaks
                                         -- to get this.

+       resumeHistory   :: [History],
+       resumeHistoryIx :: Int           -- 0 <==> at the top of the history

    }
 
 getResumeContext :: Session -> IO [Resume]
    }
 
 getResumeContext :: Session -> IO [Resume]

@@ -115,37 +120,46 @@ data SingleStep
 isStep RunToCompletion = False
 isStep _ = True
 
 isStep RunToCompletion = False
 isStep _ = True
 

--- type History = [HistoryItem]
--- 
--- data HistoryItem = HistoryItem HValue BreakInfo
--- 
--- historyBreakInfo :: HistoryItem -> BreakInfo
--- historyBreakInfo (HistoryItem _ bi) = bi
--- 
--- setContextToHistoryItem :: Session -> HistoryItem -> IO ()
--- setContextToHistoryItem
-
--- 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.
-runStmt :: Session -> String -> IO RunResult
-runStmt session expr = runStmt_ session expr RunToCompletion
+data History
+   = History {
+        historyApStack   :: HValue,
+        historyBreakInfo :: BreakInfo
+   }

 
 

--- | Run a statement, stopping at the first breakpoint location encountered
--- (regardless of whether the breakpoint is enabled).
-stepStmt :: Session -> String -> IO RunResult
-stepStmt session expr = runStmt_ session expr SingleStep
+getHistorySpan :: Session -> History -> IO SrcSpan
+getHistorySpan s hist = withSession s $ \hsc_env -> do
+   let inf = historyBreakInfo hist 
+       num = breakInfo_number inf
+   case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
+       Just hmi -> return (modBreaks_locs (md_modBreaks (hm_details hmi)) ! num)
+       _ -> panic "getHistorySpan"

 
 

--- | Run a statement, logging breakpoints passed, and stopping when either
--- an enabled breakpoint is reached, or the statement completes.
--- traceStmt :: Session -> String -> IO (RunResult, History)
--- traceStmt session expr = runStmt_ session expr RunAndLogSteps
+{-
+ [Main.hs:42:(1,0)-(3,52)] *Main> :history 2
+ Foo.hs:1:3-5
+ Bar.hs:5:23-48
+ [Main.hs:42:(1,0)-(3,52)] *Main> :back
+ Logged breakpoint at Foo.hs:1:3-5
+ x :: Int
+ y :: a
+ _result :: [Char]
+ [-1: Foo.hs:1:3-5] *Main> :back
+ Logged breakpoint at Bar.hs:5:23-48
+ z :: a
+ _result :: Float
+ [-2: Bar.hs:5:23-48] *Main> :forward
+ Logged breakpoint at Foo.hs:1:3-5
+ x :: Int
+ y :: a
+ _result :: [Char]
+ [-1: Foo.hs:1:3-5] *Main> :cont
+ .. continues
+-} 

 
 

-runStmt_ (Session ref) expr step
+-- | Run a statement in the current interactive context.  Statement
+-- may bind multple values.
+runStmt :: Session -> String -> SingleStep -> IO RunResult
+runStmt (Session ref) expr step

    = do 
        hsc_env <- readIORef ref
 
    = do 
        hsc_env <- readIORef ref
 

@@ -176,23 +190,29 @@ runStmt_ (Session ref) expr step
 
               let ic = hsc_IC hsc_env
                   bindings = (ic_tmp_ids ic, ic_tyvars ic)
 
               let ic = hsc_IC hsc_env
                   bindings = (ic_tmp_ids ic, ic_tyvars ic)

-              handleRunStatus expr ref bindings ids breakMVar statusMVar status

 
 

-handleRunStatus expr ref bindings final_ids breakMVar statusMVar status =
+              case step of
+                RunAndLogSteps -> 
+                        traceRunStatus expr ref bindings ids   
+                                       breakMVar statusMVar status emptyHistory
+                _other ->
+                        handleRunStatus expr ref bindings ids
+                                        breakMVar statusMVar status emptyHistory
+
+
+emptyHistory = nilBL 50 -- keep a log of length 50
+
+handleRunStatus expr ref bindings final_ids breakMVar statusMVar status 
+                history =

    case status of  
       -- did we hit a breakpoint or did we complete?
       (Break apStack info tid) -> do
         hsc_env <- readIORef ref
    case status of  
       -- did we hit a breakpoint or did we complete?
       (Break apStack info tid) -> do
         hsc_env <- readIORef ref

-        let 
-            mod_name    = moduleName (breakInfo_module info)
-            mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
-            breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)
-        --
-        (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env 
-                                        apStack info breaks
+        (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env apStack info

         let
             resume = Resume expr tid breakMVar statusMVar 
         let
             resume = Resume expr tid breakMVar statusMVar 

-                              bindings final_ids apStack info span
+                              bindings final_ids apStack info span 
+                              (toListBL history) 0

             hsc_env2 = pushResume hsc_env1 resume
         --
         writeIORef ref hsc_env2
             hsc_env2 = pushResume hsc_env1 resume
         --
         writeIORef ref hsc_env2

@@ -210,28 +230,47 @@ handleRunStatus expr ref bindings final_ids breakMVar statusMVar status =
                 Linker.extendLinkEnv (zip final_names hvals)
                 return (RunOk final_names)
 
                 Linker.extendLinkEnv (zip final_names hvals)
                 return (RunOk final_names)
 

-{-
-traceRunStatus ref final_ids  
+
+traceRunStatus expr ref bindings final_ids

                breakMVar statusMVar status history = do
   hsc_env <- readIORef ref
   case status of
      -- when tracing, if we hit a breakpoint that is not explicitly
      -- enabled, then we just log the event in the history and continue.
                breakMVar statusMVar status history = do
   hsc_env <- readIORef ref
   case status of
      -- when tracing, if we hit a breakpoint that is not explicitly
      -- enabled, then we just log the event in the history and continue.

-     (Break apStack info tid) | not (isBreakEnabled hsc_env info) -> do
-        let history' = consBL (apStack,info) history
-        withBreakAction breakMVar statusMVar $ do
-           status <- withInterruptsSentTo
-                (do putMVar breakMVar ()  -- this awakens the stopped thread...
-                    return tid)
-                (takeMVar statusMVar)     -- and wait for the result
-
-           traceRunStatus ref final_ids 
-                          breakMVar statusMVar status history'
+     (Break apStack info tid) -> do
+        b <- isBreakEnabled hsc_env info
+        if b
+           then handle_normally
+           else do
+             let history' = consBL (History apStack info) history
+                -- probably better make history strict here, otherwise
+                -- our BoundedList will be pointless.
+             evaluate history'
+             setStepFlag
+             status <- withBreakAction breakMVar statusMVar $ do
+                       withInterruptsSentTo
+                         (do putMVar breakMVar ()  -- awaken the stopped thread
+                             return tid)
+                         (takeMVar statusMVar)     -- and wait for the result
+             traceRunStatus expr ref bindings final_ids 
+                            breakMVar statusMVar status history'

      _other ->
      _other ->

-        handleRunStatus ref final_ids 
-                        breakMVar statusMVar status
-                  
--}        
+        handle_normally
+  where
+        handle_normally = handleRunStatus expr ref bindings final_ids 
+                                          breakMVar statusMVar status history
+
+
+isBreakEnabled :: HscEnv -> BreakInfo -> IO Bool
+isBreakEnabled hsc_env inf =
+   case lookupUFM (hsc_HPT hsc_env) (moduleName (breakInfo_module inf)) of
+       Just hmi -> do
+         w <- getBreak (modBreaks_flags (md_modBreaks (hm_details hmi)))
+                       (breakInfo_number inf)
+         case w of Just n -> return (n /= 0); _other -> return False
+       _ ->
+         return False
+

 
 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 
 
 foreign import ccall "rts_setStepFlag" setStepFlag :: IO () 
 

@@ -277,17 +316,8 @@ withBreakAction breakMVar statusMVar io
 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
 
 noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction
 noBreakAction info apStack = putStrLn "*** Ignoring breakpoint"
 

-resume :: Session -> IO RunResult
-resume session = resume_ session RunToCompletion
-
-stepResume :: Session -> IO RunResult
-stepResume session = resume_ session SingleStep
-
--- traceResume :: Session -> IO RunResult
--- traceResume session handle = resume_ session handle RunAndLogSteps
-
-resume_ :: Session -> SingleStep -> IO RunResult
-resume_ (Session ref) step
+resume :: Session -> SingleStep -> IO RunResult
+resume (Session ref) step

  = do
    hsc_env <- readIORef ref
    let ic = hsc_IC hsc_env
  = do
    hsc_env <- readIORef ref
    let ic = hsc_IC hsc_env

@@ -311,11 +341,10 @@ resume_ (Session ref) step
                                            (ic_tmp_ids ic))
         Linker.deleteFromLinkEnv new_names
         
                                            (ic_tmp_ids ic))
         Linker.deleteFromLinkEnv new_names
         

-

         when (isStep step) $ setStepFlag
         case r of 
           Resume expr tid breakMVar statusMVar bindings 
         when (isStep step) $ setStepFlag
         case r of 
           Resume expr tid breakMVar statusMVar bindings 

-              final_ids apStack info _ -> do
+              final_ids apStack info _ _ _ -> do

                 withBreakAction breakMVar statusMVar $ do
                 status <- withInterruptsSentTo
                              (do putMVar breakMVar ()
                 withBreakAction breakMVar statusMVar $ do
                 status <- withInterruptsSentTo
                              (do putMVar breakMVar ()

@@ -323,8 +352,58 @@ resume_ (Session ref) step
                                  return tid)
                              (takeMVar statusMVar)
                                       -- and wait for the result
                                  return tid)
                              (takeMVar statusMVar)
                                       -- and wait for the result

-                handleRunStatus expr ref bindings final_ids 
-                                breakMVar statusMVar status
+                case step of
+                  RunAndLogSteps -> 
+                        traceRunStatus expr ref bindings final_ids
+                                       breakMVar statusMVar status emptyHistory
+                  _other ->
+                        handleRunStatus expr ref bindings final_ids
+                                        breakMVar statusMVar status emptyHistory
+
+
+back :: Session -> IO ([Name], Int, SrcSpan)
+back  = moveHist (+1)
+
+forward :: Session -> IO ([Name], Int, SrcSpan)
+forward  = moveHist (subtract 1)
+
+moveHist fn (Session ref) = do
+  hsc_env <- readIORef ref
+  case ic_resume (hsc_IC hsc_env) of
+     [] -> throwDyn (ProgramError "not stopped at a breakpoint")
+     (r:rs) -> do
+        let ix = resumeHistoryIx r
+            history = resumeHistory r
+            new_ix = fn ix
+        --
+        when (new_ix >= length history) $
+           throwDyn (ProgramError "no more logged breakpoints")
+        when (new_ix < 0) $
+           throwDyn (ProgramError "already at the beginning of the history")
+
+        let
+          update_ic apStack info = do
+            (hsc_env1, names, span) <- bindLocalsAtBreakpoint hsc_env 
+                                                apStack info 
+            let ic = hsc_IC hsc_env1           
+                r' = r { resumeHistoryIx = new_ix }
+                ic' = ic { ic_resume = r':rs }
+            
+            writeIORef ref hsc_env1{ hsc_IC = ic' } 
+            
+            return (names, new_ix, span)
+
+        -- careful: we want apStack to be the AP_STACK itself, not a thunk
+        -- around it, hence the cases are carefully constructed below to
+        -- make this the case.  ToDo: this is v. fragile, do something better.
+        if new_ix == 0
+           then case r of 
+                   Resume { resumeApStack = apStack, 
+                            resumeBreakInfo = info } ->
+                          update_ic apStack info
+           else case history !! (new_ix - 1) of 
+                   History apStack info ->
+                          update_ic apStack info

 
 -- -----------------------------------------------------------------------------
 -- After stopping at a breakpoint, add free variables to the environment
 
 -- -----------------------------------------------------------------------------
 -- After stopping at a breakpoint, add free variables to the environment

@@ -333,11 +412,13 @@ bindLocalsAtBreakpoint
         :: HscEnv
         -> HValue
         -> BreakInfo
         :: HscEnv
         -> HValue
         -> BreakInfo

-        -> ModBreaks

         -> IO (HscEnv, [Name], SrcSpan)
         -> IO (HscEnv, [Name], SrcSpan)

-bindLocalsAtBreakpoint hsc_env apStack info breaks = do
+bindLocalsAtBreakpoint hsc_env apStack info = do

 
    let 
 
    let 

+       mod_name    = moduleName (breakInfo_module info)
+       mod_details = fmap hm_details (lookupUFM (hsc_HPT hsc_env) mod_name)
+       breaks      = md_modBreaks (expectJust "handlRunStatus" mod_details)

        index     = breakInfo_number info
        vars      = breakInfo_vars info
        result_ty = breakInfo_resty info
        index     = breakInfo_number info
        vars      = breakInfo_vars info
        result_ty = breakInfo_resty info

@@ -352,7 +433,7 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do
    let (ids, offsets) = unzip pointers
    hValues <- mapM (getIdValFromApStack apStack) offsets
    new_ids <- zipWithM mkNewId occs ids
    let (ids, offsets) = unzip pointers
    hValues <- mapM (getIdValFromApStack apStack) offsets
    new_ids <- zipWithM mkNewId occs ids

-   let names = map idName ids
+   let names = map idName new_ids

 
    -- make an Id for _result.  We use the Unique of the FastString "_result";
    -- we don't care about uniqueness here, because there will only be one
 
    -- make an Id for _result.  We use the Unique of the FastString "_result";
    -- we don't care about uniqueness here, because there will only be one

@@ -369,16 +450,15 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do
    --    - tidy the type variables
    --    - globalise the Id (Ids are supposed to be Global, apparently).
    --
    --    - tidy the type variables
    --    - globalise the Id (Ids are supposed to be Global, apparently).
    --

-   let all_ids | isPointer result_id = result_id : ids
-               | otherwise           = ids
+   let all_ids | isPointer result_id = result_id : new_ids
+               | otherwise           = new_ids

        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
        new_tyvars = unionVarSets tyvarss             
        (id_tys, tyvarss) = mapAndUnzip (skolemiseTy.idType) all_ids
        (_,tidy_tys) = tidyOpenTypes emptyTidyEnv id_tys
        new_tyvars = unionVarSets tyvarss             

-       new_ids = zipWith setIdType all_ids tidy_tys
-       global_ids = map (globaliseId VanillaGlobal) new_ids
+       final_ids = zipWith setIdType all_ids tidy_tys

 
    let   ictxt0 = hsc_IC hsc_env
 
    let   ictxt0 = hsc_IC hsc_env

-         ictxt1 = extendInteractiveContext ictxt0 global_ids new_tyvars
+         ictxt1 = extendInteractiveContext ictxt0 final_ids new_tyvars

 
    Linker.extendLinkEnv (zip names hValues)
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]
 
    Linker.extendLinkEnv (zip names hValues)
    Linker.extendLinkEnv [(result_name, unsafeCoerce# apStack)]

@@ -389,7 +469,7 @@ bindLocalsAtBreakpoint hsc_env apStack info breaks = do
      let uniq = idUnique id
          loc = nameSrcLoc (idName id)
          name = mkInternalName uniq occ loc
      let uniq = idUnique id
          loc = nameSrcLoc (idName id)
          name = mkInternalName uniq occ loc

-         ty = tidyTopType (idType id)
+         ty = idType id

          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
      return new_id
 
          new_id = Id.mkGlobalId VanillaGlobal name ty (idInfo id)
      return new_id
 

@@ -410,7 +490,7 @@ skolemiseTyVar tyvar = mkTcTyVar (tyVarName tyvar) (tyVarKind tyvar)
 foreign import ccall unsafe "rts_getApStackVal" 
         getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
 
 foreign import ccall unsafe "rts_getApStackVal" 
         getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
 

-getIdValFromApStack :: a -> Int -> IO HValue
+getIdValFromApStack :: HValue -> Int -> IO HValue

 getIdValFromApStack apStack stackDepth = do
      apSptr <- newStablePtr apStack
      resultSptr <- getApStackVal apSptr (stackDepth - 1)
 getIdValFromApStack apStack stackDepth = do
      apSptr <- newStablePtr apStack
      resultSptr <- getApStackVal apSptr (stackDepth - 1)

@@ -459,10 +539,13 @@ data BoundedList a = BL
                         [a] -- left
                         [a] -- right,  list is (left ++ reverse right)
 
                         [a] -- left
                         [a] -- right,  list is (left ++ reverse right)
 

+nilBL :: Int -> BoundedList a
+nilBL bound = BL 0 bound [] []
+

 consBL a (BL len bound left right)
   | len < bound = BL (len+1) bound (a:left) right
 consBL a (BL len bound left right)
   | len < bound = BL (len+1) bound (a:left) right

-  | null right  = BL len     bound [] $! tail (reverse left)
-  | otherwise   = BL len     bound [] $! tail right
+  | null right  = BL len     bound [a]      $! tail (reverse left)
+  | otherwise   = BL len     bound (a:left) $! tail right

 
 toListBL (BL _ _ left right) = left ++ reverse right
 
 
 toListBL (BL _ _ left right) = left ++ reverse right