From: Pepe Iborra Date: Sun, 10 Dec 2006 23:05:53 +0000 (+0000) Subject: Split the GHCi monad apart from InteractiveUI, together with some related functions X-Git-Tag: 2006-12-17~8 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=8099fc7e9c54b24dc50c2cd1b9bfdc59e2d218b1 Split the GHCi monad apart from InteractiveUI, together with some related functions I found this convenient while I was extending ghci with the debugger. I wanted to put all the debugger stuff in a separate module, but I would need a huge hs-boot file to break the circular dependencies. This option seemed better --- diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs new file mode 100644 index 0000000..cf578a7 --- /dev/null +++ b/compiler/ghci/GhciMonad.hs @@ -0,0 +1,221 @@ +module GhciMonad where + +#include "HsVersions.h" + +import qualified GHC +import {-#SOURCE#-} Debugger +import Breakpoints +import Outputable +import Panic hiding (showException) +import Util + +import Numeric +import Control.Exception as Exception +import Data.Char +import Data.Dynamic +import Data.Int ( Int64 ) +import Data.IORef +import Data.Typeable +import System.CPUTime +import System.IO +import Control.Monad as Monad +import GHC.Exts + +----------------------------------------------------------------------------- +-- GHCi monad + +data GHCiState = GHCiState + { + progname :: String, + args :: [String], + prompt :: String, + editor :: String, + session :: GHC.Session, + options :: [GHCiOption], + prelude :: GHC.Module + } + +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 +getPrelude = getGHCiState >>= return . prelude + +GLOBAL_VAR(saved_sess, no_saved_sess, GHC.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) + +isOptionSet :: GHCiOption -> GHCi Bool +isOptionSet opt + = do st <- getGHCiState + return (opt `elem` options st) + +setOption :: GHCiOption -> GHCi () +setOption opt + = do st <- getGHCiState + setGHCiState (st{ options = opt : filter (/= opt) (options st) }) + +unsetOption :: GHCiOption -> GHCi () +unsetOption opt + = do st <- getGHCiState + setGHCiState (st{ options = filter (/= opt) (options st) }) + +io :: IO a -> GHCi a +io m = GHCi { unGHCi = \s -> m >>= return } + +showForUser :: SDoc -> GHCi String +showForUser doc = do + session <- getSession + unqual <- io (GHC.getPrintUnqual session) + return $! showSDocForUser unqual doc + +----------------------------------------------------------------------------- +-- User code exception handling + +-- 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 = 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)) + +----------------------------------------------------------------------------- +-- recursive exception handlers + +-- Don't forget to unblock async exceptions in the handler, or if we're +-- in an exception loop (eg. let a = error a in a) the ^C exception +-- may never be delivered. Thanks to Marcin for pointing out the bug. + +ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a +ghciHandle h (GHCi m) = GHCi $ \s -> + Exception.catch (m s) + (\e -> unGHCi (ghciUnblock (h e)) 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 + +----------------------------------------------------------------------------- +-- 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 System.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" + + return () + + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = io $ do Monad.join (readIORef flush_interp) + return () + +turnOffBuffering :: IO () +turnOffBuffering + = do Monad.join (readIORef turn_off_buffering) + return () diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index b4c1f6e..e7a5a37 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -71,7 +71,6 @@ import System.Console.Readline as Readline --import SystemExts import Control.Exception as Exception -import Data.Dynamic -- import Control.Concurrent import Numeric @@ -79,7 +78,6 @@ import Data.List import Data.Int ( Int64 ) import Data.Maybe ( isJust, isNothing, fromMaybe, catMaybes ) import System.Cmd -import System.CPUTime import System.Environment import System.Exit ( exitWith, ExitCode(..) ) import System.Directory @@ -557,32 +555,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 []) @@ -617,12 +589,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 @@ -644,43 +610,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 System.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" - - 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 () @@ -1465,133 +1394,6 @@ completeFilename = completeNone completeHomeModuleOrFile=completeNone #endif ------------------------------------------------------------------------------ --- GHCi monad - -data GHCiState = GHCiState - { - progname :: String, - args :: [String], - prompt :: String, - editor :: String, - session :: GHC.Session, - options :: [GHCiOption], - prelude :: Module - } - -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 -getPrelude = getGHCiState >>= return . prelude - -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) - -isOptionSet :: GHCiOption -> GHCi Bool -isOptionSet opt - = do st <- getGHCiState - return (opt `elem` options st) - -setOption :: GHCiOption -> GHCi () -setOption opt - = do st <- getGHCiState - setGHCiState (st{ options = opt : filter (/= opt) (options st) }) - -unsetOption :: GHCiOption -> GHCi () -unsetOption opt - = do st <- getGHCiState - setGHCiState (st{ options = filter (/= opt) (options st) }) - -io :: IO a -> GHCi a -io m = GHCi { unGHCi = \s -> m >>= return } - ------------------------------------------------------------------------------ --- recursive exception handlers - --- Don't forget to unblock async exceptions in the handler, or if we're --- in an exception loop (eg. let a = error a in a) the ^C exception --- may never be delivered. Thanks to Marcin for pointing out the bug. - -ghciHandle :: (Exception -> GHCi a) -> GHCi a -> GHCi a -ghciHandle h (GHCi m) = GHCi $ \s -> - Exception.catch (m s) - (\e -> unGHCi (ghciUnblock (h e)) 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