X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=afd970214b5f1be4c5c9ac23e396158a0d8d97a1;hb=00fc612dc1e776ef34bd09b4f4ef4f6650d418b0;hp=f4c27d24e651174372965c6ac07c82733dcd7142;hpb=fcb512af6653fea167d3f876e027c32ec6d6f786;p=ghc-hetmet.git

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index f4c27d2..afd9702 100644
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -82,9 +82,10 @@ import Data.Array
 import Control.Monad as Monad
 import Text.Printf
 import Foreign
-import Foreign.C        ( withCStringLen )
+import Foreign.C
 import GHC.Exts		( unsafeCoerce# )
 import GHC.IOBase	( IOErrorType(InvalidArgument) )
+import GHC.TopHandler
 
 import Data.IORef	( IORef, readIORef, writeIORef )
 
@@ -280,8 +281,9 @@ findEditor = do
         return ""
 #endif
 
-interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO ()
-interactiveUI session srcs maybe_expr = do
+interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String]
+              -> IO ()
+interactiveUI session srcs maybe_exprs = do
    -- 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
@@ -297,7 +299,7 @@ interactiveUI session srcs maybe_expr = do
     -- Initialise buffering for the *interpreted* I/O system
    initInterpBuffering session
 
-   when (isNothing maybe_expr) $ do
+   when (isNothing maybe_exprs) $ do
         -- Only for GHCi (not runghc and ghc -e):
 
         -- Turn buffering off for the compiled program's stdout/stderr
@@ -328,7 +330,7 @@ interactiveUI session srcs maybe_expr = do
 
    default_editor <- findEditor
 
-   startGHCi (runGHCi srcs maybe_expr)
+   startGHCi (runGHCi srcs maybe_exprs)
         GHCiState{ progname = "<interactive>",
                    args = [],
                    prompt = "%s> ",
@@ -351,8 +353,8 @@ interactiveUI session srcs maybe_expr = do
 
    return ()
 
-runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
-runGHCi paths maybe_expr = do
+runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
+runGHCi paths maybe_exprs = do
   let read_dot_files = not opt_IgnoreDotGhci
 
   when (read_dot_files) $ do
@@ -390,7 +392,7 @@ runGHCi paths maybe_expr = do
   when (not (null paths)) $ do
      ok <- ghciHandle (\e -> do showException e; return Failed) $
                 loadModule paths
-     when (isJust maybe_expr && failed ok) $
+     when (isJust maybe_exprs && failed ok) $
         io (exitWith (ExitFailure 1))
 
   -- if verbosity is greater than 0, or we are connected to a
@@ -399,7 +401,7 @@ runGHCi paths maybe_expr = do
   dflags <- getDynFlags
   let show_prompt = verbosity dflags > 0 || is_tty
 
-  case maybe_expr of
+  case maybe_exprs of
         Nothing ->
           do
 #if defined(mingw32_HOST_OS)
@@ -415,17 +417,25 @@ runGHCi paths maybe_expr = do
 #endif
             -- enter the interactive loop
             interactiveLoop is_tty show_prompt
-        Just expr -> do
+        Just exprs -> do
             -- just evaluate the expression we were given
-            enqueueCommands [expr]
-            let handleEval (ExitException code) = io (exitWith code)
-                handleEval e                    = handler e
-            runCommands' handleEval (return Nothing)
+            enqueueCommands exprs
+            let handle e = do st <- getGHCiState
+                                   -- Jump through some hoops to get the
+                                   -- current progname in the exception text:
+                                   -- <progname>: <exception>
+                              io $ withProgName (progname st)
+                                   -- The "fast exit" part just calls exit()
+                                   -- directly instead of doing an orderly
+                                   -- runtime shutdown, otherwise the main
+                                   -- GHCi thread will complain about being
+                                   -- interrupted.
+                                 $ topHandlerFastExit e
+            runCommands' handle (return Nothing)
 
   -- and finally, exit
   io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
 
-
 interactiveLoop :: Bool -> Bool -> GHCi ()
 interactiveLoop is_tty show_prompt =
   -- Ignore ^C exceptions caught here
@@ -607,7 +617,7 @@ runCommands' eh getCmd = do
     Nothing -> return ()
     Just c  -> do
       b <- ghciHandle eh (doCommand c)
-      if b then return () else runCommands getCmd
+      if b then return () else runCommands' eh getCmd
   where
     noSpace q = q >>= maybe (return Nothing)
                             (\c->case removeSpaces c of