Various cleanups and improvements to the breakpoint support

  - move parts of the debugger implementation below the GHC API where
    they belong.  There is still more in Debugger that violates the
    layering, hopefully I'll get to that later.

  - instead of returning an IO action from runStmt for resuming,
    return a ResumeHandle that is passed to GHC.resume.

  - breakpoints now return [Name] which is displayed in the same
    way as when a binding statement is executed.

  - :load, :add, :reload now clear the active breakpoints and context

  - :break gives a sensible error when used on a non-interpreted module

  - export breakpoint-related types from GHC

  - remove a bunch of layer-violating imports from InteractiveUI

  - remove some more vestiges of the old breakpoint code (topLevel in
    the GHCi state).

  - remove TickTree and use a simple array instead, cached per module

diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index 99ce717..e028c12 100644 (file)
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -30,7 +30,9 @@ module SrcLoc (
 
        -- These are dubious exports, because they crash on some inputs,
        -- used only in Lexer.x where we are sure what the Span looks like
 
        -- These are dubious exports, because they crash on some inputs,
        -- used only in Lexer.x where we are sure what the Span looks like

-       srcSpanFile, srcSpanEndLine, srcSpanEndCol,
+       srcSpanFile, 
+        srcSpanStartLine, srcSpanEndLine, 
+        srcSpanStartCol, srcSpanEndCol,

 
        Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
     ) where
 
        Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
     ) where

diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index ce975fe..cf8e914 100644 (file)
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -87,8 +87,8 @@ addCoverageTicksToBinds dflags mod mod_loc binds = do
                         | (P r1 c1 r2 c2, _box) <- entries ] 
 
   let modBreaks = emptyModBreaks 
                         | (P r1 c1 r2 c2, _box) <- entries ] 
 
   let modBreaks = emptyModBreaks 

-                  { modBreaks_array = breakArray 
-                  , modBreaks_ticks = locsTicks 
+                  { modBreaks_flags = breakArray 
+                  , modBreaks_locs  = locsTicks 

                   } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do
                   } 
 
   doIfSet_dyn dflags  Opt_D_dump_hpc $ do

@@ -170,6 +170,19 @@ addTickLHsExprBreakAlways e
     | opt_Hpc   = addTickLHsExpr e
     | otherwise = addTickLHsExprAlways e
 
     | opt_Hpc   = addTickLHsExpr e
     | otherwise = addTickLHsExprAlways e
 

+-- version of addTick that does not actually add a tick,
+-- because the scope of this tick is completely subsumed by 
+-- another.
+addTickLHsExprNever :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprNever (L pos e0) = do
+    e1 <- addTickHsExpr e0
+    return $ L pos e1
+
+addTickLHsExprBreakOnly :: LHsExpr Id -> TM (LHsExpr Id)
+addTickLHsExprBreakOnly e
+    | opt_Hpc   = addTickLHsExprNever e
+    | otherwise = addTickLHsExprAlways e
+

 -- selectively add ticks to interesting expressions
 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
 addTickLHsExpr (L pos e0) = do
 -- selectively add ticks to interesting expressions
 addTickLHsExpr :: LHsExpr Id -> TM (LHsExpr Id)
 addTickLHsExpr (L pos e0) = do

@@ -202,14 +215,6 @@ addTickLHsExprOptAlt oneOfMany (L pos e0)
     fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos 
     return $ fn $ L pos e1
 
     fn <- allocTickBox (if oneOfMany then AltBox else ExpBox) pos 
     return $ fn $ L pos e1
 

--- version of addTick that does not actually add a tick,
--- because the scope of this tick is completely subsumed by 
--- another.
-addTickLHsExpr' :: LHsExpr Id -> TM (LHsExpr Id)
-addTickLHsExpr' (L pos e0) = do
-    e1 <- addTickHsExpr e0
-    return $ L pos e1
-

 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addBinTickLHsExpr boxLabel (L pos e0) = do
     e1 <- addTickHsExpr e0
 addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id)
 addBinTickLHsExpr boxLabel (L pos e0) = do
     e1 <- addTickHsExpr e0

@@ -223,18 +228,18 @@ addTickHsExpr e@(HsLit _) = return e
 addTickHsExpr e@(HsLam matchgroup) =
         liftM HsLam (addTickMatchGroup matchgroup)
 addTickHsExpr (HsApp e1 e2) = 
 addTickHsExpr e@(HsLam matchgroup) =
         liftM HsLam (addTickMatchGroup matchgroup)
 addTickHsExpr (HsApp e1 e2) = 

-       liftM2 HsApp (addTickLHsExpr' e1) (addTickLHsExpr e2)
+       liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2)

 addTickHsExpr (OpApp e1 e2 fix e3) = 
        liftM4 OpApp 
                (addTickLHsExpr e1) 
 addTickHsExpr (OpApp e1 e2 fix e3) = 
        liftM4 OpApp 
                (addTickLHsExpr e1) 

-               (addTickLHsExpr' e2)
+               (addTickLHsExprNever e2)

                (return fix)
                (addTickLHsExpr e3)
 addTickHsExpr (NegApp e neg) =
        liftM2 NegApp
                (addTickLHsExpr e) 
                (addTickSyntaxExpr hpcSrcSpan neg)
                (return fix)
                (addTickLHsExpr e3)
 addTickHsExpr (NegApp e neg) =
        liftM2 NegApp
                (addTickLHsExpr e) 
                (addTickSyntaxExpr hpcSrcSpan neg)

-addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExpr' e)
+addTickHsExpr (HsPar e) = liftM HsPar (addTickLHsExprNever e)

 addTickHsExpr (SectionL e1 e2) = 
        liftM2 SectionL
                (addTickLHsExpr e1)
 addTickHsExpr (SectionL e1 e2) = 
        liftM2 SectionL
                (addTickLHsExpr e1)

@@ -255,7 +260,7 @@ addTickHsExpr (HsIf  e1 e2 e3) =
 addTickHsExpr (HsLet binds e) =
        liftM2 HsLet
                (addTickHsLocalBinds binds)             -- to think about: !patterns.
 addTickHsExpr (HsLet binds e) =
        liftM2 HsLet
                (addTickHsLocalBinds binds)             -- to think about: !patterns.

-               (addTickLHsExpr' e)
+               (addTickLHsExprBreakOnly e)

 addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
        liftM4 HsDo
                (return cxt)
 addTickHsExpr (HsDo cxt stmts last_exp srcloc) =
        liftM4 HsDo
                (return cxt)

@@ -289,7 +294,7 @@ addTickHsExpr (RecordUpd    e rec_binds ty1 ty2) =
 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
 addTickHsExpr (ExprWithTySigOut e ty) =
        liftM2 ExprWithTySigOut
 addTickHsExpr (ExprWithTySig {}) = error "addTickHsExpr: ExprWithTySig"
 addTickHsExpr (ExprWithTySigOut e ty) =
        liftM2 ExprWithTySigOut

-               (addTickLHsExpr' e) -- No need to tick the inner expression
+               (addTickLHsExprNever e) -- No need to tick the inner expression

                                    -- for expressions with signatures
                (return ty)
 addTickHsExpr (ArithSeq         ty arith_seq) =
                                    -- for expressions with signatures
                (return ty)
 addTickHsExpr (ArithSeq         ty arith_seq) =

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index ca66250..b09d739 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -1446,7 +1446,7 @@ runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r)
 runBc us modBreaks (BcM m) 
    = m (BcM_State us 0 [] breakArray)   
    where
 runBc us modBreaks (BcM m) 
    = m (BcM_State us 0 [] breakArray)   
    where

-   breakArray = modBreaks_array modBreaks
+   breakArray = modBreaks_flags modBreaks

 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index f0f8973..4389213 100644 (file)
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -4,10 +4,15 @@
 --
 -- Pepe Iborra (supported by Google SoC) 2006
 --
 --
 -- Pepe Iborra (supported by Google SoC) 2006
 --

+-- ToDo: lots of violation of layering here.  This module should
+-- decide whether it is above the GHC API (import GHC and nothing
+-- else) or below it.
+-- 

 -----------------------------------------------------------------------------
 
 -----------------------------------------------------------------------------
 

-module Debugger (pprintClosureCommand, instantiateTyVarsToUnknown) where
+module Debugger (pprintClosureCommand) where

 
 

+import qualified DebuggerTys

 import Linker
 import RtClosureInspect
 
 import Linker
 import RtClosureInspect
 

@@ -24,7 +29,6 @@ import RdrName
 import UniqSupply
 import Type
 import TyCon
 import UniqSupply
 import Type
 import TyCon

-import DataCon

 import TcGadt
 import GHC
 import GhciMonad
 import TcGadt
 import GHC
 import GhciMonad

@@ -203,56 +207,6 @@ newGrimName cms userName  = do
         name    = mkInternalName unique occname noSrcLoc
     return name
 
         name    = mkInternalName unique occname noSrcLoc
     return name
 

-----------------------------------------------------------------------------
--- | Replace all the tyvars in a Term with the opaque type GHC.Base.Unknown
-----------------------------------------------------------------------------
-instantiateTyVarsToUnknown :: Session -> Type -> IO Type
-instantiateTyVarsToUnknown cms ty
--- We have a GADT, so just fix its tyvars
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    , isGADT tycon
-    = mapM fixTyVars args >>= return . mkTyConApp tycon
--- We have a regular TyCon, so map recursively to its args
-    | Just (tycon, args) <- splitTyConApp_maybe ty
-    , tycon /= funTyCon
-    = do unknownTyVar <- unknownTV
-         args' <- mapM (instantiateTyVarsToUnknown cms) args
-         return$ mkTyConApp tycon args'
--- we have a tyvar of kind *
-    | Just tyvar <- getTyVar_maybe ty
-    , ([],_) <- splitKindFunTys (tyVarKind tyvar) 
-    = unknownTV
--- we have a higher kind tyvar, so insert an unknown of the appropriate kind
-    | Just tyvar <- getTyVar_maybe ty
-    , (args,_) <- splitKindFunTys (tyVarKind tyvar)
-    = liftM mkTyConTy $ unknownTC !! length args
--- Base case
-    | otherwise    = return ty 
-
- where unknownTV = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknownTyConName
-         return$ mkTyConTy unknown_tc
-       unknownTC = [undefined, unknownTC1, unknownTC2, unknownTC3]
-       unknownTC1 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown1TyConName
-         return unknown_tc
-       unknownTC2 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown2TyConName
-         return unknown_tc
-       unknownTC3 = do 
-         Just (ATyCon unknown_tc) <- lookupName cms unknown3TyConName
-         return unknown_tc
---       isGADT ty | pprTrace' "isGADT" (ppr ty <> colon <> ppr(isGadtSyntaxTyCon ty)) False = undefined
-       isGADT tc | Just dcs <- tyConDataCons_maybe tc = any (not . null . dataConEqSpec) dcs
-                 | otherwise = False
-       fixTyVars ty 
-           | Just (tycon, args) <- splitTyConApp_maybe ty
-           = mapM fixTyVars args >>= return . mkTyConApp tycon
--- Fix the tyvar so that the interactive environment doesn't choke on it TODO 
-           | Just tv <- getTyVar_maybe ty = return ty --TODO
-           | otherwise = return ty
-

 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 stripUnknowns :: [Name] -> Id -> Id
 stripUnknowns names id = setIdType id . fst . go names . idType 
 -- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
 stripUnknowns :: [Name] -> Id -> Id
 stripUnknowns names id = setIdType id . fst . go names . idType 

@@ -289,3 +243,8 @@ stripUnknowns names id = setIdType id . fst . go names . idType
            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
            kind2 = mkArrowKind kind1 liftedTypeKind
            kind3 = mkArrowKind kind2 liftedTypeKind
            kind1 = mkArrowKind liftedTypeKind liftedTypeKind
            kind2 = mkArrowKind kind1 liftedTypeKind
            kind3 = mkArrowKind kind2 liftedTypeKind

+
+instantiateTyVarsToUnknown :: Session -> Type -> IO Type
+instantiateTyVarsToUnknown (Session ref) ty
+  = do hsc_env <- readIORef ref
+       DebuggerTys.instantiateTyVarsToUnknown hsc_env ty

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 3cab56b..d56a581 100644 (file)
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -17,11 +17,13 @@ import Util
 import DynFlags
 import HscTypes
 import SrcLoc
 import DynFlags
 import HscTypes
 import SrcLoc

+import Module

 
 import Numeric
 
 import Numeric

+import Control.Concurrent

 import Control.Exception as Exception
 import Control.Exception as Exception

+import Data.Array

 import Data.Char
 import Data.Char

-import Data.Dynamic

 import Data.Int         ( Int64 )
 import Data.IORef
 import Data.List
 import Data.Int         ( Int64 )
 import Data.IORef
 import Data.List

@@ -43,11 +45,16 @@ data GHCiState = GHCiState
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: GHC.Module,
        session        :: GHC.Session,
        options        :: [GHCiOption],
         prelude        :: GHC.Module,

-       topLevel       :: Bool,
-        resume         :: [IO GHC.RunResult],
-        breaks         :: !ActiveBreakPoints
+        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
 data GHCiOption 
        = ShowTiming            -- show time/allocs after evaluation
        | ShowType              -- show the type of expressions

@@ -86,8 +93,8 @@ getActiveBreakPoints :: GHCi ActiveBreakPoints
 getActiveBreakPoints = liftM breaks getGHCiState 
 
 -- don't reset the counter back to zero?
 getActiveBreakPoints = liftM breaks getGHCiState 
 
 -- don't reset the counter back to zero?

-clearActiveBreakPoints :: GHCi ()
-clearActiveBreakPoints = do
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do

    st <- getGHCiState
    let oldActiveBreaks = breaks st
        newActiveBreaks = oldActiveBreaks { breakLocations = [] } 
    st <- getGHCiState
    let oldActiveBreaks = breaks st
        newActiveBreaks = oldActiveBreaks { breakLocations = [] } 

@@ -172,28 +179,23 @@ unsetOption opt
 io :: IO a -> GHCi a
 io m = GHCi { unGHCi = \s -> m >>= return }
 
 io :: IO a -> GHCi a
 io m = GHCi { unGHCi = \s -> m >>= return }
 

-isTopLevel :: GHCi Bool
-isTopLevel = getGHCiState >>= return . topLevel
-
-getResume :: GHCi (Maybe (IO GHC.RunResult))
-getResume = do
-   st <- getGHCiState
-   case (resume st) of
-      []    -> return Nothing
-      (x:_) -> return $ Just x
-
-popResume :: GHCi ()
+popResume :: GHCi (Maybe (SrcSpan, ThreadId, GHC.ResumeHandle))

 popResume = do
    st <- getGHCiState 
    case (resume st) of
 popResume = do
    st <- getGHCiState 
    case (resume st) of

-      []     -> return () 
-      (_:xs) -> setGHCiState $ st { resume = xs } 
+      []     -> return Nothing
+      (x:xs) -> do setGHCiState $ st { resume = xs } ; return (Just x)

          
          

-pushResume :: IO GHC.RunResult -> GHCi ()
-pushResume resumeAction = do
+pushResume :: SrcSpan -> ThreadId -> GHC.ResumeHandle -> GHCi ()
+pushResume span threadId resumeAction = do

    st <- getGHCiState
    let oldResume = resume st
    st <- getGHCiState
    let oldResume = resume st

-   setGHCiState $ st { resume = resumeAction : oldResume }
+   setGHCiState $ st { resume = (span, threadId, resumeAction) : oldResume }
+
+discardResumeContext :: GHCi ()
+discardResumeContext = do
+   st <- getGHCiState
+   setGHCiState st { resume = [] }

 
 showForUser :: SDoc -> GHCi String
 showForUser doc = do
 
 showForUser :: SDoc -> GHCi String
 showForUser doc = do

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index b794436..4a98b9e 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -18,13 +18,16 @@ import GhciMonad
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
 -- The GHC interface
 import qualified GHC
 import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),

-                          Type, Module, ModuleName, TyThing(..), Phase )
+                          Type, Module, ModuleName, TyThing(..), Phase,
+                          BreakIndex )
+import Debugger

 import DynFlags
 import Packages
 import PackageConfig
 import UniqFM
 import PprTyThing
 import Outputable
 import DynFlags
 import Packages
 import PackageConfig
 import UniqFM
 import PprTyThing
 import Outputable

+import Module           -- for ModuleEnv

 
 -- for createtags
 import Name
 
 -- for createtags
 import Name

@@ -40,18 +43,6 @@ import StaticFlags
 import Linker
 import Util
 
 import Linker
 import Util
 

--- The debugger
-import Debugger 
-import HscTypes
-import Id
-import Var       ( globaliseId )
-import IdInfo
-import NameEnv
-import RdrName
-import Module
-import Type
-import TcType
-

 #ifndef mingw32_HOST_OS
 import System.Posix
 #if __GLASGOW_HASKELL__ > 504
 #ifndef mingw32_HOST_OS
 import System.Posix
 #if __GLASGOW_HASKELL__ > 504

@@ -74,7 +65,7 @@ import Control.Exception as Exception
 -- import Control.Concurrent
 
 import Data.List
 -- import Control.Concurrent
 
 import Data.List

-import Data.Maybe      ( isJust, isNothing, fromMaybe, catMaybes )
+import Data.Maybe

 import System.Cmd
 import System.Environment
 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Cmd
 import System.Environment
 import System.Exit     ( exitWith, ExitCode(..) )

@@ -85,8 +76,8 @@ import Data.Char
 import Data.Dynamic
 import Data.Array
 import Control.Monad as Monad
 import Data.Dynamic
 import Data.Array
 import Control.Monad as Monad

-import Foreign.StablePtr       ( StablePtr, newStablePtr, deRefStablePtr, freeStablePtr )

 
 

+import Foreign.StablePtr       ( newStablePtr )

 import GHC.Exts                ( unsafeCoerce# )
 import GHC.IOBase      ( IOErrorType(InvalidArgument), IO(IO) )
 
 import GHC.Exts                ( unsafeCoerce# )
 import GHC.IOBase      ( IOErrorType(InvalidArgument), IO(IO) )
 

@@ -98,7 +89,6 @@ import System.Posix.Internals ( setNonBlockingFD )
 import ByteCodeLink (HValue)
 import ByteCodeInstr (BreakInfo (..))
 import BreakArray
 import ByteCodeLink (HValue)
 import ByteCodeInstr (BreakInfo (..))
 import BreakArray

-import TickTree 

 
 -----------------------------------------------------------------------------
 
 
 -----------------------------------------------------------------------------
 

@@ -118,10 +108,10 @@ builtin_commands :: [Command]
 builtin_commands = [
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),
 builtin_commands = [
        -- Hugs users are accustomed to :e, so make sure it doesn't overlap
   ("?",                keepGoing help,                 False, completeNone),

-  ("add",      tlC$ keepGoingPaths addModule,  False, completeFilename),
+  ("add",      keepGoingPaths addModule,       False, completeFilename),

   ("break",     breakCmd, False, completeNone),   
   ("browse",    keepGoing browseCmd,           False, completeModule),
   ("break",     breakCmd, False, completeNone),   
   ("browse",    keepGoing browseCmd,           False, completeModule),

-  ("cd",       tlC$ keepGoing changeDirectory, False, completeFilename),
+  ("cd",       keepGoing changeDirectory,      False, completeFilename),

   ("check",    keepGoing checkModule,          False, completeHomeModule),
   ("continue",  continueCmd, False, completeNone),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),
   ("check",    keepGoing checkModule,          False, completeHomeModule),
   ("continue",  continueCmd, False, completeNone),
   ("ctags",    keepGoing createCTagsFileCmd,   False, completeFilename),

@@ -134,12 +124,12 @@ builtin_commands = [
   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),
   ("help",     keepGoing help,                 False, completeNone),
   ("info",      keepGoing info,                        False, completeIdentifier),
   ("kind",     keepGoing kindOfType,           False, completeIdentifier),

-  ("load",     tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
+  ("load",     keepGoingPaths loadModule_,False, completeHomeModuleOrFile),

   ("module",   keepGoing setContext,           False, completeModule),
   ("module",   keepGoing setContext,           False, completeModule),

-  ("main",     tlC$ keepGoing runMain,         False, completeIdentifier),
+  ("main",     keepGoing runMain,              False, completeIdentifier),

   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("quit",     quit,                           False, completeNone),
   ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
   ("quit",     quit,                           False, completeNone),

-  ("reload",   tlC$ keepGoing reloadModule,    False, completeNone),
+  ("reload",   keepGoing reloadModule,         False, completeNone),

   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
   ("set",      keepGoing setCmd,               True,  completeSetOptions),
   ("show",     keepGoing showCmd,              False, completeNone),
   ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),

@@ -152,14 +142,6 @@ builtin_commands = [
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 
 keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool)
 keepGoing a str = a str >> return False
 

--- tlC: Top Level Command, not allowed in inferior sessions
-tlC ::  (String -> GHCi Bool) -> (String -> GHCi Bool)
-tlC a str = do 
-    top_level <- isTopLevel
-    if not top_level
-       then throwDyn (CmdLineError "Command only allowed at Top Level")
-       else a str
-

 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 keepGoingPaths a str = a (toArgs str) >> return False
 
 keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
 keepGoingPaths a str = a (toArgs str) >> return False
 

@@ -279,9 +261,9 @@ interactiveUI session srcs maybe_expr = do
                   session = session,
                   options = [],
                    prelude = prel_mod,
                   session = session,
                   options = [],
                    prelude = prel_mod,

-                  topLevel = True,

                    resume = [],
                    resume = [],

-                   breaks = emptyActiveBreakPoints
+                   breaks = emptyActiveBreakPoints,
+                   tickarrays = emptyModuleEnv

                  }
 
 #ifdef USE_READLINE
                  }
 
 #ifdef USE_READLINE

@@ -462,7 +444,7 @@ mkPrompt toplevs exports prompt
     
         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
                  hsep (map (ppr . GHC.moduleName) exports)
     
         perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
                  hsep (map (ppr . GHC.moduleName) exports)

-             
+

 
 #ifdef USE_READLINE
 readlineLoop :: GHCi ()
 
 #ifdef USE_READLINE
 readlineLoop :: GHCi ()

@@ -513,9 +495,9 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
                  -- failure to run the command causes exit(1) for ghc -e.
                _       -> finishEvalExpr nms
 
                  -- failure to run the command causes exit(1) for ghc -e.
                _       -> finishEvalExpr nms
 

-runStmt :: String -> GHCi (Maybe [Name])
+runStmt :: String -> GHCi (Maybe (Bool,[Name]))

 runStmt stmt
 runStmt stmt

- | null (filter (not.isSpace) stmt) = return (Just [])
+ | null (filter (not.isSpace) stmt) = return (Just (False,[]))

  | otherwise
  = do st <- getGHCiState
       session <- getSession
  | otherwise
  = do st <- getGHCiState
       session <- getSession

@@ -523,90 +505,34 @@ runStmt stmt
                     GHC.runStmt session stmt
       switchOnRunResult result
 
                     GHC.runStmt session stmt
       switchOnRunResult result
 

-switchOnRunResult :: GHC.RunResult -> GHCi (Maybe [Name])
+switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))

 switchOnRunResult GHC.RunFailed = return Nothing
 switchOnRunResult (GHC.RunException e) = throw e
 switchOnRunResult GHC.RunFailed = return Nothing
 switchOnRunResult (GHC.RunException e) = throw e

-switchOnRunResult (GHC.RunOk names) = return $ Just names
-switchOnRunResult (GHC.RunBreak apStack _threadId info resume) = do  -- Todo: we don't use threadID, perhaps delete?
+switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
+switchOnRunResult (GHC.RunBreak threadId names info resume) = do

    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) 
    let modBreaks  = GHC.modInfoModBreaks mod_info
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info) 
    let modBreaks  = GHC.modInfoModBreaks mod_info

-   let ticks      = modBreaks_ticks modBreaks
-   io $ displayBreakInfo session ticks info
-   io $ extendEnvironment session apStack (breakInfo_vars info) 
-   pushResume resume
-   return Nothing
-
-displayBreakInfo :: Session -> Array Int SrcSpan -> BreakInfo -> IO ()
-displayBreakInfo session ticks info = do
-   unqual <- GHC.getPrintUnqual session
+   let ticks      = GHC.modBreaks_locs modBreaks
+
+   -- display information about the breakpoint

    let location = ticks ! breakInfo_number info
    let location = ticks ! breakInfo_number info

-   printForUser stdout unqual $
-      ptext SLIT("Stopped at") <+> ppr location $$ localsMsg 
-   where
-   vars = map fst $ breakInfo_vars info 
-   localsMsg = if null vars
-                  then text "No locals in scope."
-                  else text "Locals:" <+> (pprWithCommas showId vars)
-   showId id = ppr (idName id) <+> dcolon <+> ppr (idType id) 
-
--- Todo: turn this into a primop, and provide special version(s) for unboxed things
-foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
-
-getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
-getIdValFromApStack apStack (identifier, stackDepth) = do
-   -- ToDo: check the type of the identifer and decide whether it is unboxed or not
-   apSptr <- newStablePtr apStack
-   resultSptr <- getApStackVal apSptr (stackDepth - 1)
-   result <- deRefStablePtr resultSptr
-   freeStablePtr apSptr
-   freeStablePtr resultSptr 
-   return (identifier, unsafeCoerce# result)
-
-extendEnvironment :: Session -> a -> [(Id, Int)] -> IO ()
-extendEnvironment s@(Session ref) apStack idsOffsets = do
-   idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
-   let (ids, hValues) = unzip idsVals 
-   let names = map idName ids
-   let global_ids = map globaliseAndTidy ids
-   typed_ids  <- mapM instantiateIdType global_ids
-   hsc_env <- readIORef ref
-   let ictxt = hsc_IC hsc_env
-       rn_env   = ic_rn_local_env ictxt
-       type_env = ic_type_env ictxt
-       bound_names = map idName typed_ids
-       new_rn_env  = extendLocalRdrEnv rn_env bound_names
-       -- Remove any shadowed bindings from the type_env;
-       -- they are inaccessible but might, I suppose, cause 
-       -- a space leak if we leave them there
-       shadowed = [ n | name <- bound_names,
-                    let rdr_name = mkRdrUnqual (nameOccName name),
-                    Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
-       filtered_type_env = delListFromNameEnv type_env shadowed
-       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 }
-   writeIORef ref (hsc_env { hsc_IC = new_ic })
-   extendLinkEnv (zip names hValues) -- ToDo: we must remember to restore the old env after we finish a breakpoint
-   where
-   globaliseAndTidy :: Id -> Id
-   globaliseAndTidy id
-      = let tidied_type = tidyTopType$ idType id
-        in setIdType (globaliseId VanillaGlobal id) tidied_type
+   unqual <- io $ GHC.getPrintUnqual session
+   io $ printForUser stdout unqual $
+      ptext SLIT("Stopped at") <+> ppr location

 
 

-   -- | Instantiate the tyVars with GHC.Base.Unknown
-   instantiateIdType :: Id -> IO Id
-   instantiateIdType id = do
-      instantiatedType <- instantiateTyVarsToUnknown s (idType id)
-      return$ setIdType id instantiatedType
+   pushResume location threadId resume
+   return (Just (True,names))

 
 -- possibly print the type and revert CAFs after evaluating an expression
 finishEvalExpr mb_names
 
 -- possibly print the type and revert CAFs after evaluating an expression
 finishEvalExpr mb_names

- = do b <- isOptionSet ShowType
+ = do show_types <- isOptionSet ShowType

       session <- getSession
       case mb_names of
        Nothing    -> return ()      
       session <- getSession
       case mb_names of
        Nothing    -> return ()      

-       Just names -> when b (mapM_ (showTypeOfName session) names)
+       Just (is_break,names) -> 
+                when (is_break || show_types) $
+                      mapM_ (showTypeOfName session) names

 
       flushInterpBuffers
       io installSignalHandlers
 
       flushInterpBuffers
       io installSignalHandlers

@@ -841,6 +767,9 @@ reloadModule m = do
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.

+  discardResumeContext
+  discardTickArrays
+  discardActiveBreakPoints

   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'

@@ -1043,10 +972,8 @@ browseCmd m =
 
 browseModule m exports_only = do
   s <- getSession
 
 browseModule m exports_only = do
   s <- getSession

-  modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing
-  is_interpreted <- io (GHC.moduleIsInterpreted s modl)
-  when (not is_interpreted && not exports_only) $
-       throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
+  modl <- if exports_only then lookupModule s m
+                          else wantInterpretedModule s m

 
   -- Temporarily set the context to the module we're interested in,
   -- just so we can get an appropriate PrintUnqualified
 
   -- Temporarily set the context to the module we're interested in,
   -- just so we can get an appropriate PrintUnqualified

@@ -1530,15 +1457,15 @@ continueCmd other = do
 
 doContinue :: IO () -> GHCi Bool
 doContinue actionBeforeCont = do 
 
 doContinue :: IO () -> GHCi Bool
 doContinue actionBeforeCont = do 

-   resumeAction <- getResume
-   popResume
+   resumeAction <- popResume

    case resumeAction of
       Nothing -> do 
          io $ putStrLn "There is no computation running."
          return False
    case resumeAction of
       Nothing -> do 
          io $ putStrLn "There is no computation running."
          return False

-      Just action -> do
+      Just (_,_,handle) -> do

          io $ actionBeforeCont
          io $ actionBeforeCont

-         runResult <- io action
+         session <- getSession
+         runResult <- io $ GHC.resume session handle

          names <- switchOnRunResult runResult
          finishEvalExpr names
          return False 
          names <- switchOnRunResult runResult
          finishEvalExpr names
          return False 

@@ -1552,7 +1479,7 @@ deleteCmd argLine = do
    deleteSwitch [] = 
       io $ putStrLn "The delete command requires at least one argument."
    -- delete all break points
    deleteSwitch [] = 
       io $ putStrLn "The delete command requires at least one argument."
    -- delete all break points

-   deleteSwitch ("*":_rest) = clearActiveBreakPoints
+   deleteSwitch ("*":_rest) = discardActiveBreakPoints

    deleteSwitch idents = do
       mapM_ deleteOneBreak idents 
       where
    deleteSwitch idents = do
       mapM_ deleteOneBreak idents 
       where

@@ -1573,7 +1500,7 @@ breakSwitch _session [] = do
    return False
 breakSwitch session args@(arg1:rest) 
    | looksLikeModule arg1 = do
    return False
 breakSwitch session args@(arg1:rest) 
    | looksLikeModule arg1 = do

-        mod     <- lookupModule session arg1 
+        mod <- wantInterpretedModule session arg1

         breakByModule mod rest
         return False
    | otherwise = do
         breakByModule mod rest
         return False
    | otherwise = do

@@ -1590,6 +1517,14 @@ breakSwitch session args@(arg1:rest)
    looksLikeModule []    = False
    looksLikeModule (x:_) = isUpper x
 
    looksLikeModule []    = False
    looksLikeModule (x:_) = isUpper x
 

+wantInterpretedModule :: Session -> String -> GHCi Module
+wantInterpretedModule session str = do
+   modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+   is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+   when (not is_interpreted) $
+       throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+   return modl
+

 breakByModule :: Module -> [String] -> GHCi () 
 breakByModule mod args@(arg1:rest)
    | all isDigit arg1 = do  -- looks like a line number
 breakByModule :: Module -> [String] -> GHCi () 
 breakByModule mod args@(arg1:rest)
    | all isDigit arg1 = do  -- looks like a line number

@@ -1606,16 +1541,16 @@ breakByModule mod args@(arg1:rest)
 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args
 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args

-   | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+   | [] <- args = findBreakAndSet mod $ findBreakByLine line

    | [col] <- args, all isDigit col =
    | [col] <- args, all isDigit col =

-        findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
+        findBreakAndSet mod $ findBreakByCoord (line, read col)

    | otherwise = io $ putStrLn "Invalid arguments to break command."
    | otherwise = io $ putStrLn "Invalid arguments to break command."

-        
-findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+
+findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()

 findBreakAndSet mod lookupTickTree = do 
 findBreakAndSet mod lookupTickTree = do 

-   (breakArray, ticks) <- getModBreak mod 
-   let tickTree   = tickTreeFromList (assocs ticks)
-   case lookupTickTree tickTree of 
+   tickArray <- getTickArray mod
+   (breakArray, _) <- getModBreak mod
+   case lookupTickTree tickArray of 

       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
       Just (tick, span) -> do
          success <- io $ setBreakFlag True breakArray tick 
       Nothing  -> io $ putStrLn $ "No breakpoints found at that location."
       Just (tick, span) -> do
          success <- io $ setBreakFlag True breakArray tick 

@@ -1639,13 +1574,79 @@ findBreakAndSet mod lookupTickTree = do
                                  <+> ppr span
             io $ putStrLn str
 
                                  <+> ppr span
             io $ putStrLn str
 

+-- When a line number is specified, the current policy for choosing
+-- the best breakpoint is this:
+--    - the leftmost complete subexpression on the specified line, or
+--    - the leftmost subexpression starting on the specified line, or
+--    - the rightmost subexpression enclosing the specified line
+--
+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByLine line arr = 
+  listToMaybe (sortBy leftmost complete)   `mplus`
+  listToMaybe (sortBy leftmost incomplete) `mplus`
+  listToMaybe (sortBy rightmost ticks)
+  where 
+        ticks = arr ! line
+
+        starts_here = [ tick | tick@(nm,span) <- ticks,
+                               srcSpanStartLine span == line ]
+
+        (complete,incomplete) = partition ends_here starts_here
+            where ends_here (nm,span) = srcSpanEndLine span == line
+
+findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
+findBreakByCoord (line, col) arr =
+  listToMaybe (sortBy rightmost contains)
+  where 
+        ticks = arr ! line
+
+        -- the ticks that span this coordinate
+        contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+
+leftmost  (_,a) (_,b) = a `compare` b
+rightmost (_,a) (_,b) = b `compare` a
+
+spans :: SrcSpan -> (Int,Int) -> Bool
+spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
+   where loc = mkSrcLoc (srcSpanFile span) l c
+
+
+-- --------------------------------------------------------------------------
+-- Tick arrays
+
+getTickArray :: Module -> GHCi TickArray
+getTickArray modl = do
+   st <- getGHCiState
+   let arrmap = tickarrays st
+   case lookupModuleEnv arrmap modl of
+      Just arr -> return arr
+      Nothing  -> do
+        (breakArray, ticks) <- getModBreak modl 
+        let arr = mkTickArray (assocs ticks)
+        setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
+        return arr
+
+discardTickArrays :: GHCi ()
+discardTickArrays = do
+   st <- getGHCiState
+   setGHCiState st{tickarrays = emptyModuleEnv}
+
+mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
+mkTickArray ticks
+  = accumArray (flip (:)) [] (1, max_line) 
+        [ (line, (nm,span)) | (nm,span) <- ticks,
+                              line <- srcSpanLines span ]
+    where
+        max_line = maximum (map srcSpanEndLine (map snd ticks))
+        srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+

 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
 getModBreak mod = do
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session mod
    let modBreaks  = GHC.modInfoModBreaks mod_info
 getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
 getModBreak mod = do
    session <- getSession
    Just mod_info <- io $ GHC.getModuleInfo session mod
    let modBreaks  = GHC.modInfoModBreaks mod_info

-   let array      = modBreaks_array modBreaks
-   let ticks      = modBreaks_ticks modBreaks
+   let array      = GHC.modBreaks_flags modBreaks
+   let ticks      = GHC.modBreaks_locs  modBreaks

    return (array, ticks)
 
 lookupModule :: Session -> String -> GHCi Module
    return (array, ticks)
 
 lookupModule :: Session -> String -> GHCi Module

diff --git a/compiler/ghci/TickTree.hs b/compiler/ghci/TickTree.hs
deleted file mode 100644 (file)
index a472e59..0000000
--- a/compiler/ghci/TickTree.hs
+++ /dev/null
@@ -1,110 +0,0 @@
------------------------------------------------------------------------------
---
--- Trees of source spans used by the breakpoint machinery
---
--- (c) The University of Glasgow 2007
---
------------------------------------------------------------------------------
-
-module TickTree 
-   ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList )
-   where
-
-import SrcLoc
-
-import Data.List (partition, foldl') 
-
-type TickNumber = Int
-
-newtype TickTree = Root [SpanTree]
-
-data SpanTree 
-   = Node 
-     { spanTreeTick     :: TickNumber 
-     , spanTreeLoc      :: SrcSpan
-     , spanTreeChildren :: [SpanTree]
-     }
-
-mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree
-mkNode tick loc kids
-   = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids }
-
-emptyTickTree :: TickTree
-emptyTickTree = Root []
-
-tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree
-tickTreeFromList 
-   = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree 
-
-insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree
-insertTickTree tick loc (Root children)
-   = Root $ insertSpanTree tick loc children
-
-insertSpanTree :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
-insertSpanTree tick loc [] = [mkNode tick loc []] 
-insertSpanTree tick loc children@(kid:siblings) 
-   | null containedKids = insertDeeper tick loc children
-   | otherwise = mkNode tick loc children : rest
-   where
-   (containedKids, rest) = getContainedKids loc children
-   insertDeeper :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
-   insertDeeper tick loc [] = [mkNode tick loc []] 
-   insertDeeper tick loc nodes@(kid:siblings)
-      | srcSpanStart loc < srcSpanStart kidLoc = newBranch : nodes 
-      | kidLoc `contains` loc = newKid : siblings 
-      | otherwise = kid : insertDeeper tick loc siblings
-      where
-      newBranch = mkNode tick loc []
-      kidLoc = spanTreeLoc kid
-      newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid)
-                      (insertSpanTree tick loc $ spanTreeChildren kid)
-
-getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree])
-getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree)) 
-
--- True if the left loc contains the right loc
-contains :: SrcSpan -> SrcSpan -> Bool
-contains span1 span2
-   = srcSpanStart span1 <= srcSpanStart span2 &&
-     srcSpanEnd   span1 <= srcSpanEnd   span2   
-
-type TickLoc = (TickNumber, SrcSpan)
-type LineNumber = Int
-type ColumnNumber = Int
-type Coord = (LineNumber, ColumnNumber)
-
-srcSpanStartLine = srcLocLine . srcSpanStart
-
-lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc 
-lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children
-
-lookupSpanTreeLine :: LineNumber -> [SpanTree] -> Maybe TickLoc 
-lookupSpanTreeLine line [] = Nothing 
-lookupSpanTreeLine line (node:nodes)
-   | startLine == line && endLine == line 
-        = Just (spanTreeTick node, spanTreeLoc node) 
-   | startLine > line  
-        = lookupSpanTreeLine line nodes
-   | otherwise = 
-        case lookupSpanTreeLine line (spanTreeChildren node) of
-                Nothing    -> lookupSpanTreeLine line nodes
-                x@(Just _) -> x
-   where
-   startLine = srcSpanStartLine (spanTreeLoc node) 
-   endLine = srcSpanEndLine (spanTreeLoc node) 
-
-lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc 
-lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing
-
-lookupSpanTreeCoord :: Coord -> [SpanTree] -> Maybe TickLoc -> Maybe TickLoc 
-lookupSpanTreeCoord coord [] acc = acc 
-lookupSpanTreeCoord coord (kid:siblings) acc
-   | spanTreeLoc kid `spans` coord 
-        = lookupSpanTreeCoord coord (spanTreeChildren kid) 
-                              (Just (spanTreeTick kid, spanTreeLoc kid))
-   | otherwise 
-        = lookupSpanTreeCoord coord siblings acc
-   where
-   spans :: SrcSpan -> Coord -> Bool
-   spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
-        where loc = mkSrcLoc (srcSpanFile span) l c

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5f78c3e..a04c06c 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -77,13 +77,16 @@ module GHC (
        exprType,
        typeKind,
        parseName,
        exprType,
        typeKind,
        parseName,

-       RunResult(..),
+       RunResult(..),  ResumeHandle,

        runStmt,
        runStmt,

+        resume,

        showModule,
         isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,
        lookupName,
         obtainTerm, obtainTerm1,
        showModule,
         isModuleInterpreted,
        compileExpr, HValue, dynCompileExpr,
        lookupName,
         obtainTerm, obtainTerm1,

+        ModBreaks(..), BreakIndex,
+        BreakInfo(breakInfo_number, breakInfo_module),

         modInfoModBreaks, 
 #endif
 
         modInfoModBreaks, 
 #endif
 

@@ -182,69 +185,50 @@ module GHC (
 import RtClosureInspect ( cvObtainTerm, Term )
 import TcRnDriver      ( tcRnLookupRdrName, tcRnGetInfo,
                          tcRnLookupName, getModuleExports )
 import RtClosureInspect ( cvObtainTerm, Term )
 import TcRnDriver      ( tcRnLookupRdrName, tcRnGetInfo,
                          tcRnLookupName, getModuleExports )

-import RdrName         ( plusGlobalRdrEnv, Provenance(..), 
-                         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
-                         mkGlobalRdrEnv )
-import HscMain         ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
-import Name            ( nameOccName )
-import Type            ( tidyType )
-import Var             ( varName )

 import VarEnv          ( emptyTidyEnv )
 import GHC.Exts         ( unsafeCoerce#, Ptr )
 import VarEnv          ( emptyTidyEnv )
 import GHC.Exts         ( unsafeCoerce#, Ptr )

-import Foreign.StablePtr( deRefStablePtr, castPtrToStablePtr, StablePtr, newStablePtr, freeStablePtr )
+import Foreign.StablePtr( deRefStablePtr, StablePtr, newStablePtr, freeStablePtr )

 import Foreign          ( poke )
 import Foreign          ( poke )

-import Data.Maybe       ( fromMaybe)

 import qualified Linker
 
 import Data.Dynamic     ( Dynamic )
 import Linker          ( HValue, getHValue, extendLinkEnv )
 
 import qualified Linker
 
 import Data.Dynamic     ( Dynamic )
 import Linker          ( HValue, getHValue, extendLinkEnv )
 

-import ByteCodeInstr    (BreakInfo)
+import ByteCodeInstr
+import DebuggerTys
+import IdInfo
+import HscMain          ( hscParseIdentifier, hscTcExpr, hscKcType, hscStmt )

 #endif
 
 #endif
 

-import Packages                ( initPackages )
-import NameSet         ( NameSet, nameSetToList, elemNameSet )
-import RdrName         ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..), 
-                         globalRdrEnvElts, extendGlobalRdrEnv,
-                          emptyGlobalRdrEnv )
+import Packages
+import NameSet
+import RdrName

 import HsSyn 
 import HsSyn 

-import Type            ( Kind, Type, dropForAlls, PredType, ThetaType,
-                         pprThetaArrow, pprParendType, splitForAllTys,
-                         pprTypeApp, funResultTy )
-import Id              ( Id, idType, isImplicitId, isDeadBinder,
-                          isExportedId, isLocalId, isGlobalId,
-                          isRecordSelector, recordSelectorFieldLabel,
-                          isPrimOpId, isFCallId, isClassOpId_maybe,
-                          isDataConWorkId, idDataCon,
-                          isBottomingId )
-import Var             ( TyVar )
+import Type             hiding (typeKind)
+import Id
+import Var              hiding (setIdType)

 import TysPrim         ( alphaTyVars )
 import TysPrim         ( alphaTyVars )

-import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
-                         isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,
-                         tyConTyVars, tyConDataCons, synTyConDefn,
-                         synTyConType, synTyConResKind )
-import Class           ( Class, classSCTheta, classTvsFds, classMethods )
-import FunDeps         ( pprFundeps )
-import DataCon         ( DataCon, dataConWrapId, dataConSig, dataConTyCon,
-                         dataConFieldLabels, dataConStrictMarks, 
-                         dataConIsInfix, isVanillaDataCon )
-import Name            ( Name, nameModule, NamedThing(..), nameSrcLoc )
+import TyCon
+import Class
+import FunDeps
+import DataCon
+import Name             hiding ( varName )

 import OccName         ( parenSymOcc )
 import OccName         ( parenSymOcc )

-import NameEnv         ( nameEnvElts )
+import NameEnv

 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo      ( getImports, getOptions )
 import Finder
 import InstEnv         ( Instance, instanceDFunId, pprInstance, pprInstanceHdr )
 import SrcLoc
 import DriverPipeline
 import DriverPhases    ( Phase(..), isHaskellSrcFilename, startPhase )
 import HeaderInfo      ( getImports, getOptions )
 import Finder

-import HscMain         ( newHscEnv, hscFileCheck, HscChecked(..) )
+import HscMain          ( newHscEnv, hscFileCheck, HscChecked(..) )

 import HscTypes
 import DynFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM
 import HscTypes
 import DynFlags
 import SysTools     ( initSysTools, cleanTempFiles, cleanTempFilesExcept,
                       cleanTempDirs )
 import Module
 import UniqFM

-import PackageConfig    ( PackageId, stringToPackageId, mainPackageId )
+import PackageConfig

 import FiniteMap
 import Panic
 import Digraph
 import FiniteMap
 import Panic
 import Digraph

@@ -259,15 +243,15 @@ import Outputable
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )
 import BasicTypes
 import TcType           ( tcSplitSigmaTy, isDictTy )
 import Maybes          ( expectJust, mapCatMaybes )

-import HaddockParse     ( parseHaddockParagraphs, parseHaddockString )
+import HaddockParse

 import HaddockLex       ( tokenise )
 
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )
 import HaddockLex       ( tokenise )
 
 import Control.Concurrent
 import System.Directory ( getModificationTime, doesFileExist )

-import Data.Maybe      ( isJust, isNothing )
-import Data.List       ( partition, nub )
+import Data.Maybe
+import Data.List

 import qualified Data.List as List
 import qualified Data.List as List

-import Control.Monad   ( unless, when )
+import Control.Monad

 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime )
 import Control.Exception as Exception hiding (handle)
 import System.Exit     ( exitWith, ExitCode(..) )
 import System.Time     ( ClockTime )
 import Control.Exception as Exception hiding (handle)

@@ -2151,11 +2135,13 @@ data RunResult
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
   | RunException Exception     -- ^ statement raised an exception
   = RunOk [Name]               -- ^ names bound by this evaluation
   | RunFailed                  -- ^ statement failed compilation
   | RunException Exception     -- ^ statement raised an exception

-  | forall a . RunBreak a ThreadId BreakInfo (IO RunResult)
+  | RunBreak ThreadId [Name] BreakInfo ResumeHandle

 
 

-data Status a
-   = Break RunResult               -- ^ the computation hit a breakpoint
-   | Complete (Either Exception a) -- ^ the computation completed with either an exception or a value
+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]

 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.
 
 -- | Run a statement in the current interactive context.  Statement
 -- may bind multple values.

@@ -2177,60 +2163,67 @@ runStmt (Session ref) expr
         case maybe_stuff of
           Nothing -> return RunFailed
           Just (new_hsc_env, names, hval) -> do
         case maybe_stuff of
           Nothing -> return RunFailed
           Just (new_hsc_env, names, hval) -> do

+              writeIORef ref new_hsc_env

 
 

-              -- resume says what to do when we continue execution from a breakpoint
-              -- onBreakAction says what to do when we hit a breakpoint
-              -- they are mutually recursive, hence the strange use tuple let-binding 
-              let (resume, onBreakAction)
-                     = ( do stablePtr <- newStablePtr onBreakAction 
-                            poke breakPointIOAction stablePtr
-                            putMVar breakMVar ()
-                            status <- takeMVar statusMVar
-                            switchOnStatus ref new_hsc_env names status
-                       , \ids apStack -> do 
-                            tid <- myThreadId
-                            putMVar statusMVar (Break (RunBreak apStack tid ids resume))
-                            takeMVar breakMVar 
-                       )
-
-              -- 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 <- newStablePtr onBreakAction
-              poke breakPointIOAction stablePtr
+              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

 
               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
               status <- sandboxIO statusMVar thing_to_run
               freeStablePtr stablePtr -- be careful not to leak stable pointers!
 
               let thing_to_run = unsafeCoerce# hval :: IO [HValue]
               status <- sandboxIO statusMVar thing_to_run
               freeStablePtr stablePtr -- be careful not to leak stable pointers!

-              switchOnStatus ref new_hsc_env names status
-   where
-   switchOnStatus ref hs_env names status = 
-      case status of  
-         -- did we hit a breakpoint or did we complete?
-         (Break result) -> return result 
-         (Complete either_hvals) ->
+              handleRunStatus ref names status
+
+handleRunStatus ref names status =
+   case status of  
+      -- did we hit a breakpoint or did we complete?
+      (Break apStack info tid res) -> do
+                hsc_env <- readIORef ref
+                (new_hsc_env, names) <- extendEnvironment hsc_env apStack 
+                                                (breakInfo_vars info)
+                writeIORef ref new_hsc_env 
+                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)
                case either_hvals of
                    Left e -> return (RunException e)
                    Right hvals -> do
                        extendLinkEnv (zip names hvals)

-                       writeIORef ref hs_env 

                        return (RunOk names)
            
 -- this points to the IO action that is executed when a breakpoint is hit
 foreign import ccall "&breakPointIOAction" 
                        return (RunOk names)
            
 -- this points to the IO action that is executed when a breakpoint is hit
 foreign import ccall "&breakPointIOAction" 

-        breakPointIOAction :: Ptr (StablePtr (a -> BreakInfo -> IO ())) 
+        breakPointIOAction :: Ptr (StablePtr (BreakInfo -> HValue -> IO ())) 

 
 -- When running a computation, we redirect ^C exceptions to the running
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".
 
 -- When running a computation, we redirect ^C exceptions to the running
 -- thread.  ToDo: we might want a way to continue even if the target
 -- thread doesn't die when it receives the exception... "this thread
 -- is not responding".

-sandboxIO :: MVar (Status a) -> IO a -> IO (Status a) 
+sandboxIO :: MVar Status -> IO [HValue] -> IO Status

 sandboxIO statusMVar thing = do
   ts <- takeMVar interruptTargetThread
   child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
   putMVar interruptTargetThread (child:ts)
   takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
 
 sandboxIO statusMVar thing = do
   ts <- takeMVar interruptTargetThread
   child <- forkIO (do res <- Exception.try thing; putMVar statusMVar (Complete res))
   putMVar interruptTargetThread (child:ts)
   takeMVar statusMVar `finally` modifyMVar_ interruptTargetThread (return.tail)
 

+setBreakAction res@(ResumeHandle breakMVar statusMVar names) = do 
+  stablePtr <- newStablePtr onBreak
+  poke breakPointIOAction stablePtr
+  return stablePtr
+  where onBreak ids apStack = do
+                tid <- myThreadId
+                putMVar statusMVar (Break apStack ids tid res)
+                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
+

 {-
 -- This version of sandboxIO runs the expression in a completely new
 -- RTS main thread.  It is disabled for now because ^C exceptions
 {-
 -- This version of sandboxIO runs the expression in a completely new
 -- RTS main thread.  It is disabled for now because ^C exceptions

@@ -2261,6 +2254,57 @@ XXX the type of rts_evalStableIO no longer matches the above
 
 -}
 
 
 -}
 

+-- -----------------------------------------------------------------------------
+-- After stopping at a breakpoint, add free variables to the environment
+
+-- Todo: turn this into a primop, and provide special version(s) for unboxed things
+foreign import ccall "rts_getApStackVal" getApStackVal :: StablePtr a -> Int -> IO (StablePtr b)
+
+getIdValFromApStack :: a -> (Id, Int) -> IO (Id, HValue)
+getIdValFromApStack apStack (identifier, stackDepth) = do
+   -- ToDo: check the type of the identifer and decide whether it is unboxed or not
+   apSptr <- newStablePtr apStack
+   resultSptr <- getApStackVal apSptr (stackDepth - 1)
+   result <- deRefStablePtr resultSptr
+   freeStablePtr apSptr
+   freeStablePtr resultSptr 
+   return (identifier, unsafeCoerce# result)
+
+extendEnvironment :: HscEnv -> a -> [(Id, Int)] -> IO (HscEnv, [Name])
+extendEnvironment hsc_env apStack idsOffsets = do
+   idsVals <- mapM (getIdValFromApStack apStack) idsOffsets 
+   let (ids, hValues) = unzip idsVals 
+   let names = map idName ids
+   let global_ids = map globaliseAndTidy ids
+   typed_ids  <- mapM instantiateIdType global_ids
+   let ictxt = hsc_IC hsc_env
+       rn_env   = ic_rn_local_env ictxt
+       type_env = ic_type_env ictxt
+       bound_names = map idName typed_ids
+       new_rn_env  = extendLocalRdrEnv rn_env bound_names
+       -- Remove any shadowed bindings from the type_env;
+       -- they are inaccessible but might, I suppose, cause 
+       -- a space leak if we leave them there
+       shadowed = [ n | name <- bound_names,
+                    let rdr_name = mkRdrUnqual (nameOccName name),
+                    Just n <- [lookupLocalRdrEnv rn_env rdr_name] ]
+       filtered_type_env = delListFromNameEnv type_env shadowed
+       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
+   return (hsc_env{hsc_IC = new_ic}, names)
+  where
+   globaliseAndTidy :: Id -> Id
+   globaliseAndTidy id
+      = let tidied_type = tidyTopType$ idType id
+        in setIdType (globaliseId VanillaGlobal id) tidied_type
+
+   -- | Instantiate the tyVars with GHC.Base.Unknown
+   instantiateIdType :: Id -> IO Id
+   instantiateIdType id = do
+      instantiatedType <- instantiateTyVarsToUnknown hsc_env (idType id)
+      return$ setIdType id instantiatedType

 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames
 
 -----------------------------------------------------------------------------
 -- show a module and it's source/object filenames

diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index c7926e3..1101e86 100644 (file)
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -62,7 +62,7 @@ module HscTypes (
         HpcInfo, noHpcInfo,
 
         -- Breakpoints
         HpcInfo, noHpcInfo,
 
         -- Breakpoints

-        ModBreaks (..), emptyModBreaks
+        ModBreaks (..), BreakIndex, emptyModBreaks

     ) where
 
 #include "HsVersions.h"
     ) where
 
 #include "HsVersions.h"

@@ -1243,18 +1243,22 @@ byteCodeOfObject other     = pprPanic "byteCodeOfObject" (ppr other)
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

--- all the information about the breakpoints for a given module
+type BreakIndex = Int
+
+-- | all the information about the breakpoints for a given module

 data ModBreaks
    = ModBreaks
 data ModBreaks
    = ModBreaks

-   { modBreaks_array :: BreakArray
-            -- the array of breakpoint flags indexed by tick number
-   , modBreaks_ticks :: !(Array Int SrcSpan)
+   { modBreaks_flags :: BreakArray
+        -- The array of flags, one per breakpoint, 
+        -- indicating which breakpoints are enabled.
+   , modBreaks_locs :: !(Array BreakIndex SrcSpan)
+        -- An array giving the source span of each breakpoint.

    }
 
 emptyModBreaks :: ModBreaks
 emptyModBreaks = ModBreaks
    }
 
 emptyModBreaks :: ModBreaks
 emptyModBreaks = ModBreaks

-   { modBreaks_array = error "ModBreaks.modBreaks_array not initialised"
+   { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"

          -- Todo: can we avoid this? 
          -- Todo: can we avoid this? 

-   , modBreaks_ticks = array (0,-1) []
+   , modBreaks_locs = array (0,-1) []

    }
 \end{code}
    }
 \end{code}