workaround #2277: turn off the RTS timer when calling into editline

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index cacbce2..9e72a38 100644 (file)
--- 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" #-}
 -----------------------------------------------------------------------------
 --
@@ -318,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
@@ -611,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
@@ -622,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)
@@ -1406,12 +1421,12 @@ 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 = filterOut (\(_,f) -> f `elem` languageOptions)
+        nonLanguageDynFlags = filterOut (\(_, f, _) -> f `elem` languageOptions)
                                         others
         flags = [Opt_PrintExplicitForalls
                 ,Opt_PrintBindResult
@@ -1689,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)
@@ -2234,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)