1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
11 #include "HsVersions.h"
14 import {-#SOURCE#-} Debugger
17 import Panic hiding (showException)
21 import Control.Exception as Exception
24 import Data.Int ( Int64 )
30 import Control.Monad as Monad
33 -----------------------------------------------------------------------------
36 data GHCiState = GHCiState
42 session :: GHC.Session,
43 options :: [GHCiOption],
44 prelude :: GHC.Module,
45 bkptTable :: IORef (BkptTable GHC.Module),
50 = ShowTiming -- show time/allocs after evaluation
51 | ShowType -- show the type of expressions
52 | RevertCAFs -- revert CAFs after every evaluation
55 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
57 startGHCi :: GHCi a -> GHCiState -> IO a
58 startGHCi g state = do ref <- newIORef state; unGHCi g ref
60 instance Monad GHCi where
61 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
62 return a = GHCi $ \s -> return a
64 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
65 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
66 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
68 getGHCiState = GHCi $ \r -> readIORef r
69 setGHCiState s = GHCi $ \r -> writeIORef r s
72 getSession = getGHCiState >>= return . session
73 getPrelude = getGHCiState >>= return . prelude
75 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
76 no_saved_sess = error "no saved_ses"
77 saveSession = getSession >>= io . writeIORef saved_sess
78 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
79 restoreSession = readIORef saved_sess
83 io (GHC.getSessionDynFlags s)
84 setDynFlags dflags = do
86 io (GHC.setSessionDynFlags s dflags)
88 isOptionSet :: GHCiOption -> GHCi Bool
90 = do st <- getGHCiState
91 return (opt `elem` options st)
93 setOption :: GHCiOption -> GHCi ()
95 = do st <- getGHCiState
96 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
98 unsetOption :: GHCiOption -> GHCi ()
100 = do st <- getGHCiState
101 setGHCiState (st{ options = filter (/= opt) (options st) })
104 io m = GHCi { unGHCi = \s -> m >>= return }
106 isTopLevel :: GHCi Bool
107 isTopLevel = getGHCiState >>= return . topLevel
109 getBkptTable :: GHCi (BkptTable GHC.Module)
110 getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
111 io$ readIORef table_ref
113 setBkptTable :: BkptTable GHC.Module -> GHCi ()
114 setBkptTable new_table = do
115 table_ref <- getGHCiState >>= return . bkptTable
116 io$ writeIORef table_ref new_table
118 modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
119 modifyBkptTable f = do
121 new_bt <- io . evaluate$ f bt
124 showForUser :: SDoc -> GHCi String
126 session <- getSession
127 unqual <- io (GHC.getPrintUnqual session)
128 return $! showSDocForUser unqual doc
130 -- --------------------------------------------------------------------------
131 -- Inferior Sessions Exceptions (used by the debugger)
133 data InfSessionException =
134 StopChildSession -- A child session requests to be stopped
135 | StopParentSession -- A child session requests to be stopped
136 -- AND that the parent session quits after that
137 | ChildSessionStopped String -- A child session has stopped
141 -- --------------------------------------------------------------------------
142 -- timing & statistics
144 timeIt :: GHCi a -> GHCi a
146 = do b <- isOptionSet ShowTiming
149 else do allocs1 <- io $ getAllocations
150 time1 <- io $ getCPUTime
152 allocs2 <- io $ getAllocations
153 time2 <- io $ getCPUTime
154 io $ printTimes (fromIntegral (allocs2 - allocs1))
158 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
159 -- defined in ghc/rts/Stats.c
161 printTimes :: Integer -> Integer -> IO ()
162 printTimes allocs psecs
163 = do let secs = (fromIntegral psecs / (10^12)) :: Float
164 secs_str = showFFloat (Just 2) secs
166 parens (text (secs_str "") <+> text "secs" <> comma <+>
167 text (show allocs) <+> text "bytes")))
169 -----------------------------------------------------------------------------
176 -- Have to turn off buffering again, because we just
177 -- reverted stdout, stderr & stdin to their defaults.
179 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
180 -- Make it "safe", just in case
182 -----------------------------------------------------------------------------
183 -- To flush buffers for the *interpreted* computation we need
184 -- to refer to *its* stdout/stderr handles
186 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
187 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
189 command_sequence :: [String] -> String
190 command_sequence = unwords . intersperse "Prelude.>>"
192 no_buffer :: String -> String
193 no_buffer h = unwords ["System.IO.hSetBuffering",
195 "System.IO.NoBuffering"]
198 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
200 flush_buffer :: String -> String
201 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
204 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
206 initInterpBuffering :: GHC.Session -> IO ()
207 initInterpBuffering session
208 = do maybe_hval <- GHC.compileExpr session no_buf_cmd
211 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
212 other -> panic "interactiveUI:setBuffering"
214 maybe_hval <- GHC.compileExpr session flush_cmd
216 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
217 _ -> panic "interactiveUI:flush"
222 flushInterpBuffers :: GHCi ()
224 = io $ do Monad.join (readIORef flush_interp)
227 turnOffBuffering :: IO ()
229 = do Monad.join (readIORef turn_off_buffering)