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

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index fdf32dc..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 )
 
@@ -419,14 +420,22 @@ runGHCi paths maybe_exprs = do
         Just exprs -> do
             -- just evaluate the expression we were given
             enqueueCommands exprs
-            let handleEval (ExitException code) = io (exitWith code)
-                handleEval e                    = handler e
-            runCommands' handleEval (return Nothing)
+            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
@@ -608,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