1 -----------------------------------------------------------------------------
3 -- Monadery code used in InteractiveUI
5 -- (c) The GHC Team 2005-2006
7 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module GhciMonad where
18 #include "HsVersions.h"
21 import Outputable hiding (printForUser, printForUserPartWay)
22 import qualified Outputable
23 import Panic hiding (showException)
34 import Control.Exception as Exception
37 import Data.Int ( Int64 )
42 import System.Directory
43 import System.Environment
45 import Control.Monad as Monad
48 -----------------------------------------------------------------------------
51 type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
53 data GHCiState = GHCiState
60 session :: GHC.Session,
61 options :: [GHCiOption],
62 prelude :: GHC.Module,
64 breaks :: ![(Int, BreakLocation)],
65 tickarrays :: ModuleEnv TickArray,
66 -- tickarrays caches the TickArray for loaded modules,
67 -- so that we don't rebuild it each time the user sets
69 -- ":" at the GHCi prompt repeats the last command, so we
71 last_command :: Maybe Command,
73 remembered_ctx :: [(CtxtCmd, [String], [String])],
74 -- we remember the :module commands between :loads, so that
75 -- on a :reload we can replay them. See bugs #2049,
76 -- #1873, #1360. Previously we tried to remember modules that
77 -- were supposed to be in the context but currently had errors,
78 -- but this was complicated. Just replaying the :module commands
79 -- seems to be the right thing.
80 virtual_path :: FilePath,
81 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
89 type TickArray = Array Int [(BreakIndex,SrcSpan)]
92 = ShowTiming -- show time/allocs after evaluation
93 | ShowType -- show the type of expressions
94 | RevertCAFs -- revert CAFs after every evaluation
99 { breakModule :: !GHC.Module
100 , breakLoc :: !SrcSpan
101 , breakTick :: {-# UNPACK #-} !Int
102 , onBreakCmd :: String
105 instance Eq BreakLocation where
106 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
107 breakTick loc1 == breakTick loc2
109 prettyLocations :: [(Int, BreakLocation)] -> SDoc
110 prettyLocations [] = text "No active breakpoints."
111 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
113 instance Outputable BreakLocation where
114 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
115 if null (onBreakCmd loc)
117 else doubleQuotes (text (onBreakCmd loc))
119 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
120 recordBreak brkLoc = do
122 let oldActiveBreaks = breaks st
123 -- don't store the same break point twice
124 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
125 (nm:_) -> return (True, nm)
127 let oldCounter = break_ctr st
128 newCounter = oldCounter + 1
129 setGHCiState $ st { break_ctr = newCounter,
130 breaks = (oldCounter, brkLoc) : oldActiveBreaks
132 return (False, oldCounter)
134 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a }
136 startGHCi :: GHCi a -> GHCiState -> IO a
137 startGHCi g state = do ref <- newIORef state; unGHCi g ref
139 instance Monad GHCi where
140 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
141 return a = GHCi $ \s -> return a
143 instance Functor GHCi where
144 fmap f m = m >>= return . f
146 ghciHandleDyn :: Typeable t => (t -> GHCi a) -> GHCi a -> GHCi a
147 ghciHandleDyn h (GHCi m) = GHCi $ \s ->
148 Exception.catchDyn (m s) (\e -> unGHCi (h e) s)
150 getGHCiState = GHCi $ \r -> readIORef r
151 setGHCiState s = GHCi $ \r -> writeIORef r s
153 -- for convenience...
154 getSession = getGHCiState >>= return . session
155 getPrelude = getGHCiState >>= return . prelude
157 GLOBAL_VAR(saved_sess, no_saved_sess, GHC.Session)
158 no_saved_sess = error "no saved_ses"
159 saveSession = getSession >>= io . writeIORef saved_sess
160 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
161 restoreSession = readIORef saved_sess
165 io (GHC.getSessionDynFlags s)
166 setDynFlags dflags = do
168 io (GHC.setSessionDynFlags s dflags)
170 isOptionSet :: GHCiOption -> GHCi Bool
172 = do st <- getGHCiState
173 return (opt `elem` options st)
175 setOption :: GHCiOption -> GHCi ()
177 = do st <- getGHCiState
178 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
180 unsetOption :: GHCiOption -> GHCi ()
182 = do st <- getGHCiState
183 setGHCiState (st{ options = filter (/= opt) (options st) })
186 io m = GHCi { unGHCi = \s -> m >>= return }
188 printForUser :: SDoc -> GHCi ()
189 printForUser doc = do
190 session <- getSession
191 unqual <- io (GHC.getPrintUnqual session)
192 io $ Outputable.printForUser stdout unqual doc
194 printForUserPartWay :: SDoc -> GHCi ()
195 printForUserPartWay doc = do
196 session <- getSession
197 unqual <- io (GHC.getPrintUnqual session)
198 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
200 withVirtualPath :: GHCi a -> GHCi a
201 withVirtualPath m = do
202 ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi
204 io$ setCurrentDirectory (virtual_path st)
205 result <- m -- Evaluate in the virtual wd..
206 vwd <- io getCurrentDirectory
207 setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path
208 io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd
211 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
212 runStmt expr step = withVirtualPath$ do
213 session <- getSession
215 io$ withProgName (progname st) $ withArgs (args st) $
216 GHC.runStmt session expr step
218 resume :: GHC.SingleStep -> GHCi GHC.RunResult
219 resume step = withVirtualPath$ do
220 session <- getSession
221 io$ GHC.resume session step
224 -- --------------------------------------------------------------------------
225 -- timing & statistics
227 timeIt :: GHCi a -> GHCi a
229 = do b <- isOptionSet ShowTiming
232 else do allocs1 <- io $ getAllocations
233 time1 <- io $ getCPUTime
235 allocs2 <- io $ getAllocations
236 time2 <- io $ getCPUTime
237 io $ printTimes (fromIntegral (allocs2 - allocs1))
241 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
242 -- defined in ghc/rts/Stats.c
244 printTimes :: Integer -> Integer -> IO ()
245 printTimes allocs psecs
246 = do let secs = (fromIntegral psecs / (10^12)) :: Float
247 secs_str = showFFloat (Just 2) secs
249 parens (text (secs_str "") <+> text "secs" <> comma <+>
250 text (show allocs) <+> text "bytes")))
252 -----------------------------------------------------------------------------
255 revertCAFs :: GHCi ()
259 when (not (ghc_e s)) $ io turnOffBuffering
260 -- Have to turn off buffering again, because we just
261 -- reverted stdout, stderr & stdin to their defaults.
263 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
264 -- Make it "safe", just in case
266 -----------------------------------------------------------------------------
267 -- To flush buffers for the *interpreted* computation we need
268 -- to refer to *its* stdout/stderr handles
270 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
271 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
272 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
274 -- After various attempts, I believe this is the least bad way to do
275 -- what we want. We know look up the address of the static stdin,
276 -- stdout, and stderr closures in the loaded base package, and each
277 -- time we need to refer to them we cast the pointer to a Handle.
278 -- This avoids any problems with the CAF having been reverted, because
279 -- we'll always get the current value.
281 -- The previous attempt that didn't work was to compile an expression
282 -- like "hSetBuffering stdout NoBuffering" into an expression of type
283 -- IO () and run this expression each time we needed it, but the
284 -- problem is that evaluating the expression might cache the contents
285 -- of the Handle rather than referring to it from its static address
286 -- each time. There's no safe workaround for this.
288 initInterpBuffering :: GHC.Session -> IO ()
289 initInterpBuffering session
290 = do -- make sure these are linked
291 mb_hval1 <- GHC.compileExpr session "System.IO.stdout"
292 mb_hval2 <- GHC.compileExpr session "System.IO.stderr"
293 mb_hval3 <- GHC.compileExpr session "System.IO.stdin"
294 when (any isNothing [mb_hval1,mb_hval2,mb_hval3]) $
295 panic "interactiveUI:setBuffering"
297 -- ToDo: we should really look up these names properly, but
298 -- it's a fiddle and not all the bits are exposed via the GHC
300 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
301 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
302 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
304 let f ref (Just ptr) = writeIORef ref ptr
305 f ref Nothing = panic "interactiveUI:setBuffering2"
306 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
307 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
310 flushInterpBuffers :: GHCi ()
312 = io $ do getHandle stdout_ptr >>= hFlush
313 getHandle stderr_ptr >>= hFlush
315 turnOffBuffering :: IO ()
317 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
318 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
320 getHandle :: IORef (Ptr ()) -> IO Handle
322 (Ptr addr) <- readIORef ref
323 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)