X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FDebugger.hs;h=62633d2648364d400d40e8bac24bd20154246b73;hb=a6156829d4e671c5385769ccc7675e644591525d;hp=125d634d70d6eafa86f694626dfebd92ad83de53;hpb=01314483b22813020e4746cc32d97a0f9fb6e806;p=ghc-hetmet.git

diff --git a/compiler/ghci/Debugger.hs b/compiler/ghci/Debugger.hs
index 125d634..62633d2 100644
--- a/compiler/ghci/Debugger.hs
+++ b/compiler/ghci/Debugger.hs
@@ -34,6 +34,7 @@ import GhciMonad
 import PackageConfig
 
 import Outputable
+import Pretty                    ( Mode(..), showDocWith )
 import ErrUtils
 import FastString
 import SrcLoc
@@ -44,6 +45,7 @@ import Control.Exception
 import Control.Monad
 import qualified Data.Map as Map
 import Data.Array.Unboxed
+import Data.Array.Base
 import Data.List
 import Data.Typeable             ( Typeable )
 import Data.Maybe
@@ -83,7 +85,9 @@ pprintClosureCommand bindThings force str = do
                    else bindSuspensions cms term                         
      showterm  <- pprTerm cms term'
      unqual    <- GHC.getPrintUnqual cms
-     (putStrLn . showSDocForUser unqual) (ppr id <+> char '=' <+> showterm)
+     let showSDocForUserOneLine unqual doc = 
+             showDocWith LeftMode (doc (mkErrStyle unqual))
+     (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
      -- Before leaving, we compare the type obtained to see if it's more specific
      -- Note how we need the Unknown-clear type returned by obtainTerm
      let Just reconstructedType = termType term  
@@ -326,18 +330,26 @@ bkptOptions cmd = do
       io$ putStrLn msg
 
     bkptOptions' s ("add":cmds) bt 
+      | [line]         <- cmds
+      , [(lineNum,[])] <- reads line
+      = do (toplevel,_) <- io$ GHC.getContext s
+           case toplevel of
+             (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
+             [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"
+
       | [mod_name,line]<- cmds
       , [(lineNum,[])] <- reads line
-      =  handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
+      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+         handleAdd (\mod->addBkptByLine mod lineNum)
 
       | [mod_name,line,col] <- cmds
-      = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
+      = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+         handleAdd (\mod->addBkptByCoord mod (read line, read col))
 
       | otherwise = throwDyn $ CmdLineError $ 
                        "syntax: :breakpoint add Module line [col]"
        where 
-         handleAdd mod_name f = do
-           mod         <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing
+         handleAdd f mod = 
            either 
              (handleBkptEx s mod)
              (\(newTable, site) -> do
@@ -369,31 +381,28 @@ bkptOptions cmd = do
       = handleDel mod $ delBkptByCoord mod (lineNum, colNum)
         
       | otherwise = throwDyn $ CmdLineError $ 
-             "syntax: :breakpoint del (breakpoint # | Module line [col])"
+             "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
 
        where delMsg = "Breakpoint deleted"
              handleDel mod f = either (handleBkptEx s mod)
                                       (\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
                                       (f bt)
                                       
-
     bkptOptions' _ _ _ = throwDyn $ CmdLineError $ 
                          "syntax: :breakpoint (list|continue|stop|add|del)"
 
 -- Error messages
 --    handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
-    handleBkptEx s m NotHandled  = io$
-                                   findModSummary m                  >>= \mod_summary ->
-                                   isModuleInterpreted s mod_summary >>= \it -> 
-       if it
+    handleBkptEx s m NotHandled  = io$ do
+       isInterpreted <- findModSummary m >>= isModuleInterpreted s
+       if isInterpreted
         then error$ "Module " ++ showSDoc (ppr m) ++  " was not loaded under debugging mode.\n" 
                  ++ "Enable debugging mode with -fdebugging (and reload your module)"
         else error$ "Module " ++ showSDoc (ppr m) ++  " was loaded in compiled (.o) mode.\n" 
                  ++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
-                     where findModSummary m = getModuleGraph s >>= \mod_graph ->  
-                               case [ modsum | modsum <- mod_graph
-                                             , ms_mod modsum == m ] of
-                                 [modsum] -> return modsum
+         where findModSummary m = do 
+                 mod_graph <- getModuleGraph s 
+                 return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
     handleBkptEx _ _ e = error (show e)
 
 -------------------------
@@ -536,15 +545,16 @@ addModule a siteCoords bt
    , sitesByRow   <- [ [(s,c) | (s,(r,c)) <- siteCoords, r==i] 
                        | i <- [0..nrows] ]
    , nsites       <- length siteCoords
-   , initialBkpts <- listArray (1, nsites) (repeat False) 
+   , initialBkpts <- listArray (0, nsites+1) (repeat False) 
    = bt{ sites       = Map.insert a sitesByRow (sites bt) 
        , breakpoints = Map.insert a initialBkpts (breakpoints bt) }
 
+-- This MUST be fast
+isBkptEnabled bt site | bt `seq` site `seq` False = undefined
 isBkptEnabled bt (a,site) 
    | Just bkpts <- bkptsOf bt a 
-   , inRange (bounds bkpts) site
-   = bkpts ! site 
-   | otherwise = panic "unexpected condition: I don't know that breakpoint site"
+   = ASSERT (inRange (bounds bkpts) site) 
+     unsafeAt bkpts site
 
 -----------------
 -- Other stuff