X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=573aaa01cc49fb4a75746534d2f81e0b7d80133a;hb=d0a4736028a4834f6ce643a0629c7b5f1f451d34;hp=c9de96ff62864fd1a9a208f0e656873d54719dc3;hpb=e53f09de573cdda360a72e94553b2eecd747497c;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index c9de96f..573aaa0 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -3,7 +3,7 @@
 --
 -- GHC Interactive User Interface
 --
--- (c) The GHC Team 2005
+-- (c) The GHC Team 2005-2006
 --
 -----------------------------------------------------------------------------
 module InteractiveUI ( 
@@ -13,52 +13,45 @@ 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              ( Id, globaliseId, idName, idType )
-import HscTypes         ( Session(..), InteractiveContext(..), HscEnv(..)
-                        , extendTypeEnvWithIds )
-import RdrName          ( extendLocalRdrEnv, mkRdrUnqual, lookupLocalRdrEnv )
-import NameEnv          ( delListFromNameEnv )
-import TcType           ( tidyTopType )
-import qualified Id     ( setIdType )
-import IdInfo           ( GlobalIdDetails(..) )
-import Linker           ( HValue, extendLinkEnv, withExtendedLinkEnv,initDynLinker  )
-import PrelNames        ( breakpointJumpName, breakpointCondJumpName )
-#endif
+import GhciMonad
 
 -- The GHC interface
 import qualified GHC
-import GHC		( Session, verbosity, dopt, DynFlag(..), Target(..),
-			  TargetId(..), DynFlags(..),
-			  pprModule, Type, Module, SuccessFlag(..),
-			  TyThing(..), Name, LoadHowMuch(..), Phase,
-			  GhcException(..), showGhcException,
-			  CheckedModule(..), SrcLoc )
-import DynFlags         ( allFlags )
-import Packages		( PackageState(..) )
-import PackageConfig	( InstalledPackageInfo(..) )
-import UniqFM		( eltsUFM )
+import GHC              ( Session, LoadHowMuch(..), Target(..),  TargetId(..),
+                          Type, Module, ModuleName, TyThing(..), Phase )
+import DynFlags
+import Packages
+import PackageConfig
+import UniqFM
 import PprTyThing
 import Outputable
 
--- for createtags (should these come via GHC?)
-import Module		( moduleString )
-import Name		( nameSrcLoc, nameModule, nameOccName )
-import OccName		( pprOccName )
-import SrcLoc		( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol )
+-- for createtags
+import Name
+import OccName
+import SrcLoc
 
 -- Other random utilities
-import Digraph		( flattenSCCs )
-import BasicTypes	( failed, successIf )
-import Panic 		( panic, installSignalHandlers )
+import Digraph
+import BasicTypes hiding (isTopLevel)
+import Panic      hiding (showException)
 import Config
-import StaticFlags	( opt_IgnoreDotGhci )
-import Linker		( showLinkerState )
-import Util		( removeSpaces, handle, global, toArgs,
-			  looksLikeModuleName, prefixMatch, sortLe )
+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
@@ -68,6 +61,7 @@ import System.Posix
 #else
 import GHC.ConsoleHandler ( flushConsole )
 import System.Win32	  ( setConsoleCP, setConsoleOutputCP )
+import qualified System.Win32
 #endif
 
 #ifdef USE_READLINE
@@ -78,24 +72,22 @@ import System.Console.Readline as Readline
 --import SystemExts
 
 import Control.Exception as Exception
-import Data.Dynamic
 -- import Control.Concurrent
 
 import Numeric
 import Data.List
 import Data.Int		( Int64 )
-import Data.Maybe	( isJust, fromMaybe, catMaybes )
+import Data.Maybe	( isJust, isNothing, fromMaybe, catMaybes )
 import System.Cmd
-import System.CPUTime
 import System.Environment
 import System.Exit	( exitWith, ExitCode(..) )
 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 )
-import Text.Printf
 
 import GHC.Exts		( unsafeCoerce# )
 import GHC.IOBase	( IOErrorType(InvalidArgument) )
@@ -120,23 +112,37 @@ 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
+  ("edit",	keepGoing editFile,		False, completeFilename),
   ("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),
@@ -146,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
 
@@ -157,11 +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" ++
@@ -171,12 +191,13 @@ helpText =
  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" ++
  "   :set prog <progname>        set the value returned by System.getProgName\n" ++
  "   :set prompt <prompt>        set the prompt used in GHCi\n" ++
+ "   :set editor <cmd>           set the command used for :edit\n" ++
  "\n" ++
  "   :show modules               show the currently loaded modules\n" ++
  "   :show bindings              show the current bindings made at the prompt\n" ++
  "\n" ++
  "   :ctags [<file>]             create tags file for Vi (default: \"tags\")\n" ++
- "   :etags [<file>]           	 create tags file for Emacs (defauilt: \"TAGS\")\n" ++
+ "   :etags [<file>]             create tags file for Emacs (default: \"TAGS\")\n" ++
  "   :type <expr>                show the type of <expr>\n" ++
  "   :kind <type>                show the kind of <type>\n" ++
  "   :undef <cmd>                undefine user-defined command :<cmd>\n" ++
@@ -190,77 +211,28 @@ 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
-         withExtendedLinkEnv (zip names hValues) $
-           startGHCi (interactiveLoop is_tty True)
-                     GHCiState{ progname = "<interactive>",
-                                args = [],
-                                prompt = location++"> ",
-                                session = session,
-                                options = [] }
-         writeIORef ref hsc_env
-         putStrLn $ "Returning to normal execution..."
-         return b
+ "                         (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" 
+    `IO.catch` \_ -> do
+#if mingw32_HOST_OS
+	win <- System.Win32.getWindowsDirectory
+	return (win `joinFileName` "notepad.exe")
+#else
+	return ""
 #endif
 
 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
@@ -273,18 +245,23 @@ interactiveUI session srcs maybe_expr = do
    newStablePtr stdout
    newStablePtr stderr
 
-   hFlush stdout
-   hSetBuffering stdout NoBuffering
-
 	-- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 
+   when (isNothing maybe_expr) $ do
+	-- Only for GHCi (not runghc and ghc -e):
+	-- Turn buffering off for the compiled program's stdout/stderr
+	turnOffBuffering
+	-- Turn buffering off for GHCi's stdout
+	hFlush stdout
+	hSetBuffering stdout NoBuffering
 	-- We don't want the cmd line to buffer any input that might be
 	-- intended for the program, so unbuffer stdin.
-   hSetBuffering stdin NoBuffering
+	hSetBuffering stdin NoBuffering
 
 	-- initial context is just the Prelude
-   GHC.setContext session [] [prelude_mod]
+   prel_mod <- GHC.findModule session prel_name Nothing
+   GHC.setContext session [] [prel_mod]
 
 #ifdef USE_READLINE
    Readline.initialize
@@ -300,12 +277,21 @@ 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)
 	GHCiState{ progname = "<interactive>",
 		   args = [],
                    prompt = "%s> ",
+		   editor = default_editor,
 		   session = session,
-		   options = [] }
+		   options = [],
+                   prelude = prel_mod,
+                   bkptTable = bkptTable,
+		   topLevel  = True
+                 }
 
 #ifdef USE_READLINE
    Readline.resetTerminal Nothing
@@ -313,6 +299,8 @@ interactiveUI session srcs maybe_expr = do
 
    return ()
 
+prel_name = GHC.mkModuleName "Prelude"
+
 runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
 runGHCi paths maybe_expr = do
   let read_dot_files = not opt_IgnoreDotGhci
@@ -481,8 +469,8 @@ mkPrompt toplevs exports prompt
         f (x:xs) = char x <> f xs
         f [] = empty
     
-        perc_s = hsep (map (\m -> char '*' <> pprModule m) toplevs) <+>
-                 hsep (map pprModule exports)
+        perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+                 hsep (map (ppr . GHC.moduleName) exports)
              
 
 #ifdef USE_READLINE
@@ -523,7 +511,7 @@ runCommand c = ghciHandle handler (doCommand c)
 runCommandEval c = ghciHandle handleEval (doCommand c)
   where 
     handleEval (ExitException code) = io (exitWith code)
-    handleEval e                    = do showException e
+    handleEval e                    = do handler e
 				         io (exitWith (ExitFailure 1))
 
     doCommand (':' : command) = specialCommand command
@@ -534,32 +522,6 @@ runCommandEval c = ghciHandle handleEval (doCommand c)
 		  -- failure to run the command causes exit(1) for ghc -e.
 		_       -> finishEvalExpr nms
 
--- This is the exception handler for exceptions generated by the
--- user's code; 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 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))
-
 runStmt :: String -> GHCi (Maybe [Name])
 runStmt stmt
  | null (filter (not.isSpace) stmt) = return (Just [])
@@ -594,12 +556,6 @@ showTypeOfName session n
 	  Nothing    -> return ()
 	  Just thing -> showTyThing thing
 
-showForUser :: SDoc -> GHCi String
-showForUser doc = do
-  session <- getSession
-  unqual <- io (GHC.getPrintUnqual session)
-  return $! showSDocForUser unqual doc
-
 specialCommand :: String -> GHCi Bool
 specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
 specialCommand str = do
@@ -621,45 +577,6 @@ lookupCommand str = do
      		c:_ -> return (Just c)
 
 -----------------------------------------------------------------------------
--- To flush buffers for the *interpreted* computation we need
--- to refer to *its* stdout/stderr handles
-
-GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
-GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
-
-no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
-	     " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
-flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
-
-initInterpBuffering :: Session -> IO ()
-initInterpBuffering session
- = do maybe_hval <- GHC.compileExpr session no_buf_cmd
-	
-      case maybe_hval of
-	Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
-	other	  -> panic "interactiveUI:setBuffering"
-	
-      maybe_hval <- GHC.compileExpr session flush_cmd
-      case maybe_hval of
-	Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
-	_         -> panic "interactiveUI:flush"
-
-      turnOffBuffering	-- Turn it off right now
-
-      return ()
-
-
-flushInterpBuffers :: GHCi ()
-flushInterpBuffers
- = io $ do Monad.join (readIORef flush_interp)
-           return ()
-
-turnOffBuffering :: IO ()
-turnOffBuffering
- = do Monad.join (readIORef turn_off_buffering)
-      return ()
-
------------------------------------------------------------------------------
 -- Commands
 
 help :: String -> GHCi ()
@@ -688,7 +605,8 @@ info s  = do { let names = words s
 filterOutChildren :: [Name] -> [Name]
 filterOutChildren names = filter (not . parent_is_there) names
  where parent_is_there n 
-	 | Just p <- GHC.nameParent_maybe n = p `elem` names
+--	 | Just p <- GHC.nameParent_maybe n = p `elem` names
+-- ToDo!!
 	 | otherwise		           = False
 
 pprInfo exts (thing, fixity, insts)
@@ -732,6 +650,27 @@ changeDirectory dir = do
   dir <- expandPath dir
   io (setCurrentDirectory dir)
 
+editFile :: String -> GHCi ()
+editFile str
+  | null str  = do
+	-- find the name of the "topmost" file loaded
+     session <- getSession
+     graph0 <- io (GHC.getModuleGraph session)
+     graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
+     let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
+     case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
+	Just file -> do_edit file
+	Nothing   -> throwDyn (CmdLineError "unknown file name")
+  | otherwise = do_edit str
+  where
+	do_edit file = do
+	   st <- getGHCiState
+	   let cmd = editor st
+	   when (null cmd) $ 
+		throwDyn (CmdLineError "editor not set, use :set editor")
+	   io $ system (cmd ++ ' ':file)
+           return ()
+
 defineMacro :: String -> GHCi ()
 defineMacro s = do
   let (macro_name, definition) = break isSpace s
@@ -807,16 +746,16 @@ loadModule' files = do
 
 checkModule :: String -> GHCi ()
 checkModule m = do
-  let modl = GHC.mkModule m
+  let modl = GHC.mkModuleName m
   session <- getSession
   result <- io (GHC.checkModule session modl)
   case result of
     Nothing -> io $ putStrLn "Nothing"
     Just r  -> io $ putStrLn (showSDoc (
-	case checkedModuleInfo r of
+	case GHC.checkedModuleInfo r of
 	   Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
 		let
-		    (local,global) = partition ((== modl) . GHC.nameModule) scope
+		    (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
 		in
 			(text "global names: " <+> ppr global) $$
 		        (text "local  names: " <+> ppr local)
@@ -832,22 +771,23 @@ reloadModule "" = do
 reloadModule m = do
   io (revertCAFs)		-- always revert CAFs on reload.
   session <- getSession
-  ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m)))
+  ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
   afterLoad ok session
 
 afterLoad ok session = do
   io (revertCAFs)  -- always revert CAFs on load.
   graph <- io (GHC.getModuleGraph session)
-  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph
+  graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
   setContextAfterLoad session graph'
-  modulesLoadedMsg ok (map GHC.ms_mod graph')
-#if defined(GHCI) && defined(BREAKPOINT)
-  io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session))
-                    ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))])
-#endif
+  do 
+     bt  <- getBkptTable
+     bt' <- io$ refreshBkptTable session bt graph'
+     setBkptTable bt'
+  modulesLoadedMsg ok (map GHC.ms_mod_name graph')
 
 setContextAfterLoad session [] = do
-  io (GHC.setContext session [] [prelude_mod])
+  prel_mod <- getPrelude
+  io (GHC.setContext session [] [prel_mod])
 setContextAfterLoad session ms = do
   -- load a target if one is available, otherwise load the topmost module.
   targets <- io (GHC.getTargets session)
@@ -864,7 +804,7 @@ setContextAfterLoad session ms = do
 	(m:_) -> Just m
 
    summary `matches` Target (TargetModule m) _
-	= GHC.ms_mod summary == m
+	= GHC.ms_mod_name summary == m
    summary `matches` Target (TargetFile f _) _ 
 	| Just f' <- GHC.ml_hs_file (GHC.ms_location summary)	= f == f'
    summary `matches` target
@@ -873,17 +813,19 @@ setContextAfterLoad session ms = do
    load_this summary | m <- GHC.ms_mod summary = do
 	b <- io (GHC.moduleIsInterpreted session m)
 	if b then io (GHC.setContext session [m] []) 
-       	     else io (GHC.setContext session []  [prelude_mod,m])
+       	     else do
+                   prel_mod <- getPrelude
+                   io (GHC.setContext session []  [prel_mod,m])
 
 
-modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi ()
+modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
 modulesLoadedMsg ok mods = do
   dflags <- getDynFlags
   when (verbosity dflags > 0) $ do
    let mod_commas 
 	| null mods = text "none."
 	| otherwise = hsep (
-	    punctuate comma (map pprModule mods)) <> text "."
+	    punctuate comma (map ppr mods)) <> text "."
    case ok of
     Failed ->
        io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
@@ -911,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)
@@ -950,8 +896,9 @@ createTagsFile session tagskind tagFile = do
         is_interpreted <- GHC.moduleIsInterpreted session m
         -- should we just skip these?
         when (not is_interpreted) $
-          throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted"))
-
+          throwDyn (CmdLineError ("module '" 
+                                ++ GHC.moduleNameString (GHC.moduleName m)
+                                ++ "' is not interpreted"))
         mbModInfo <- GHC.getModuleInfo session m
         let unqual 
 	      | Just modinfo <- mbModInfo,
@@ -1039,8 +986,7 @@ browseCmd m =
 
 browseModule m exports_only = do
   s <- getSession
-
-  let modl = GHC.mkModule m
+  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"))
@@ -1048,7 +994,8 @@ browseModule m exports_only = do
   -- Temporarily set the context to the module we're interested in,
   -- just so we can get an appropriate PrintUnqualified
   (as,bs) <- io (GHC.getContext s)
-  io (if exports_only then GHC.setContext s [] [prelude_mod,modl]
+  prel_mod <- getPrelude
+  io (if exports_only then GHC.setContext s [] [prel_mod,modl]
 		      else GHC.setContext s [modl] [])
   unqual <- io (GHC.getPrintUnqual s)
   io (GHC.setContext s as bs)
@@ -1089,47 +1036,53 @@ setContext str
     sensible ('*':m) = looksLikeModuleName m
     sensible m       = looksLikeModuleName m
 
-newContext mods = do
-  session <- getSession
-  (as,bs) <- separate session mods [] []
-  let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs
-  io (GHC.setContext session as bs')
-
-separate :: Session -> [String] -> [Module] -> [Module]
-  -> GHCi ([Module],[Module])
+separate :: Session -> [String] -> [Module] -> [Module] 
+        -> GHCi ([Module],[Module])
 separate session []           as bs = return (as,bs)
-separate session (('*':m):ms) as bs = do
-   let modl = GHC.mkModule m
-   b <- io (GHC.moduleIsInterpreted session modl)
-   if b then separate session ms (modl:as) bs
-   	else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted"))
-separate session (m:ms)       as bs = separate session ms as (GHC.mkModule m:bs)
-
-prelude_mod = GHC.mkModule "Prelude"
+separate session (('*':str):ms) as bs = do
+   m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+   b <- io $ GHC.moduleIsInterpreted session m
+   if b then separate session ms (m:as) bs
+   	else throwDyn (CmdLineError ("module '"
+                        ++ GHC.moduleNameString (GHC.moduleName m)
+                        ++ "' is not interpreted"))
+separate session (str:ms) as bs = do
+  m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+  separate session ms as (m:bs)
+
+newContext :: [String] -> GHCi ()
+newContext strs = do
+  s <- getSession
+  (as,bs) <- separate s strs [] []
+  prel_mod <- getPrelude
+  let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs
+  io $ GHC.setContext s as bs'
 
 
-addToContext mods = do
-  cms <- getSession
-  (as,bs) <- io (GHC.getContext cms)
+addToContext :: [String] -> GHCi ()
+addToContext strs = do
+  s <- getSession
+  (as,bs) <- io $ GHC.getContext s
 
-  (as',bs') <- separate cms mods [] []
+  (new_as,new_bs) <- separate s strs [] []
 
-  let as_to_add = as' \\ (as ++ bs)
-      bs_to_add = bs' \\ (as ++ bs)
+  let as_to_add = new_as \\ (as ++ bs)
+      bs_to_add = new_bs \\ (as ++ bs)
 
-  io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add))
+  io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add)
 
 
-removeFromContext mods = do
-  cms <- getSession
-  (as,bs) <- io (GHC.getContext cms)
+removeFromContext :: [String] -> GHCi ()
+removeFromContext strs = do
+  s <- getSession
+  (as,bs) <- io $ GHC.getContext s
 
-  (as_to_remove,bs_to_remove) <- separate cms mods [] []
+  (as_to_remove,bs_to_remove) <- separate s strs [] []
 
   let as' = as \\ (as_to_remove ++ bs_to_remove)
       bs' = bs \\ (as_to_remove ++ bs_to_remove)
 
-  io (GHC.setContext cms as' bs')
+  io $ GHC.setContext s as' bs'
 
 ----------------------------------------------------------------------------
 -- Code for `:set'
@@ -1152,11 +1105,13 @@ setCmd ""
    		   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
    	   ))
 setCmd str
-  = case words str of
+  = case toArgs str of
 	("args":args) -> setArgs args
 	("prog":prog) -> setProg prog
-        ("prompt":prompt) -> setPrompt (dropWhile isSpace $ drop 6 $ dropWhile isSpace str)
+        ("prompt":prompt) -> setPrompt (after 6)
+        ("editor":cmd) -> setEditor (after 6)
 	wds -> setOptions wds
+   where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
 
 setArgs args = do
   st <- getGHCiState
@@ -1168,6 +1123,10 @@ setProg [prog] = do
 setProg _ = do
   io (hPutStrLn stderr "syntax: :set prog <progname>")
 
+setEditor cmd = do
+  st <- getGHCiState
+  setGHCiState st{ editor = cmd }
+
 setPrompt value = do
   st <- getGHCiState
   if null value
@@ -1184,21 +1143,28 @@ setOptions wds =
 
       -- then, dynamic flags
       dflags <- getDynFlags
+      let pkg_flags = packageFlags dflags
       (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts
-      setDynFlags dflags'
-
-        -- update things if the users wants more packages
-{- TODO:
-        let new_packages = pkgs_after \\ pkgs_before
-        when (not (null new_packages)) $
-  	   newPackages new_packages
--}
 
       if (not (null leftovers))
 		then throwDyn (CmdLineError ("unrecognised flags: " ++ 
 						unwords leftovers))
 		else return ()
 
+      new_pkgs <- setDynFlags dflags'
+
+      -- if the package flags changed, we should reset the context
+      -- and link the new packages.
+      dflags <- getDynFlags
+      when (packageFlags dflags /= pkg_flags) $ do
+        io $ hPutStrLn stderr "package flags have changed, ressetting and loading new packages..."
+        session <- getSession
+        io (GHC.setTargets session [])
+        io (GHC.load session LoadAllTargets)
+        io (linkPackages dflags new_pkgs)
+        setContextAfterLoad session []
+      return ()
+
 
 unsetOptions :: String -> GHCi ()
 unsetOptions str
@@ -1245,16 +1211,6 @@ optToStr ShowTiming = "s"
 optToStr ShowType   = "t"
 optToStr RevertCAFs = "r"
 
-{- ToDo
-newPackages new_pkgs = do	-- The new packages are already in v_Packages
-  session <- getSession
-  io (GHC.setTargets session [])
-  io (GHC.load session Nothing)
-  dflags   <- getDynFlags
-  io (linkPackages dflags new_pkgs)
-  setContextAfterLoad []
--}
-
 -- ---------------------------------------------------------------------------
 -- code for `:show'
 
@@ -1263,6 +1219,7 @@ showCmd str =
 	["modules" ] -> showModules
 	["bindings"] -> showBindings
 	["linker"]   -> io showLinkerState
+        ["breakpoints"] -> showBkptTable
 	_ -> throwDyn (CmdLineError "syntax:  :show [modules|bindings]")
 
 showModules = do
@@ -1293,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
 
@@ -1357,13 +1322,19 @@ completeModule w = do
 completeHomeModule w = do
   s <- restoreSession
   g <- GHC.getModuleGraph s
-  let home_mods = map GHC.ms_mod g
+  let home_mods = map GHC.ms_mod_name g
   return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
 
 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
@@ -1387,15 +1358,15 @@ 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
 	   | otherwise = ""
 
-allExposedModules :: DynFlags -> [Module]
+allExposedModules :: DynFlags -> [ModuleName]
 allExposedModules dflags 
- = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
  where
   pkg_db = pkgIdMap (pkgState dflags)
 #else
@@ -1407,75 +1378,51 @@ completeHomeModule = completeNone
 completeSetOptions = completeNone
 completeFilename   = completeNone
 completeHomeModuleOrFile=completeNone
+completeBkpt       = completeNone
 #endif
 
------------------------------------------------------------------------------
--- GHCi monad
-
-data GHCiState = GHCiState
-     { 
-	progname       :: String,
-	args	       :: [String],
-        prompt         :: String,
-	session        :: GHC.Session,
-	options        :: [GHCiOption]
-     }
-
-data GHCiOption 
-	= ShowTiming		-- show time/allocs after evaluation
-	| ShowType		-- show the type of expressions
-	| RevertCAFs		-- revert CAFs after every evaluation
-	deriving Eq
-
-newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
-
-startGHCi :: GHCi a -> GHCiState -> IO a
-startGHCi g state = do ref <- newIORef state; unGHCi g ref
-
-instance Monad GHCi where
-  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
-  return a  = GHCi $ \s -> return a
-
-ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
-ghciHandleDyn h (GHCi m) = GHCi $ \s -> 
-   Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
-
-getGHCiState   = GHCi $ \r -> readIORef r
-setGHCiState s = GHCi $ \r -> writeIORef r s
-
--- for convenience...
-getSession = getGHCiState >>= return . session
-
-GLOBAL_VAR(saved_sess, no_saved_sess, Session)
-no_saved_sess = error "no saved_ses"
-saveSession = getSession >>= io . writeIORef saved_sess
-splatSavedSession = io (writeIORef saved_sess no_saved_sess)
-restoreSession = readIORef saved_sess
-
-getDynFlags = do
-  s <- getSession
-  io (GHC.getSessionDynFlags s)
-setDynFlags dflags = do 
-  s <- getSession 
-  io (GHC.setSessionDynFlags s dflags)
+-- ---------------------------------------------------------------------------
+-- User code exception handling
 
-isOptionSet :: GHCiOption -> GHCi Bool
-isOptionSet opt
- = do st <- getGHCiState
-      return (opt `elem` options st)
+-- 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
 
-setOption :: GHCiOption -> GHCi ()
-setOption opt
- = do st <- getGHCiState
-      setGHCiState (st{ options = opt : filter (/= opt) (options st) })
+handler exception = do
+  flushInterpBuffers
+  io installSignalHandlers
+  ghciHandle handler (showException exception >> return False)
 
-unsetOption :: GHCiOption -> GHCi ()
-unsetOption opt
- = do st <- getGHCiState
-      setGHCiState (st{ options = filter (/= opt) (options st) })
+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)
 
-io :: IO a -> GHCi a
-io m = GHCi { unGHCi = \s -> m >>= return }
+showException other_exception
+  = io (putStrLn ("*** Exception: " ++ show other_exception))
 
 -----------------------------------------------------------------------------
 -- recursive exception handlers
@@ -1492,46 +1439,6 @@ ghciHandle h (GHCi m) = GHCi $ \s ->
 ghciUnblock :: GHCi a -> GHCi a
 ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s)
 
------------------------------------------------------------------------------
--- timing & statistics
-
-timeIt :: GHCi a -> GHCi a
-timeIt action
-  = do b <- isOptionSet ShowTiming
-       if not b 
-	  then action 
-	  else do allocs1 <- io $ getAllocations
-		  time1   <- io $ getCPUTime
-		  a <- action
-		  allocs2 <- io $ getAllocations
-		  time2   <- io $ getCPUTime
-		  io $ printTimes (fromIntegral (allocs2 - allocs1)) 
-				  (time2 - time1)
-		  return a
-
-foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
-	-- defined in ghc/rts/Stats.c
-
-printTimes :: Integer -> Integer -> IO ()
-printTimes allocs psecs
-   = do let secs = (fromIntegral psecs / (10^12)) :: Float
-	    secs_str = showFFloat (Just 2) secs
-	putStrLn (showSDoc (
-		 parens (text (secs_str "") <+> text "secs" <> comma <+> 
-			 text (show allocs) <+> text "bytes")))
-
------------------------------------------------------------------------------
--- reverting CAFs
-	
-revertCAFs :: IO ()
-revertCAFs = do
-  rts_revertCAFs
-  turnOffBuffering
-	-- Have to turn off buffering again, because we just 
-	-- reverted stdout, stderr & stdin to their defaults.
-
-foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()  
-	-- Make it "safe", just in case
 
 -- ----------------------------------------------------------------------------
 -- Utils
@@ -1568,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
+
+