X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=7adb0642dc71554f9fd003292a713a75f21c3313;hb=aa9a4f1053d3c554629a2ec25955e7530c95b892;hp=db7844d9006ffbfbe555df26a39b0266b9557bb0;hpb=b47555c3c6e7d9b6cbe17714fee9fd22d1779928;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index db7844d..7adb064 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1,3 +1,6 @@ +{-# OPTIONS -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- -- @@ -38,6 +41,7 @@ import Name import SrcLoc -- Other random utilities +import ErrUtils import Digraph import BasicTypes hiding (isTopLevel) import Panic hiding (showException) @@ -64,7 +68,7 @@ import System.Console.Editline.Readline as Readline --import SystemExts -import Control.Exception as Exception +import Exception -- import Control.Concurrent import System.FilePath @@ -317,7 +321,7 @@ interactiveUI session srcs maybe_exprs = do #ifdef USE_EDITLINE is_tty <- hIsTerminalDevice stdin - when is_tty $ do + when is_tty $ withReadline $ do Readline.initialize withGhcAppData @@ -454,12 +458,8 @@ runGHCi paths maybe_exprs = do -- current progname in the exception text: -- : 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 + -- this used to be topHandlerFastExit, see #2228 + $ topHandler e runCommands' handle (return Nothing) -- and finally, exit @@ -614,9 +614,7 @@ readlineLoop = do io yield saveSession -- for use by completion prompt <- mkPrompt - l <- io (readline prompt `finally` setNonBlockingFD 0) - -- readline sometimes puts stdin into blocking mode, - -- so we need to put it back for the IO library + l <- io $ withReadline (readline prompt) splatSavedSession case l of Nothing -> return Nothing @@ -625,6 +623,20 @@ readlineLoop = do io (addHistory l) str <- io $ consoleInputToUnicode True l return (Just str) + +withReadline :: IO a -> IO a +withReadline = bracket_ stopTimer (do startTimer; setNonBlockingFD 0) + -- Two problems are being worked around here: + -- 1. readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library + -- 2. editline doesn't handle some of its system calls returning + -- EINTR, so our timer signal confuses it, hence we turn off + -- the timer signal when making calls to editline. (#2277) + -- If editline is ever fixed, we can remove this. + +-- These come from the RTS +foreign import ccall unsafe startTimer :: IO () +foreign import ccall unsafe stopTimer :: IO () #endif queryQueue :: GHCi (Maybe String) @@ -845,7 +857,7 @@ help :: String -> GHCi () help _ = io (putStr helpText) info :: String -> GHCi () -info "" = throwDyn (CmdLineError "syntax: ':i '") +info "" = ghcError (CmdLineError "syntax: ':i '") info s = do { let names = words s ; session <- getSession ; dflags <- getDynFlags @@ -935,7 +947,7 @@ editFile str = st <- getGHCiState let cmd = editor st when (null cmd) - $ throwDyn (CmdLineError "editor not set, use :set editor") + $ ghcError (CmdLineError "editor not set, use :set editor") io $ system (cmd ++ ' ':file) return () @@ -967,7 +979,7 @@ chooseEditFile = do targets <- io (GHC.getTargets session) case msum (map fromTarget targets) of Just file -> return file - Nothing -> throwDyn (CmdLineError "No files to edit.") + Nothing -> ghcError (CmdLineError "No files to edit.") where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f fromTarget _ = Nothing -- when would we get a module target? @@ -984,7 +996,7 @@ defineMacro overwrite s = do unlines defined) else do if (not overwrite && macro_name `elem` defined) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is already defined")) else do @@ -1013,7 +1025,7 @@ undefineMacro str = mapM_ undef (words str) where undef macro_name = do cmds <- io (readIORef macros_ref) if (macro_name `notElem` map cmdName cmds) - then throwDyn (CmdLineError + then ghcError (CmdLineError ("macro '" ++ macro_name ++ "' is not defined")) else do io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) @@ -1227,8 +1239,8 @@ browseCmd bang m = case (as,bs) of (as@(_:_), _) -> browseModule bang (last as) True ([], bs@(_:_)) -> browseModule bang (last bs) True - ([], []) -> throwDyn (CmdLineError ":browse: no current module") - _ -> throwDyn (CmdLineError "syntax: :browse ") + ([], []) -> ghcError (CmdLineError ":browse: no current module") + _ -> ghcError (CmdLineError "syntax: :browse ") -- without bang, show items in context of their parents and omit children -- with bang, show class methods and data constructors separately, and @@ -1252,7 +1264,7 @@ browseModule bang modl exports_only = do mb_mod_info <- io $ GHC.getModuleInfo s modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ + Nothing -> ghcError (CmdLineError ("unknown module: " ++ GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do dflags <- getDynFlags @@ -1324,7 +1336,7 @@ setContext str playCtxtCmd True (cmd, as, bs) st <- getGHCiState setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } - | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") + | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs, as, bs) = case str of @@ -1409,13 +1421,13 @@ setCmd "" vcat (text "other dynamic, non-language, flag settings:" :map (flagSetting dflags) nonLanguageDynFlags) )) - where flagSetting dflags (str,f) + where flagSetting dflags (str, f, _) | dopt f dflags = text " " <> text "-f" <> text str | otherwise = text " " <> text "-fno-" <> text str - (ghciFlags,others) = partition (\(_,f)->f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) DynFlags.fFlags - nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags) - others + nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions) + others flags = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException @@ -1491,10 +1503,11 @@ newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do dflags <- getDynFlags let pkg_flags = packageFlags dflags - (dflags',leftovers) <- io $ GHC.parseDynamicFlags dflags minus_opts + (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags minus_opts + io $ handleFlagWarnings dflags' warns if (not (null leftovers)) - then throwDyn (CmdLineError ("unrecognised flags: " ++ + then ghcError (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () @@ -1528,7 +1541,7 @@ unsetOptions str mapM_ unsetOpt plus_opts let no_flag ('-':'f':rest) = return ("-fno-" ++ rest) - no_flag f = throwDyn (ProgramError ("don't know how to reverse " ++ f)) + no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f)) no_flags <- mapM no_flag minus_opts newDynFlags no_flags @@ -1583,7 +1596,7 @@ showCmd str = do ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ " | breaks | context | packages | languages ]")) showModules :: GHCi () @@ -1639,7 +1652,8 @@ showPackages = do pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "packages currently loaded:" - : map (nest 2 . text . packageIdString) pkg_ids + : map (nest 2 . text . packageIdString) + (sortBy (compare `on` packageIdFS) pkg_ids) where showFlag (ExposePackage p) = text $ " -package " ++ p showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p @@ -1649,7 +1663,7 @@ showLanguages = do dflags <- getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "active language flags:" : - [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags] + [text (" -X" ++ str) | (str, f, _) <- DynFlags.xFlags, dopt f dflags] -- ----------------------------------------------------------------------------- -- Completion @@ -1690,7 +1704,7 @@ completeWord w start end = do (s,r') = span isBreak r in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words - -- where a compiler flag (ie. -fno-monomorphism-restriction) should + -- where a compiler flag (e.g. -ddump-simpl) should -- only be a single word. selectWord [] = (0,w) selectWord ((offset,x):xs) @@ -1866,7 +1880,7 @@ wantInterpretedModule str = do modl <- lookupModule str is_interpreted <- io (GHC.moduleIsInterpreted session modl) when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) + ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted")) return modl wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String @@ -2080,7 +2094,7 @@ breakByModuleLine mod line args | otherwise = breakSyntax breakSyntax :: a -breakSyntax = throwDyn (CmdLineError "Syntax: :break [] []") +breakSyntax = ghcError (CmdLineError "Syntax: :break [] []") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -2235,7 +2249,7 @@ listModuleLine modl line = do -- | list a section of a source file around a particular SrcSpan. -- If the highlight flag is True, also highlight the span using --- start_bold/end_bold. +-- start_bold\/end_bold. listAround :: SrcSpan -> Bool -> IO () listAround span do_highlight = do contents <- BS.readFile (unpackFS file)