X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=b5af439d640173a3ae49fc437883ac9ee10c059a;hb=a6156829d4e671c5385769ccc7675e644591525d;hp=e7a5a37edb9c793863fe6e09842344ae3849bdb8;hpb=8099fc7e9c54b24dc50c2cd1b9bfdc59e2d218b1;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index e7a5a37..b5af439 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -13,19 +13,7 @@ module InteractiveUI (
 
 #include "HsVersions.h"
 
-#if defined(GHCI) && defined(BREAKPOINT)
-import GHC.Exts         ( Int(..), Ptr(..), int2Addr# )
-import Foreign.StablePtr ( deRefStablePtr, castPtrToStablePtr )
-import System.IO.Unsafe ( unsafePerformIO )
-import Var
-import HscTypes
-import RdrName
-import NameEnv
-import TcType
-import qualified Id
-import IdInfo
-import PrelNames
-#endif
+import GhciMonad
 
 -- The GHC interface
 import qualified GHC
@@ -45,13 +33,26 @@ import SrcLoc
 
 -- Other random utilities
 import Digraph
-import BasicTypes
-import Panic hiding (showException)
+import BasicTypes hiding (isTopLevel)
+import Panic      hiding (showException)
 import Config
 import StaticFlags
 import Linker
 import Util
 
+-- The debugger
+import Breakpoints
+import Debugger hiding  ( addModule )
+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
@@ -84,6 +85,7 @@ import System.Directory
 import System.IO
 import System.IO.Error as IO
 import Data.Char
+import Data.Dynamic
 import Control.Monad as Monad
 import Foreign.StablePtr	( newStablePtr )
 
@@ -110,9 +112,14 @@ GLOBAL_VAR(commands, builtin_commands, [Command])
 
 builtin_commands :: [Command]
 builtin_commands = [
-  ("add",	keepGoingPaths addModule,	False, completeFilename),
+  ("add",	tlC$ keepGoingPaths addModule,	False, completeFilename),
   ("browse",    keepGoing browseCmd,		False, completeModule),
-  ("cd",    	keepGoing changeDirectory, 	False, completeFilename),
+#ifdef DEBUGGER
+        -- I think that :c should mean :continue rather than :cd, makes more sense
+        --  (pepe 01.11.07)
+  ("continue",  const(bkptOptions "continue"),  False, completeNone),
+#endif
+  ("cd",    	tlC$ keepGoing changeDirectory,	False, completeFilename),
   ("def",	keepGoing defineMacro,		False, completeIdentifier),
   ("e", 	keepGoing editFile,		False, completeFilename),
 	-- Hugs users are accustomed to :e, so make sure it doesn't overlap
@@ -120,16 +127,22 @@ builtin_commands = [
   ("help",	keepGoing help,			False, completeNone),
   ("?",		keepGoing help,			False, completeNone),
   ("info",      keepGoing info,			False, completeIdentifier),
-  ("load",	keepGoingPaths loadModule_,	False, completeHomeModuleOrFile),
+  ("load",	tlC$ keepGoingPaths loadModule_,False, completeHomeModuleOrFile),
   ("module",	keepGoing setContext,		False, completeModule),
-  ("main",	keepGoing runMain,		False, completeIdentifier),
-  ("reload",	keepGoing reloadModule,		False, completeNone),
+  ("main",	tlC$ keepGoing runMain,		False, completeIdentifier),
+  ("reload", 	tlC$ keepGoing reloadModule,  	False, completeNone),
   ("check",	keepGoing checkModule,		False, completeHomeModule),
   ("set",	keepGoing setCmd,		True,  completeSetOptions),
   ("show",	keepGoing showCmd,		False, completeNone),
   ("etags",	keepGoing createETagsFileCmd,	False, completeFilename),
   ("ctags",	keepGoing createCTagsFileCmd, 	False, completeFilename),
   ("type",	keepGoing typeOfExpr,		False, completeIdentifier),
+#if defined(DEBUGGER)
+  ("print",     keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+  ("sprint",    keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+  ("force",     keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+  ("breakpoint",bkptOptions,                    False, completeBkpt),
+#endif
   ("kind",	keepGoing kindOfType,		False, completeIdentifier),
   ("unset",	keepGoing unsetOptions,		True,  completeSetOptions),
   ("undef",     keepGoing undefineMacro,	False, completeMacro),
@@ -139,6 +152,14 @@ builtin_commands = [
 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
 
@@ -150,13 +171,17 @@ helpText =
  "\n" ++
  "   <stmt>                      evaluate/run <stmt>\n" ++
  "   :add <filename> ...         add module(s) to the current target set\n" ++
+ "   :breakpoint <option>        commands for the GHCi debugger\n" ++
  "   :browse [*]<module>         display the names defined by <module>\n" ++
  "   :cd <dir>                   change directory to <dir>\n" ++
+ "   :continue                   equivalent to ':breakpoint continue'\n"  ++
  "   :def <cmd> <expr>           define a command :<cmd>\n" ++
  "   :edit <file>                edit file\n" ++
  "   :edit                       edit last module\n" ++
  "   :help, :?                   display this list of commands\n" ++
  "   :info [<name> ...]          display information about the given names\n" ++
+ "   :print [<name> ...]         prints a value without forcing its computation\n" ++
+ "   :sprint [<name> ...]        simplified version of :print\n" ++
  "   :load <filename> ...        load module(s) and their dependents\n" ++
  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" ++
  "   :main [<arguments> ...]     run the main function with the given arguments\n" ++
@@ -186,73 +211,15 @@ helpText =
  "    +s            print timing/memory stats after each evaluation\n" ++
  "    +t            print type after evaluation\n" ++
  "    -<flags>      most GHC command line flags can also be set here\n" ++
- "                         (eg. -v2, -fglasgow-exts, etc.)\n"
-
-
-#if defined(GHCI) && defined(BREAKPOINT)
-globaliseAndTidy :: Id -> Id
-globaliseAndTidy id
--- Give the Id a Global Name, and tidy its type
-  = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
-  where
-    tidy_type = tidyTopType (idType id)
-
-
-printScopeMsg :: Session -> String -> [Id] -> IO ()
-printScopeMsg session location ids
-    = GHC.getPrintUnqual session >>= \unqual ->
-      printForUser stdout unqual $
-        text "Local bindings in scope:" $$
-        nest 2 (pprWithCommas showId ids)
-    where showId id = ppr (idName id) <+> dcolon <+> ppr (idType id)
-
-jumpCondFunction :: Session -> Int -> [HValue] -> String -> Bool -> b -> b
-jumpCondFunction session ptr hValues location True b = b
-jumpCondFunction session ptr hValues location False b
-    = jumpFunction session ptr hValues location b
-
-jumpFunction :: Session -> Int -> [HValue] -> String -> b -> b
-jumpFunction session@(Session ref) (I# idsPtr) hValues location b
-    = unsafePerformIO $
-      do ids <- deRefStablePtr (castPtrToStablePtr (Ptr (int2Addr# idsPtr)))
-         let names = map idName ids
-         ASSERT (length names == length hValues) return ()
-         printScopeMsg session location ids
-         hsc_env <- readIORef ref
-
-         let ictxt = hsc_IC hsc_env
-             global_ids = map globaliseAndTidy ids
-             rn_env   = ic_rn_local_env ictxt
-             type_env = ic_type_env ictxt
-             bound_names = map idName global_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 global_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 })
-         is_tty <- hIsTerminalDevice stdin
-         prel_mod <- GHC.findModule session prel_name Nothing
-	 default_editor <- findEditor
-         withExtendedLinkEnv (zip names hValues) $
-           startGHCi (interactiveLoop is_tty True)
-                     GHCiState{ progname = "<interactive>",
-                                args = [],
-                                prompt = location++"> ",
-				editor = default_editor,
-                                session = session,
-                                options = [],
-                                prelude =  prel_mod }
-         writeIORef ref hsc_env
-         putStrLn $ "Returning to normal execution..."
-         return b
-#endif
+ "                         (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ "\n" ++
+ " Options for ':breakpoint':\n" ++
+ "   list                                     list the current breakpoints\n" ++
+ "   add [Module] line [col]                    add a new breakpoint\n" ++
+ "   del (breakpoint# | Module line [col])    delete a breakpoint\n" ++
+ "   continue                                 continue execution\n"  ++
+ "   stop                   Stop a computation and return to the top level\n" ++
+ "   step [count]           Step by step execution (DISABLED)\n"
 
 findEditor = do
   getEnv "EDITOR" 
@@ -266,11 +233,6 @@ findEditor = do
 
 interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
 interactiveUI session srcs maybe_expr = do
-#if defined(GHCI) && defined(BREAKPOINT)
-   initDynLinker =<< GHC.getSessionDynFlags session
-   extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
-                 ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]
-#endif
    -- HACK! If we happen to get into an infinite loop (eg the user
    -- types 'let x=x in x' at the prompt), then the thread will block
    -- on a blackhole, and become unreachable during GC.  The GC will
@@ -315,6 +277,8 @@ interactiveUI session srcs maybe_expr = do
    Readline.setCompleterWordBreakCharacters word_break_chars
 #endif
 
+   bkptTable <- newIORef emptyBkptTable
+   GHC.setBreakpointHandler session (instrumentationBkptHandler bkptTable)
    default_editor <- findEditor
 
    startGHCi (runGHCi srcs maybe_expr)
@@ -324,7 +288,10 @@ interactiveUI session srcs maybe_expr = do
 		   editor = default_editor,
 		   session = session,
 		   options = [],
-                   prelude = prel_mod }
+                   prelude = prel_mod,
+                   bkptTable = bkptTable,
+		   topLevel  = True
+                 }
 
 #ifdef USE_READLINE
    Readline.resetTerminal Nothing
@@ -812,11 +779,11 @@ afterLoad ok session = do
   graph <- io (GHC.getModuleGraph session)
   graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
+  do 
+     bt  <- getBkptTable
+     bt' <- io$ refreshBkptTable session bt graph'
+     setBkptTable bt'
   modulesLoadedMsg ok (map GHC.ms_mod_name graph')
-#if defined(GHCI) && defined(BREAKPOINT)
-  io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
-                    ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
-#endif
 
 setContextAfterLoad session [] = do
   prel_mod <- getPrelude
@@ -886,7 +853,11 @@ kindOfType str
 		           io (putStrLn (str ++ " :: " ++ tystr))
 
 quit :: String -> GHCi Bool
-quit _ = return True
+quit _ =  do in_inferior_session <- liftM not isTopLevel 
+             if in_inferior_session 
+               then throwDyn StopParentSession
+               else return True
+          
 
 shellEscape :: String -> GHCi Bool
 shellEscape str = io (system str >> return False)
@@ -1248,6 +1219,7 @@ showCmd str =
 	["modules" ] -> showModules
 	["bindings"] -> showBindings
 	["linker"]   -> io showLinkerState
+        ["breakpoints"] -> showBkptTable
 	_ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 
 showModules = do
@@ -1278,6 +1250,14 @@ cleanType ty = do
 	then return ty
 	else return $! GHC.dropForAlls ty
 
+showBkptTable :: GHCi ()
+showBkptTable = do
+  bt     <- getBkptTable
+  msg <- showForUser . vcat $ 
+             [ ppr mod <> colon <+> fcat 
+                       [ parens(int row <> comma <> int col) | (row,col) <- sites]
+               | (mod, sites) <-  sitesList bt ]
+  io (putStrLn msg)
 -- -----------------------------------------------------------------------------
 -- Completion
 
@@ -1349,6 +1329,12 @@ completeSetOptions w = do
   return (filter (w `isPrefixOf`) options)
     where options = "args":"prog":allFlags
 
+completeBkpt = unionComplete completeModule completeBkptCmds
+
+completeBkptCmds w = do
+  return (filter (w `isPrefixOf`) options)
+    where options = ["add","del","list","stop"]
+
 completeFilename = Readline.filenameCompletionFunction
 
 completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename
@@ -1372,7 +1358,7 @@ wrapCompleter fun w =  do
 getCommonPrefix :: [String] -> String
 getCommonPrefix [] = ""
 getCommonPrefix (s:ss) = foldl common s ss
-  where common s "" = s
+  where common s "" = ""
 	common "" s = ""
 	common (c:cs) (d:ds)
 	   | c == d = c : common cs ds
@@ -1392,8 +1378,68 @@ completeHomeModule = completeNone
 completeSetOptions = completeNone
 completeFilename   = completeNone
 completeHomeModuleOrFile=completeNone
+completeBkpt       = completeNone
 #endif
 
+-- ---------------------------------------------------------------------------
+-- User code exception handling
+
+-- This is the exception handler for exceptions generated by the
+-- user's code and exceptions coming from children sessions; 
+-- it normally just prints out the exception.  The
+-- handler must be recursive, in case showing the exception causes
+-- more exceptions to be raised.
+--
+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,
+-- raising another exception.  We therefore don't put the recursive
+-- handler arond the flushing operation, so if stderr is closed
+-- GHCi will just die gracefully rather than going into an infinite loop.
+handler :: Exception -> GHCi Bool
+handler (DynException dyn) 
+  | Just StopChildSession <- fromDynamic dyn 
+     -- propagate to the parent session
+  = do ASSERTM (liftM not isTopLevel) 
+       throwDyn StopChildSession
+
+  | Just StopParentSession <- fromDynamic dyn 
+  = do at_topLevel <-  isTopLevel
+       if at_topLevel then return True else throwDyn StopParentSession
+  
+  | Just (ChildSessionStopped msg) <- fromDynamic dyn     
+  = io(putStrLn msg) >> return False
+
+handler exception = do
+  flushInterpBuffers
+  io installSignalHandlers
+  ghciHandle handler (showException exception >> return False)
+
+showException (DynException dyn) =
+  case fromDynamic dyn of
+    Nothing               -> io (putStrLn ("*** Exception: (unknown)"))
+    Just Interrupted      -> io (putStrLn "Interrupted.")
+    Just (CmdLineError s) -> io (putStrLn s)	 -- omit the location for CmdLineError
+    Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
+    Just other_ghc_ex     -> io (print other_ghc_ex)
+
+showException other_exception
+  = io (putStrLn ("*** Exception: " ++ show other_exception))
+
+-----------------------------------------------------------------------------
+-- recursive exception handlers
+
+-- Don't forget to unblock async exceptions in the handler, or if we're
+-- in an exception loop (eg. let a = error a in a) the ^C exception
+-- may never be delivered.  Thanks to Marcin for pointing out the bug.
+
+ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a
+ghciHandle h (GHCi m) = GHCi $ \s -> 
+   Exception.catch (m s) 
+	(\e -> unGHCi (ghciUnblock (h e)) s)
+
+ghciUnblock :: GHCi a -> GHCi a
+ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
+
+
 -- ----------------------------------------------------------------------------
 -- Utils
 
@@ -1429,3 +1475,85 @@ setUpConsole = do
 	setConsoleOutputCP 28591 -- ISO Latin-1
 #endif
 	return ()
+
+
+instrumentationBkptHandler :: IORef (BkptTable Module) -> BkptHandler Module
+instrumentationBkptHandler ref_bkptTable = BkptHandler {
+    isAutoBkptEnabled = \sess bkptLoc -> do 
+      bktpTable <- readIORef ref_bkptTable
+      return$ isBkptEnabled bktpTable bkptLoc
+
+  , handleBreakpoint = doBreakpoint ref_bkptTable 
+  }
+
+doBreakpoint :: IORef (BkptTable Module)-> Session -> [(Id,HValue)] -> BkptLocation Module -> String -> b -> IO b
+doBreakpoint ref_bkptTable s@(Session ref) values _ locMsg b = do
+         let (ids, hValues) = unzip values
+             names = map idName ids
+         ASSERT (length names == length hValues) return ()
+         let global_ids = map globaliseAndTidy ids
+         printScopeMsg locMsg global_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 })
+         is_tty <- hIsTerminalDevice stdin
+         prel_mod <- GHC.findModule s prel_name Nothing
+         withExtendedLinkEnv (zip names hValues) $ 
+           startGHCi (interactiveLoop is_tty True) GHCiState{ 
+                              progname = "<interactive>",
+                              args     = [],
+                              prompt   = locMsg ++ "> ",
+                              session  = s,
+                              options  = [],
+                              bkptTable= ref_bkptTable,
+                              prelude  = prel_mod,
+			      topLevel = False }
+             `catchDyn` (\e -> case e of 
+                           StopChildSession -> evaluate$
+                                               throwDyn (ChildSessionStopped "")
+                           StopParentSession -> throwDyn StopParentSession
+           ) `finally` do
+             writeIORef ref hsc_env
+             putStrLn $ "Returning to normal execution..."
+         return b
+  where 
+     printScopeMsg :: String -> [Id] -> IO ()
+     printScopeMsg location ids = do
+       unqual  <- GHC.getPrintUnqual s
+       printForUser stdout unqual $
+         text "Stopped at a breakpoint in " <> text (stripColumn location) <>
+         char '.' <+> text "Local bindings in scope:" $$
+         nest 2 (pprWithCommas showId ids)
+      where 
+           showId id = 
+                ppr (idName id) <+> dcolon <+> ppr (idType id) 
+           stripColumn = reverse . tail . dropWhile (/= ':') . reverse
+
+-- | Give the Id a Global Name, and tidy its type
+     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 s (idType id)
+       return$ setIdType id instantiatedType
+
+