1 {-# OPTIONS -fno-cse #-}
2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
4 -----------------------------------------------------------------------------
6 -- Monadery code used in InteractiveUI
8 -- (c) The GHC Team 2005-2006
10 -----------------------------------------------------------------------------
12 module GhciMonad where
14 #include "HsVersions.h"
17 import Outputable hiding (printForUser, printForUserPartWay)
18 import qualified Outputable
19 import Panic hiding (showException)
28 import MonadUtils ( MonadIO, liftIO )
35 import Data.Int ( Int64 )
39 import System.Directory
40 import System.Environment
42 import Control.Monad as Monad
45 -----------------------------------------------------------------------------
48 type Command = (String, String -> GHCi Bool, Maybe String, String -> IO [String])
50 data GHCiState = GHCiState
57 options :: [GHCiOption],
58 prelude :: GHC.Module,
60 breaks :: ![(Int, BreakLocation)],
61 tickarrays :: ModuleEnv TickArray,
62 -- tickarrays caches the TickArray for loaded modules,
63 -- so that we don't rebuild it each time the user sets
65 -- ":" at the GHCi prompt repeats the last command, so we
67 last_command :: Maybe Command,
69 remembered_ctx :: [(CtxtCmd, [String], [String])],
70 -- we remember the :module commands between :loads, so that
71 -- on a :reload we can replay them. See bugs #2049,
72 -- \#1873, #1360. Previously we tried to remember modules that
73 -- were supposed to be in the context but currently had errors,
74 -- but this was complicated. Just replaying the :module commands
75 -- seems to be the right thing.
76 virtual_path :: FilePath,
77 ghc_e :: Bool -- True if this is 'ghc -e' (or runghc)
85 type TickArray = Array Int [(BreakIndex,SrcSpan)]
88 = ShowTiming -- show time/allocs after evaluation
89 | ShowType -- show the type of expressions
90 | RevertCAFs -- revert CAFs after every evaluation
95 { breakModule :: !GHC.Module
96 , breakLoc :: !SrcSpan
97 , breakTick :: {-# UNPACK #-} !Int
98 , onBreakCmd :: String
101 instance Eq BreakLocation where
102 loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
103 breakTick loc1 == breakTick loc2
105 prettyLocations :: [(Int, BreakLocation)] -> SDoc
106 prettyLocations [] = text "No active breakpoints."
107 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
109 instance Outputable BreakLocation where
110 ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
111 if null (onBreakCmd loc)
113 else doubleQuotes (text (onBreakCmd loc))
115 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
116 recordBreak brkLoc = do
118 let oldActiveBreaks = breaks st
119 -- don't store the same break point twice
120 case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
121 (nm:_) -> return (True, nm)
123 let oldCounter = break_ctr st
124 newCounter = oldCounter + 1
125 setGHCiState $ st { break_ctr = newCounter,
126 breaks = (oldCounter, brkLoc) : oldActiveBreaks
128 return (False, oldCounter)
130 newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }
132 reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a
133 reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s
135 reifyGHCi :: ((Session, IORef GHCiState) -> IO a) -> GHCi a
136 reifyGHCi f = GHCi f'
138 -- f' :: IORef GHCiState -> Ghc a
139 f' gs = reifyGhc (f'' gs)
140 -- f'' :: IORef GHCiState -> Session -> IO a
143 startGHCi :: GHCi a -> GHCiState -> Ghc a
144 startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref
146 instance Monad GHCi where
147 (GHCi m) >>= k = GHCi $ \s -> m s >>= \a -> unGHCi (k a) s
148 return a = GHCi $ \_ -> return a
150 instance Functor GHCi where
151 fmap f m = m >>= return . f
153 ghciHandleGhcException :: (GhcException -> GHCi a) -> GHCi a -> GHCi a
154 ghciHandleGhcException = handleGhcException
156 getGHCiState :: GHCi GHCiState
157 getGHCiState = GHCi $ \r -> liftIO $ readIORef r
158 setGHCiState :: GHCiState -> GHCi ()
159 setGHCiState s = GHCi $ \r -> liftIO $ writeIORef r s
161 liftGhc :: Ghc a -> GHCi a
162 liftGhc m = GHCi $ \_ -> m
164 instance MonadIO GHCi where
165 liftIO m = liftGhc $ liftIO m
167 instance GhcMonad GHCi where
168 setSession s' = liftGhc $ setSession s'
169 getSession = liftGhc $ getSession
171 instance ExceptionMonad GHCi where
172 gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)
173 gbracket acq rel ib =
174 GHCi $ \r -> gbracket (unGHCi acq r)
175 (\x -> unGHCi (rel x) r)
176 (\x -> unGHCi (ib x) r)
178 GHCi $ \r -> gfinally (unGHCi th r) (unGHCi cu r)
180 instance WarnLogMonad GHCi where
181 setWarnings warns = liftGhc $ setWarnings warns
182 getWarnings = liftGhc $ getWarnings
184 -- for convenience...
185 getPrelude :: GHCi Module
186 getPrelude = getGHCiState >>= return . prelude
188 GLOBAL_VAR(saved_sess, no_saved_sess, Session)
190 no_saved_sess :: Session
191 no_saved_sess = error "no saved_ses"
193 saveSession :: GHCi ()
197 writeIORef saved_sess s
199 splatSavedSession :: GHCi ()
200 splatSavedSession = io (writeIORef saved_sess no_saved_sess)
202 -- restoreSession :: IO Session
203 -- restoreSession = readIORef saved_sess
205 withRestoredSession :: Ghc a -> IO a
206 withRestoredSession ghc = do
207 s <- readIORef saved_sess
210 getDynFlags :: GHCi DynFlags
212 GHC.getSessionDynFlags
214 setDynFlags :: DynFlags -> GHCi [PackageId]
215 setDynFlags dflags = do
216 GHC.setSessionDynFlags dflags
218 isOptionSet :: GHCiOption -> GHCi Bool
220 = do st <- getGHCiState
221 return (opt `elem` options st)
223 setOption :: GHCiOption -> GHCi ()
225 = do st <- getGHCiState
226 setGHCiState (st{ options = opt : filter (/= opt) (options st) })
228 unsetOption :: GHCiOption -> GHCi ()
230 = do st <- getGHCiState
231 setGHCiState (st{ options = filter (/= opt) (options st) })
236 printForUser :: SDoc -> GHCi ()
237 printForUser doc = do
238 unqual <- GHC.getPrintUnqual
239 io $ Outputable.printForUser stdout unqual doc
241 printForUserPartWay :: SDoc -> GHCi ()
242 printForUserPartWay doc = do
243 unqual <- GHC.getPrintUnqual
244 io $ Outputable.printForUserPartWay stdout opt_PprUserLength unqual doc
246 withVirtualPath :: GHCi a -> GHCi a
247 withVirtualPath m = do
248 ghci_wd <- io getCurrentDirectory -- Store the cwd of GHCi
250 io$ setCurrentDirectory (virtual_path st)
251 result <- m -- Evaluate in the virtual wd..
252 vwd <- io getCurrentDirectory
253 setGHCiState (st{ virtual_path = vwd}) -- Update the virtual path
254 io$ setCurrentDirectory ghci_wd -- ..and restore GHCi wd
257 runStmt :: String -> GHC.SingleStep -> GHCi GHC.RunResult
258 runStmt expr step = withVirtualPath$ do
261 withProgName (progname st) $
264 GHC.handleSourceError (\e -> do GHC.printExceptionAndWarnings e
265 return GHC.RunFailed) $ do
266 GHC.runStmt expr step
268 resume :: GHC.SingleStep -> GHCi GHC.RunResult
269 resume step = withVirtualPath$ do
273 -- --------------------------------------------------------------------------
274 -- timing & statistics
276 timeIt :: GHCi a -> GHCi a
278 = do b <- isOptionSet ShowTiming
281 else do allocs1 <- io $ getAllocations
282 time1 <- io $ getCPUTime
284 allocs2 <- io $ getAllocations
285 time2 <- io $ getCPUTime
286 io $ printTimes (fromIntegral (allocs2 - allocs1))
290 foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64
291 -- defined in ghc/rts/Stats.c
293 printTimes :: Integer -> Integer -> IO ()
294 printTimes allocs psecs
295 = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float
296 secs_str = showFFloat (Just 2) secs
298 parens (text (secs_str "") <+> text "secs" <> comma <+>
299 text (show allocs) <+> text "bytes")))
301 -----------------------------------------------------------------------------
304 revertCAFs :: GHCi ()
308 when (not (ghc_e s)) $ io turnOffBuffering
309 -- Have to turn off buffering again, because we just
310 -- reverted stdout, stderr & stdin to their defaults.
312 foreign import ccall "revertCAFs" rts_revertCAFs :: IO ()
313 -- Make it "safe", just in case
315 -----------------------------------------------------------------------------
316 -- To flush buffers for the *interpreted* computation we need
317 -- to refer to *its* stdout/stderr handles
319 GLOBAL_VAR(stdin_ptr, error "no stdin_ptr", Ptr ())
320 GLOBAL_VAR(stdout_ptr, error "no stdout_ptr", Ptr ())
321 GLOBAL_VAR(stderr_ptr, error "no stderr_ptr", Ptr ())
323 -- After various attempts, I believe this is the least bad way to do
324 -- what we want. We know look up the address of the static stdin,
325 -- stdout, and stderr closures in the loaded base package, and each
326 -- time we need to refer to them we cast the pointer to a Handle.
327 -- This avoids any problems with the CAF having been reverted, because
328 -- we'll always get the current value.
330 -- The previous attempt that didn't work was to compile an expression
331 -- like "hSetBuffering stdout NoBuffering" into an expression of type
332 -- IO () and run this expression each time we needed it, but the
333 -- problem is that evaluating the expression might cache the contents
334 -- of the Handle rather than referring to it from its static address
335 -- each time. There's no safe workaround for this.
337 initInterpBuffering :: Ghc ()
338 initInterpBuffering = do -- make sure these are linked
339 dflags <- GHC.getSessionDynFlags
343 -- ToDo: we should really look up these names properly, but
344 -- it's a fiddle and not all the bits are exposed via the GHC
346 mb_stdin_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdin_closure"
347 mb_stdout_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stdout_closure"
348 mb_stderr_ptr <- ObjLink.lookupSymbol "base_GHCziHandle_stderr_closure"
350 let f ref (Just ptr) = writeIORef ref ptr
351 f _ Nothing = panic "interactiveUI:setBuffering2"
352 zipWithM f [stdin_ptr,stdout_ptr,stderr_ptr]
353 [mb_stdin_ptr,mb_stdout_ptr,mb_stderr_ptr]
356 flushInterpBuffers :: GHCi ()
358 = io $ do getHandle stdout_ptr >>= hFlush
359 getHandle stderr_ptr >>= hFlush
361 turnOffBuffering :: IO ()
363 = do hdls <- mapM getHandle [stdin_ptr,stdout_ptr,stderr_ptr]
364 mapM_ (\h -> hSetBuffering h NoBuffering) hdls
366 getHandle :: IORef (Ptr ()) -> IO Handle
368 (Ptr addr) <- readIORef ref
369 case addrToHValue# addr of (# hval #) -> return (unsafeCoerce# hval)