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)
22 import Control.Exception as Exception
25 import Data.Int ( Int64 )
31 import Control.Monad as Monad
34 -----------------------------------------------------------------------------
37 data GHCiState = GHCiState
43 session :: GHC.Session,
44 options :: [GHCiOption],
45 prelude :: GHC.Module,
46 bkptTable :: IORef (BkptTable GHC.Module),
51 = ShowTiming -- show time/allocs after evaluation
52 | ShowType -- show the type of expressions
53 | RevertCAFs -- revert CAFs after every evaluation
56 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
58 startGHCi :: GHCi a -> GHCiState -> IO a
59 startGHCi g state = do ref <- newIORef state; unGHCi g ref
61 instance Monad GHCi where
62 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
63 return a = GHCi $ \s -> return a
65 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
66 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
67 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
69 getGHCiState = GHCi $ \r -> readIORef r
70 setGHCiState s = GHCi $ \r -> writeIORef r s
73 getSession = getGHCiState >>= return . session
74 getPrelude = getGHCiState >>= return . prelude
76 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
77 no_saved_sess = error "no saved_ses"
78 saveSession = getSession >>= io . writeIORef saved_sess
79 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
80 restoreSession = readIORef saved_sess
84 io (GHC.getSessionDynFlags s)
85 setDynFlags dflags = do
87 io (GHC.setSessionDynFlags s dflags)
89 isOptionSet :: GHCiOption -> GHCi Bool
91 = do st <- getGHCiState
92 return (opt `elem` options st)
94 setOption :: GHCiOption -> GHCi ()
96 = do st <- getGHCiState
97 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
99 unsetOption :: GHCiOption -> GHCi ()
101 = do st <- getGHCiState
102 setGHCiState (st{ options = filter (/= opt) (options st) })
105 io m = GHCi { unGHCi = \s -> m >>= return }
107 isTopLevel :: GHCi Bool
108 isTopLevel = getGHCiState >>= return . topLevel
110 getBkptTable :: GHCi (BkptTable GHC.Module)
111 getBkptTable = do table_ref <- getGHCiState >>= return . bkptTable
112 io$ readIORef table_ref
114 setBkptTable :: BkptTable GHC.Module -> GHCi ()
115 setBkptTable new_table = do
116 table_ref <- getGHCiState >>= return . bkptTable
117 io$ writeIORef table_ref new_table
119 modifyBkptTable :: (BkptTable GHC.Module -> BkptTable GHC.Module) -> GHCi ()
120 modifyBkptTable f = do
122 new_bt <- io . evaluate$ f bt
125 showForUser :: SDoc -> GHCi String
127 session <- getSession
128 unqual <- io (GHC.getPrintUnqual session)
129 return $! showSDocForUser unqual doc
131 -- --------------------------------------------------------------------------
132 -- Inferior Sessions Exceptions (used by the debugger)
134 data InfSessionException =
135 StopChildSession -- A child session requests to be stopped
136 | StopParentSession -- A child session requests to be stopped
137 -- AND that the parent session quits after that
138 | ChildSessionStopped String -- A child session has stopped
142 -- --------------------------------------------------------------------------
143 -- timing & statistics
145 timeIt :: GHCi a -> GHCi a
147 = do b <- isOptionSet ShowTiming
150 else do allocs1 <- io $ getAllocations
151 time1 <- io $ getCPUTime
153 allocs2 <- io $ getAllocations
154 time2 <- io $ getCPUTime
155 io $ printTimes (fromIntegral (allocs2 - allocs1))
159 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
160 -- defined in ghc/rts/Stats.c
162 printTimes :: Integer -> Integer -> IO ()
163 printTimes allocs psecs
164 = do let secs = (fromIntegral psecs / (10^12)) :: Float
165 secs_str = showFFloat (Just 2) secs
167 parens (text (secs_str "") <+> text "secs" <> comma <+>
168 text (show allocs) <+> text "bytes")))
170 -----------------------------------------------------------------------------
177 -- Have to turn off buffering again, because we just
178 -- reverted stdout, stderr & stdin to their defaults.
180 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
181 -- Make it "safe", just in case
183 -----------------------------------------------------------------------------
184 -- To flush buffers for the *interpreted* computation we need
185 -- to refer to *its* stdout/stderr handles
187 GLOBAL_VAR(flush_interp, error "no flush_interp", IO ())
188 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
190 command_sequence :: [String] -> String
191 command_sequence = unwords . intersperse "Prelude.>>"
193 no_buffer :: String -> String
194 no_buffer h = unwords ["System.IO.hSetBuffering",
196 "System.IO.NoBuffering"]
199 no_buf_cmd = command_sequence $ map no_buffer ["stdout", "stderr", "stdin"]
201 flush_buffer :: String -> String
202 flush_buffer h = unwords ["System.IO.hFlush", "System.IO." ++ h]
205 flush_cmd = command_sequence [flush_buffer "stdout", flush_buffer "stderr"]
207 initInterpBuffering :: GHC.Session -> IO ()
208 initInterpBuffering session
209 = do -- we don't want to be fooled by any modules lying around in the current
210 -- directory when we compile these code fragments, so set the import
211 -- path to be empty while we compile them.
212 dflags <- GHC.getSessionDynFlags session
213 GHC.setSessionDynFlags session dflags{importPaths=[]}
215 maybe_hval <- GHC.compileExpr session no_buf_cmd
218 Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ())
219 other -> panic "interactiveUI:setBuffering"
221 maybe_hval <- GHC.compileExpr session flush_cmd
223 Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ())
224 _ -> panic "interactiveUI:flush"
226 GHC.setSessionDynFlags session dflags
227 GHC.workingDirectoryChanged session
231 flushInterpBuffers :: GHCi ()
233 = io $ do Monad.join (readIORef flush_interp)
236 turnOffBuffering :: IO ()
238 = do Monad.join (readIORef turn_off_buffering)